sim

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: terra
 Type: Package
 Title: Spatial Data Analysis
-Version: 1.7-72
-Date: 2024-02-06
+Version: 1.7-73
+Date: 2024-02-09
 Depends: R (>= 3.5.0)
 Suggests: parallel, tinytest, ncdf4, sf (>= 0.9-8), deldir, XML, leaflet (>= 2.2.1), htmlwidgets
 LinkingTo: Rcpp

NAMESPACE

@@ -1,7 +1,7 @@
 useDynLib(terra, .registration=TRUE)
 import(methods, Rcpp)
 exportClasses(SpatExtent, SpatRaster, SpatRasterDataset, SpatRasterCollection, SpatVector, SpatVectorProxy, SpatVectorCollection)
-exportMethods("[", "[[", "!", "%in%", activeCat, "activeCat<-", "add<-", addCats, adjacent, all.equal, aggregate, allNA, align, animate, anyNA, app, area, Arith, approximate, as.bool, as.int, as.contour, as.lines, as.points, as.polygons, as.raster, as.array, as.data.frame, as.factor, as.list, as.logical, as.matrix, as.numeric, atan2, atan_2, autocor, barplot, blocks, boundaries, boxplot, buffer, cartogram, categories, cats, catalyze, clamp, clamp_ts, classify, clearance, cellSize, cells, cellFromXY, cellFromRowCol, cellFromRowColCombine, centroids, click, colFromX, colFromCell, colorize, coltab, "coltab<-", combineGeoms, compare, concats, Compare, compareGeom, contour, convHull, countNA, costDist, crds, cover, crop, crosstab, crs, "crs<-", datatype, deepcopy, delaunay, densify, density, depth, "depth<-", describe, diff, disagg, direction, distance, dots, draw, droplevels, elongate, emptyGeoms, erase, extend, ext, "ext<-", extract, extractRange, expanse, fillHoles, fillTime, flip, focal, focal3D, focalCor, focalPairs, focalReg, focalCpp, focalValues, forceCCW, freq, gaps, geom, geomtype, getTileExtents, global, gridDist, gridDistance, has.colors, has.RGB, has.time, hasMinMax, hasValues, hist, head, identical, ifel, impose, init, image, inext, interpIDW, interpNear, inMemory, inset, interpolate, intersect, is.bool, is.int, is.lonlat, is.rotated, isTRUE, isFALSE, is.empty, is.factor, is.lines, is.points, is.polygons, is.related, is.valid, k_means, lapp, layerCor, levels, linearUnits, lines, Logic, varnames, "varnames<-", logic, longnames, "longnames<-", makeValid, mask, match, math, Math, Math2, mean, median, meta, merge, mergeLines, mergeTime, minCircle, minmax, minRect, modal, mosaic, na.omit, not.na, NAflag, "NAflag<-", nearby, nearest, ncell, ncol, "ncol<-", nlyr, "nlyr<-", noNA, normalize.longitude, nrow, "nrow<-", nsrc, origin, "origin<-", pairs, panel, patches, perim, persp, plot, plotRGB, plet, prcomp, princomp, RGB, "RGB<-", polys, points, predict, project, quantile, query, rangeFill, rapp, rast, rasterize, rasterizeGeom, rasterizeWin,readStart, readStop, readValues, rectify, regress, relate, removeDupNodes, res, "res<-", resample, rescale, rev, rcl, roll, rotate, rowFromY, rowColCombine, rowColFromCell, rowFromCell, sapp, scale, scoff, "scoff<-", sds, sort, sprc, sel, selectRange, setMinMax, setValues, segregate, selectHighest, set.cats, set.crs, set.ext, set.names, set.RGB, set.values, size, sharedPaths, shift, sieve, simplifyGeom, snap, sources, spatSample, split, spin, stdev, stretch, subset, subst, summary, Summary, svc, symdif, t, metags, "metags<-", tail, tapp, terrain, tighten, makeNodes, makeTiles, time, timeInfo, "time<-", text, trans, trim, units, union, "units<-", unique, unwrap, update, vect, values, "values<-", viewshed, voronoi, vrt, weighted.mean, where.min, where.max, which.lyr, which.min, which.max, which.lyr, width, window, "window<-", writeCDF, writeRaster, wrap, wrapCache, writeStart, writeStop, writeVector, writeValues, xmin, xmax, "xmin<-", "xmax<-", xres, xFromCol, xyFromCell, xFromCell, ymin, ymax, "ymin<-", "ymax<-", yres, yFromCell, yFromRow, zonal, zoom, cbind2, readRDS, saveRDS, unserialize, serialize, xapp)
+exportMethods("[", "[[", "!", "%in%", activeCat, "activeCat<-", "add<-", addCats, adjacent, all.equal, aggregate, allNA, align, animate, anyNA, app, area, Arith, approximate, as.bool, as.int, as.contour, as.lines, as.points, as.polygons, as.raster, as.array, as.data.frame, as.factor, as.list, as.logical, as.matrix, as.numeric, atan2, atan_2, autocor, barplot, blocks, boundaries, boxplot, buffer, cartogram, categories, cats, catalyze, clamp, clamp_ts, classify, clearance, cellSize, cells, cellFromXY, cellFromRowCol, cellFromRowColCombine, centroids, click, colFromX, colFromCell, colorize, coltab, "coltab<-", combineGeoms, compare, concats, Compare, compareGeom, contour, convHull, countNA, costDist, crds, cover, crop, crosstab, crs, "crs<-", datatype, deepcopy, delaunay, densify, density, depth, "depth<-", describe, diff, disagg, direction, distance, dots, draw, droplevels, elongate, emptyGeoms, erase, extend, ext, "ext<-", extract, extractRange, expanse, fillHoles, fillTime, flip, focal, focal3D, focalCor, focalPairs, focalReg, focalCpp, focalValues, forceCCW, freq, gaps, geom, geomtype, getTileExtents, global, gridDist, gridDistance, has.colors, has.RGB, has.time, hasMinMax, hasValues, hist, head, identical, ifel, impose, init, image, inext, interpIDW, interpNear, inMemory, inset, interpolate, intersect, is.bool, is.int, is.lonlat, is.rotated, isTRUE, isFALSE, is.empty, is.factor, is.lines, is.points, is.polygons, is.related, is.valid, k_means, lapp, layerCor, levels, linearUnits, lines, Logic, varnames, "varnames<-", logic, longnames, "longnames<-", makeValid, mask, match, math, Math, Math2, mean, median, meta, merge, mergeLines, mergeTime, minCircle, minmax, minRect, modal, mosaic, na.omit, not.na, NAflag, "NAflag<-", nearby, nearest, ncell, ncol, "ncol<-", nlyr, "nlyr<-", noNA, normalize.longitude, nrow, "nrow<-", nsrc, origin, "origin<-", pairs, panel, patches, perim, persp, plot, plotRGB, plet, prcomp, princomp, RGB, "RGB<-", polys, points, predict, project, quantile, query, rangeFill, rapp, rast, rasterize, rasterizeGeom, rasterizeWin, readStart, readStop, readValues, rectify, regress, relate, removeDupNodes, res, "res<-", resample, rescale, rev, rcl, roll, rotate, rowFromY, rowColCombine, rowColFromCell, rowFromCell, sapp, scale, scoff, "scoff<-", sds, similarity, sort, sprc, sel, selectRange, setMinMax, setValues, segregate, selectHighest, set.cats, set.crs, set.ext, set.names, set.RGB, set.values, size, sharedPaths, shift, sieve, simplifyGeom, snap, sources, spatSample, split, spin, stdev, stretch, subset, subst, summary, Summary, svc, symdif, t, metags, "metags<-", tail, tapp, terrain, tighten, makeNodes, makeTiles, time, timeInfo, "time<-", text, trans, trim, units, union, "units<-", unique, unwrap, update, vect, values, "values<-", viewshed, voronoi, vrt, weighted.mean, where.min, where.max, which.lyr, which.min, which.max, which.lyr, width, window, "window<-", writeCDF, writeRaster, wrap, wrapCache, writeStart, writeStop, writeVector, writeValues, xmin, xmax, "xmin<-", "xmax<-", xres, xFromCol, xyFromCell, xFromCell, ymin, ymax, "ymin<-", "ymax<-", yres, yFromCell, yFromRow, zonal, zoom, cbind2, readRDS, saveRDS, unserialize, serialize, xapp)
 
 S3method(cbind, SpatVector)
 S3method(rbind, SpatVector)

