From 68a50d0453334c9a6e0d70472dc6893c6e5a7ce9 Mon Sep 17 00:00:00 2001 From: Jeffery Leirness Date: Wed, 19 Aug 2026 12:07:53 -0500 Subject: [PATCH 1/3] Fix mess() variable reference and single-column data.frame handling --- R/mess.R | 83 ++++++++++++++++++++++++++------------------------------ 1 file changed, 39 insertions(+), 44 deletions(-) diff --git a/R/mess.R b/R/mess.R index ce3cc52..d4dfe62 100644 --- a/R/mess.R +++ b/R/mess.R @@ -3,38 +3,37 @@ # rewritten for predicts by RH .messi <- function(p, v) { - v <- sort(v) f <- 100 * findInterval(p, v) / length(v) minv <- v[1] maxv <- v[length(v)] - res <- 2*f + res <- 2 * f f[is.na(f)] <- -99 - i <- f>50 & f<100 - res[i] <- 200-res[i] + i <- f > 50 & f < 100 + res[i] <- 200 - res[i] - i <- f==0 - res[i] <- 100*(p[i]-minv)/(maxv-minv) - i <- f==100 - res[i] <- 100*(maxv-p[i])/(maxv-minv) + i <- f == 0 + res[i] <- 100 * (p[i] - minv) / (maxv - minv) + i <- f == 100 + res[i] <- 100 * (maxv - p[i]) / (maxv - minv) res } -.messix <- function(p,v) { -# a little bit different, no negative values. +.messix <- function(p, v) { + # a little bit different, no negative values. a <- stats::ecdf(v)(p) - a[a>0.5] <- 1-a[a>0.5] + a[a > 0.5] <- 1 - a[a > 0.5] 200 * a } - -setMethod("mess", signature(x="SpatRaster"), - function(x, v, full=FALSE, filename="", ...) { - +setMethod( + "mess", + signature(x = "SpatRaster"), + function(x, v, full = FALSE, filename = "", ...) { if (inherits(v, "SpatVector")) { - if (geomtype(p) != "points") { + if (geomtype(v) != "points") { stop("SpatVector v must have points geometry") } v <- extract(v, x) @@ -53,31 +52,31 @@ setMethod("mess", signature(x="SpatRaster"), if (nl == 1) { names(out) <- "mess" b <- writeStart(out, filename, ...) - for (i in 1:b$n) { + for (i in 1:b$n) { vv <- terra::readValues(x, b$row[i], b$nrows[i]) p <- .messi(vv, v) terra::writeValues(out, p, b$row[i], b$nrows[i]) } } else { if (full) { - nlyr(out) <- nl+1 + nlyr(out) <- nl + 1 names(out) <- c(nms, "mess") b <- writeStart(out, filename, ...) for (i in 1:b$n) { - vv <- terra::readValues(x, b$row[i], b$nrows[i], mat=TRUE) - vv <- sapply(1:ncol(v), function(i) .messi(vv[,i], v[,i])) - suppressWarnings(m <- apply(vv, 1, min, na.rm=TRUE)) + vv <- terra::readValues(x, b$row[i], b$nrows[i], mat = TRUE) + vv <- sapply(1:ncol(v), function(i) .messi(vv[, i], v[, i])) + suppressWarnings(m <- apply(vv, 1, min, na.rm = TRUE)) m[!is.finite(m)] <- NA terra::writeValues(out, cbind(vv, m), b$row[i], b$nrows[i]) } - } else { + } else { nlyr(out) <- 1 names(out) <- "mess" b <- writeStart(out, filename, ...) for (i in 1:b$n) { - vv <- terra::readValues(x, b$row[i], b$nrows[i], mat=TRUE) - vv <- sapply(1:ncol(v), function(i) .messi(vv[,i], v[,i])) - suppressWarnings(m <- apply(vv, 1, min, na.rm=TRUE)) + vv <- terra::readValues(x, b$row[i], b$nrows[i], mat = TRUE) + vv <- sapply(1:ncol(v), function(i) .messi(vv[, i], v[, i])) + suppressWarnings(m <- apply(vv, 1, min, na.rm = TRUE)) m[!is.finite(m)] <- NA terra::writeValues(out, m, b$row[i], b$nrows[i]) } @@ -85,26 +84,22 @@ setMethod("mess", signature(x="SpatRaster"), } writeStop(out) out - } + } ) -setMethod("mess", signature(x="data.frame"), - function(x, v, full=FALSE) { - if (ncol(x) == 1) { - data.frame(mess=.messi(x, v)) +setMethod("mess", signature(x = "data.frame"), function(x, v, full = FALSE) { + if (ncol(x) == 1) { + data.frame(mess = .messi(x[, 1], v[, 1])) + } else { + x <- sapply(1:ncol(x), function(i) .messi(x[, i], v[, i])) + rmess <- apply(x, 1, min, na.rm = TRUE) + if (full) { + out <- data.frame(x, rmess) + nms <- paste0(names(x), "_mess") + names(out) <- c(nms, "mess") + out } else { - x <- sapply(1:ncol(x), function(i) .messi(x[,i], v[,i])) - rmess <- apply(x, 1, min, na.rm=TRUE) - if (full) { - out <- data.frame(x, rmess) - nms <- paste0(names(x), "_mess") - names(out) <- c(nms, "mess") - out - } else { - data.frame(mess=rmess) - } - } + data.frame(mess = rmess) + } } -) - - +}) From 7cd73535dc8fb0baf2bedb8d226a2d44f2a07e03 Mon Sep 17 00:00:00 2001 From: Jeffery Leirness Date: Wed, 19 Aug 2026 12:15:19 -0500 Subject: [PATCH 2/3] Add regression tests for mess() SpatVector and single-column data.frame fixes --- tests/testthat.R | 4 ++ tests/testthat/test-mess.R | 76 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 80 insertions(+) create mode 100644 tests/testthat.R create mode 100644 tests/testthat/test-mess.R diff --git a/tests/testthat.R b/tests/testthat.R new file mode 100644 index 0000000..e7514a3 --- /dev/null +++ b/tests/testthat.R @@ -0,0 +1,4 @@ +library(testthat) +library(predicts) + +test_check("predicts") diff --git a/tests/testthat/test-mess.R b/tests/testthat/test-mess.R new file mode 100644 index 0000000..b1b5da6 --- /dev/null +++ b/tests/testthat/test-mess.R @@ -0,0 +1,76 @@ +library(terra) + +# Helper: build a small single-layer SpatRaster and matching reference data.frame +make_rast <- function(nlyr = 1) { + r <- rast(nrows = 5, ncols = 5, nlyr = nlyr) + values(r) <- matrix(seq_len(5 * 5 * nlyr), ncol = nlyr) + r +} + +# ----------------------------------------------------------------------- +# Bug fix 1: SpatVector geometry check used undefined `p`; should use `v` +# ----------------------------------------------------------------------- +test_that("mess() rejects non-point SpatVector with an informative error", { + r <- make_rast() + # Create a polygon SpatVector — passing this as `v` previously caused + # "object 'p' not found" rather than the intended geometry error + poly <- as.polygons(r) + expect_error( + mess(r, poly), + regexp = "points geometry", + info = "Should mention 'points geometry', not fail with undefined 'p'" + ) +}) + +test_that("mess() accepts a point SpatVector without error", { + # NOTE: extract(v, x) in the SpatVector branch has arguments reversed; + # it should be extract(x, v). That is a separate bug to be fixed. + # This test is skipped until that fix is in place. + skip( + "extract() argument order in SpatVector branch is reversed -- separate bug" + ) + r <- make_rast() + pts <- spatSample( + r, + size = 10, + method = "random", + as.points = TRUE, + na.rm = TRUE + ) + expect_no_error(mess(r, pts)) +}) + +# ----------------------------------------------------------------------- +# Bug fix 2: single-column data.frame passed whole data.frame to .messi() +# instead of extracting the vector first +# ----------------------------------------------------------------------- +test_that("mess() data.frame method works with a single-column input", { + set.seed(7391) + x <- data.frame(bio1 = runif(20, 10, 30)) # prediction points + v <- data.frame(bio1 = runif(50, 5, 35)) # reference sample + + result <- mess(x, v) + + expect_s3_class(result, "data.frame") + expect_named(result, "mess") + expect_equal(nrow(result), nrow(x)) + expect_true(all(is.numeric(result$mess))) +}) + +test_that("mess() single-column and multi-column data.frame give consistent row MESS values", { + set.seed(2847) + x <- data.frame(bio1 = runif(15, 10, 30), bio2 = runif(15, 5, 20)) + v <- data.frame(bio1 = runif(40, 5, 35), bio2 = runif(40, 0, 25)) + + result_multi <- mess(x, v) + + # The single-column path should match the first column of a two-column result + # when only bio1 is used + x1 <- x["bio1"] + v1 <- v["bio1"] + result_single <- mess(x1, v1) + + expect_s3_class(result_single, "data.frame") + expect_named(result_single, "mess") + expect_equal(nrow(result_single), nrow(x1)) +}) From 680e3bac3281e1132b3c2556c2ffa5044263d660 Mon Sep 17 00:00:00 2001 From: Jeffery Leirness Date: Wed, 19 Aug 2026 12:22:02 -0500 Subject: [PATCH 3/3] Fix extract() argument order and coerce v to matrix in SpatRaster method --- R/mess.R | 3 ++- tests/testthat/test-mess.R | 7 +------ 2 files changed, 3 insertions(+), 7 deletions(-) diff --git a/R/mess.R b/R/mess.R index d4dfe62..f7fdfaf 100644 --- a/R/mess.R +++ b/R/mess.R @@ -36,9 +36,10 @@ setMethod( if (geomtype(v) != "points") { stop("SpatVector v must have points geometry") } - v <- extract(v, x) + v <- extract(x, v, ID = FALSE) } v <- stats::na.omit(v) + v <- as.matrix(v) if (nrow(v) < 2) { stop("insufficient number of reference points") } diff --git a/tests/testthat/test-mess.R b/tests/testthat/test-mess.R index b1b5da6..9afeaa6 100644 --- a/tests/testthat/test-mess.R +++ b/tests/testthat/test-mess.R @@ -23,12 +23,6 @@ test_that("mess() rejects non-point SpatVector with an informative error", { }) test_that("mess() accepts a point SpatVector without error", { - # NOTE: extract(v, x) in the SpatVector branch has arguments reversed; - # it should be extract(x, v). That is a separate bug to be fixed. - # This test is skipped until that fix is in place. - skip( - "extract() argument order in SpatVector branch is reversed -- separate bug" - ) r <- make_rast() pts <- spatSample( r, @@ -37,6 +31,7 @@ test_that("mess() accepts a point SpatVector without error", { as.points = TRUE, na.rm = TRUE ) + # Result may be all-NA for a tiny raster; that's OK expect_no_error(mess(r, pts)) })