new arg key_use in make_cubble() for potential_match

R/checks.R

@@ -0,0 +1,15 @@
+check_key_tbl <- function(obj){
+  if (!inherits(obj, "key_tbl")){
+    cli::cli_abort(
+      "The {.field obj} need to be the result from {.fn check_key}.")
+  }
+
+}
+
+
+check_arg_key_use <- function(arg){
+  if (!arg %in% c("spatial", "temporal")){
+    cli::cli_abort(
+      "The {.field key_use} need to be either 'spatial' or 'temporal'.")
+  }
+}

R/make-cubble.R

@@ -27,6 +27,9 @@
 #' checking. This argument allow the check result to be parsed back to
 #' \code{make_cubble} to also match the \code{potential_pairs} found by the
 #' check.
+#' @param key_use a character of either "spatial" or "temporal". When
+#' \code{potential_math} is activated, this argument specifies which key column
+#' in the potential match to use. Default to "temporal".
 #' @rdname cubble-class
 #' @return a cubble object
 #' @export
@@ -61,7 +64,7 @@ cubble <- function(..., key, index, coords) {
 #' @rdname cubble-class
 #' @export
 make_cubble <- function(spatial, temporal, by = NULL, key, index, coords,
-                        potential_match = NULL){
+                        potential_match = NULL, key_use = "temporal"){
   key <- enquo(key)
   index <- enquo(index)
   coords <- enquo(coords)
@@ -121,16 +124,19 @@ make_cubble <- function(spatial, temporal, by = NULL, key, index, coords,
   }
 
   if (!is.null(potential_match)){
-    if (!inherits(potential_match, "key_tbl")){
-      cli::cli_abort(
-      "The {.field potential_key_match} need to be the result
-      from {.fn check_key}.")
-    }
-
+    check_key_tbl(potential_match)
     tp <- potential_match$potential_pairs$temporal
     sp <- potential_match$potential_pairs$spatial
-    idx <- match(temporal[[key]], tp)
-    temporal[[key]] <- ifelse(!is.na(idx), sp[idx], temporal[[key]])
+
+    check_arg_key_use(key_use)
+    if (key_use == "spatial"){
+      idx <- match(temporal[[key]], tp)
+      temporal[[key]] <- ifelse(!is.na(idx), sp[idx], temporal[[key]])
+    } else{
+      idx <- match(spatial[[key]], sp)
+      spatial[[key]] <- ifelse(!is.na(idx), tp[idx], spatial[[key]])
+    }
+
   }
 
   # find whether there are unmatched spatial and temporal key level

tests/testthat/_snaps/make-cubble.md

@@ -0,0 +1,39 @@
+# make cubble with partial match
+
+    Code
+      dplyr::pull(make_cubble(lga2, covid2, potential_match = check_res), lga)
+    Warning <simpleWarning>
+      st_centroid assumes attributes are constant over geometries
+    Warning <lifecycle_warning_deprecated>
+      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)
+      
+        # Now:
+        data %>% select(all_of(by))
+      
+      See <https://tidyselect.r-lib.org/reference/faq-external-vector.html>.
+    Output
+      [1] "Kingston (C)" "Latrobe (C)" 
+
+---
+
+    Code
+      dplyr::pull(make_cubble(lga2, covid2, potential_match = check_res, key_use = "spatial"),
+      lga)
+    Warning <simpleWarning>
+      st_centroid assumes attributes are constant over geometries
+    Warning <lifecycle_warning_deprecated>
+      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)
+      
+        # Now:
+        data %>% select(all_of(by))
+      
+      See <https://tidyselect.r-lib.org/reference/faq-external-vector.html>.
+    Output
+      [1] "Kingston (C) (Vic.)" "Latrobe (C) (Vic.)" 
+

tests/testthat/test-make-cubble.R

@@ -26,3 +26,23 @@ test_that("when there are sf and tsibble",{
   expect_identical(cb_nested %>% face_temporal() %>% face_spatial(), cb_nested)
   expect_identical(cb_long %>% face_spatial() %>% face_temporal(), cb_long)
 })
+
+
+test_that("make cubble with partial match", {
+  lga2 <- lga |>
+    rename(lga = lga_name_2018) |>
+    dplyr::filter(stringr::str_detect(lga, "Kingston|Latrobe"))
+  covid2 <- covid |> filter(stringr::str_detect(lga, "Kingston|Latrobe")) |>
+    as_tsibble(key = lga)
+  check_res <- check_key(spatial = lga2, temporal = covid2)
+
+  expect_snapshot(
+    make_cubble(lga2, covid2, potential_match = check_res) |>
+      dplyr::pull(lga))
+
+  expect_snapshot(
+    make_cubble(lga2, covid2,
+                potential_match = check_res, key_use = "spatial") |>
+      dplyr::pull(lga)
+  )
+})