NEWS.md

@@ -1,11 +1,15 @@
-# version 1.7-72
+# version 1.7-73
 
 ## enhancements
 
 - `extract` has new argument "small=TRUE" to allow for strict use of "touches=FALSE" [#1419](https://github.com/rspatial/terra/issues/1419) by Floris Vanderhaeghe.
 - `as.list<SpatRaster>` has new argument "geom=NULL"
 - `rast<list>` now recognizes (x, y, z) base R "image" structures [stackoverflow](https://stackoverflow.com/questions/77949551/rspatial-convert-a-grid-list-to-a-raster-using-terra) by Ignacio Marzan.
 
+## new 
+
+- `similarity<SpatRaster>` method
+
 
 # version 1.7-71
 

R/Agenerics.R

@@ -1,6 +1,7 @@
 #if (!isGeneric("#")) { setGeneric("#", function(x, ...) standardGeneric("#")) }
 #if (!isGeneric("prcomp")) {setGeneric("prcomp", function(x, ...) standardGeneric("princomp"))}
 
+if (!isGeneric("similarity")) {setGeneric("similarity", function(x, y, ...) standardGeneric("similarity"))}
 if (!isGeneric("k_means")) {setGeneric("k_means", function(x, ...) standardGeneric("k_means"))}
 if (!isGeneric("princomp")) {setGeneric("princomp", function(x, ...) standardGeneric("princomp"))}
 if (!isGeneric("extractRange")) { setGeneric("extractRange", function(x, y, ...) standardGeneric("extractRange"))}

R/distance.R

@@ -205,3 +205,49 @@ setMethod("direction", signature(x="SpatRaster"),
 	}
 )
 
+
+
+setMethod("similarity", signature(x="SpatRaster", y="SpatVector"),
+	function(x, y, labels=NULL, filename="", ...) {
+		e <- as.matrix(extract(x, y, fun="mean", na.rm=TRUE, ID=FALSE))
+		d <- list()
+		for (i in 1:nrow(e)) {
+		  d[[i]] <- sum((x - e[i,])^2)
+		}	
+		out <- which.min(rast(d))
+		if (!is.null(labels)) {
+			levels(out) <- data.frame(ID=1:nrow(y), label=labels)
+		}
+		if (filename!="") {
+			out <- writeRaster(out, filename, ...)
+		}
+		out
+	}
+)
+
+setMethod("similarity", signature(x="SpatRaster", y="data.frame"),
+	function(x, y, labels=NULL, filename="", ...) {
+
+		if (!(all(names(y) %in% names(x)) && (all(names(x) %in% names(y))))) {
+			error("similarity", "names of x and y must match")
+		}
+		y <- y[, names(x)]
+		i <- unique(sapply(y, class))
+		if (any(i != "numeric")) {
+			error("similarity", "all values in y must be numeric")
+		}
+		y <- as.matrix(y)
+		d <- list()
+		for (i in 1:nrow(y)) {
+		  d[[i]] <- sum((x - y[i,])^2)
+		}	
+		out <- which.min(rast(d))
+		if (!is.null(labels)) {
+			levels(out) <- data.frame(ID=1:nrow(y), label=labels)
+		}
+		if (filename!="") {
+			out <- writeRaster(out, filename, ...)
+		}
+		out
+	}
+)

R/inset.R

@@ -23,16 +23,16 @@ setMethod("inext", signature(x="SpatVector"),
 			rescale(x, fx=fx, fy=fy, e[1], e[3])
 		}
 	}
