#' Find graphics device coordinates for rectangles
#' @description Finds graphics device coordinates for rectangles that can be used to construct image legend
#' @param minWorS The minimum X (horizontal legend) or Y (vertical) user coordinate (0 - 1) for the legend
#' @param maxEorN The maximum X (horizontal legend) or Y (vertical) user coordinate (0 - 1) for the legend
#' @param ncuts Number of intervals for legend
#' @param EWorNS "EW" for horizontal legend (default) or "NS" for vertical
#' @param constEWorNS The coordinate that will remain constant (X coord for vertical legend, Y for horiz)
#' @param resEWorNS The width in user coordinate for the legend
#' @return List of coordinates for the four corners of each segment of legend, in graphical device coords
#' @details This function depends on the TeachingDemos library, and still uses the deprecated cnvrt.coords().
#' @export
rect_coords <- function(minWorS, maxEorN, ncuts, EWorNS = "EW", constEWorNS,
resEWorNS) {
space <- diff(c(minWorS, maxEorN)) / ncuts # Resolution in map coordinates for legend boxes
crds <- seq(minWorS, maxEorN, space) # map coordinates for legend boxes
vcrd <- rbind(crds[-length(crds)], crds[-1]) # Segment coordinates (legend intervals)
if(EWorNS == "NS") {
rects <- lapply(1:ncuts, function(x) {
rbind("ll" = c("x" = constEWorNS, "y" = vcrd[1, x]),
"lr" = c("x" = constEWorNS + resEWorNS, "y" = vcrd[1, x]),
"ul" = c("x" = constEWorNS, "y" = vcrd[2, x]),
"ur" = c("x" = constEWorNS + resEWorNS, "y" = vcrd[2, x]))
})
} else if(EWorNS == "EW") {
rects <- lapply(1:ncuts, function(x) {
rbind("ll" = c("x" = vcrd[1, x], "y" = constEWorNS),
"lr" = c("x" = vcrd[2, x], "y" = constEWorNS),
"ul" = c("x" = vcrd[1, x], "y" = constEWorNS + resEWorNS),
"ur" = c("x" = vcrd[2, x], "y" = constEWorNS + resEWorNS))
})
}
rtdev <- lapply(1:ncuts, function(x) {
#do.call("cbind", TeachingDemos::cnvrt.coords(rects[[x]][, 1], rects[[x]][, 2], 'tdev')$usr)
cbind(grconvertX(rects[[x]][, 1], from = "ndc", to = "user"),
grconvertY(rects[[x]][, 2], from = "ndc", to = "user"))
})
return(rtdev)
}
#' Create a legend where you want it
#' @description Creates a vertical or horizontal legend in a location of your choosing
#' @param ncuts Number of intervals for legend
#' @param legend.text Label for the legend (e.g. units)
#' @param legend.vals Vector of labels for the legend
#' @param legend.pos A 1 or 2 element vector that specifies where along vector legend.text should be (details)
#' @param longdims Vector specifying the user coordinates for the legend's long axis (e.g. c(0.2, 0.8))
#' @param shortdims 1) anchor user coordinate for the short axis; 2) width of short axis (e.g. c(0.05, 0.02))
#' @param colvec Vector of colors to fill each polygon in vector, equal in length to ncuts
#' @param leg.adj Tweak position(s) of legend.vals and/or legend.text (see details)
#' @param cex.val Adjusts the text size of legend.vals and/or legend.text (see details)
#' @param srt.val Rotation of legend.vals and/or legend.text (see details)
#' @param horiz TRUE (default) or FALSE for horizontal or vertical legend
#' @param textside Specify "bottom" (default) or "top" for side of legend.vals on legend
#' @param textcol Vector of colors for legend.vals and legend.text
#' @param bordercol Outline color for polygon borders in legend
#' @return A polygon based legend
#' @details Legend.pos uses a two parameter vector, with the second value specifying the polygon number in the
#' legend next to/above/below which the legend.text will appear, and the first which of the four corners of
#' the polygon it will be closest to. Default values are chosen if just one (which then specifies polygon
#' number)vor no values are provided. leg.adj is passed as either a list of two two element vectors, or a
#' single two element vector. If a list, the first element specifies adjustments for legend.values, and the
#' second element adjustments for the legend.text. If just a vector, then these values are used for both. e.g.
#' list(c(0, 0), c(-1, -0.5)); c(0, -0.5).
#' @name flex_legend
#' @rdname flex_legend
#' @examples
#' library(raster)
#' r1 <- raster(nrow = 20, ncol = 20)
#' r1[] <- sample(0:75, ncell(r1), replace = TRUE)
#' brks <- round(quantile(r1, seq(0, 1, 0.1)))
#' cols <- colorRampPalette(c("red", "antiquewhite", "blue"))
#' par(mar = c(5, 4, 0, 0))
#' plot(r1, axes = FALSE, box = FALSE, legend = FALSE, breaks = brks, col = cols(length(brks) - 1))
#' flex_legend(ncuts = length(brks) - 1, legend.text = "vals", leg.adj = list(c(0.5, 1), c(0, -0.5)),
#' legend.vals = brks, legend.pos = c(4, 5), longdims = c(0.2, 0.8), shortdims = c(0.08, 0.03),
#' colvec = cols(length(brks) - 1))
#' dev.off()
#'
#' par(mar = c(0, 4, 0, 4))
#' plot(r1, axes = FALSE, box = FALSE, legend = FALSE, breaks = brks, col = cols(length(brks) - 1))
#' flex_legend(ncuts = length(brks) - 1, legend.text = "vals", textside = "right",
#' legend.pos = c(3, 10), leg.adj = list(c(0.2, 0.5), c(0, -1)),
#' horiz = FALSE, legend.vals = brks, longdims = c(0.2, 0.8),
#' shortdims = c(0.85, 0.02), colvec = cols(length(brks) - 1))
#' dev.off()
#' @export
flex_legend <- function(ncuts, legend.text, legend.vals, legend.pos, longdims, shortdims, colvec,
leg.adj = c(0, 0), cex.val = 1, srt.val = 0, horiz = TRUE, textside = "bottom",
textcol = "black", bordercol = "black") {
lbump <- 0
if(missing(legend.pos)) {
lp <- NULL
lbump <- 0.06
print("Missing legend position")
} else {
lp <- legend.pos
}
if(is.list(leg.adj)) {
ladj1 <- leg.adj[[1]]
ladj2 <- leg.adj[[2]]
} else {
ladj1 <- leg.adj
ladj2 <- leg.adj
}
if(length(cex.val) > 1) {
cex1 <- cex.val[1]
cex2 <- cex.val[2]
} else {
cex1 <- cex.val
cex2 <- cex.val
}
if(length(srt.val) > 1) {
srt1 <- srt.val[1]
srt2 <- srt.val[2]
} else {
srt1 <- srt.val
srt2 <- srt.val
}
ncuts <- ncuts
par(xpd = NA)
if(horiz == TRUE) {
direction <- "EW"
if(is.null(lp)) lp <- c(2, ceiling(ncuts / 2))
if(length(lp) < 2) lp <- c(2, legend.pos)
if(textside == "bottom") tp <- side <- c(1, 2)
if(textside == "top") tp <- c(3, 4)
if(textside == "left" | textside == "right") stop("Horizontal legends must have labels on top or bottom")
} else if(horiz == FALSE) {
direction <- "NS"
if(is.null(lp)) lp <- c(3, ncuts)
if(length(lp) < 2) lp <- c(3, legend.pos)
if(textside == "left") tp <- c(1, 3)
if(textside == "right") tp <- c(2, 4)
if(textside == "top" | textside == "bottom") stop("Vertical legends must have labels on left or right")
}
crds <- rect_coords(minWorS = longdims[1], maxEorN = longdims[2], ncuts = ncuts, EWorNS = direction,
constEWorNS = shortdims[1], resEWorNS = shortdims[2])
leg <- sapply(1:length(crds), function(j) {
rect(crds[[j]][1, 1], crds[[j]][1, 2], crds[[j]][4, 1], crds[[j]][4, 2], col = colvec[j],
border = bordercol)
})
if(horiz == TRUE) {
tcrds <- rbind(crds[[1]][tp[1], ], do.call("rbind", lapply(1:ncuts, function(j) crds[[j]][tp[2], ])))
if(textside == "bottom") tcrds[, 2] <- tcrds[, 2] - abs(tcrds[, 2] * 0.02)
if(textside == "top") tcrds[, 2] <- tcrds[, 2] + abs(tcrds[, 2] * 0.02)
}
if(horiz == FALSE) {
tcrds <- rbind(crds[[1]][tp[1], ], do.call("rbind", lapply(1:ncuts, function(j) crds[[j]][tp[2], ])))
if(textside == "left") tcrds[, 1] <- tcrds[, 1] - abs(tcrds[, 1] * 0.02)
if(textside == "right") tcrds[, 1] <- tcrds[, 1] + abs(tcrds[, 1] * 0.02)
}
text(x = tcrds[, 1], y = tcrds[, 2], labels = legend.vals, adj = ladj1, cex = cex1, srt = srt1,
col = textcol)
lcrds <- crds[[lp[2]]][lp[1], ]
text(x = lcrds[1], y = lcrds[2] + abs(lcrds[2] * lbump), legend.text, cex = cex2, adj = ladj2,
srt = srt2, col = textcol)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.