From 523c6f2fd75163b4d2235b3fd60bf335ceea8f46 Mon Sep 17 00:00:00 2001 From: Konstantin Date: Tue, 16 Jan 2024 03:39:34 +0100 Subject: [PATCH] Fixed a bug in rasterPCA.R causing model.center and model.n.obs not to have the same dim --- R/rasterCVA.R | 2 -- R/rasterPCA.R | 6 ++---- R/sam.R | 10 +++++----- man/rasterCVA.Rd | 2 -- man/rasterPCA.Rd | 2 -- man/sam.Rd | 2 +- tests/testthat/test-rasterPCA.R | 8 +------- 7 files changed, 9 insertions(+), 23 deletions(-) diff --git a/R/rasterCVA.R b/R/rasterCVA.R index a14c1a1..06c59ca 100644 --- a/R/rasterCVA.R +++ b/R/rasterCVA.R @@ -21,7 +21,6 @@ #' Returns a SpatRaster with two layers: change vector angle and change vector magnitude #' @export #' @examples -#' \donttest{ #' library(terra) #' pca <- rasterPCA(lsat)$map #' @@ -29,7 +28,6 @@ #' cva <- rasterCVA(pca[[1:2]], pca[[3:4]]) #' cva #' plot(cva) -#' } rasterCVA <- function(x, y, tmf = NULL, nct = NULL, ...) { x <- .toTerra(x) y <- .toTerra(y) diff --git a/R/rasterPCA.R b/R/rasterPCA.R index eee04aa..d0d1f87 100644 --- a/R/rasterPCA.R +++ b/R/rasterPCA.R @@ -24,7 +24,6 @@ #' @return Returns a named list containing the PCA model object ($model) and a SpatRaster with the principal component layers ($object). #' @export #' @examples -#' \donttest{ #' library(ggplot2) #' library(reshape2) #' ggRGB(rlogo, 1,2,3) @@ -43,7 +42,6 @@ #' plots <- lapply(1:3, function(x) ggR(rpc$map, x, geom_raster = TRUE)) #' grid.arrange(plots[[1]],plots[[2]], plots[[3]], ncol=2) #' } -#' } rasterPCA <- function(img, nSamples = NULL, nComp = nlyr(img), spca = FALSE, maskCheck = TRUE, ...){ img <- .toTerra(img) @@ -60,7 +58,7 @@ rasterPCA <- function(img, nSamples = NULL, nComp = nlyr(img), spca = FALSE, ma if(!is.null(nSamples)){ trainData <- terra::spatSample(img, size = nSamples, na.rm = TRUE) - if(nrow(trainData) < terra::nlyr(img)) stop("nSamples too small or img contains a layer with NAs only") + if(nrow(trainData) < nlyr(img)) stop("nSamples too small or img contains a layer with NAs only") model <- stats::princomp(trainData, scores = FALSE, cor = spca) } else { if(maskCheck) { @@ -72,7 +70,7 @@ rasterPCA <- function(img, nSamples = NULL, nComp = nlyr(img), spca = FALSE, ma covMat <- terra::layerCor(img, "cov", na.rm = TRUE) model <- stats::princomp(covmat = covMat$covariance, cor = spca) model$center <- covMat$mean - model$n.obs <- terra::ncell(!any(is.na(img))) + model$n.obs <- t(global(img, "sum", na.rm = TRUE)) if(spca) { ## Calculate scale as population sd like in in princomp diff --git a/R/sam.R b/R/sam.R index 3493405..c646afe 100644 --- a/R/sam.R +++ b/R/sam.R @@ -13,20 +13,20 @@ #' In a second step one can the go ahead an enforce thresholds of maximum angles or simply classify each pixel to the most similar endmember. #' @return SpatRaster #' If \code{angles = FALSE} a single Layer will be returned in which each pixel is assigned to the closest endmember class (integer pixel values correspond to row order of \code{em}. -#' @examples +#' @examples #' library(terra) #' library(ggplot2) -#' -#' ## Sample endmember spectra +#' +#' ## Sample endmember spectra #' ## First location is water, second is open agricultural vegetation #' pts <- data.frame(x = c(624720, 627480), y = c(-414690, -411090)) #' endmembers <- extract(lsat, pts) #' rownames(endmembers) <- c("water", "vegetation") -#' +#' #' ## Calculate spectral angles #' lsat_sam <- sam(lsat, endmembers, angles = TRUE) #' plot(lsat_sam) -#' +#' #' ## Classify based on minimum angle #' lsat_sam <- sam(lsat, endmembers, angles = FALSE) #' diff --git a/man/rasterCVA.Rd b/man/rasterCVA.Rd index a832124..7ef16da 100644 --- a/man/rasterCVA.Rd +++ b/man/rasterCVA.Rd @@ -33,7 +33,6 @@ For example for a given pixel in image A and B for the red and nir band the chan Angles are returned *in degree* beginning with 0 degrees pointing 'north', i.e. the y-axis, i.e. the second band. } \examples{ -\donttest{ library(terra) pca <- rasterPCA(lsat)$map @@ -42,4 +41,3 @@ cva <- rasterCVA(pca[[1:2]], pca[[3:4]]) cva plot(cva) } -} diff --git a/man/rasterPCA.Rd b/man/rasterPCA.Rd index c2333d7..6e94307 100644 --- a/man/rasterPCA.Rd +++ b/man/rasterPCA.Rd @@ -47,7 +47,6 @@ Standardised PCA (SPCA) can be useful if imagery or bands of different dynamic r has the same effect as using normalised bands of unit variance. } \examples{ -\donttest{ library(ggplot2) library(reshape2) ggRGB(rlogo, 1,2,3) @@ -67,4 +66,3 @@ if(require(gridExtra)){ grid.arrange(plots[[1]],plots[[2]], plots[[3]], ncol=2) } } -} diff --git a/man/sam.Rd b/man/sam.Rd index 63eca93..87e114c 100644 --- a/man/sam.Rd +++ b/man/sam.Rd @@ -31,7 +31,7 @@ In a second step one can the go ahead an enforce thresholds of maximum angles or library(terra) library(ggplot2) -## Sample endmember spectra +## Sample endmember spectra ## First location is water, second is open agricultural vegetation pts <- data.frame(x = c(624720, 627480), y = c(-414690, -411090)) endmembers <- extract(lsat, pts) diff --git a/tests/testthat/test-rasterPCA.R b/tests/testthat/test-rasterPCA.R index b30c3b6..f230e95 100644 --- a/tests/testthat/test-rasterPCA.R +++ b/tests/testthat/test-rasterPCA.R @@ -7,13 +7,10 @@ ld <- as.data.frame(lsat_t) for(spc in c(FALSE, TRUE)) { test_that(paste("stats::princomp(covMat(raster)) == stats::princomp(sample) with spca=",spc), { - skip_on_covr() - skip_on_cran() - skip_on_ci() expect_s3_class(r <- rasterPCA(lsat_t, nSamples = NULL, spca = spc), c("RStoolbox", "rasterPCA")) expect_s3_class(rs <- rasterPCA(lsat_t, nSamples = ncell(lsat_t), spca = spc), c("RStoolbox", "rasterPCA")) expect_equal(abs(unclass(rs$model$loadings)), abs(unclass(r$model$loadings))) - expect_equivalent(abs(r$map[]), abs(rs$map[])) + expect_equal(abs(r$map[]), abs(rs$map[]), tolerance = 1e-03) }) } @@ -26,9 +23,6 @@ for(i in seq_len(nrow(G))){ smpl <- if(G[i,"smpl"]) ncell(lsat_t) else NULL test_that(paste("rasterPCA NA handling; spca =",spc, "; nSamples =", deparse(smpl)), { suppressWarnings({ - skip_on_cran() - skip_on_covr() - skip_on_ci() expect_s3_class(r <- rasterPCA(lsat_t, nSamples = smpl, spca = spc), c("RStoolbox", "rasterPCA")) expect_true(all(is.na(r$map[c(100:200,400:500)]))) expect_false(any(is.na(r$map[1:99])))