How can I shuffle time blocks in time series without overlap in R?
Let's assume there is a group of 3 persons, for which I have a time series of when they start and finish an activity. An example dataframe would be:
library(tidyverse)
GrXX <- tibble(Individual = rep(c("A", "B", "C"), times = c(2, 3, 5)),
Frame_beginning = c(1, 16, 7, 21, 29, 3, 9, 12, 19, 27),
Frame_end = c(3, 22, 15, 24, 30, 7, 10, 12, 24, 30),
Duration = Frame_end - Frame_beginning + 1,
Frame_end_valid_group = 30)
This group can be represented by the following figure:
I would love to shuffle this group around, so that the time blocks within individuals are randomly placed, without overlap within individuals (there can be overlap between individuals). Additonally, all original time blocks should also be fully on the shuffled timeline (i.e., they should not start or finish outside of the original timeline). One potential shuffling could be the following: 
My question is how to do that in R, in an efficient way. I started some code, but it seems very complex for the task, and does not prevent all overlaps. Here it is:
GrXX_shuffled <- tibble()
for (i in c("A", "B", "C")) {
temp <- GrXX %>%
filter(Individual == i) %>%
arrange(-Duration, Frame_beginning)
valid_frames <- c()
Frame_shuffled_start <- c()
Frame_shuffled_end <- c()
Frame_earliest <- 1
for (j in 1:nrow(temp)) {
temp2 <- temp[j, ]
if(j == 1) {
valid_frames <- 1:(temp2$Frame_end_valid_group - temp2$Duration + 1)
temp2 <- temp2 %>%
mutate(Frame_beginning_shuffled = sample(valid_frames, size = 1), .after = Frame_beginning) %>%
mutate(Frame_end_shuffled = Frame_beginning_shuffled + Duration - 1, .after = Frame_end)
GrXX_shuffled <- bind_rows(GrXX_shuffled, temp2)
}
if(j != 1) {
valid_frames <- c(Frame_earliest:(Frame_shuffled_start[j-1] - temp2$Duration - 1),
(Frame_shuffled_end[j-1] + 2):(temp2$Frame_end_valid_group - temp2$Duration + 1))
valid_frames <- valid_frames[valid_frames >= 1 & valid_frames <= 30]
temp2 <- temp2 %>%
mutate(Frame_beginning_shuffled = sample(valid_frames, size = 1), .after = Frame_beginning) %>%
mutate(Frame_end_shuffled = Frame_beginning_shuffled + Duration - 1, .after = Frame_end)
GrXX_shuffled <- bind_rows(GrXX_shuffled, temp2)
}
Frame_shuffled_start <- sort(c(Frame_shuffled_start, temp2$Frame_beginning_shuffled))
Frame_shuffled_end <- sort(c(Frame_shuffled_end, temp2$Frame_end_shuffled))
Frame_earliest <- min(valid_frames_2)
}
}
The idea behind the code is to:
- for each individual select the block with the longest duration and shuffle it around on the empty timeline (and it should not start too late so that the full block is still fully on the timeline)
- then go for the next longest block (if it exists) and place it in the rest of the timeline, without overlap with any previous already-shuffled blocks
- repeat until no more blocks have to be shuffled
Any idea how to solve this efficiently?
Many thanks in advance :-)
Solution
Here's an efficient function to do what was described. It assumes discrete timesteps as in the OP's example.
library(data.table)
library(RcppAlgos) # for `compositionsSample`
library(Rfast) # for `colShuffle` and `colCumSums`
shuffle <- function(dt, n = 1L) {
f <- function(v, m) {
k <- length(v)
k1 <- k + 1L
as.data.table(
cbind(
rep = rep(1:n, each = k),
matrix(
colCumSums(
`dim<-`(
rbind(
`dim<-`(t(compositionsSample(0:(m - sum(v)), k + 1, TRUE,
n = n)[,-k - 1]), NULL),
`dim<-`(colShuffle(matrix(v, k, n)), NULL)
), c(2*k, n)
)
) + 1:0,
n*k, 2, TRUE, list(NULL, c("Frame_beginning", "Frame_end"))
)
)
)[,`:=`(Duration = Frame_end - Frame_beginning + 1,
Frame_end_valid_group = m)]
}
setorder(
setcolorder(dt[,f(Duration, Frame_end_valid_group[1]), Individual], "rep"),
rep, Individual
)
}
Demonstrating:
shuffle(setDT(GrXX))[]
#> rep Individual Frame_beginning Frame_end Duration Frame_end_valid_group
#> <num> <char> <num> <num> <num> <num>
#> 1: 1 A 3 9 7 30
#> 2: 1 A 27 29 3 30
#> 3: 1 B 2 3 2 30
#> 4: 1 B 5 8 4 30
#> 5: 1 B 21 29 9 30
#> 6: 1 C 1 5 5 30
#> 7: 1 C 8 8 1 30
#> 8: 1 C 12 13 2 30
#> 9: 1 C 17 22 6 30
#> 10: 1 C 26 29 4 30
It can also do multiple shuffles using the n argument:
shuffle(GrXX, 3)[]
#> rep Individual Frame_beginning Frame_end Duration Frame_end_valid_group
#> <num> <char> <num> <num> <num> <num>
#> 1: 1 A 17 23 7 30
#> 2: 1 A 25 27 3 30
#> 3: 1 B 5 8 4 30
#> 4: 1 B 16 17 2 30
#> 5: 1 B 19 27 9 30
#> 6: 1 C 4 4 1 30
#> 7: 1 C 6 9 4 30
#> 8: 1 C 11 12 2 30
#> 9: 1 C 15 20 6 30
#> 10: 1 C 25 29 5 30
#> 11: 2 A 8 10 3 30
#> 12: 2 A 19 25 7 30
#> 13: 2 B 5 6 2 30
#> 14: 2 B 8 16 9 30
#> 15: 2 B 20 23 4 30
#> 16: 2 C 3 7 5 30
#> 17: 2 C 11 12 2 30
#> 18: 2 C 14 17 4 30
#> 19: 2 C 19 19 1 30
#> 20: 2 C 21 26 6 30
#> 21: 3 A 12 14 3 30
#> 22: 3 A 23 29 7 30
#> 23: 3 B 4 5 2 30
#> 24: 3 B 10 13 4 30
#> 25: 3 B 15 23 9 30
#> 26: 3 C 2 7 6 30
#> 27: 3 C 9 10 2 30
#> 28: 3 C 12 16 5 30
#> 29: 3 C 19 19 1 30
#> 30: 3 C 23 26 4 30
And it's fast:
microbenchmark::microbenchmark(shuffle(GrXX, 100))
#> Unit: milliseconds
#> expr min lq mean median uq max neval
#> shuffle(GrXX, 100) 1.9616 2.1486 2.343154 2.22235 2.36755 5.8275 100
- grid.arrange's relative height argument didn't works well in RMarkdown
- How apply a function to every element of a matrix?
- Polar plot in R using ggplot2
- Find total length of time in multiple values of a dataset that overlaps with a given period of time
- Faster than R's `simplify2array`?
- What is the most simple way to label a data.table frequency chart in R?
- How to show dates in a secondary x-axis while the primary x-axis is numerical?
- online compiler for r-markdown document
- Unecessarily large column widths in HTML tables published by R Quarto when the table header contains special characters
- Bootstrapping a vector of results, by group in R
- Speeding Up Monte Carlo Simulations for Weather-Dependent Claims
- Is there an R class which allows to list 2 elements but shows only the first of them by default when called?
- Convert day of week number to weekday name in R
- How do you use "<<-" (scoping assignment) in R?
- Using reactivePoll to monitor and process file changes
- How to find out which graph is most similar to another graph?
- ggplot2: rectangular background behind axis text in circular bar plot
- How to simulate button click using rvest
- CMIP6, automating by month
- Covert dummy variables to single categorical in R?
- Animated reducing bar chart with gganimate
- Create an object class matrix/array from data frame
- How to add a vector of names to `sort_by()` in base R
- Among many subfolders, find CSVs starting with a given string and within ZIPs or not, and merge them while adding their names in a new column with R
- How to add a greek letter to an axis label to a 3D plot in plotly?
- bigrquery + dplyr error when using functions and sourcing from separate R script
- Shiny App Error: /v1/applications/ 400 - Validation Error Execution halted
- Rupee Unicode replacement not working in R
- Mutate multiple variable to create multiple new variables
- How to use the Stata equivalent of a foreach loop in R with mutate()