V3.2

.github/workflows/R-CMD-check.yml

@@ -1,25 +1,32 @@
-on:
-  push:
-    branches: [ master ]
-  pull_request:
-    branches: [ master ]
-
-name: R-CMD-check
-
-jobs:
-  R-CMD-check:
-    runs-on: macOS-latest
-    steps:
-      - uses: actions/checkout@v3
-      - uses: r-lib/actions/setup-r@v2
-      - name: Setting up pandoc for Rmd docs
-        uses: r-lib/actions/setup-pandoc@v2
-      - uses: r-lib/actions/setup-tinytex@v2
-      - name: Install dependencies
-        run: |
-          install.packages(c("remotes", "rcmdcheck"))
-          remotes::install_deps(dependencies = TRUE)
-        shell: Rscript {0}
-      - name: Check
-        run: rcmdcheck::rcmdcheck(args = "--no-manual", error_on = "error")
-        shell: Rscript {0}
+on:
+  push:
+    branches: [ master ]
+  pull_request:
+    branches: [ master ]
+
+name: R-CMD-check
+
+jobs:
+  R-CMD-check:
+    runs-on: ubuntu-latest
+    steps:
+      - uses: actions/checkout@v4
+      - uses: r-lib/actions/setup-r@v2
+      - name: Setting up pandoc for Rmd docs
+        uses: r-lib/actions/setup-pandoc@v2
+      - uses: r-lib/actions/setup-tinytex@v2
+      - name: Install dependencies
+        run: |
+          install.packages(c("remotes", "rcmdcheck", "covr"))
+          remotes::install_deps(dependencies = TRUE)
+        shell: Rscript {0}
+
+      - name: Check
+        run: rcmdcheck::rcmdcheck(args = "--no-manual", error_on = "error")
+        shell: Rscript {0}
+
+      - name: Test coverage
+        run: covr::codecov()
+        shell: Rscript {0}
+        env:
+          CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }}

.gitignore

@@ -10,3 +10,5 @@ vignettes/tutorial_1.R
 vignettes/tutorial_1.html
 vignettes/tutorial_2.R
 vignettes/tutorial_2.html
+/doc/
+/Meta/

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: blockCV
 Type: Package
 Title: Spatial and Environmental Blocking for K-Fold and LOO Cross-Validation
