R/inset.R

In rspatial/terra: Spatial Data Analysis

# Author: Robert J. Hijmans
# Date :  December 2020
# Version 1.0
# License GPL v3


setMethod("inext", signature(x="SpatVector"),
	function(x, e, y=NULL, gap=0) {
	# the area used for scaling
		gap <- rep_len(gap, 2)
		e <- as.vector(e) + c(gap[1], -gap[1], gap[2], -gap[2])
		stopifnot((e[2] > e[1]) && (e[4] > e[3]))
		ex <- ext(x)
		x <- shift(x, e[1] - ex[1], e[3] - ex[3])
		ve <- ext(x)
		fx <- (e[2] - e[1]) / (ve[2] - ve[1])
		fy <- (e[4] - e[3]) / (ve[4] - ve[3])

		if (!is.null(y)) {
			y <- shift(y, e[1] - ex[1], e[3] - ex[3])
			rescale(y, fx=fx, fy=fy, e[1], e[3])
		} else {
			rescale(x, fx=fx, fy=fy, e[1], e[3])
		}
	}
)	


.inset <- function(x, e, loc="", scale=0.2, background="white", perimeter=TRUE, pper, box=NULL, pbox, add=TRUE, xpd=NA, offset=0.1, ...) {

	usr <- unlist(get.clip()[1:4])
	if (missing(e)) {
		e <- ext(usr)
		xe <- ext(x)
		r <- diff(xe[1:2]) / diff(xe[3:4])
		n <- scale * diff(e[1:2])
		e[2] <- e[1] + n
		e[3] <- e[4] - n / r
	}

	#offset <- 0.9
	offset <- 1 - offset
	offset <- max(0.1, min(1, offset))
	scale  <- offset * min(e / ext(x))

	y  <- rescale(x, scale)
	ey <- ext(y)
	xy <- c(mean(ey[1:2]), mean(ey[3:4]))
	xybox <- c(mean(e[1:2]), mean(e[3:4]))
	dx <- xybox[1] - xy[1]
	dy <- xybox[2] - xy[2]
	y  <- shift(y, dx, dy)
	if (!is.null(box)) {
		ex <- ext(x)
		box <- rescale(as.polygons(box), scale, x0=ex[1]+diff(ex[1:2])/2, y0=ex[3]+diff(ex[3:4])/2)
		box <- shift(box, dx, dy)
	}

	if ((loc != "") && (loc != "topleft")) {
		stopifnot(loc %in% c("bottomright", "bottom", "bottomleft", "left", "topleft", "top", "topright", "right", "center"))

		ex <- ext(x)
		if (grepl("top", loc)) {
			dy <- usr[4] - e[4]
		} else if (grepl("bottom", loc)) {
			dy <- usr[3] - e[3]
		} else {
			dy <- (usr[3] + diff(usr[3:4])/2) - (e[3] + diff(e[3:4])/2)
		}
		if (grepl("left", loc)) {
			dx <- usr[1] - e[1]
		} else if (grepl("right", loc)) {
			dx <- usr[2] - e[2]
		} else {
			dx <- (usr[1] + diff(usr[1:2])/2) - (e[1] + diff(e[1:2])/2)
		}
		y <- shift(y, dx, dy)
		e <- shift(e, dx, dy)
		if (!is.null(box)) {
			box <- shift(box, dx, dy)
		}
	}
	
	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)
		}

		if (!is.null(box)) {
			if (missing(pbox) || !is.list(pbox)) {
				pbox <- list()
			}
			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, offset=0.1, add=TRUE, ...) {
		.inset(x, e, loc=loc, scale=scale, background=background, perimeter=perimeter, pper=pper, box=box, pbox=pbox, offset=offset, add=add, ...)
	}
)


setMethod("inset", signature(x="SpatRaster"),
	function(x, e, loc="", scale=0.2, background="white", perimeter=TRUE, box=NULL, pper, pbox, offset=0.1, add=TRUE, ...) {
		.inset(x, e, loc=loc, scale=scale, background=background, perimeter=perimeter, pper=pper, box=box, pbox=pbox, offset=offset, add=add, ...)
	}
)