check_symbol_specials <- function(xcol, xsize, xshape, g, gt, gby, xvary, data, nx, interactive) {
if (!xvary[["symbol.size"]]) {
if (!all(is.numeric(xsize))) stop("symbol sizes are neither numeric nor valid variable name(s)", call. = FALSE)
for (i in 1:nx) data[[paste("SIZE", i, sep="_")]] <- xsize[i]
xsize <- paste("SIZE", 1:nx, sep="_")
gby$free.scales.symbol.size <- FALSE
}
if (xvary[["symbol.col"]]) {
is.colors <- FALSE
} else {
# check for direct color input
is.colors <- all(valid_colors(xcol))
if (!is.colors) stop("Invalid symbol colors", call. = FALSE)
xcol <- do.call("process_color", c(list(col=col2hex(xcol), alpha=g$alpha), gt$pc))
for (i in 1:nx) data[[paste("COLOR", i, sep="_")]] <- xcol[i]
xcol <- paste("COLOR", 1:nx, sep="_")
}
# symbol shapes: create a library with all the custom symbols (grobs) or icons, represented by symbol numbers 1000+
just <- g$just
if (any(is.na(just))) {
just <- c(.5, .5)
just.override <- FALSE
} else {
just <- c(ifelse(is_num_string(just[1]), as.numeric(just[1]), ifelse(just[1]=="left", 1, ifelse(just[1]=="right", 0, .5))),
ifelse(is_num_string(just[2]), as.numeric(just[2]), ifelse(just[2]=="bottom", 1, ifelse(just[2]=="top", 0, .5))))
just.override <- TRUE
}
#justx <- size.npc.w * ( - .5)
#justy <- size.npc.h * ( - .5)
if (!xvary[["symbol.shape"]]) {
if (!is.list(xshape)) {
if (!all(is.numeric(xshape))) stop("symbol shape(s) ('shape' argument) is/are neither numeric nor valid variable name(s)", call. = FALSE)
} else if (is.list(xshape)) {
xshape <- submit_symbol_shapes(xshape, interactive=interactive, just=just, just.override=just.override, grob.dim=g$grob.dim)
} else {
stop("symbol shape(s) ('shape' argument) is/are neither symbol numers, nor grobs, nor valid variable name(s)", call. = FALSE)
}
for (i in 1:nx) data[[paste("SHAPE", i, sep="_")]] <- xshape[i]
xshape <- paste("SHAPE", 1:nx, sep="_")
}
if (is.list(g$shapes)) {
if (inherits(g$shapes, "grob") || any(vapply(g$shapes, inherits, FUN.VALUE = logical(1), "grob")) || (("iconUrl" %in% names(g$shapes)))) {
# one grob, list of grobs or icon(s)
if ("iconUrl" %in% names(g$shapes)) g$shapes <- split_icon(g$shapes)
g$shapes <- submit_symbol_shapes(g$shapes, interactive=interactive, just=just, just.override=just.override, grob.dim=g$grob.dim)
} else {
# list of list of grobs or icons
g$shapes <- lapply(g$shapes, function(gshape) {
if ("iconUrl" %in% names(gshape)) gshape <- split_icon(gshape)
submit_symbol_shapes(gshape, interactive=interactive, just=just, just.override=just.override, grob.dim=g$grob.dim)
})
}
}
list(xcol = xcol, xsize = xsize, xshape = xshape, g=g, gby = gby, data = data, is.colors = is.colors, just = just)
}
postprocess_symbols <- function(res, g, gt, data, npol, nx, just, interactive) {
if (is.null(g$border.col)) {
symbol.border.col <- NA
g$border.lwd <- NA
} else {
symbol.border.col <- g$border.col
if (is.na(symbol.border.col)) {
symbol.border.col <- gt$aes.colors["borders"]
}
symbol.border.col <- do.call("process_color", c(list(col=symbol.border.col, alpha=g$border.alpha), gt$pc))
}
if (!is.null(g$shapes.legend)) {
shape.neutral <- g$shapes.legend
# col.neutral <- if (is.na(g$shapes.legend.fill)[1]) gt$aes.colors["symbols"] else g$shapes.legend.fill
} else {
shape.neutral <- NULL
# col.neutral <- NA
}
col.neutral <- if (is.na(g$shapes.legend.fill)[1]) NA else g$shapes.legend.fill
# if (!g$legend.size.show) symbol.size.legend.title <- NA
# if (!g$legend.col.show) symbol.col.legend.title <- NA
# if (!g$legend.shape.show) symbol.shape.legend.title <- NA
are.icons <- any(!is.na(res$symbol.shape) & res$symbol.shape>999)
if (are.icons && !interactive) {
scale <- g$scale * g$icon.scale
res$symbol.size <- res$symbol.size * g$icon.scale
res$symbol.size.legend.sizes <- res$symbol.size.legend.sizes * g$icon.scale
g$legend.max.symbol.size <- g$legend.max.symbol.size * g$icon.scale
} else scale <- g$scale
xmod <- g$xmod
ymod <- g$ymod
xmod <- if (is.character(xmod)) data[[xmod]] else rep(xmod, length.out=npol)
ymod <- if (is.character(ymod)) data[[ymod]] else rep(ymod, length.out=npol)
if (g$jitter>0) {
xmod <- xmod + rnorm(n=npol, sd=g$jitter)
ymod <- ymod + rnorm(n=npol, sd=g$jitter)
}
xmod <- matrix(xmod, nrow=npol, ncol=nx)
ymod <- matrix(ymod, nrow=npol, ncol=nx)
clustering <- g$clustering
if (identical(clustering, FALSE)) {
clustering <- NULL
} else if (identical(clustering, TRUE)) {
clustering <- leaflet::markerClusterOptions()
}
# list(
# shape.neutral = shape.neutral,
# col.neutral = col.neutral,
# are.icons = are.icons,
# scale = scale)
res$symbol.col.legend.misc$symbol.border.col <- symbol.border.col
res$symbol.size.legend.misc$symbol.border.col <- symbol.border.col
res$symbol.shape.legend.misc$symbol.border.col <- symbol.border.col
res$symbol.col.legend.sizes <- res$symbol.size.legend.misc$symbol.max.size
res$symbol.col.legend.shapes <- if (is.null(shape.neutral)) res$symbol.shape.legend.misc$shape.neutral else shape.neutral
res$symbol.size.legend.shapes <- if (is.null(shape.neutral)) res$symbol.shape.legend.misc$shape.neutral else shape.neutral
if (!is.na(col.neutral)) res$symbol.size.legend.palette <- col.neutral
res$symbol.shape.legend.sizes <- res$symbol.size.legend.misc$symbol.max.size
if (!is.na(col.neutral)) res$symbol.shape.legend.palette <- col.neutral
res$symbol.misc <- list(symbol.are.dots=g$are.dots, symbol.are.markers=g$are.markers, symbol.are.icons=are.icons, just=just, clustering=clustering)
res$symbol.xmod <- xmod
res$symbol.ymod <- ymod
res$symbol.border.lwd <- g$border.lwd
res$symbol.border.col <- symbol.border.col
res
}
process_symbols <- function(data, g, gt, gby, z, interactive) {
# aesthetics
xs <- list(symbol.col = g$col, symbol.size = g$size, symbol.shape = g$shape)
process_aes(type = "symbol", xs, c("xcol", "xsize", "xshape"), ifelse(g$are.dots, "dots", "symbols"), data, g, gt, gby, z, interactive)
}
submit_symbol_shapes <- function(x, interactive, just, just.override, grob.dim) {
if (any(vapply(x, is.null, logical(1)))) stop("one of more shapes are NULL")
shapeLib <- get("shapeLib", envir = .TMAP_CACHE)
justLib <- get("justLib", envir = .TMAP_CACHE)
n <- length(x)
id <- 999 + length(shapeLib)
if (interactive) {
items <- lapply(x, function(xs) {
ic <- if ("iconUrl" %in% names(xs)) {
split_icon(xs)[[1]]
} else if (is.grob(xs)) {
grob2icon(xs, grob.dim, just)
} else NA
# add anchor based on just specs
if (all(c("iconWidth", "iconHeight") %in% names(ic)) &&
((!any(c("iconAnchorX", "iconAnchorY") %in% names(ic))) || just.override)) {
ic$iconAnchorX <- ic$iconWidth * (1-just[1])
ic$iconAnchorY <- ic$iconHeight * just[2]
}
ic
})
just_items <- as.list(rep(NA, n))
} else {
just_items <- lapply(x, function(xs) {
if (just.override) {
just
} else if ("iconUrl" %in% names(xs)) {
if (all(c("iconWidth", "iconHeight", "iconAnchorX", "iconAnchorY") %in% names(xs))) {
c(1-(xs$iconAnchorX / xs$iconWidth), xs$iconAnchorY / xs$iconHeight)
} else NA
} else NA
})
items <- lapply(x, function(xs) {
if ("iconUrl" %in% names(xs)) {
grb <- icon2grob(xs)
# take first one
if (is.grob(grb)) grb else grb[[1]]
} else if (is.grob(xs)) {
xs
} else NA
})
}
numbers <- is.na(items)
if (all(numbers)) return(unlist(x, use.names = FALSE))
new_id <- id + 1:sum(!numbers)
x2 <- integer(n)
x2[numbers] <- unlist(x[numbers], use.names = FALSE)
x2[!numbers] <- new_id
shapeLib <- c(shapeLib, items[!numbers])
justLib <- c(justLib, just_items[!numbers])
assign("shapeLib", shapeLib, envir = .TMAP_CACHE)
assign("justLib", justLib, envir = .TMAP_CACHE)
names(x2) <- names(x)
x2
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.