slide_tsibble() returns a list of tsibble

closed #135

NEWS.md

@@ -1,5 +1,6 @@
 # tsibble 0.8.2.9000
 
+* **Breaking change**: `slide_tsibble()`, `tile_tsibble()`, `stretch_tsibble()` return a list of tsibbles instead of a tsibble with new `.id` column.
 * `index_by()` supports lambda expression (#91).
 * Defunct argument `gather` in `as_tsibble.mts()` in favour of `pivot_longer`.
 * `yearweek()` handles characters containing keywords "W"/"Wk"/"Week", for example `yearweek("2019 W03")`.

R/slide.R

@@ -391,7 +391,6 @@ partial_pslider <- function(..., .size = 1, .step = 1, .fill = NA,
 #' @param .x A tsibble.
 #' @param .size A positive integer for window size.
 #' @inheritParams slide
-#' @param .id A character naming the new column `.id` containing the partition.
 #'
 #' @section Rolling tsibble:
 #' `slide_tsibble()`, `tile_tsibble()`, and `stretch_tsibble()` provide fast
@@ -400,8 +399,7 @@ partial_pslider <- function(..., .size = 1, .step = 1, .fill = NA,
 #' and proceed.
 #'
 #' They are useful for preparing the tsibble for time series cross validation.
-#' They all return a tsibble including a new column `.id` as part of the key. The
-#' output dimension will increase considerably with `slide_tsibble()` and
+#' The output dimension will increase considerably with `slide_tsibble()` and
 #' `stretch_tsibble()`, which is likely to run out of memory when the data is
 #' large. Alternatively, you could construct cross validation using `pslide()`
 #' and `pstretch()` to avoid the memory issue.
@@ -416,9 +414,9 @@ partial_pslider <- function(..., .size = 1, .step = 1, .fill = NA,
 #' )
 #' harvest %>%
 #'   slide_tsibble(.size = 2)
-slide_tsibble <- function(.x, .size = 1, .step = 1, .id = ".id") {
+slide_tsibble <- function(.x, .size = 1, .step = 1) {
   lst_indices <- map(key_rows(.x), slider, .size = .size, .step = .step)
-  roll_tsibble(.x, indices = lst_indices, .id = .id)
+  roll_tsibble(.x, indices = lst_indices)
 }
 
 # fast_slider <- function(.x, .size = 1, .step = 1) {
@@ -431,27 +429,18 @@ slide_tsibble <- function(.x, .size = 1, .step = 1, .id = ".id") {
 #   # list(indices = .x[idx], id_indices = id_indices)
 # }
 
-roll_tsibble <- function(.x, indices, .id = ".id") {
-  if (.id %in% names(.x)) {
-    abort(sprintf("Can't overwrite existing column `%s`.", .id))
-  }
+roll_tsibble <- function(.x, indices) {
   tbl <- as_tibble(ungroup(.x))
   row_indices <- unlist(indices, use.names = FALSE)
   id_indices <-
     unlist(map(
       indices,
       ~ purrr::imap(.x, ~ rep.int(.y, length(.x)))
     ), use.names = FALSE)
-  res <-
-    group_by(
-      mutate(tbl[row_indices, ], !!.id := id_indices),
-      !!!groups(.x)
-    )
-  new_key <- c(.id, key_vars(.x))
-  build_tsibble(
-    res,
-    key = !!new_key, index = !!index(.x), index2 = !!index2(.x),
-    interval = interval(.x), validate = FALSE
+  res <- unname(split(tbl[row_indices, ], id_indices))
+  lapply(res, update_meta, .x, 
+    ordered = is_ordered(.x), 
+    interval = interval(.x)
   )
 }
 

R/stretch.R

@@ -263,7 +263,6 @@ pstretcher <- function(..., .step = 1, .init = 1, .bind = FALSE) { # parallel sl
 #' @param .x A tsibble.
 #' @param .step A positive integer for incremental step.
 #' @inheritParams stretch
-#' @param .id A character naming the new column `.id` containing the partition.
 #'
 #' @inheritSection slide_tsibble Rolling tsibble
 #' @family rolling tsibble
@@ -277,9 +276,9 @@ pstretcher <- function(..., .step = 1, .init = 1, .bind = FALSE) { # parallel sl
 #' )
 #' harvest %>%
 #'   stretch_tsibble()
-stretch_tsibble <- function(.x, .step = 1, .init = 1, .id = ".id") {
+stretch_tsibble <- function(.x, .step = 1, .init = 1) {
   lst_indices <- map(key_rows(.x), stretcher, .step = .step, .init = .init)
-  roll_tsibble(.x, indices = lst_indices, .id = .id)
+  roll_tsibble(.x, indices = lst_indices)
 }
 
 incr <- function(.init, .step) {

R/tile.R

@@ -181,7 +181,6 @@ ptiler <- function(..., .size = 1, .bind = FALSE) { # parallel tiling
 #' @param .x A tsibble.
 #' @param .size A positive integer for window size.
 #' @inheritParams tile
-#' @param .id A character naming the new column `.id` containing the partition.
 #'
 #' @inheritSection slide_tsibble Rolling tsibble
 #' @family rolling tsibble
@@ -195,9 +194,9 @@ ptiler <- function(..., .size = 1, .bind = FALSE) { # parallel tiling
 #' )
 #' harvest %>%
 #'   tile_tsibble(.size = 2)
-tile_tsibble <- function(.x, .size = 1, .id = ".id") {
+tile_tsibble <- function(.x, .size = 1) {
   lst_indices <- map(key_rows(.x), tiler, .size = .size)
-  roll_tsibble(.x, indices = lst_indices, .id = .id)
+  roll_tsibble(.x, indices = lst_indices)
 }
 
 #' Tiling window in parallel

tests/testthat/test-roll-tsibble.R

@@ -1,35 +1,31 @@
 context("rolling tsibble")
 
 harvest <- tsibble(
-  year = rep(2010:2012, 2),
-  fruit = rep(c("kiwi", "cherry"), each = 3),
-  kilo = sample(1:10, size = 6),
+  year = c(rep(2010:2012, 2), 2013),
+  fruit = c(rep(c("kiwi", "cherry"), each = 3), "kiwi"),
+  kilo = sample(1:10, size = 7),
   key = fruit, index = year
 )
 
-test_that("error for existing `.id`", {
-  expect_error(
-    slide_tsibble(harvest, .size = 2, .id = "kilo"),
-    "Can't overwrite existing column `kilo`."
-  )
-})
-
 test_that("slide_tsibble()", {
   res <- slide_tsibble(harvest, .size = 2)
-  expect_equal(NROW(res), NROW(harvest) + 2L)
-  expect_named(res, c(names(harvest), ".id"))
-  expect_equal(res$.id, c(rep(1:2, each = 4)))
+  expect_is(res, "list")
+  expect_is(res[[1]], "tbl_ts")
+  expect_length(res, 3)
+  expect_equal(NROW(res[[1]]), 2 * 2)
+  expect_equal(NROW(res[[3]]), 2)
 })
 
 test_that("tile_tsibble()", {
-  res <- tile_tsibble(harvest, .size = 2, .id = "tile_id")
-  expect_equal(NROW(res), NROW(harvest))
-  expect_named(res, c(names(harvest), "tile_id"))
-  expect_equal(res$tile_id, c(rep(1, 4), rep(2, 2)))
+  res <- tile_tsibble(harvest, .size = 2)
+  expect_length(res, 2)
+  expect_equal(NROW(res[[1]]), 2 * 2)
+  expect_equal(NROW(res[[2]]), 2 + 1)
 })
 
 test_that("stretch_tsibble()", {
   res <- stretch_tsibble(harvest)
-  expect_equal(NROW(res), NROW(harvest) * 2)
-  expect_equal(res$.id, c(rep(1, 2), rep(2, 4), rep(3, 6)))
+  expect_length(res, 4)
+  expect_equal(NROW(res[[1]]), 2)
+  expect_equal(NROW(res[[4]]), 4)
 })