R/plot_legend.R

In rspatial/terra: Spatial Data Analysis

.get_breaks <- function(x, n, method, r=NULL) {
	#x <- x[!is.na(x)]
	
	if (is.function(method)) {
		if (!is.null(r)) {
			if (!is.na(r[1])) { 
				x[ x < r[1] ] <- NA
			} 
			if (!is.na(r[2])) { 
				x[ x > r[2] ] <- NA
			} 
		}
		breaks <- method(x)
	} else if (method[1]=="cases") {
		if (!is.null(r)) {
			if (!is.na(r[1])) { 
				x[ x < r[1] ] <- NA
			} 
			if (!is.na(r[2])) { 
				x[ x > r[2] ] <- NA
			} 
		}
		n <- n+1
		i <- seq(0, 1, length.out=n)
		breaks <- quantile(x, i, na.rm=TRUE)
		breaks <- unique(breaks)
		if ((breaks[1] %% 1) != 0) {
			breaks[1] <- breaks[1] - 0.000001
		}
		if ((breaks[n] %% 1) != 0) {
			breaks[n] <- breaks[n] + 0.000001
		}
	} else { # if (method=="eqint") {
		if (is.null(r)) {
			r <- c(min(x, na.rm=TRUE), max(x, na.rm=TRUE))
		} else if (any(is.na(r))) {
			if (is.na(r[1])) r[1] <- min(x, na.rm=TRUE)
			if (is.na(r[2])) r[2] <- max(x, na.rm=TRUE)
		}
		small <- 1e-16
		if ((r[1] %% 1) != 0) { r[1] <- r[1] - small }
		if ((r[2] %% 1) != 0) { r[2] <- r[2] + small }
		breaks <- seq(r[1] , r[2], length.out=n+1)
	}
	unique(breaks)
}

.get_nrnc <- function(nr, nc, nl) {
	if (missing(nc)) {
		nc <- ceiling(sqrt(nl))
	} else {
		nc <- max(1, min(nl, round(nc)))
	}
	if (missing(nr)) {
		nr <- ceiling(nl / nc)
	} else {
		nr <- max(1, min(nl, round(nr)))
		nc <- ceiling(nl / nr)
	}
	c(nr, nc)
}


retro_labels <- function(x, lat=TRUE) {
	if ((is.null(x)) || (!is.numeric(x))) {
		return(x)
	}
	if ((length(x) > 1) && (min(diff(x)) <= 1/120)) {
		d <- floor(x)
		m <- floor(60*(x - d))
		s <- round(3600*(x - d - m/60))
	} else {
		d <- floor(x)
		m <- round(60*(x - d))
		s <- 0
	}

	if (lat) {
		h <- c("S", "", "N")[sign(d)+2]
	} else {
		h <- c("W", "", "E")[sign(d)+2]
	}
	d <- abs(d)
	i <- (s == 0) & (m == 0)
	j <- (s == 0) & (m != 0)

	m <- formatC(m, width=2, flag="0")
	s <- formatC(s, width=2, flag="0")
	r <- paste0(d, "\u00B0" , m, "'", s, '"', h)
	r[i] <- paste0(d[i], "\u00B0" , h[i])
	r[j] <- paste0(d[j], "\u00B0" , m[j], "'", h[j])	
	r
}



