Merge pull request #63 from EvolEcolGroup/rename_geom

Rename geom

R/recipe_sf.R

@@ -41,8 +41,6 @@ recipe.sf <- function(x, ...) {
       sf::st_drop_geometry()
   }
 
-
-
   rec <- recipe(x, ...) %>%
     update_role(dplyr::any_of(c("X", "Y")), new_role = "coords")
   class(rec) <- c("spatial_recipe", class(rec))

R/recipes_sf_methods.R

@@ -3,16 +3,22 @@ prep.spatial_recipe <- function(x, training = NULL, fresh = FALSE, verbose = FAL
                                 retain = TRUE, log_changes = FALSE, strings_as_factors = TRUE,
                                 ...) {
   if (!is.null(training)) {
-    # if we have a geometry
-    if ("geometry" %in% names(training)) {
-      ## convert_geometry_column
+    # sometimes we have a tibble with a geometry column but not cast into an sf object
+    # (this is the case when running a workflow)
+    if (inherits(training,"sf")){
+      geom_col <- attributes(training)$sf_column
+    } else {
+      geom_col <- names(training)[unlist(lapply(training, inherits, "sfc"))]
+    }
+    if (length(geom_col) > 0) {
+      geom_col <- geom_col[1]
       training <- training %>%
-        dplyr::bind_cols(sf::st_coordinates(training$geometry)) %>%
+        dplyr::bind_cols(sf::st_coordinates(training[[geom_col]])) %>%
         sf::st_drop_geometry()
     }
     # Add dummy X and Y if they are not already present
     if (!all(c("X", "Y") %in% names(training))) {
-      training <- training %>% dplyr::mutate(X = NA, Y = NA)
+      training <- training %>% dplyr::mutate(X = NA_real_, Y = NA_real_)
     }
   }
   NextMethod(generic="prep",
@@ -26,18 +32,26 @@ prep.spatial_recipe <- function(x, training = NULL, fresh = FALSE, verbose = FAL
 bake.spatial_recipe <- function(object, new_data, ..., composition = "tibble") {
   ## convert_geometry_column
   if (!is.null(new_data)) {
-    if ("geometry" %in% names(new_data)) {
-      ## convert_geometry_column
+    # sometimes we have a tibble with a geometry column but not cast into an sf object
+    # (this is the case when running a workflow)
+    if (inherits(new_data,"sf")){
+      geom_col <- attributes(new_data)$sf_column
+    } else {
+      geom_col <- names(new_data)[unlist(lapply(new_data, inherits, "sfc"))]
+    }
+    if (length(geom_col) > 0) {
+      # if we have multiple geometry column, we use the first one
+      geom_col <- geom_col[1]
       new_data <- new_data %>%
-        dplyr::bind_cols(sf::st_coordinates(new_data$geometry)) %>%
+        dplyr::bind_cols(sf::st_coordinates(new_data[[geom_col]])) %>%
         sf::st_drop_geometry()
     }
     # Add dummy X and Y if they are not already present
     if (!all(c("X", "Y") %in% names(new_data))) {
-      new_data <- new_data %>% dplyr::mutate(X = NA, Y = NA)
+      new_data <- new_data %>% dplyr::mutate(X = NA_real_, Y = NA_real_)
     }
   }
-  NextMethod(generic="bake", object = object, 
+  NextMethod(generic="bake", object = object,
                   new_data = sf::st_drop_geometry(new_data), ...,
                   composition = composition)
 }

tests/testthat/test_recipe_sf.R

@@ -44,3 +44,38 @@ test_that("sdm_recipe_sf", {
   # X should just be a dummy variable
   expect_true(all(is.na(baked_no_xy$X)))
 })
+
+test_that("sdm_recipe_sf works with a geometry named differently", {
+  lacerta_thin <- readRDS(system.file("extdata/lacerta_climate_sf.RDS",
+    package = "tidysdm"
+  ))
+  sf::st_geometry(lacerta_thin) <- "geom"
+  lacerta_rec <- recipe(lacerta_thin, formula = class ~ .)
+
+  lacerta_models <-
+    # create the workflow_set
+    workflow_set(
+      preproc = list(default = lacerta_rec),
+      models = list(
+        # the standard glm specs
+        glm = sdm_spec_glm(),
+        # rf specs with tuning
+        rf = sdm_spec_rf()
+      ),
+      # make all combinations of preproc and models,
+      cross = TRUE
+    ) %>%
+    # tweak controls to store information needed later to create the ensemble
+    option_add(control = control_ensemble_grid())
+  set.seed(100)
+  lacerta_cv <- spatial_block_cv(data = lacerta_thin, v = 3, n = 5)
+  lacerta_models <-
+    lacerta_models %>%
+    workflow_map("tune_grid",
+                 resamples = lacerta_cv, grid = 3,
+                 metrics = sdm_metric_set(), verbose = FALSE
+    )
+  res <- collect_notes(.Last.tune.result) %>% dplyr::distinct(type, note)
+  # expect no errors
+  expect_true(nrow(res) == 0)
+})