Merge pull request #43 from adamlilith/solstice_2022_2023

`enmSdmX` 1.1.15

DESCRIPTION

@@ -2,7 +2,7 @@ Package: enmSdmX
 Type: Package
 Title: Species Distribution Modeling and Ecological Niche Modeling
 Version: 1.1.5
-Date: 2023-04-10
+Date: 2024-05-16
 Authors@R: 
 	c(
 		person(

NEWS.md

@@ -1,5 +1,7 @@
-# enmSdmX 1.1.5 2023-04-10
+# enmSdmX 1.1.5 2024-05-16
 - Added function `trainESM()` for ensembles of small models.
+- Added several UTM coordinate reference systems accessible through `getCRS()`.
+- Fixed bug in `precidtEnmSdm()` for predicting kernel density models from the **ks** package.
 
 # enmSdmX 1.1.3 2023-03-06
 - `trainGLM()`,  `trainNS()`, and `predictEnmSdm()` now have options to automatically center and scale predictors.

R/customCRS.r

@@ -124,52 +124,6 @@ customLambert <- function(x) {
 customVNS <- function(x, alt = 35800) {
 
 	alt <- 1000 * alt
-
-	cent <- .getCentroid(x)
-	long <- cent$long
-	lat <- cent$lat
-
-	out <- paste0(
-		'PROJCRS["World_Vertical_Perspective",
-			BASEGEOGCRS["WGS 84",
-			DATUM["World Geodetic System 1984",
-				ELLIPSOID["WGS 84",6378137,298.257223563,
-					LENGTHUNIT["metre",1]]],
-			PRIMEM["Greenwich",0,
-				ANGLEUNIT["Degree",0.0174532925199433]]],
-		CONVERSION["World_Vertical_Perspective",
-			METHOD["Vertical Perspective",
-				ID["EPSG",9838]],
-			PARAMETER["Latitude of topocentric origin",', lat, ',
-				ANGLEUNIT["Degree",0.0174532925199433],
-				ID["EPSG",8834]],
-			PARAMETER["Longitude of topocentric origin",', long, ',
-				ANGLEUNIT["Degree",0.0174532925199433],
-				ID["EPSG",8835]],
-			PARAMETER["Viewpoint height",', alt, ',
-				LENGTHUNIT["metre",1],
-				ID["EPSG",8840]]],
-		CS[Cartesian,2],
-			AXIS["(E)",east,
-				ORDER[1],
-				LENGTHUNIT["metre",1]],
-			AXIS["(N)",north,
-				ORDER[2],
-				LENGTHUNIT["metre",1]],
-		USAGE[
-			SCOPE["Not known."],
-			AREA["World."],
-			BBOX[-90,-180,90,180]]]'
-	)
-
-	out
-
-}
-
-customVNS <- function(x, alt = 35800) {
-
-	alt <- 1000 * alt
-
 	cent <- .getCentroid(x)
 	long <- cent$long
 	lat <- cent$lat
@@ -211,7 +165,6 @@ customVNS <- function(x, alt = 35800) {
 
 }
 
-
 ### get centroid of raster, vector, sf, etc. object
 ###################################################
 .getCentroid <- function(x) {
@@ -236,6 +189,7 @@ customVNS <- function(x, alt = 35800) {
 		lat <- cent[1L, 2L]
 
 	} else if (inherits(x, c('matrix', 'data.frame'))) {
+
 		if (ncol(x) != 2L | nrow(x) != 1L) stop('Argument "x" must be a 2-column data frame/matrix with one row, a two-element numeric vector, or a spatial object.')
 		long <- x[1L, 1L]
 		lat <- x[1L, 2L]

R/extentToVect.r

@@ -14,6 +14,11 @@
 #' plot(madExtent, border='blue', lty='dotted')
 #' plot(mad0[1], add=TRUE)
 #'
+#' # NB This is the same as:
+#' library(terra)
+#' madExtent <- ext(mad0)
+#' madExtent <- as.polygons(madExtent, crs = crs(mad0))
+#' 
 #' @export
 extentToVect <- function(x, ...) {
 

R/getCRS.r

@@ -4,9 +4,9 @@
 #'
 #' @param x This can be any of:
 #' \itemize{
-#'		\item Name of CRS: Each CRS has one "long" name and at least one "short" name, which appear in the table returned by \code{getCRS()}. You can use the "long" name of the CRS, or either of the two "short" names.  Spaces, case, and dashes are ignored, but to make the codes more memorable, they are shown as having them.
-#' 		\item \code{NULL} (default): This returns a table of projections with their "long" and "short" names (nearly the same as \code{data(crss)}).
-#'		\item An object of class \code{SpatVector}, \code{SpatRaster}, or \code{sf}. If this is a "\code{Spat}" object, then a character vector with the CRS in WKT form is returned. If a \code{sf} is supplied, then a \code{crs} object is returned in WKT format.
+#'		\item Name of CRS: Each CRS has at least one "alias", which appears in the table returned by \code{getCRS()}. You can use any of the aliases to refer to a CRS. Within the function, spaces, case, and dashes in aliases are ignored, but to help make the aliases more memorable, the aliases include them.
+#' 		\item \code{NULL} (default): This returns a table of projections with their aliases (nearly the same as \code{data(crss)}).
+#'		\item An object of class \code{SpatVector}, \code{SpatRaster}, or \code{sf}. If this is a "\code{Spat}" or "\code{G}" object, then a character vector with the CRS in WKT form is returned. If a \code{sf} is supplied, then a \code{crs} object is returned in WKT format.
 #' }
 #'
 #' @param nice If \code{TRUE}, then print the CRS in a formatted manner and return it invisibly. Default is \code{FALSE}.
@@ -76,6 +76,7 @@ getCRS <- function(
 		} else if (inherits(x, 'sf')) {
 			out <- sf::st_crs(x)
 		} else {
+
 			# return WKT2
 			x <- tolower(x)
 			x <- gsub(x, pattern=' ', replacement='')

R/predictEnmSdm.r

@@ -136,19 +136,19 @@ predictEnmSdm <- function(
 		# GLM
 		} else if (inherits(model, c('glm'))) {
 
-				# center and scale... match names of newdata to pre-calculated centers/scales in GLM object saved by trainGLM()
-				if (scale && any(names(model) == 'scale')) {
-					
-					scaling <- TRUE
-					centers <- model$scale$mean
-					scales <- model$scale$sd
-					nms <- names(newdata)
-					centers <- centers[match(nms, names(centers))]
-					scales <- scales[match(nms, names(scales))]
-					
-				} else {
-					scaling <- FALSE
-				}
+			# center and scale... match names of newdata to pre-calculated centers/scales in GLM object saved by trainGLM()
+			if (scale && any(names(model) == 'scale')) {
+
+				scaling <- TRUE
+				centers <- model$scale$mean
+				scales <- model$scale$sd
+				nms <- names(newdata)
+				centers <- centers[match(nms, names(centers))]
+				scales <- scales[match(nms, names(scales))]
+
+			} else {
+				scaling <- FALSE
+			}
 
 			if (inherits(newdata, c('SpatRaster'))) {
 				if (scaling) newdata <- terra::scale(newdata, center = centers, scale = scales)
@@ -188,7 +188,25 @@ predictEnmSdm <- function(
 			# hack... not calling ks functions explicitly at least once in package generates warning
 			if (FALSE) fhat <- ks::kde(stats::rnorm(100))
 			predictKde <- utils::getFromNamespace('predict.kde', 'ks')
-			out <- predictKde(model, x=as.matrix(newdata), ...)
+			newdataMatrix <- as.matrix(newdata)
+			n <- nrow(newdataMatrix)
+			notNas <- which(stats::complete.cases(newdataMatrix))
+			newdataMatrix <- newdataMatrix[notNas, ]
+			preds <- predictKde(model, x = newdataMatrix, ...)
+
+			if (inherits(newdata, "SpatRaster")) {
+
+				out <- newdata[[1L]]
+				out[] <- NA_real_
+				out <- setValueByCell(out, preds, cell=notNas, format='raster')
+				names(out) <- 'kde'
+
+			} else {
+
+				out <- rep(NA_real_, n)
+				out[notNas] <- preds
+
+			}
 
 		# Maxent
 		} else if (inherits(model, c('MaxEnt', 'MaxEnt_model'))) {
@@ -236,7 +254,6 @@ predictEnmSdm <- function(
 				model$binary
 			}
 
-
 			if (inherits(newdata, 'SpatRaster')) {
 
 				nd <- as.data.frame(newdata, na.rm=FALSE)

man/examples/customCRS_examples.r

@@ -31,7 +31,7 @@ library(terra)
 # Get outline of Canada...
 # We wrap this in tryCatch() in case the server is down.
 can <- tryCatch(
-	gadm('CAN', level=0, path=tempdir()),
+	gadm('CAN', level=0, path=tempdir(), resolution=2),
 	error=function(cond) FALSE
 )
 
@@ -55,4 +55,5 @@ if (!is.logical(can)) {
 	par(oldPar)
 
 }		
+
 }