Merge pull request #80 from business-science/tidyr

Updates for tidyr 1.0.0

DESCRIPTION

@@ -27,16 +27,20 @@ Imports:
     hms (>= 0.4),
     lubridate (>= 1.6.0),
     purrr (>= 0.2.3),
+    Rcpp (>= 0.12.7),
     rlang (>= 0.1.6),
     tibble (>= 1.4.1),
-    Rcpp (>= 0.12.7),
-    zoo (>= 1.8-0)
+    tidyselect (>= 0.2.5),
+    vctrs (>= 0.2.0),
+    zoo (>= 1.8-0),
+    lifecycle
 Suggests: 
     broom,
     covr,
     gapminder,
     knitr,
     testthat,
-    tidyr
+    tidyr (>= 1.0.0)
 VignetteBuilder: knitr
 LinkingTo: Rcpp
+LazyData: yes

NAMESPACE

@@ -93,6 +93,7 @@ importFrom(dplyr,summarise_)
 importFrom(dplyr,summarize_)
 importFrom(dplyr,transmute)
 importFrom(dplyr,ungroup)
+importFrom(lifecycle,deprecated)
 importFrom(rlang,"%||%")
 importFrom(rlang,":=")
 importFrom(rlang,.data)

R/aaa.R

@@ -28,6 +28,7 @@ register_s3_method <- function(pkg, generic, class, fun = NULL) { # nocov start
   )
 }
 
