Nothing
cat2shape <- function(x,
var,
shapes,
drop.levels = FALSE,
legend.labels = NULL,
shapeNA = NA,
legend.NA.text = "Missing",
showNA = NA,
legend.format=list(align="left"),
reverse = FALSE) {
sel <- attr(x, "sel")
if (is.null(sel)) sel <- rep(TRUE, length(x))
x[!sel] <- NA
gt <- get("tmapOptions", envir = .TMAP_CACHE)
show.messages <- gt$show.messages
show.warnings <- gt$show.warnings
if (!is.factor(x)) x <- factor(x, levels=sort(unique(x)))
# drop levels
if (drop.levels) {
y <- droplevels(x)
matching <- match(levels(y), levels(x))
if (length(shapes) == nlevels(x)) {
shapes <- shapes[matching]
}
if (!is.null(legend.labels) && (length(legend.labels) == nlevels(x))) {
legend.labels <- legend.labels[matching]
}
x <- y
}
nCol <- nlevels(x)
max_levels <- length(shapes)
named <- !is.null(names(shapes))
if (named) {
nms <- names(shapes)
xs <- levels(x)
if (!setequal(xs, nms)) {
c1 <- setdiff(xs, nms)
c2 <- setdiff(nms, xs)
txt <- paste0("Names of shapes argument do not match with the values of the variable \"", var, "\".")
if (length(c1)>0) {
stop(paste0(txt, " Values not specified in shapes argument: \"", paste(c1, collapse="\", \""), "\".") , call. = FALSE)
} else if (show.messages) {
message(paste0(txt, " Names in shapes argument for which no values exist: \"", paste(c2, collapse="\", \""), "\"."))
}
}
shapes <- shapes[match(xs, nms)]
} else {
if (nCol > max_levels) {
if (show.warnings) warning("Number of levels (unique values) is ", nCol, ", which is larger than number of symbol shapes (", max_levels, ").", call. = FALSE)
mapping <- if (max_levels==1) {
rep(1, nCol)
} else as.numeric(cut(seq.int(nCol), breaks=max_levels))
to <- c(which(mapping[-nCol] - mapping[-1]!=0), nCol)
from <- c(0, to[-max_levels]) + 1
lvls <- levels(x)
new_lvls <- paste0(lvls[from], "...", lvls[to])
x <- factor(mapping[as.integer(x)], levels=1:max_levels, labels=new_lvls)
}
nCol <- nlevels(x)
}
# in case the number of shapes is more than the number of levels
shapes <- rep(shapes, length.out=nCol)
if (is.null(legend.labels)) {
legend.labels <- levels(x)
} else {
legend.labels <- rep(legend.labels, length.out = nCol)
}
shps <- shapes[as.integer(x)]
shpsNA <- is.na(shps)
if (any(shpsNA)) {
if (is.na(showNA)) showNA <- any(shpsNA & sel)
shps[shpsNA] <- shapeNA
} else {
if (is.na(showNA)) showNA <- FALSE
}
legend.values <- legend.labels
if (reverse) {
legend.labels <- rev(legend.labels)
shapes <- rev(shapes)
}
if (showNA) {
legend.labels <- c(legend.labels, legend.NA.text)
shapes <- c(shapes, shapeNA)
}
attr(legend.labels, "align") <- legend.format$text.align
list(shps=shps, legend.labels=legend.labels, legend.values=legend.values, shapes=shapes)
}
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.