Nothing
#' @title Add a Map of class map as Drawings to Loon plot
#'
#' @description The maps library provides some map data in polygon which can be
#' added as drawings (currently with polygons) to Loon plots. This function
#' adds map objects with class map from the maps library as background
#' drawings.
#'
#' @template param_widget
#' @param x a map object of class \code{\link[maps]{map}} as defined in the
#' \code{maps} \R package
#' @inheritParams l_layer_polygon
#' @template param_parent
#' @template param_index
#' @param asSingleLayer if \code{TRUE} then all the polygons get placed in a
#' n-dimension layer of type polygons. Otherwise, if \code{FALSE}, each
#' polygon gets its own layer.
#' @template param_dots_method_not_used
#'
#' @return If \code{asSingleLayer=TRUE} then returns layer id of polygons layer,
#' otherwise group layer that contains polygon children layers.
#'
#' @export
#' @export l_layer.map
#'
#' @examples
#' if(interactive()){
#'
#' if (requireNamespace("maps", quietly = TRUE)) {
#' canada <- maps::map("world", "Canada",
#' fill=TRUE, plot=FALSE)
#' p <- l_plot()
#' l_map <- l_layer(p, canada,
#' asSingleLayer=TRUE, color = "cornsilk")
#' l_map['color'] <- ifelse(grepl("lake", canada$names, TRUE),
#' "lightblue", "cornsilk")
#' l_scaleto_layer(p, l_map)
#' l_map['active'] <- FALSE
#' l_map['active'] <- TRUE
#' l_map['tag']
#' }
#'
#' }
l_layer.map <- function(widget, x,
color="", linecolor="black", linewidth=1,
label, parent="root", index=0, asSingleLayer=TRUE, ...) {
l_throwErrorIfNotLoonWidget(widget)
map <- x
if(!is(map,"map")) {
stop("map is not an map object from the maps library.")
}
if (all(is.na(map$x) != is.na(map$y))) {
stop("NA's not at same indices in x and y")
}
if (missing(label)) {
label <- deparse(substitute(map))
}
is.color <- function(x) {
vapply(x, function(X) {
tryCatch(is.matrix(grDevices::col2rgb(X)),
error = function(e) FALSE)
}, logical(1))
}
if(!all(color=="" | is.color(color))) {
stop("color needs to be a color or \"\"")
}
if(!all(linecolor=="" | is.color(linecolor))) {
stop("linecolor needs to be a color or \"\"")
}
if(!all(linewidth>=0)) {
stop("linewidth needs to be numeric and >=0")
}
pos <- which(is.na(map$x))
npolygons <- length(pos) + 1
id <- NA
if (npolygons == 1) {
id <- l_layer_polygon(widget, x=map$x, y=map$y,
color=color[1],
linecolor=linecolor[1],
linewidth=linewidth[1],
label=label)
} else {
if (length(color) == 1) {
color <- rep(color, npolygons)
} else if (length(color) != 1 && length(color) != npolygons) {
warning("only first color element used as length not equal to number of polygons")
color <- rep(color[1], npolygons)
}
if (length(linecolor) == 1) {
linecolor <- rep(linecolor, npolygons)
} else if (length(linecolor) != 1 && length(linecolor) != npolygons) {
warning("only first linecolor element used as length not equal to number of polygons")
linecolor <- rep(linecolor[1], npolygons)
}
if (length(linewidth) == 1) {
linewidth <- rep(linewidth, npolygons)
} else if (length(linewidth) != 1 && length(linewidth) != npolygons) {
warning("only first linewidth element used as length not equal to number of polygons")
linewidth <- rep(linewidth[1], npolygons)
}
newPos <- c(0, pos, length(map$x)+1)
ids <- rep(NA, npolygons)
x <- map$x
y <- map$y
if(asSingleLayer) {
## use a polygons layer
xlist <- vector(mode="list", length = npolygons)
ylist <- vector(mode="list", length = npolygons)
for(i in 1:npolygons) {
sel <- seq(newPos[i]+1, newPos[i+1]-1, by=1)
xlist[[i]] <- x[sel]
ylist[[i]] <- y[sel]
}
id <- l_layer_polygons(widget, xlist, ylist,
color=color,
linecolor=linecolor,
linewidth=linewidth,
tag=map$names,
label=label,
parent=parent,
index='end')
} else {
## use a group with polygon layers
id <- l_layer_group(widget, label=label, parent=parent, index=index)
for (i in 1:npolygons) {
sel <- seq(newPos[i]+1, newPos[i+1]-1, by=1)
l_layer_polygon(widget, x[sel], y[sel],
color=color[i],
linecolor=linecolor[i],
linewidth=linewidth[i],
label=map$names[i],
parent=id,
index='end')
}
}
}
return(id)
}
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.