Nothing
#' Divide device into rows and columns
#'
#' \code{autolayout} divides the current device into equal-sized rows
#' and equal-sized columns based on the specified arguments.
#'
#' The rows and columns are constructed using the
#' \code{\link[graphics]{layout}} function, which is incompatible with
#' the \code{mfrow} and \code{mfcol} arguments in the
#' \code{\link[graphics]{par}} function and is also incompatible with
#' the \code{\link[graphics]{split.screen}} function.
#'
#' Note \code{\link[graphics]{par}} parameters are NOT RESET after
#' executing the \code{\link[graphics]{layout}} function so the the
#' user can use existing layout for plots.
#'
#' If \code{legend = "horizontal"} or \code{legend = "vertical"}, then
#' a portion of the device is dedicated to a legend.
#'
#' If \code{common.legend = TRUE}, then one legend region is created
#' for the entire set of plots. If \code{common.legend = FALSE}, then
#' a separate legend region is created for each individual plot.
#'
#' With respective to ordering of the plotting regions: A common
#' legend is plotted after all other plots, while individual legends
#' are plotted after each respective plot.
#'
#' @param size A vector of length two indicating the number of rows
#' and columns that should be used for the series of image data in
#' \code{z}. Note that \code{prod(size)} must match the length of
#' the third dimension of \code{z} (if it is an array), or
#' \code{c(1, 1)} if \code{z} is a matrix.
#' @param legend A character string indicating where the color scale
#' should be placed. The default is \code{"horizontal"}. The other
#' valid options are \code{"none"} and \code{"vertical"}.
#' @param common.legend A logical value indicating whether a common
#' legend scale should be used for all images provided in the
#' \code{z} array. Default is \code{TRUE}. If \code{FALSE}, a
#' separate legend is used for each image.
#' @param lratio A numeric value indicating the ratio of the width of
#' the legend scale to the width of the each image. Default is
#' \code{lratio = 0.2}.
#' @param outer A logical value indicating whether the room should be
#' left for an outer title that is common for all plots. Depends on
#' setting the \code{oma} argument of the
#' \code{\link[graphics]{par}} function.
#' @param show A logical value indicating whether the
#' \code{\link[graphics]{layout.show}} function should be called
#' after the layout is constructed.
#' @param reverse A logical value indicating whether the legend scale
#' should be plotted before the image. Default is \code{FALSE}.
#' @param legend.mar The margins for the legend. (See the \code{mar}
#' argument of \code{\link[graphics]{par}}). If not specified, then
#' sensible values are chosen based on the current vector
#' \code{par("mar")}.
#' @seealso \code{\link[graphics]{image}},
#' \code{\link[fields]{image.plot}}, \code{\link[graphics]{axis}}
#' @return NULL
#' @examples
#' # basic 2x2 layout
#' autolayout(c(2, 2))
#' # 3x2 layout with space for legends
#' autolayout(c(3, 2), legend = "h")
#' autolayout(c(3, 2), legend = "v")
#' # 3x2 layout with individuals legends
#' autolayout(c(3, 2), legend = "h", common.legend = FALSE)
#' autolayout(c(3, 2), legend = "v", common.legend = FALSE)
#' # if outer title is desired
#' autolayout(c(2, 2), outer = TRUE)
#' # reset oma parameters
#' par(oma = c(0, 0, 0, 0))
#' # impact of lratio when legend used
#' autolayout(c(2, 2), legend = "h", lratio = 0.5)
#' autolayout(c(2, 2), legend = "h", lratio = 0.2)
#' @export
autolayout <- function(size, legend = "none", common.legend = TRUE, lratio = 0.2,
outer = FALSE, show = TRUE, reverse = FALSE, legend.mar) {
# match legend argument
legend <- try(match.arg(legend, c("none", "horizontal", "vertical")),
silent = TRUE)
# set legend margin values, if not specified
if (missing(legend.mar))
legend.mar <- automar(legend)
# sanity check
arg.check.autolayout(size, legend, common.legend, outer, show, lratio,
reverse, legend.mar)
# number of rows and columns desired
ng <- prod(size)
nr <- size[1]
nc <- size[2]
# choose layout depending on whether a legend is required, and if so,
# whether the legend should be horizontal or vertical and whether the
# legend is common. A common legend is plotted after all other plots,
# while individual legends are plotted after each respective plot.
# setup if there is no legend
if (legend == "none") {
mat <- matrix(seq_len(ng), nrow = nr, byrow = TRUE)
lheight <- rep(1, nr) # common height for all panes
lwidth <- rep(1, nc) # common width for all panes
} else {
# setup if there should be a legend setup the legend is common
if (common.legend) {
mat <- matrix(seq_len(ng), nrow = nr, byrow = TRUE)
if (legend == "horizontal") {
# make sure legend is in last position
if (!reverse) {
mat <- rbind(mat, matrix(ng + 1, ncol = nc))
} else {
# first position make sure legend is in first position
mat <- rbind(mat + 1, matrix(1, ncol = nc))
}
lheight <- c(rep(1/lratio, nr), 1)
lwidth <- c(rep(1, nc))
} else {
if (!reverse) {
# make sure legend is in first position
mat <- cbind(mat, matrix(ng + 1, nrow = nr))
} else {
# make sure legend is in first position
mat <- cbind(mat + 1, matrix(1, nrow = nr))
}
lheight <- rep(1, nr)
lwidth <- c(rep(1/lratio, nc), 1)
}
} else {
# setup if the legend is not common horizontal legend
if (legend == "horizontal") {
mat <- matrix(0, nrow = 2 * nr, ncol = nc)
for (i in seq_len(nr)) {
crow <- (i - 1) * 2 + 1
if (!reverse) {
mat[crow, ] <- (i - 1) * nc * 2 + seq_len(nc) * 2 -
1
mat[crow + 1, ] <- (i - 1) * nc * 2 + seq_len(nc) *
2
} else {
mat[crow, ] <- (i - 1) * nc * 2 + seq_len(nc) * 2
mat[crow + 1, ] <- (i - 1) * nc * 2 + seq_len(nc) *
2 - 1
}
}
lheight <- c(rep(c(1/lratio, 1), nr))
lwidth <- c(rep(1, nc))
} else {
# vertical legend
mat <- matrix(1:(2 * ng), nrow = nr, ncol = 2 * nc, byrow = TRUE)
if (reverse) {
mat <- matrix(1:(2 * ng), nrow = nr, ncol = 2 * nc, byrow = TRUE) +
matrix(rep(c(1, -1), length = ng), nrow = nr, ncol = 2 *
nc, byrow = TRUE)
}
lheight <- rep(1, nr)
lwidth <- c(rep(c(1/lratio, 1), nc))
}
}
}
if (outer) {
oma <- graphics::par("oma")
# make sure there"s room for outer title
if (max(oma) == 0) {
warning("There is no room in the outer margin for an outer title.
Setting par(oma = c(0, 0, 3, 0)).")
graphics::par(oma = c(0, 0, 3, 0))
}
}
# execute layout
graphics::layout(mat, heights = lheight, widths = lwidth)
.legend.horizontal(ifelse(legend == "vertical", FALSE, TRUE))
.legend.mar(legend.mar)
# show layout, if desired
if (show) {
graphics::layout.show(max(mat))
}
}
arg.check.autolayout <- function(size, legend, common.legend, outer, show,
lratio, reverse, legend.mar = graphics::par("mar")) {
if (length(size) != 2) {
stop("size should be a vector of length 2")
}
if (!is.numeric(size)) {
stop("size should be numeric")
}
if (min(size) < 1) {
stop("the elements of size should be positive integers")
}
if (length(legend) > 1) {
stop("invalid legend argument")
}
if (class(legend) == "try-error") {
stop("invalid legend argument")
}
if (length(common.legend) > 1) {
stop("common.legend should be a single logical value")
}
if (!is.logical(common.legend)) {
stop("common.legend should be a single logical value")
}
if (length(outer) > 1) {
stop("outer should be a single logical value")
}
if (!is.logical(outer)) {
stop("outer should be a single logical value")
}
if (length(show) > 1) {
stop("show should be a single logical value")
}
if (!is.logical(show)) {
stop("show should be a single logical value")
}
if (length(lratio) != 1) {
stop("lratio should be a single positive number")
}
if (!is.numeric(lratio)) {
stop("lratio should be a single positive number")
}
if (lratio <= 0) {
stop("lratio should be a single positive number")
}
if (length(reverse) > 1) {
stop("reverse should be a single logical value")
}
if (!is.logical(reverse)) {
stop("reverse should be a single logical value")
}
if (length(legend.mar) != 4) {
stop("legend.mar should have four elements")
}
if (!is.numeric(legend.mar)) {
stop("legend.mar should be a numeric vector")
}
if (min(legend.mar) < 0) {
stop("legend.mar cannot have negative values")
}
}
#' Add legend to projected image.
#'
#' \code{autolegend} adds a color scale to the current device based on
#' the information from the last calls to the
#' \code{\link[autoimage]{autolayout}} and
#' \code{\link[autoimage]{pimage}} functions.
#'
#' Internally, \code{autolegend} calls the \code{.legend.scale.args},
#' \code{.legend.horizontal}, and \code{.legend.mar} functions to
#' obtain the relevant information.
#'
#' @seealso \code{\link[autoimage]{autolayout}},
#' \code{\link[autoimage]{pimage}},
#' \code{\link[autoimage]{legend.scale}}
#' @return NULL
#' @examples
#' data(narccap)
#' autolayout(c(1, 1), legend = "h")
#' pimage(lon, lat, tasmax[,,1], legend = "none")
#' autolegend()
#'
#' # common legend with distinct lines
#' autolayout(c(1, 2), legend = "h")
#' pimage(lon, lat, tasmax[,,1], legend = "none", map = "world")
#' pimage(lon, lat, tasmax[,,2], legend = "none", map = "usa",
#' proj = "bonne", parameters = 40)
#' autolegend()
#'
#' # separate legends with distinct lines
#' autolayout(c(1, 2), legend = "v", common.legend = FALSE)
#' pimage(lon, lat, tasmax[,,1], legend = "none", map = "state",
#' proj = "bonne", parameters = 40, axes = FALSE)
#' autolegend()
#' pimage(lon, lat, tasmax[,,2], legend = "none", map = "usa",
#' proj = "albers", parameters = c(32, 45), axes = FALSE)
#' autolegend()
#'
#' data(worldMapEnv, package = "maps")
#' # extract hawaii and alaskan borders
#' hiak <- maps::map("world", c("USA:Hawaii", "USA:Alaska"),
#' plot = FALSE)
#' # extract colorado cities from us.cities
#' data(us.cities, package = "maps")
#' codf <- us.cities[us.cities$country.etc == "CO", ]
#' # select smaller subset of colorado cities
#' codf <- codf[c(3, 5, 7:11, 15, 18), ]
#' # extract capitals from us.cities
#' capdf <- us.cities[us.cities$capital == 2,]
#'
#' # setup plotting area
#' autolayout(c(1, 2), legend = "h", common.legend = FALSE, outer = TRUE)
#' # create image of NARCCAP data.
#' # xlim is chosen so to include alaska and hawaii
#' # add grey state borders
#' pimage(lon, lat, tasmax[,,1], legend = "none", proj = "mercator",
#' map = "state", xlim = c(-180, 20),
#' lines.args = list(col = "grey"))
#' # add hawaii and alaskan borders
#' plines(hiak, proj = "mercator", col = "grey")
#' # add state captials to image
#' ppoints(capdf$lon, capdf$lat, proj = "mercator", pch = 16)
#' # title image
#' title("tasmax for North America")
#' # add legend for plot
#' autolegend()
#' # load colorado geochemical data
#' data(co, package = "gear")
#' # create image for colorado aluminum measurements
#' # use bonne projection
#' # customize legend colors
#' # add grey county borders
#' pimage(co$lon, co$lat, co$Al, map = "county", legend = "none",
#' proj = "bonne", parameters = 39,
#' paxes.args = list(grid = FALSE),
#' col = fields::tim.colors(64),
#' lines.args = list(col = "grey"))
#' # add colorado city points to image
#' ppoints(codf$lon, codf$lat, pch = 16, proj = "bonne")
#' # add names of colorado cities to image
#' ptext(codf$lon, codf$lat, labels = codf$name, proj = "bonne", pos = 4)
#' # title plot
#' title("Colorado Aluminum levels (%)")
#' # add legend to current image
#' autolegend()
#' # add common title for plots
#' mtext("Two complicated maps", col = "purple", outer = TRUE, cex = 2)
#'
#' reset.par() # reset device default
#' @export
autolegend <- function() {
legend.mar <- .legend.mar()
legend.scale.args <- .legend.scale.args()
if (is.null(legend.scale.args$zlim)) {
stop("pimage or heat_ppoints must be called before autolegend")
}
legend.scale.args$horizontal <- .legend.horizontal()
curmar <- par("mar")
par(mar = legend.mar)
do.call("legend.scale", legend.scale.args)
par(mar = curmar)
}
#' Creates hidden information for the legend margin and legend scale
#' to using autolegend function.
#' @export
#' @keywords internal
".legend.scale.args" <- local({
val <- list(zlim = NULL, col = NULL, breaks = NULL, axis.args = NULL)
function(new) if (!missing(new))
val <<- new else val
})
#' @export
#' @keywords internal
".legend.mar" <- local({
val <- c(5.1, 0, 4.1, 0)
function(new) if (!missing(new))
val <<- new else val
})
#' @keywords internal
#' @export
".legend.horizontal" <- local({
val <- TRUE
function(new) if (!missing(new))
val <<- new else val
})
#' Sensible legend margins
#'
#' \code{automar} determines sensible margins for
#' \code{\link[autoimage]{legend.scale}} based on the value currently
#' set for \code{par("mar")}.
#'
#' The margins produced by \code{automar} are based on the current
#' choice of \code{par("mar")}. If the user has specified a poor
#' choice for \code{par("mar")}, then \code{automar} might also
#' produce a poor choice for the legend margin.
#'
#' @param legend A character string indicating the orientation of the
#' \code{\link[autoimage]{legend.scale}}. The default is
#' \code{"none"}. The other valid options are \code{"horizontal"}
#' and \code{"vertical"}.
#' @return NULL
#' @examples
#' automar()
#' automar("h")
#' automar("v")
#' @export
automar <- function(legend = "none") {
legend <- match.arg(legend, c("none", "horizontal", "vertical"))
legend.mar <- graphics::par("mar")
if (legend == "horizontal") {
legend.mar[3] <- 0
legend.mar[1] <- 3.1
} else if (legend == "vertical") {
legend.mar[2] <- 0
legend.mar[4] <- 3.1
}
return(legend.mar)
}
#' Automatically select plot matrix dimensions
#'
#' \code{autosize} automatically makes a sensible choice for the
#' dimensions of a plot matrix based on \code{n}, the number of plots.
#' Only works for \code{n <= 36}. The dimensions are chosen to be as
#' close to a square as possible.
#'
#' @param n The number of plots. Should be a positive integer.
#' @return A vector of length 2 with the number of rows and number of
#' columns for the plot matrix.
#' @examples
#' autosize(3)
#' autosize(9)
#' autosize(11)
#' autosize(24)
#' @export
autosize <- function(n) {
if (length(n) != 1)
stop("n should be a single positive integer")
if (length(n) < 1)
stop("n should be a single positive integer")
n <- round(n) # just in case somebody puts in a non-integer
if (n == 1) {
# the trivial case
return(c(1, 1))
} else if (n == 2 | n == 3) {
return(c(1, n))
} else if (n == 4) {
return(c(2, 2))
} else if (n == 5 | n == 6) {
return(c(2, 3))
} else if (n > 6 & n <= 9) {
return(c(3, 3))
} else if (n > 9 & n <= 12) {
return(c(3, 4))
} else if (n > 12 & n <= 16) {
return(c(4, 4))
} else if (n > 16 & n <= 20) {
return(c(4, 5))
} else if (n > 21 & n <= 25) {
return(c(5, 5))
} else if (n > 26 & n <= 30) {
return(c(5, 6))
} else if (n > 31 & n <= 36) {
return(c(6, 6))
} else {
stop("autosize only works for n <= 36. user must choose size.")
}
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.