+tidyr_at_least_1.0.0 <- NULL
 
 .onLoad <- function(libname, pkgname) {
 
@@ -41,6 +42,7 @@ register_s3_method <- function(pkg, generic, class, fun = NULL) { # nocov start
     register_s3_method("tidyr", "nest",   "tbl_time")
     register_s3_method("tidyr", "unnest", "tbl_time")
     register_s3_method("tidyr", "unnest", "tbl_df")
+    tidyr_at_least_1.0.0 <<- utils::packageVersion("tidyr") >= "1.0.0"
   }
 
   invisible()

R/compat-tidyr.R

@@ -1,43 +1,99 @@
-nest.tbl_time <- function(data, ..., .key = "data") {
-  .key       <- rlang::enexpr(.key)
-  .key_sym   <- rlang::sym(.key)
-  .key_char  <- rlang::expr_name(.key)
-  index_quo  <- get_index_quo(data)
-  index_char <- get_index_char(data)
+#' @importFrom lifecycle deprecated
+
+nest.tbl_time <- function(.data, ..., .key = deprecated()) {
+  check_tidyr_version()
+
+  if (rlang::is_missing(.key)) {
+    .key_char <- deprecated()
+  } else {
+    .key <- rlang::enexpr(.key)
+    .key_char <- rlang::expr_name(.key)
+  }
+
+  index_quo  <- get_index_quo(.data)
+  index_char <- get_index_char(.data)
 
   # Need this to avoid data VS .key = "data" collision in the mutate/map
-  ..original_data <- data
+  ..original_data <- .data
 
   # Perform the nest on a tibble
-  .data_nested <- tidyr::nest(as_tibble(data), ..., .key = !! .key)
-
-  # See if the index is nested
-  index_is_nested <- index_char %in% colnames(.data_nested[[.key_char]][[1]])
-
-  # Each nested element should be a tbl_time with attributes
-  if(index_is_nested) {
-    dplyr::mutate(
-      .data_nested,
-      !! .key_sym := purrr::map(
-        .x = !! .key_sym,
-        .f = ~reconstruct(.x, ..original_data))
-    )
+  .data_nested <- tidyr::nest(as_tibble(.data), ..., .key = .key_char)
+
+  # Figure out the names of the new nested columns
+  if (rlang::is_missing(.key)) {
+    nested_columns <- names(rlang::enquos(...))
+
+    if (rlang::is_empty(nested_columns)) {
+      nested_columns <- "data"
+    }
   } else {
-    # The index is in the outer df
-    reconstruct(.data_nested, ..original_data)
+    nested_columns <- .key_char
   }
+
+  contains_index <- function(col) {
+    index_char %in% colnames(.data_nested[[col]][[1]])
+  }
+
+  index_is_nested <- vapply(nested_columns, contains_index, logical(1))
+
+  for (i in seq_along(nested_columns)) {
+    # Each nested element should be a list_of<tbl_time> with attributes
+    if (index_is_nested[i]) {
+      nested_column_sym <- rlang::sym(nested_columns[i])
+
+      .data_nested <- dplyr::mutate(
+        .data_nested,
+        !!nested_column_sym := purrr::map(!!nested_column_sym, ~reconstruct(.x, ..original_data)),
+        !!nested_column_sym := vctrs::as_list_of(!!nested_column_sym, .ptype = (!!nested_column_sym)[[1]])
+      )
+    } else {
+      # The index is in the outer df
+      .data_nested <- reconstruct(.data_nested, ..original_data)
+    }
+  }
+
+  .data_nested
 }
 
-unnest.tbl_time <- function(data, ..., .drop = NA, .id = NULL, .sep = NULL) {
+unnest.tbl_time <- function(data,
+                            cols,
+                            ...,
+                            keep_empty = FALSE,
+                            ptype = NULL,
+                            names_sep = NULL,
+                            names_repair = "check_unique",
+                            .drop = "DEPRECATED",
+                            .id = "DEPRECATED",
+                            .sep = "DEPRECATED",
+                            .preserve = "DEPRECATED") {
+  check_tidyr_version()
+
   # This is called after nesting but excluding the index in the nest
   #reconstruct(NextMethod(), data)
+
+  # Pre-evaluate `cols`, as NextMethod() will evaluate it before tidyr can enquo() it
+  cols <- tidyselect::vars_select(names(data), !!rlang::enquo(cols))
+
   copy_.data <- new_tbl_time(data, get_index_quo(data), get_index_time_zone(data))
   reconstruct(NextMethod(), copy_.data)
 }
 
-unnest.tbl_df <- function(data, ..., .drop = NA, .id = NULL, .sep = NULL) {
+unnest.tbl_df <- function(data,
+                          cols,
+                          ...,
+                          keep_empty = FALSE,
+                          ptype = NULL,
+                          names_sep = NULL,
+                          names_repair = "check_unique",
+                          .drop = deprecated(),
+                          .id = deprecated(),
+                          .sep = deprecated(),
+                          .preserve = deprecated()) {
+  check_tidyr_version()
   # Called after nesting a tbl_time, index is in the nest, then unnesting
-  quos <- rlang::quos(...)
+
+  # Pre-evaluate `cols`, as NextMethod() will evaluate it before tidyr can enquo() it
+  cols <- tidyselect::vars_select(names(data), !!rlang::enquo(cols))
 
   list_cols <- names(data)[purrr::map_lgl(data, rlang::is_list)]
 
@@ -80,7 +136,6 @@ unnest.tbl_df <- function(data, ..., .drop = NA, .id = NULL, .sep = NULL) {
 
 gather.tbl_time <- function(data, key = "key", value = "value", ..., na.rm = FALSE,
                             convert = FALSE, factor_key = FALSE)  {
-
   key   <- rlang::enquo(key)
   value <- rlang::enquo(value)
   quos  <- rlang::quos(...)
@@ -93,7 +148,6 @@ gather.tbl_time <- function(data, key = "key", value = "value", ..., na.rm = FAL
 
 spread.tbl_time <- function(data, key, value, fill = NA, convert = FALSE, drop = TRUE,
                             sep = NULL)  {
-
   key   <- rlang::enquo(key)
   value <- rlang::enquo(value)
 
@@ -103,3 +157,15 @@ spread.tbl_time <- function(data, key, value, fill = NA, convert = FALSE, drop =
 
   reconstruct(spread_data, data)
 }
+
+# ------------------------------------------------------------------------------
+
+check_tidyr_version <- function() {
+  if (tidyr_at_least_1.0.0) {
+    return()
+  }
+
+  rlang::abort("`tidyr` must be at least version '1.0.0' to use this feature.")
+}
+
+

R/index-based-generics.R

@@ -70,7 +70,7 @@ push_datetime.default <- function(x, push) {
 }
 
 push_datetime.hms <- function(x, push) {
-  hms::as.hms(push_datetime.default(x, push))
+  hms::as_hms(push_datetime.default(x, push))
 }
 
 
@@ -292,5 +292,5 @@ coerce_start_date.yearqtr <- function(x, start_date) {
 }
 
 coerce_start_date.hms <- function(x, start_date) {
-  hms::as.hms(start_date, tz = get_index_col_time_zone(start_date))
+  hms::as_hms(start_date)
 }

R/round-index.R

@@ -30,7 +30,7 @@ ceiling_index.default <- function(x, unit = "seconds") {
 #' @export
 ceiling_index.hms <- function(x, unit = "seconds") {
   ceilinged <- ceiling_index(as.POSIXct(x), unit)
-  hms::as.hms(ceilinged, get_index_col_time_zone(ceilinged))
+  hms::as_hms(ceilinged)
 }
 
 #' @export
@@ -77,7 +77,7 @@ floor_index.default <- function(x, unit = "seconds") {
 #' @export
 floor_index.hms <- function(x, unit = "seconds") {
   floored <- floor_index(as.POSIXct(x), unit)
-  hms::as.hms(floored, attr(floored, "tzone"))
+  hms::as_hms(floored)
 }
 
 #' @export

R/seq.R

@@ -26,5 +26,5 @@ seq.hms <- function(from, to, by, ...) {
     as.POSIXct(to),
     by
   )
-  hms::as.hms(.seq, tz = attr(.seq, "tzone"))
+  hms::as_hms(.seq)
 }

R/to_posixct_numeric.R

@@ -86,5 +86,5 @@ dispatch_to_datetime.yearqtr <- function(dummy, x, ..., tz = NULL) {
 
 dispatch_to_datetime.hms <- function(dummy, x, ..., tz = NULL) {
   datetime <- dispatch_to_datetime.default(dummy, x, tz = tz)
-  hms::as.hms(datetime, tz = get_index_col_time_zone(datetime))
+  hms::as_hms(datetime)
 }

tests/testthat/test_ceiling_index.R

@@ -27,6 +27,6 @@ test_that("Ceiling works with hms", {
   hms_test <- create_series('01'~'12', period = "hourly", class = "hms")
   expect_equal(
     ceiling_index(hms_test$date, "12 hour"),
-    rep(43200, 12) %>% hms::as.hms()
+    rep(43200, 12) %>% hms::as_hms()
   )
 })

tests/testthat/test_coercion.R

@@ -9,7 +9,7 @@ test_df <- data.frame(
   group2 = c("d", "e", "e")
 )
 
-test_time <- tibble::as.tibble(test_df)
+test_time <- tibble::as_tibble(test_df)
 
 # Tests
 
@@ -19,7 +19,7 @@ test_that("Can coerce tbl_df to tbl_time", {
   attr(test_time2, "index_quo") <- rlang::quo(date)
   attr(test_time2, "index_time_zone") <- "UTC"
   class(test_time2) <- c("tbl_time", class(test_time2))
-  
+
   expect_equal(as_tbl_time(test_time, date), test_time2)
 })
 
@@ -31,7 +31,7 @@ test_that("Can coerce grouped_df to tbl_time", {
   # tbl_time first then group
   test_time_g <- as_tbl_time(test_time, date) %>%
     group_by(group1)
-  
+
   # group then tbl_time
   expect_equal(test_time %>% group_by(group1) %>% as_tbl_time(date), test_time_g)
 })

tests/testthat/test_compat-tidyr.R

@@ -28,23 +28,51 @@ test_that("nest() with index creates tbl_df", {
 test_that("nest() without index stays tbl_time", {
 
   # Can't use grouped_df with -date, tidyr::nest only chooses groups
-  FANG_nested <- FANG_time %>% tidyr::nest(-date)
+  FANG_nested <- FANG_time %>% tidyr::nest(data = -date)
 
   expect_is(FANG_nested, "tbl_time")
 })
 
+test_that("nest() with .key is deprecated but works", {
+  expect_warning(
+    FANG_nested <- FANG_time %>% tidyr::nest(-date, .key = "stuff")
+  )
+
+  expect_is(FANG_nested, "tbl_time")
+  expect_is(FANG_nested$stuff[[1]], "tbl_df")
+})
+
 test_that("unnest() with index goes back to tbl_time", {
 
-  FANG_unnested <- FANG_g_time %>% tidyr::nest() %>% tidyr::unnest()
+  FANG_unnested <- FANG_g_time %>% tidyr::nest() %>% tidyr::unnest(cols = data)
 
   expect_is(FANG_unnested, "tbl_time")
   expect_equal(get_index_col(FANG_g_time), get_index_col(FANG_unnested))
 })
 
 test_that("unnest() without index stays tbl_time", {
 
-  FANG_unnested <- FANG_time %>% tidyr::nest(-symbol, -date) %>% tidyr::unnest()
+  FANG_unnested <- FANG_time %>% tidyr::nest(data = c(-symbol, -date)) %>% tidyr::unnest(cols = data)
 
   expect_is(FANG_unnested, "tbl_time")
   expect_equal(get_index_col(FANG_time), get_index_col(FANG_unnested))
 })
+
+test_that("unnest() with `...` is deprecated but works", {
+  FANG_nested <- FANG_g_time %>% tidyr::nest(data1 = open, data2 = high)
+
+  expect_warning(
+    FANG_unnested <- tidyr::unnest(FANG_nested, data1, data2)
+  )
+
+  expect_is(FANG_unnested, "tbl_time")
+})
+
+test_that("can still do a normal unnest()", {
+  mtcars_unnested <- mtcars %>%
+    tidyr::nest(data = c(mpg, cyl)) %>%
+    tidyr::unnest(cols = data)
+
+  expect_is(mtcars_unnested, "tbl_df")
+  expect_equal(sort(colnames(mtcars_unnested)), sort(colnames(mtcars)))
+})

tests/testthat/test_floor_index.R

@@ -27,6 +27,6 @@ test_that("Floor works with hms", {
   hms_test <- create_series('01'~'12', period = "hourly", class = "hms")
   expect_equal(
     floor_index(hms_test$date, "12 hour"),
-    c(rep(0, 11), 43200) %>% hms::as.hms()
+    c(rep(0, 11), 43200) %>% hms::as_hms()
   )
 })