-Version: 3.1-7
-Date: 2025-08-01
+Version: 3.2-0
+Date: 2025-08-15
 Authors@R: c(person("Roozbeh", "Valavi", role = c("aut", "cre"),
                     email = "valavi.r@gmail.com", comment = c(ORCID = "0000-0003-2495-5277")),
              person("Jane", "Elith", role = "aut",

NEWS.md

@@ -1,12 +1,17 @@
+# version 3.2.0
+* Added two new methods, L1 and L2 distances, to the `cv_similarity` function
+* Fixed a warning in `cv_similarity` for colour aesthetics with ggplot
+* Fixed the summary method and plotting for `cv_spatial_autocor`
+
 # version 3.1.7
-* Temporarily added `sp` package dependency to avoid CRAN check as required by `automap` package [#55].
+* Temporarily added `sp` package dependency to avoid CRAN error as required by `automap` package [#55].
 
 # version 3.1.6
 * Resolved unclear error messages; issue [#52](https://github.com/rvalavi/blockCV/issues/52) by A. Márcia Barbosa
 * Resolved ggplot testing failure; issue [#54](https://github.com/rvalavi/blockCV/issues/54) by Teun van den Brand
 
 # version 3.1.5
-* Resolved background pattern artifacts in raster plotting; issue [#50](https://github.com/rvalavi/blockCV/issues/50) by Camila Neder.
+* Resolved background pattern artefacts in raster plotting; issue [#50](https://github.com/rvalavi/blockCV/issues/50) by Camila Neder.
 
 # version 3.1.4
 * Just the `biomod2` example is updated in vignettes; and the link in help file
@@ -40,7 +45,7 @@
 * Massive performance improvement in the C++ code of `cv_nndm` function for large datasets
 
 # version 3.0
-* Dependency to rgdal and rgeos are removed, and overall less dependency
+* Dependency to `rgdal` and `rgeos` are removed, and overall less dependency
 * Function names have been changed, with all functions now starting with `cv_`
 * The old functions (v2.x) still work to allow appropriate time for adapting the new code
 * The CV blocking functions are now: `cv_spatial`, `cv_cluster`, `cv_buffer`, and `cv_nndm`

R/RcppExports.R

@@ -5,3 +5,7 @@ nndm_cpp <- function(X, Gij, phi, min_train) {
     .Call(`_blockCV_nndm_cpp`, X, Gij, phi, min_train)
 }
 
+similarity_cpp <- function(train_mat, test_mat, rand_mat, L1 = TRUE) {
+    .Call(`_blockCV_similarity_cpp`, train_mat, test_mat, rand_mat, L1)
+}
+

R/checks.R

@@ -1,8 +1,14 @@
 # Author: Roozbeh Valavi
 # contact: valavi.r@gmail.com
 # Date : May 2023
-# Version 0.2
-# Licence GPL v3
+# Version 0.3
+
+# check the object is a blockCV object
+.check_cv <- function(x) {
+    is_cv <- inherits(x, c("cv_spatial", "cv_cluster", "cv_buffer", "cv_nndm"))
+    if (!is_cv) stop("'cv' must be a blockCV cv_* object.")
+}
+
 
 # check points fall within the raster layer
 .check_within <- function(x, r) {

R/cv_block_size.R

@@ -108,8 +108,7 @@ cv_block_size <- function(
     if(!is.null(x)){
         geom_x <- ggplot2::geom_sf(
             data = x,
-            switch(!is.null(column), ggplot2::aes(colour = {{ column }}), NULL),
-            # ggplot2::aes(colour = {{ switch(!is.null(column), column, NULL) }}),
+            switch(!is.null(column), ggplot2::aes(colour = {{ column }})),
             inherit.aes = FALSE,
             alpha = 0.5
         )
@@ -158,7 +157,7 @@ cv_block_size <- function(
                                  fill = "orangered4",
                                  alpha = 0.04,
                                  size = 0.2) +
-                switch(!is.null(x), geom_x, NULL) +
+                switch(!is.null(x), geom_x) +
                 ggplot2::ggtitle("Spatial blocks",
                                  subtitle=paste("Using",
                                                 input$num,

R/cv_buffer.R

@@ -117,7 +117,7 @@ cv_buffer <- function(
     add_bg <- (presence_bg && add_bg)
 
     if(progress) pb <- utils::txtProgressBar(min = 0, max = n, style = 3)
-    fold_list <- lapply(x_1s, function(i, pbag = add_bg){
+    fold_list <- lapply(x_1s, function(i, pbag = add_bg) {
         if(pbag){
             test_ids <- which(dmatrix[i, ] <= size)
             inside <- x[test_ids, column, drop = TRUE]
@@ -127,14 +127,13 @@ cv_buffer <- function(
             test_set <- i
         }
         if(progress) utils::setTxtProgressBar(pb, i)
-        list(as.numeric(which(dmatrix[i, ] > size)),
-             as.numeric(test_set))
-    }
-    )
+
+        list(as.numeric(which(dmatrix[i, ] > size)), as.numeric(test_set))
+    })
 
     # calculate train test table summary
     if(report){
-        train_test_table <- .ttt(fold_list, x, column, n)
+        train_test_table <- .table_summary(fold_list, x, column, n)
         print(summary(train_test_table)[c(1,4,6), ])
     }
 
@@ -172,32 +171,3 @@ summary.cv_buffer <- function(object, ...){
     }
 }
 
-
-# count the train and test records
-.ttt <- function(fold_list, x, column, n){
-    if(is.null(column)){
-        tt_count <- base::data.frame(train = rep(0, n), test = 0)
-        for(i in seq_len(n)){
-            train_set <- fold_list[[i]][[1]]
-            test_set <- fold_list[[i]][[2]]
-            tt_count$train[i] <- length(train_set)
-            tt_count$test[i] <- length(test_set)
-        }
-    } else{
-        cl <- sort(unique(x[, column, drop = TRUE]))
-        clen <- length(cl)
-        .check_classes(clen, column) # column should be binary or categorical
-        tt_count <- as.data.frame(matrix(0, nrow = n, ncol = clen * 2))
-        names(tt_count) <- c(paste("train", cl, sep = "_"), paste("test", cl, sep = "_"))
-        for(i in seq_len(n)){
-            train_set <- fold_list[[i]][[1]]
-            test_set <- fold_list[[i]][[2]]
-            countrain <- table(x[train_set, column, drop = TRUE])
-            countest <- table(x[test_set, column, drop = TRUE])
-            tt_count[i, which(cl %in% names(countrain))] <- countrain
-            tt_count[i, clen + which(cl %in% names(countest))] <- countest
-        }
-    }
-
-    return(tt_count)
-}

R/cv_cluster.R

@@ -205,7 +205,7 @@ cv_cluster <- function(
     final_objs <- list(
         folds_list = fold_list,
         folds_ids = fold_ids,
-        biomod_table = switch(biomod2, as.matrix(biomod_table), NULL),
+        biomod_table = switch(biomod2, as.matrix(biomod_table)),
         k = k,
         column = column,
         type = ifelse(is.null(r), "Spatial Cluster", "Environmental Cluster"),

R/cv_nndm.R

@@ -186,7 +186,7 @@ cv_nndm <- function(
     )
     # calculate train test table summary
     if(report){
-        train_test_table <- .ttt(fold_list, x, column, n)
+        train_test_table <- .table_summary(fold_list, x, column, n)
         print(summary(train_test_table)[c(1,4,6), ])
     }
 

R/cv_plot.R

@@ -58,10 +58,8 @@ cv_plot <- function(
 ){
     # check for availability of ggplot2
     .check_pkgs(c("ggplot2"))
-
-    if(!class(cv) %in% c("cv_spatial", "cv_cluster", "cv_buffer", "cv_nndm")){
-        stop("'cv' must be a blockCV cv_* object.")
-    }
+    # check it's a cv obj
+    .check_cv(cv)
 
     # check x is an sf object
     if(!missing(x)){
@@ -73,6 +71,8 @@ cv_plot <- function(
         r <- .check_r(r)
         r <- r[[1]]
     }
+    # is it a cv_spatial object?
+    is_spatial <- inherits(cv, "cv_spatial")
 
     # make geom_tile for raster plots
     if(!is.null(r)){
@@ -91,10 +91,11 @@ cv_plot <- function(
         geom_rast <- ggplot2::geom_tile(
             data = map_df,
             ggplot2::aes(x = get("x"), y = get("y"), fill = get("value")))
+
         geom_rast_col <- ggplot2::scale_fill_gradientn(colours = raster_colors)
     }
     # make geom_sf for spatial blocks
-    if(methods::is(cv, "cv_spatial")){
+    if(is_spatial){
         blocks <- cv$blocks
         geom_poly <- ggplot2::geom_sf(
             data = sf::st_geometry(blocks),
@@ -114,56 +115,49 @@ cv_plot <- function(
         }
     } else{
         # stop if x is missing for buffer and cluster
-        if(!methods::is(cv, "cv_spatial")) stop("'x' is required for plotting cv_cluster and cv_buffer.")
+        if(!is_spatial) stop("'x' is required for plotting cv_cluster, cv_buffer and cv_nndm.")
     }
 
-    if(missing(x)){
-        if(methods::is(cv, "cv_spatial")){
+    geom_sftext <- if (label_size > 0) {
+        ggplot2::geom_sf_text(
+            ggplot2::aes(label = get("folds")),
+            size = label_size, fun.geometry = sf::st_centroid
+        )
+    } else NULL
 
+    if(missing(x)){
+        if(is_spatial){
             p1 <- ggplot2::ggplot(data = blocks) +
-                switch(!is.null(r), geom_rast, NULL) +
-                switch(!is.null(r), geom_rast_col, NULL) +
+                switch(!is.null(r), geom_rast) + # only switch works with ggplot
+                switch(!is.null(r), geom_rast_col) +
                 ggplot2::geom_sf(colour = "red",
                                  fill = "orangered4",
                                  alpha = 0.04,
                                  linewidth = 0.2) +
-                ggplot2::geom_sf_text(
-                    ggplot2::aes(label = get("folds")),
-                    size = label_size, fun.geometry = sf::st_centroid) +
+                switch(!is.null(geom_sftext), geom_sftext) +
                 ggplot2::labs(x = "", y = "") + # or set the axes labes to NULL
                 ggplot2::scale_x_continuous(guide = ggplot2::guide_axis(check.overlap = TRUE)) +
                 ggplot2::theme_minimal() +
                 ggplot2::guides(fill = "none")
-
         }
 
     } else{
-
         p1 <- ggplot2::ggplot(data = x_long) +
-            switch(!is.null(r), geom_rast, NULL) +
-            switch(!is.null(r), geom_rast_col, NULL) +
-            switch(methods::is(cv, "cv_spatial"), geom_poly, NULL) +
-            # ggplot2::geom_sf(ggplot2::aes(col = rlang::.data$value),
-            ggplot2::geom_sf(ggplot2::aes(col = get("value")),
-                             alpha = points_alpha) +
+            switch(!is.null(r), geom_rast) + # only switch works with ggplot
+            switch(!is.null(r), geom_rast_col) +
+            switch(is_spatial, geom_poly) +
+            ggplot2::geom_sf(ggplot2::aes(col = get("value")), alpha = points_alpha) +
             ggplot2::scale_color_manual(values = points_colors, na.value = "#BEBEBE03") +
-            # ggplot2::facet_wrap(~ rlang::.data$folds, nrow = nrow, ncol = ncol) +
             ggplot2::facet_wrap(~get("folds"), nrow = nrow, ncol = ncol) +
             ggplot2::labs(x = "", y = "", col = "") + # set the axes labes to NULL
             ggplot2::theme_bw() +
             ggplot2::guides(fill = "none")
-
     }
 
     return(p1)
 }
 
 
-# is it a LOO CV object?
-.is_loo <- function(x){
-    methods::is(x, "cv_buffer") || methods::is(x, "cv_nndm")
-}
-
 # transform x and fold numbers for plotting
 .x_to_long <- function(x, cv, num_plot=1:10){
     # get the folds list