.get.leg.coords <- function(x) {

	if (is.null(x$leg$ext)) {
		if (x$clip) {
			p <- x$leg$ext <- x$lim
		} else {
			p <- x$leg$ext <- graphics::par("usr")		
		}
	} else {
		p <- as.vector(x$leg$ext)
	}
	xmin <- p[1]
	xmax <- p[2]
	ymin <- p[3]
	ymax <- p[4]
	flip <- FALSE
	
	if (!is.null(x$leg$shrink)) {
		s <- x$leg$shrink
		if ((s[1] <= 1) & (s[1] >= 0.5)) {
			s[1] <- 2*(s[1] - 0.5)
		} else if (s[1] < 0.5) {
			s[1] <- (2*(0.5 - s[1]))
			flip <- TRUE
		}
		x$leg$size <- s
	} 
	
	if (is.null(x$leg$size)) {
		x$leg$size <- c(1,1)
	} else if (length(x$leg$size) == 1) {
		x$leg$size <- c(x$leg$size, 1)
	}
	if (x$leg$size[1] < 0) flip <- TRUE
	x$leg$size <- abs(x$leg$size)

	if (!is.null(x$leg$main)) {
		n <- length(x$leg$main)
		x$leg$size[1] <- min(x$leg$size[1], (1 - .05*n))
	}

	horiz <- isTRUE(x$leg$x %in% c("top", "bottom"))
	if (horiz) {
#		xd <- (xmax - xmin) * x$leg$size[2]
#		xmin <- xmin + xd 
#		xmax <- xmax - xd

		rhalf <- (xmax - xmin) / 2
		xmid <- xmin + rhalf
		xd <- rhalf * x$leg$size[1]
		xmin <- xmid - xd 
		xmax <- xmid + xd
		
#		yd <- (ymax - ymin) * x$leg$size[1]/1.5
#		ymin <- ymin + yd
#		ymax <- ymax - yd

		yd <- ymax - ymin
		if (x$leg$x == "top") {
			ymax <- ymin + yd * x$leg$size[2] 		
		} else {
			ymin <- ymax - yd * x$leg$size[2] 
		}
		if (flip) {
			tmp <- xmin
			xmin <- xmax
			xmax <- tmp
		}
	} else {

		rhalf <- (ymax - ymin) / 2
		ymid <- ymin + rhalf
		yd <- rhalf * x$leg$size[1]
		ymin <- ymid - yd 
		ymax <- ymid + yd

		xd <- xmax - xmin
		#xmin <- xmin + xd * x$leg$size[2]/5
		#xmax <- xmax - xd * x$leg$size[2]/5
		xmax <- xmin + xd * x$leg$size[2] 
		
		if (flip) {
			tmp <- ymin
			ymin <- ymax
			ymax <- tmp
		}
    }
	dx <- xmax - xmin
	dy <- ymax - ymin

	x$leg$ext <- data.frame(xmin=xmin, xmax=xmax, ymin=ymin, ymax=ymax, dx=dx, dy=dy)
	x
}


.line.usr <- function(line, side) {
## https://stackoverflow.com/questions/30765866/get-margin-line-locations-in-log-space/30835971#30835971

	lh <- graphics::par("cin")[2] * graphics::par("cex") * graphics::par("lheight")
	x_off <- diff(graphics::grconvertX(c(0, lh), "inches", "npc"))
	y_off <- diff(graphics::grconvertY(c(0, lh), "inches", "npc"))
	if (side == 1) {
		graphics::grconvertY(-line * y_off, "npc", "user")
	} else if (side ==2) {
		graphics::grconvertX(-line * x_off, "npc", "user")
	} else if (side ==3) {
		graphics::grconvertY(1 + line * y_off, "npc", "user")
	} else {
		graphics::grconvertX(1 + line * x_off, "npc", "user")
	}
}

.get.leg.extent <- function(x) {
	#usr <- graphics::par("usr")
	dxy <- graphics::par("cxy") * graphics::par("cex")
	loc <- x$leg$x
	if (x$clip) {
		usr <- x$lim
	} else {
		usr <- graphics::par("usr")
	}
	xmin <- usr[1]
	xmax <- usr[2]
	ymin <- usr[3]
	ymax <- usr[4]
	p <- NULL
	if (is.character(loc)) {
		if (loc == "left") {
			#s <- .line.usr(trunc(graphics::par("mar")[2]), 2)
			#p <- c(s+4*dxy[1], s+5*dxy[1], ymin, ymax)	
			if (any(2 %in% x$axs$lab)) {
				p <- c(xmin-4*dxy[1], xmin-3*dxy[1], ymin, ymax)			
			} else {
				p <- c(xmin-2*dxy[1], xmin-dxy[1], ymin, ymax)
			}
		} else if (loc == "bottom") {
			s <- .line.usr(trunc(graphics::par("mar")[1]), 1)
			p <- c(xmin, xmax, s+1.75*dxy[2], s+2.5*dxy[2])
		} else if (loc == "top") {
			p <- c(xmin, xmax, ymax+dxy[2], ymax+1.75*dxy[2])
		} else { #if (loc == "right" or "default" 
			p <- c(xmax+dxy[1], xmax+2*dxy[1], ymin, ymax)
			if (isTRUE(x$leg$yshift)) {
				hy <- (ymax - ymin) / 2
				p[3:4] <- p[3:4] - hy
			}
		}
	}
	x$leg$ext <- p
	x$leg$user <- FALSE
	.get.leg.coords(x)
}

