.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 (x$leg$x %in% c("top", "bottom")) {
txt <- paste(legtitle, collapse=" ")
} else {
txt <- paste(legtitle, collapse="\n")
}
# offset=.5*graphics::strheight("a",cex=x$leg$title.cex)
text(x=e$xmax, y=e$ymax, labels=txt, 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, ...)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.