-)
+)	
 
 
-.inset <- function(x, e, loc="", scale=0.2, background="white", perimeter="black", pper, box=NULL, pbox, xpd=NA, ...) {
+.inset <- function(x, e, loc="", scale=0.2, background="white", perimeter=TRUE, pper, box=NULL, pbox, add=TRUE, xpd=NA, ...) {
 
 	usr <- unlist(get.clip()[1:4])
 	if (missing(e)) {
 		e <- ext(usr)
 		r <- diff(e[1:2]) / diff(e[3:4])
-		e[2] <- e[1] + scale * diff(e[1:2])
+		e[2] <- e[1] + scale * diff(e[1:2]) 
 		e[3] <- e[4] - scale * diff(e[3:4]) * r
 	}
 
@@ -77,43 +77,47 @@ setMethod("inext", signature(x="SpatVector"),
 			box <- shift(box, dx, dy)
 		}
 	}
-	if (!is.na(background)) {
-		polys(as.polygons(e), col=background, lty=0, xpd=xpd)
-	}
-
-	plot(y, ..., axes=FALSE, legend=FALSE, add=TRUE, xpd=xpd)
-
-	if (isTRUE(perimeter)) {
-		if (missing(pper) || !is.list(pper)) {
-			pper <- list()
+
+	if (add) {
+		if (!is.na(background)) {
+			polys(as.polygons(e), col=background, lty=0, xpd=xpd)
+		}
+		plot(y, ..., axes=FALSE, legend=FALSE, add=TRUE, xpd=xpd)
+
+		if (isTRUE(perimeter)) {
+			if (missing(pper) || !is.list(pper)) {
+				pper <- list()
+			}
+			#pper$x <- ext(y)
+			pper$x <- e
+			pper$xpd <- xpd
+			do.call(lines, pper)
+			#lines(e, col=perimeter)
 		}
-		pper$x <- e
-		pper$xpd <- xpd
-		do.call(lines, pper)
-		#lines(e, col=perimeter)
-	}
 
-	if (!is.null(box)) {
-		if (missing(pbox) || !is.list(pbox)) {
-			pbox <- list()
+		if (!is.null(box)) {
+			if (missing(pbox) || !is.list(pbox)) {
+				pbox <- list()
+			}
+			pbox$x <- box
+			pbox$xpd <- xpd
+			do.call(lines, pbox)
 		}
-		pbox$x <- box
-		pbox$xpd <- xpd
-		do.call(lines, pbox)
 	}
+
 	invisible(y)
 }
 
 
 setMethod("inset", signature(x="SpatVector"),
-	function(x, e, loc="", scale=0.2, background="white", perimeter=TRUE, box=NULL, pper, pbox, ...) {
-		.inset(x, e, loc=loc, scale=scale, background=background, perimeter=perimeter, pper=pper, box=box, pbox=pbox, ...)
+	function(x, e, loc="", scale=0.2, background="white", perimeter=TRUE, box=NULL, pper, pbox, add=TRUE, ...) {
+		.inset(x, e, loc=loc, scale=scale, background=background, perimeter=perimeter, pper=pper, box=box, pbox=pbox, add=add, ...)
 	}
 )
 
 
 setMethod("inset", signature(x="SpatRaster"),
-	function(x, e, loc="", scale=0.2, background="white", perimeter=TRUE, box=NULL, pper, pbox, ...) {
-		.inset(x, e, loc=loc, scale=scale, background=background, perimeter=perimeter, pper=pper, box=box, pbox=pbox, ...)
+	function(x, e, loc="", scale=0.2, background="white", perimeter=TRUE, box=NULL, pper, pbox, add=TRUE, ...) {
+		.inset(x, e, loc=loc, scale=scale, background=background, perimeter=perimeter, pper=pper, box=box, pbox=pbox, add=add, ...)
 	}
 )

R/plot_legend.R

@@ -497,7 +497,11 @@ add_box <- function(...) {
 			cbind(e[2], e[4:3]),
 			cbind(e[1], e[3])
 		)
-		lines(bx, ...)
+		if (is.null(list(...)$xpd)) {
+			lines(bx, xpd=TRUE, ...)
+		} else {
+			lines(bx, ...)		
+		}
 	}
 }
 

man/similarity.Rd

@@ -0,0 +1,56 @@
+\name{similarity}
+
+\alias{similarity}
+\alias{similarity,SpatRaster,SpatVector-method}
+\alias{similarity,SpatRaster,data.frame-method}
+
+\title{Similarity}
+
+\description{
+Determine for each grid cell the location/record it is most similar to. 
+}
+
+\usage{
+\S4method{similarity}{SpatRaster,SpatRaster}(x, y, labels="", filename="", ...)
+
+\S4method{similarity}{SpatRaster,data.frame}(x, y, labels="", filename="", ...)
+}
+
+\arguments{
+  \item{x}{SpatRaster}
+  \item{y}{SpatVector or data.frame}
+  \item{labels}{character. labels that correspond to each class (row in \code{y}}
+  \item{filename}{character. Output filename}
+  \item{...}{additional arguments for writing files as in \code{\link{writeRaster}}}
+}
+
+\value{
+SpatRaster
+}
+
+
+\examples{
+library(terra)
+f <- system.file("ex/logo.tif", package = "terra")
+r <- rast(f)
+
+# locations of interest 
+pts <- vect(cbind(c(25.25, 34.324, 43.003), c(54.577, 46.489, 30.905)))
+pts$code <- LETTERS[1:3]
+
+plot(r)
+points(pts, pch=20, cex=2, col="red")
+text(pts, "code", pos=4, halo=TRUE)
+
+x <- scale(r)
+
+s1 <- similarity(x, pts, labels=pts$code)
+plot(s1)
+
+# same result
+e <- extract(x, pts, ID=FALSE)
+s2 <- similarity(x, e, labels=c("Ap", "Nt", "Ms"))
+}
+
+\keyword{spatial}
+