.txt.loc <- function(x) {
	if (isTRUE(x$clip)) {
		dxy <- graphics::par("cxy") * x$cex.main
		if (grepl("right", x$loc.main)) {
			px <- x$lim[2]
			pos <- 2
		} else {
			px <- x$lim[1]
			pos <- 4	
		}
		if (grepl("bottom", x$loc.main)) {
			py <- x$lim[3] + dxy[2]/2
		} else {
			py <- x$lim[4] - dxy[2]/2
		}
	} else {
		dxy <- graphics::par("cxy") * x$cex.main
		usr <- graphics::par("usr")
		if (grepl("right", x$loc.main)) {
			px <- usr[2]
			pos <- 2
		} else {
			px <- usr[1]
			pos <- 4	
		}
		if (grepl("bottom", x$loc.main)) {
			py <- usr[3] + dxy[2]/2
		} else {
			py <- usr[4] - dxy[2]/2
		}
	}
	out <- c(px, py, pos)
	names(out) <- NULL
	out
}




.plot.cont.legend <- function(x, ...) {

	if (!is.null(x$leg$tic)) {
		accepted <- c("in", "out", "none", "through", "throughout")
		tics <- accepted[pmatch(x$leg$tic[1], accepted[-5], 5)]
	} else {
		tics <- "throughout"
	}

	if (!is.null(x$leg$tic.box.col)) {
		ticboxcol <- x$leg$tic.box.col
	} else {
		ticboxcol <- "black"
	}
	
	if (is.null(x$leg$x)) {
		x$leg$x <- "right"
	} else if (!(x$leg$x %in% c("left", "right", "top", "bottom"))) {
		x$leg$x <- "right"	
	}

	if (is.null(x$leg$ext)) {
		x <- .get.leg.extent(x)
	} else {
		x <- .get.leg.coords(x)
	}

	cex <- x$leg$cex
	if (is.null(cex)) cex <- 1
	cex <- cex * 0.8
	
	rotate <- isTRUE(x$leg$rotate)
	srt <- ifelse(rotate, 90, 0)

	cols <- rev(x$cols)
	nc <- length(cols)

	zlim <- x$range
	zz <- x$leg$at
	if (is.null(zz)) {
		if (is.null(x$levels)){
			x$levels <- 5
		}
		zz <- pretty(zlim, n =(x$levels+1))
		zz <- zz[zz >= zlim[1] & zz <= zlim[2]]
	}
	zztxt <- x$leg$labels
	if (is.null(zztxt)) {
		zztxt <- formatC(zz, digits=x$leg$digits, format = "f")
		if (x$fill_range) {
			if (isTRUE(x$range_filled[1])) zztxt[1] <- paste0("< ", zztxt[1])		
			if (isTRUE(x$range_filled[2])) zztxt[length(zztxt)] <- paste0("> ", zztxt[length(zztxt)])		
		}
	}
	e <- x$leg$ext
	if (x$leg$x %in% c("left", "right")) {
		Y <- seq(e$ymin, e$ymax, length.out=nc+1)
		graphics::rect(e$xmin, Y[-(nc + 1)], e$xmax, Y[-1], col=rev(cols), border=NA, xpd=NA)
		ypos <- e$ymin + (zz - zlim[1])/(zlim[2] - zlim[1]) * e$dy
		if (x$leg$x == "right") {
			if (tics == "throughout") {
				graphics::segments(e$xmin, ypos, e$xmax+e$dx*0.25, ypos, xpd=NA)
			} else if (tics == "through") {
				graphics::segments(e$xmin, ypos, e$xmax, ypos, xpd=NA)
			} else if (tics == "in") {
				graphics::segments(e$xmax-e$dx*0.25, ypos, e$xmax, ypos, xpd=NA)			
			} else if (tics == "out") {
				graphics::segments(e$xmax, ypos, e$xmax+e$dx*0.25, ypos, xpd=NA)
			}
			text(e$xmax, ypos, zztxt, pos=4, xpd=NA, cex=cex, ...)
		} else {
			if (tics == "throughout") {
				graphics::segments(e$xmin-e$dx*0.25, ypos, e$xmax, ypos, xpd=NA)
			} else if (tics == "through") {
				graphics::segments(e$xmin, ypos, e$xmax, ypos, xpd=NA)
			} else if (tics == "in") {
				graphics::segments(e$xmin, ypos, e$xmin+e$dx*0.25, ypos, xpd=NA)
			} else if (tics == "out") {
				graphics::segments(e$xmin-e$dx*0.25, ypos, e$xmin, ypos, xpd=NA)
			}
			text(e$xmin, ypos, zztxt, pos=2, xpd=NA, cex=cex, ...)
		}
	} else {
		X <- seq(e$xmin, e$xmax, length.out=nc+1)
		graphics::rect(X[-(nc + 1)], e$ymin, X[-1], e$ymax, col=rev(cols), border=NA, xpd=NA)
		xpos <- e$xmin + (zz - zlim[1])/(zlim[2] - zlim[1]) * e$dx
		if (x$leg$x == "bottom") {
			if (tics == "throughout") {
				graphics::segments(xpos, e$ymin-e$dy*0.25, xpos, e$ymax, xpd=NA)
			} else if (tics == "through") {
				graphics::segments(xpos, e$ymin, xpos, e$ymax, xpd=NA)
			} else if (tics == "in") {
				graphics::segments(xpos, e$ymin+e$dy*0.25, xpos, e$ymin, xpd=NA)
			} else if (tics == "out") {
				graphics::segments(xpos, e$ymin-e$dy*0.25, xpos, e$ymin, xpd=NA)
			}
			text(xpos, e$ymin, zztxt, pos=1, xpd=NA, cex=cex)
		} else {
			if (tics == "throughout") {
				graphics::segments(xpos, e$ymin, xpos, e$ymax+e$dy*0.25, xpd=NA)
			} else if (tics == "through") {
				graphics::segments(xpos, e$ymin, xpos, e$ymax, xpd=NA)
			} else if (tics == "in") {
				graphics::segments(xpos, e$ymax, xpos, e$ymax-e$dy*0.25, xpd=NA)
			} else if (tics == "out") {
				graphics::segments(xpos, e$ymax, xpos, e$ymax+e$dy*0.25, xpd=NA)
			}
			text(xpos, e$ymax+e$dy*0.25, zztxt, pos=3, xpd=NA, cex=cex)
		}
	}
	graphics::rect(e$xmin, e$ymin, e$xmax, e$ymax, border=ticboxcol, xpd=NA)


    if (!is.null(x$leg$title)) {
		leg_i <- x$leg$leg_i
		if (is.null(leg_i)) leg_i = 1
	    if (leg_i <= length(x$leg$title)) {
			legtitle <- x$leg$title[leg_i]
		} else {
			legtitle <- x$leg$title[1]		
		}
		e <- x$leg$ext
		if (length(legtitle) > 1) { # or perhaps !inherits(legtitle, "expression")
			if (x$leg$x %in% c("top", "bottom")) {
				legtitle <- paste(legtitle, collapse=" ")
			} else {
				legtitle <- paste(legtitle, collapse="\n")		
			}
		} 
		# offset=.5*graphics::strheight("a",cex=x$leg$title.cex)
		text(x=e$xmax, y=e$ymax, labels=legtitle, pos=3, cex=x$leg$title.cex, xpd=NA)
	}
	x
}

