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
- Converting the row of a data.table to a vector
- ggplot multi-line log-log labels
- dplyr filter vector by position in pipe %>%
- Removing white spaces in a histogram?
- How to assign and match land cover type from Corine to a dataframe with a set of lon lat coordinates?
- Error in list2env(list, envir = .GlobalEnv) : names(x) must be a character vector of the same length as x
- How to traverse hclust internal node in R
- How are the abbreviations from the par function like mgp, mar, mai, deciphered?
- How to map over function with multiple arguments (and changing data)?
- Join/fill in data based on both row and column values
- How to plot a Log Pearson III distribution using `ggplot2` in R?
- Variable names and Easystats reports
- R plotly(): Adding regression line to a correlation scatter plot
- How to Use ifelse Statements in R
- Creating subgraphs from neighbors with max weight in R using igraph
- merge based on id and dates with missing data
- Automatically adjust the size of the text inside each bar on a bar plot using ggplot2 in R
- gghighlight and facet_wrap one always highlighted
- Mask and Crop functions in Terra R
- How to use a variable in dplyr::filter?
- Changing R Temporary Files
- How do you add a general label to facets in ggplot2?
- change colour of controls in R DT datatable
- Click Button Within Datatable to Display Popup Twice in a row
- How to display values in filter with ascending order
- Select Data From Column in Data Table
- Warning: Error in dataTableOutput: unused argument (height = "auto")
- How to have cells with rounded corners in {gt}?
- Two colours in the same box
- Change color of datatable filter dropdown box