test covergage now 87%

NAMESPACE

@@ -49,7 +49,6 @@ S3method(unfold,temporal_cubble_df)
 S3method(ungroup,spatial_cubble_df)
 S3method(ungroup,temporal_cubble_df)
 S3method(update_cubble,spatial_cubble_df)
-S3method(update_cubble,temporal_cubble_df)
 export(as_cubble)
 export(bind_cols.spatial_cubble_df)
 export(bind_cols.temporal_cubble_df)

R/as-cubble.R

@@ -193,39 +193,6 @@ as_cubble.stars <- function(data, key, index, coords, ...){
  }
 }
 
-
-parse_dimension <- function(obj){
-
- if (!is.null(obj$value)) {
- out <- obj$value
- } else if (is.numeric(obj$from) &
- is.numeric(obj$to) &
- inherits(obj$delta, "numeric")){
- out <- seq(obj$offset, obj$offset +
- (obj$to - 1) * obj$delta, by = obj$delta)
- } else if (!is.na(obj$refsys)){
- if (obj$refsys == "udunits"){
- tstring <- attr(obj$offset, "units")$numerator
- origin <- parse_time(tstring)
-
- if (is.null(origin))
- cli::cli_abort(
- "The units is currently too complex for {.field cubble} to parse.")
-
- tperiod <- sub(" .*", "\\1", tstring)
- time <- seq(obj$from,obj$to, as.numeric(obj$delta))
- out <- origin %m+% do.call(tperiod, list(x = floor(time)))
- } else if (obj$refsys == "POSIXct"){
- out <- obj$value
- }
- } else{
- cli::cli_abort(
- "The units is currently too complex for {.field cubble} to parse.")
- }
-
- out
-}
-
 #' @rdname as_cubble
 #' @export
 as_cubble.sftime <- function(data, key, index, coords, ...){

R/cubble-update.R

@@ -23,16 +23,15 @@ update_cubble.spatial_cubble_df <- function(data, key = NULL,
 }
 
 #' @rdname update
-#' @export
-update_cubble.temporal_cubble_df <- function(data, key = NULL,
- index = NULL, coords = NULL,
- spatial = NULL, ...){
-
- key <- key_vars(data)
- index <- index_var(data)
- coords <- coords(data)
-
- spatial <- spatial(data)
- data |> new_temporal_cubble(
- key = key, index = index, coords = coords, spatial = spatial)
-}
+# update_cubble.temporal_cubble_df <- function(data, key = NULL,
+# index = NULL, coords = NULL,
+# spatial = NULL, ...){
+#
+# key <- key_vars(data)
+# index <- index_var(data)
+# coords <- coords(data)
+#
+# spatial <- spatial(data)
+# data |> new_temporal_cubble(
+# key = key, index = index, coords = coords, spatial = spatial)
+# }

R/matching.R

@@ -64,7 +64,7 @@ match_sites <- function(df1, df2, crs = sf::st_crs("OGC:CRS84"),
 
 
  if (temporal_matching){
- out <- out |> 
+ out <- out |>
  map(~.x |> match_temporal(
  data_id = !!enquo(data_id), match_id = !!enquo(match_id),
  temporal_match_fn = match_peak,
@@ -107,41 +107,41 @@ match_spatial <- function(df1, df2,
  if (is.null(which)) which <- ifelse(isTRUE(sf::st_is_longlat(df1)),
  "Great Circle", "Euclidean")
 
- dist_df <- sf::st_distance(df1, df2, which = which, par = par) |> 
- as_tibble() |> 
- mutate(from = key_val) |> 
- dplyr::rename_with(~ c(key_val2, "from")) |> 
+ dist_df <- sf::st_distance(df1, df2, which = which, par = par) |>
+ as_tibble() |>
+ mutate(from = key_val) |>
+ dplyr::rename_with(~ c(key_val2, "from")) |>
  tidyr::pivot_longer(cols = -.data$from, names_to = "to", values_to = "dist")
 
- gp_return <- dist_df |> 
- dplyr::slice_min(.data$dist, n = 1, by = .data$from) |> 
- dplyr::slice_min(.data$dist, n = spatial_n_group) |> 
+ gp_return <- dist_df |>
+ dplyr::slice_min(.data$dist, n = 1, by = .data$from) |>
+ dplyr::slice_min(.data$dist, n = spatial_n_group) |>
  mutate(group = dplyr::row_number())
 
- dist_df2 <- dist_df |> 
- inner_join(gp_return |> select(-.data$dist, -.data$to), by = "from") |> 
- dplyr::slice_min(.data$dist, n = spatial_n_each, by = .data$from) |> 
+ dist_df2 <- dist_df |>
+ inner_join(gp_return |> select(-.data$dist, -.data$to), by = "from") |>
+ dplyr::slice_min(.data$dist, n = spatial_n_each, by = .data$from) |>
  arrange(.data$group)
 
  if (return_cubble){
 
- res1 <- df1 |> 
- inner_join(dist_df2 |> 
- select(.data$from, .data$group) |> 
+ res1 <- df1 |>
+ inner_join(dist_df2 |>
+ select(.data$from, .data$group) |>
  rename(!!key := .data$from),
- by = key) |> 
+ by = key) |>
  update_cubble()
 
- res2 <- df2 |> 
- inner_join(dist_df2 |> 
- select(-.data$from) |> 
+ res2 <- df2 |>
+ inner_join(dist_df2 |>
+ select(-.data$from) |>
  rename(!!key := .data$to),
- by = key) |> 
- update_cubble() |> 
+ by = key) |>
+ update_cubble() |>
  arrange(.data$dist)
 
- dist_df2 <- bind_rows(res1, res2) |> 
- dplyr::group_split(.data$group) |> 
+ dist_df2 <- bind_rows(res1, res2) |>
+ dplyr::group_split(.data$group) |>
  map(update_cubble)
  }
 
@@ -164,28 +164,28 @@ match_temporal <- function(data,
  key <- key_vars(data)
  index <- index_var(data)
 
- multiple_match <- any(data |> 
- group_by(!!match_id) |> 
+ multiple_match <- any(data |>
+ group_by(!!match_id) |>
  dplyr::group_size() != 2)
  if (multiple_match){
- data <- data |> 
- dplyr::group_split(!!match_id) |> 
- map(~.x |> update_cubble() |> group_by(type) |> 
- mutate(group2 = dplyr::row_number()) |> 
- dplyr::group_split(.data$group2)) |> 
- unlist(recursive = FALSE) |> 
+ data <- data |>
+ dplyr::group_split(!!match_id) |>
+ map(~.x |> update_cubble() |> group_by(type) |>
+ mutate(group2 = dplyr::row_number()) |>
+ dplyr::group_split(.data$group2)) |>
+ unlist(recursive = FALSE) |>
  map(update_cubble)
  } else{
- data <- data |> 
+ data <- data |>
  dplyr::group_split(!!match_id)
  }
 
- data_long <- data |> 
- map(~.x |> 
- dplyr::group_split(!!data_id) |> 
- purrr::map2(var_names, ~.x |> 
- face_temporal() |> 
- dplyr::select(key, index, .y) |> 
+ data_long <- data |>
+ map(~.x |>
+ dplyr::group_split(!!data_id) |>
+ purrr::map2(var_names, ~.x |>
+ face_temporal() |>
+ dplyr::select(key, index, .y) |>
  dplyr::rename(matched = .y)))
 
  vecs <- data_long |> map(~map(.x, ~.x$matched))
@@ -205,8 +205,8 @@ match_temporal <- function(data,
  res <- out |> dplyr::bind_cols(match_res = res)
 
  if (return_cubble){
- res <- data_long |> 
- map(~map(.x, ~face_spatial(.x)) |> bind_rows()) |> 
+ res <- data_long |>
+ map(~map(.x, ~face_spatial(.x)) |> bind_rows()) |>
  map2(res$match_res, ~.x |> mutate(match_res = .y))
  }
 

R/unfold.R

@@ -36,15 +36,10 @@ unfold.temporal_cubble_df <- function(data, ...){
  to_join <- sp |> as_tibble() |> select(c(key_vars(data), ...))
  out <- as_tibble(data) |> left_join(to_join, by = key)
 
- if (nrow(out) != nrow(data)){
- var <- names(dots)
- cli::cli_alert_warning(
- "The key and unfoldd variable{?s} {.field {var}} are not one-to-one."
- )
- }
-
  if (is_tsibble(data)){
  index <- data %@% index
+ out <- out |> tsibble::as_tsibble(key = !!key, index = index)
+ tsibble_attr <- attributes(out)
  } else{
  index <- as_name(index)
  }

tests/testthat/_snaps/as-cubble.md

@@ -27,6 +27,30 @@
   2 ASN00086077 145. -38.0 12.1 moorabbin airport 94870 <tibble [10 x 4]>
   3 ASN00086282 145. -37.7 113. melbourne airport 94866 <tibble [10 x 4]>
 
+---
+
+ Code
+  as_cubble(nest(climate_flat, data = date:tmin), key = id, index = date, coords = c(
+  long, lat))
+ Output
+  # cubble: key: id [3], index: date, nested form
+  # spatial: [144.8321, -37.98, 145.0964, -37.6655], Missing CRS!
+  # temporal: date [date], prcp [dbl], tmax [dbl], tmin [dbl]
+  id long lat elev name wmo_id ts 
+  <chr> <dbl> <dbl> <dbl> <chr> <dbl> <list> 
+  1 ASN00086038 145. -37.7 78.4 essendon airport 95866 <tibble [10 x 4]>
+  2 ASN00086077 145. -38.0 12.1 moorabbin airport 94870 <tibble [10 x 4]>
+  3 ASN00086282 145. -37.7 113. melbourne airport 94866 <tibble [10 x 4]>
+
+---
+
+ Code
+  as_cubble(nest(climate_flat, data = prcp:tmin), key = id, index = date, coords = c(
+  long, lat))
+ Condition
+  Error in `as_cubble()`:
+  ! Can't' find the index variable in the data. Please check.
+
 ---
 
  Code
@@ -64,10 +88,10 @@
   Using an external vector in selections was deprecated in tidyselect 1.1.0.
   i Please use `all_of()` or `any_of()` instead.
   # Was:
-  data |> select(longlat)
+  data %>% select(longlat)
   
   # Now:
-  data |> select(all_of(longlat))
+  data %>% select(all_of(longlat))
   
   See <https://tidyselect.r-lib.org/reference/faq-external-vector.html>.
  Message
@@ -199,3 +223,16 @@
   2 ASN00086077 12.1 moora~ 94870 (145.0964 -37.98) 145. -38.0 <tibble>
   3 ASN00086282 113. melbo~ 94866 (144.8321 -37.6655) 145. -37.7 <tibble>
 
+---
+
+ Code
+  as_cubble(data_stars, key = id, index = time)
+ Output
+  # cubble: key: id [2], index: time, nested form, [sf]
+  # spatial: [130, -44, 140, -38], WGS 84
+  # temporal: time [date], var1 [dbl]
+  id long lat station ts 
+  * <int> <dbl> <dbl> <POINT [°]> <list> 
+  1 1 130 -38 (130 -38) <tibble [5 x 2]>
+  2 2 140 -44 (140 -44) <tibble [5 x 2]>
+

tests/testthat/_snaps/check-key.md

@@ -81,10 +81,10 @@
   Using an external vector in selections was deprecated in tidyselect 1.1.0.
   i Please use `all_of()` or `any_of()` instead.
   # Was:
-  data |> select(by)
+  data %>% select(by)
   
   # Now:
-  data |> select(all_of(by))
+  data %>% select(all_of(by))
   
   See <https://tidyselect.r-lib.org/reference/faq-external-vector.html>.
  Output

tests/testthat/_snaps/checks.md

@@ -0,0 +1,20 @@
+# multiplication works
+
+ Code
+  make_cubble(spatial = lga, temporal = covid, potential_match = check_res)
+ Condition
+  Warning:
+  st_centroid assumes attributes are constant over geometries
+  Error in `check_key_tbl()`:
+  ! The obj need to be the result from `check_key()`.
+
+---
+
+ Code
+  make_cubble(lga, covid, potential_match = check_res, key_use = "aaa")
+ Condition
+  Warning:
+  st_centroid assumes attributes are constant over geometries
+  Error in `check_key_tbl()`:
+  ! The obj need to be the result from `check_key()`.
+

tests/testthat/_snaps/cubble-class.md

@@ -8,10 +8,10 @@
   Using an external vector in selections was deprecated in tidyselect 1.1.0.
   i Please use `all_of()` or `any_of()` instead.
   # Was:
-  data |> select(by)
+  data %>% select(by)
   
   # Now:
-  data |> select(all_of(by))
+  data %>% select(all_of(by))
   
   See <https://tidyselect.r-lib.org/reference/faq-external-vector.html>.
  Output
@@ -24,3 +24,12 @@
   2 ASN00086077 145. -38.0 12.1 moorabbin airport 94870 <tibble [10 x 4]>
   3 ASN00086282 145. -37.7 113. melbourne airport 94866 <tibble [10 x 4]>
 
+---
+
+ Code
+  key(climate_mel)
+ Output
+  [[1]]
+  id
+  
+