get_legxy <- function(r, e, pos, yshift) {
	xy <- c(r$left, r$top)
	if (grepl("top", pos)) {
		xy[2] <- e[4]
	} else if (grepl("bottom", pos)) {
		xy[2] <- e[3] + r$h
	}

	if (grepl("left", pos)) {
		xy[1] <- e[1]
	} else if (grepl("right", pos)) {
		xy[1] <- e[2] - r$w
	}
	
	if (!is.null(yshift)) {
		hy <- (e[4] - e[3]) / 2
		xy[2] <- xy[2] - hy
	}
	xy
}


.plot.class.legend <- function(x, y, legend, fill, xpd=NA, cex=1, geomtype="",
	lty=1, lwd=1, pch=1, angle=45, density=NULL, pt.cex = 1, pt.bg="black", pt.lwd=1, 
	bty="n", border="black", seg.len=1, plotlim, yshift=NULL, title=NULL, leg_i=1, ...,
# catch and kill
	merge, trace, size) {

	cex <- cex * 0.8
	if (x %in% c("top", "default")) {
		#usr <- graphics::par("usr")
		x <- plotlim[2]
		y <- plotlim[4]
	}
	
	if (is.null(leg_i)) leg_i = 1
    if (leg_i <= length(title)) {
		title <- title[leg_i]
	} else {
		title <- title[1]		
	}
#points(leg$rect$left+leg$rect$w, leg$rect$top-leg$rect$h, xpd=T)	
	if (grepl("points", geomtype)) {
		if (inherits(x, "character")) {
			r <- legend(x, y, legend, col=fill, xpd=xpd, bty=bty, cex=cex, pch=pch, pt.cex=pt.cex, pt.bg=pt.bg, pt.lwd=pt.lwd, plot=FALSE, title=title, ...)$rect
			xy <- get_legxy(r, plotlim, x, yshift)
			leg <- legend(xy[1], xy[2], legend, col=fill, xpd=xpd, bty=bty, cex=cex, pch=pch, pt.cex=pt.cex, pt.bg=pt.bg, pt.lwd=pt.lwd, title=title, ...)
		} else {
			leg <- legend(x, y, legend, col=fill, xpd=xpd, bty=bty, cex=cex, pch=pch, pt.cex=pt.cex, pt.bg=pt.bg, pt.lwd=pt.lwd, title=title,...)
		}
	} else if (geomtype == "lines") {
		if (inherits(x, "character")) {
			r <- legend(x, y, legend, col=fill, xpd=xpd, bty=bty, cex=cex, lty=lty, lwd=lwd, seg.len=seg.len, plot=FALSE, title=title,, ...)$rect
			xy <- get_legxy(r, plotlim, x, yshift)
			leg <- legend(xy[1], xy[2], legend, col=fill, xpd=xpd, bty=bty, cex=cex, lty=lty, lwd=lwd, seg.len=seg.len, title=title,, ...)
		} else {
			leg <- legend(x, y, legend, col=fill, xpd=xpd, bty=bty, cex=cex, lty=lty, lwd=lwd, seg.len=seg.len, title=title, ...)
		}
	} else {
		if (inherits(x, "character")) {
			r <- legend(x, y, legend, fill=fill, xpd=xpd, bty=bty, cex=cex, density=density*2, angle=angle, border=border, plot=FALSE, title=title, ...)$rect
			xy <- get_legxy(r, plotlim, x, yshift)
			leg <- legend(xy[1], xy[2], legend, fill=fill, xpd=xpd, bty=bty, cex=cex, density=density*2, angle=angle, border=border, title=title, ...)
		} else {
			leg <- legend(x, y, legend, fill=fill, xpd=xpd, bty=bty, cex=cex, density=density*2, angle=angle, border=border, title=title, ...)
		}
	}
	leg
}


