#' Add a Checkerboard-Like Frame around a Plot
#'
#' This function adds a checkerboard-like frame around an existing plot (or a
#' new one) as an ensemble of small rectangles whose colors, position and width
#' can be specified by user.
#'
#' @param at_x positions on the x-Axis of the borders of rectangles.
#' @param at_y positions on the y-Axis of the borders of rectangles.
#' @param col one or several colors of rectangles background.
#' @param border color of rectangles border.
#' @param width width of the frame.
#' @param lwd thickness of rectangles border (and grid).
#' @param lty type of rectangles border lines (and grid).
#' @param asp aspect ratio of the plot (see `plot.window()`).
#' @param grid a boolean. If `TRUE` adds vertical and horizontal lines at `at_x`
#' and `at_y`.
#' @param add a boolean. If `TRUE` adds the frame to an existing plot.
#' @param ... other graphical parameters as in `par()`.
#'
#' @details
#' If `add = FALSE`, a new plot is drawn with `xlim = ylim = c(-1, 1)`. Argument
#' `col` can be set with one or multiple colors. If only one color is specified
#' in `col`, border color will be used to draw the checkerboard. If `width` is
#' `NULL`, the width of the frame is equivalent to 4% of the extent of the plot
#' area.
#'
#' @export
#'
#' @keywords frame, box, grid
#'
#' @author Nicolas Casajus, \email{nicolas.casajus@@gmail.com}
#'
#' @examples
#' ## Grid and graduations
#' addFrame()
#' addFrame(grid = TRUE)
#' addFrame(grid = TRUE, lwd = 0.25, lty = 3)
#' addFrame(at_x = seq(-1, 1, by = 0.1))
#'
#' ## Frame width
#' addFrame(width = 0.25)
#' addFrame(at_x = seq(-1, 1, by = 0.01), width = 1.00)
#'
#' ## Colors
#' addFrame(col = 1:6)
#' addFrame(col = "lightgray", border = "darkgray")
#'
#' ## Adding to a plot
#' maps::map()
#' addFrame(grid = TRUE, add = TRUE, width = 5)
#' maps::map.axes()
#'
#' ## Other graphical parameters
#' addFrame(bg = "darkgray", xaxs = "i", yaxs = "i")
#'
addFrame <- function(at_x, at_y, col = c("white", border), border = "black",
width = NULL, lwd = 1, lty = 1, asp = NA, grid = FALSE,
add = FALSE, ...) {
if (length(border) > 1) stop("Argument 'border' must be a single color.")
opar <- par(no.readonly = TRUE)
on.exit(par(opar, no.readonly = TRUE))
par(...)
if (!add) {
if (missing(at_x)) {
x_lim <- c(-1, 1)
} else {
x_lim <- range(at_x)
}
if (missing(at_y)) {
y_lim <- c(-1, 1)
} else {
y_lim <- range(at_y)
}
plot(0,
xlim = x_lim, ylim = y_lim, type = "n", ann = FALSE, axes = FALSE,
bty = "n", asp = asp
)
}
if (is.null(width)) width <- 4 * (par()$usr[2] - par()$usr[1]) / 100
if (missing(at_x)) at_x <- axTicks(side = 1)
if (missing(at_y)) at_y <- axTicks(side = 2)
at_x <- at_x[at_x > (par()$usr[1] + width) & at_x < (par()$usr[2] - width)]
at_y <- at_y[at_y > (par()$usr[3] + width) & at_y < (par()$usr[4] - width)]
if (!length(at_x)) stop("x-Axis graduations are ouside plot range.")
if (!length(at_y)) stop("y-Axis graduations are ouside plot range.")
at_x <- sort(unique(c(par()$usr[1], at_x, par()$usr[2])))
at_y <- sort(unique(c(par()$usr[3], at_y, par()$usr[4])))
ats <- list()
ats[[1]] <- at_x
ats[[2]] <- at_y
ats[[3]] <- at_x[seq(length(at_x), 1, -1)]
ats[[4]] <- at_y[seq(length(at_y), 1, -1)]
if (length(col) == 1) {
cols <- c(col, border)
} else {
cols <- col
}
cols <- rep_len(
x = cols,
length.out = 2 * (length(at_x) - 1) + 2 * (length(at_y) - 1)
)
if (grid) {
for (at in at_x) {
lines(
x = rep(at, 2),
y = c(par()$usr[3], par()$usr[4]),
col = border,
lwd = lwd,
lty = lty
)
}
for (at in at_y) {
lines(
x = c(par()$usr[1], par()$usr[2]),
y = rep(at, 2),
col = border,
lwd = lwd,
lty = lty
)
}
}
par(xpd = TRUE)
k <- 2
for (side in seq_along(ats)) {
if (length(ats[[side]]) > 3) {
for (tick in 2:(length(ats[[side]]) - 2)) {
if (side == 1) {
x1 <- ats[[side]][tick]
x2 <- ats[[side]][tick + 1]
y1 <- par()$usr[3]
y2 <- par()$usr[3] + width
}
if (side == 2) {
x1 <- par()$usr[2] - width
x2 <- par()$usr[2]
y1 <- ats[[side]][tick]
y2 <- ats[[side]][tick + 1]
}
if (side == 3) {
x1 <- ats[[side]][tick]
x2 <- ats[[side]][tick + 1]
y1 <- par()$usr[4] - width
y2 <- par()$usr[4]
}
if (side == 4) {
x1 <- par()$usr[1]
x2 <- par()$usr[1] + width
y1 <- ats[[side]][tick]
y2 <- ats[[side]][tick + 1]
}
rect(
xleft = x1,
ybottom = y1,
xright = x2,
ytop = y2,
col = cols[k],
border = border,
lwd = lwd,
lty = lty
)
k <- k + 1
}
k <- k + 2
}
}
## Corner Bottom-Left ----
col <- cols[1]
polygon(
x = c(
par()$usr[1],
ats[[1]][2],
ats[[1]][2],
par()$usr[1] + width
),
y = c(
par()$usr[3],
par()$usr[3],
par()$usr[3] + width,
par()$usr[3] + width
),
col = col,
border = border,
lwd = lwd,
lty = lty
)
## Corner Top-Left ----
col <- cols[length(ats[[1]]) + length(ats[[2]]) + length(ats[[3]]) - 3]
polygon(
x = c(
par()$usr[1] + width,
ats[[1]][2],
ats[[1]][2],
par()$usr[1]
),
y = c(
par()$usr[4] - width,
par()$usr[4] - width,
par()$usr[4],
par()$usr[4]
),
col = col,
border = border,
lwd = lwd,
lty = lty
)
## Corner Bottom-Right ----
col <- cols[length(ats[[1]]) - 1]
polygon(
x = c(
ats[[1]][length(ats[[1]]) - 1],
par()$usr[2],
par()$usr[2] - width,
ats[[1]][length(ats[[1]]) - 1]
),
y = c(
par()$usr[3],
par()$usr[3],
par()$usr[3] + width,
par()$usr[3] + width
),
col = col,
border = border,
lwd = lwd,
lty = lty
)
## Corner Top-Right ----
col <- cols[length(ats[[1]]) + length(ats[[2]]) - 1]
polygon(
x = c(
ats[[1]][length(ats[[1]]) - 1],
par()$usr[2] - width,
par()$usr[2],
ats[[1]][length(ats[[1]]) - 1]
),
y = c(
par()$usr[4] - width,
par()$usr[4] - width,
par()$usr[4],
par()$usr[4]
),
col = col,
border = border,
lwd = lwd,
lty = lty
)
## Corner Right-Bottom ----
col <- cols[length(ats[[1]])]
polygon(
x = c(
par()$usr[2] - width,
par()$usr[2],
par()$usr[2],
par()$usr[2] - width
),
y = c(
par()$usr[3] + width,
par()$usr[3],
ats[[2]][2],
ats[[2]][2]
),
col = col,
border = border,
lwd = lwd,
lty = lty
)
## Corner Right-Top ----
col <- cols[length(ats[[1]]) + length(ats[[2]]) - 2]
polygon(
x = c(
par()$usr[2] - width,
par()$usr[2],
par()$usr[2],
par()$usr[2] - width
),
y = c(
ats[[2]][length(ats[[2]]) - 1],
ats[[2]][length(ats[[2]]) - 1],
par()$usr[4],
par()$usr[4] - width
),
col = col,
border = border,
lwd = lwd,
lty = lty
)
## Corner Left-Bottom ----
col <- cols[length(cols)]
polygon(
x = c(
par()$usr[1],
par()$usr[1] + width,
par()$usr[1] + width,
par()$usr[1]
),
y = c(
par()$usr[3],
par()$usr[3] + width,
ats[[4]][length(ats[[2]]) - 1],
ats[[4]][length(ats[[2]]) - 1]
),
col = col,
border = border,
lwd = lwd,
lty = lty
)
## Corner Left-Top ----
col <- cols[length(ats[[1]]) + length(ats[[2]]) + length(ats[[3]]) - 2]
polygon(
x = c(
par()$usr[1],
par()$usr[1] + width,
par()$usr[1] + width,
par()$usr[1]
),
y = c(
ats[[4]][2],
ats[[4]][2],
par()$usr[4] - width,
par()$usr[4]
),
col = col,
border = border,
lwd = lwd,
lty = lty
)
invisible(NULL)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.