add_legend <- function(x, y, ...) {
	if (inherits(x, "character")) {
		e <- unlist(get.clip())
		if (!is.null(e)) {
			rct <- graphics::legend(x=x, y=y, plot=FALSE, ...)$rect
			xy <- get_legxy(rct, e[1:4], x, NULL)
			graphics::legend(x=xy[1], y=xy[2], ...)
		} else {
			graphics::legend(x=x, y=y, ...)
		}
	} else {
		graphics::legend(x=x, y=y, ...)
	}
}


add_box <- function(...) {
	e <- unlist(get.clip())
	if (!is.null(e)) {
		bx <- rbind(
			cbind(e[1], e[3:4]),
			cbind(e[2], e[4:3]),
			cbind(e[1], e[3])
		)
		if (is.null(list(...)$xpd)) {
			lines(bx, xpd=TRUE, ...)
		} else {
			lines(bx, ...)		
		}
	}
}


add_grid <- function(nx=NULL, ny=nx, col="lightgray", lty="dotted", lwd=1) {

	p <- get.clip()

	## adapted from graphics::grid 
	g.grid.at <- function (side, n, axp, usr2) {
		if (is.null(n)) {
			stopifnot(is.numeric(ax <- axp), length(ax) == 3L)
			graphics::axTicks(side, axp=ax, usr=usr2, log=FALSE)
		}
		else if (!is.na(n) && (n <- as.integer(n)) >= 1L) {
			at <- seq.int(usr2[1L], usr2[2L], length.out = n + 1L)
			at[-c(1L, n + 1L)]
		}
	}

    atx <- if (is.null(nx) || (!is.na(nx) && nx >= 1)) 
        g.grid.at(1L, nx, axp = graphics::par("xaxp"), usr2 = p[1:2])
    aty <- if (is.null(ny) || (!is.na(ny) && ny >= 1)) 
        g.grid.at(2L, ny, axp = graphics::par("yaxp"), usr2 = p[3:4])
    graphics::abline(v = atx, h = aty, col = col, lty = lty, lwd = lwd)
    invisible(list(atx = atx, aty = aty))
}


add_mtext <- function(text, side=3, line=0, ...) {

	stopifnot(side %in% 1:4)

	p <- unlist(get.clip())
	h <- graphics::strheight(text, units = "user", ...)	
	
	srt <- 0
	if (side==1) {
		x <- mean(p[1:2])
		y <- p[3] - h - line * h
	} else 	if (side==2) {
		x <- p[1] -1.25 * h - line * h
		y <- mean(p[3:4])
		srt <- 90
	} else 	if (side==3) {
		x <- mean(p[1:2])
		y <- p[4] + h + line * h
	} else {
		x <- p[2] + 1.25 * h + line * h
		y <- mean(p[3:4])
		srt <- 270
	} 
	
	text(x=x, y=y, labels=text, xpd=TRUE, srt=srt, ...)
}