################################################################################
### General utils
#' @name convertToSf
#' @title convertToSf
#' @description convert spdf & df to sf
#' @param spdf spdf
#' @param df df
#' @param spdfid spdfid
#' @param dfid dfid
#' @return an sf object
#' @noRd
convertToSf <- function(spdf, df, spdfid, dfid){
if (!missing(df)){
# missing IDs
if (is.null(spdfid)){spdfid <- names(spdf@data)[1]}
if (is.null(dfid)){dfid <- names(df)[1]}
# Join (only on df data), work with tibbls
spdf@data <- data.frame(spdf@data[,spdfid],
data.frame(df[match(spdf@data[,spdfid],
df[[dfid]]),]))
spdf <- spdf[!is.na(spdf@data[,dfid]),]
}
# convert
x <- sf::st_as_sf(spdf)
return(x)
}
################################################################################
### choro utils
#' @name choro
#' @title choro
#' @description add color gradients to spdf according to data classes
#' @param var vector of values used
#' @param distr vector of classes
#' @param col vector of colors
#' @param nclass number of classes targeted (if null, the Huntsberger method is used)
#' @param method classification method ("sd", "equal", "quantile", "fisher-jenks","q6","geom")
#' @return List: a vector of colors, colors and distr
#' @noRd
choro <- function(var, distr = NULL, col = NULL,
nclass = NULL, method = "quantile")
{
# Discretization
if (is.null(distr)){
distr <- getBreaks(v = var, nclass = nclass, method = method)
# Colors
if(is.null(col)){
col <- carto.pal(pal1 = "blue.pal",n1 = (length(distr) - 1))
}
colMap <- col[findInterval(var, distr, all.inside = TRUE)]
}else{
inter <- findInterval(var, distr, all.inside = FALSE,
rightmost.closed = TRUE)
inter[inter == 0] <- length(distr)
if(is.null(col)){
col <- carto.pal(pal1 = "blue.pal",n1 = (length(distr) - 1))
}
colMap <- col[inter]
}
return(list(colMap = colMap, distr = distr, col = col))
}
################################################################################
### typo utils
#' @name checkCol
#' @title checkCol
#' @description check if col length matches modalities length, if no color is
#' provided add default colors
#' @param col vector of colors
#' @param mod vector of modalities
#' @return a vector of colors.
#' @noRd
checkCol <- function(col, mod){
if (is.null(col)){
lm <- length(mod)
if (lm<=20){
col <- carto.pal(pal1 = "pastel.pal", n1 = lm)
}else{
lc <- carto.pal(pal1 = "pastel.pal", 20)
col <- sample(x = lc, size = lm , replace = TRUE)
}
}else{
if (length(col) < length(mod)){
stop(paste("'col' length (",length(col),
") must fit the number of modalities of the variable (",
length(mod),").",sep = ""),
call. = FALSE)
}
}
return(col)
}
#' @name checkOrder
#' @title checkOrder
#' @description check if col order match legend.values.order
#' @param legend.values.order legend.values.order
#' @param mod vector of modalities
#' @return a vector of legend.values.order.
#' @noRd
checkOrder <- function(legend.values.order, mod){
if (!is.null(legend.values.order)){
m <- match(mod, legend.values.order)
m <- m[!is.na(m)]
if(length(m) != length(mod) | length(mod) != length(legend.values.order)){
stop(paste("'legend.values.order' modalities must fit the modalities of the variable (",
paste(mod, collapse=","),").",sep = ""),
call. = FALSE)
}
}else{
legend.values.order <- mod
}
return(legend.values.order)
}
################################################################################
### prop symbols utils
#' @name checkMergeOrder
#' @title checkMergeOrder
#' @description clean, sorted sf object with centroid coordinates from an
#' sf object
#' @param x x
#' @param var var
#' @return an sorted and cleaned sf object with centroid coordinates.
#' @noRd
checkMergeOrder <- function(x = x, var = var){
# get centroid coords
x <- cbind(sf::st_coordinates(
sf::st_centroid(x = sf::st_geometry(x), of_largest_polygon = max(sf::st_is(sf::st_as_sf(x), "MULTIPOLYGON")))), x)
# remove NAs and 0 values
x <- x[!is.na(x = x[[var]]),]
x <- x[x[[var]]!=0, ]
# turn to positive values
x[[var]] <- abs(x[[var]])
# Order the dots
x <- x[order(abs(x[[var]]), decreasing = TRUE),]
return(x)
}
#' @name sizer
#' @title sizer
#' @description get a vector of radii
#' @param dots dots
#' @param inches inches
#' @param var var
#' @param fixmax fixmax
#' @param symbols symbols
#' @return a vector of radii
#' @noRd
sizer <- function(dots, inches, var, fixmax, symbols){
switch(symbols,
circle = {
smax <- inches * inches * pi
size <- sqrt((abs(dots[[var]]) * smax / fixmax) / pi)
},
square = {
smax <- inches * inches
size <- sqrt(abs(dots[[var]]) * smax / fixmax)
},
bar = {
smax <- inches
size <- abs(dots[[var]]) * smax / fixmax
})
return(size)
}
################################################################################
### legend utils
legpos <- function(pos, x1, x2, y1, y2, delta1, delta2,
legend_xsize, legend_ysize){
# Position
if(length(pos) == 2){
return(list(xref = pos[1], yref = pos[2]))
}
if (pos == "bottomleft") {
xref <- x1 + delta1
yref <- y1 + delta1
}
if (pos == "bottomleftextra") {
xref <- x1 + delta1
yref <- y1 + delta1 + graphics::strheight(s = "hp\nhp", cex = 0.6, font = 3)
}
if (pos == "topleft") {
xref <- x1 + delta1
yref <- y2 - 2 * delta1 - legend_ysize
}
if (pos == "topright") {
xref <- x2 - 2 * delta1 - legend_xsize
yref <- y2 -2 * delta1 - legend_ysize
}
if (pos == "bottomright") {
xref <- x2 - 2 * delta1 - legend_xsize
yref <- y1 + delta1
}
if (pos == "left") {
xref <- x1 + delta1
yref <- (y1+y2)/2-legend_ysize/2 - delta2
}
if (pos == "right") {
xref <- x2 - 2*delta1 - legend_xsize
yref <- (y1+y2)/2-legend_ysize/2 - delta2
}
if (pos == "top") {
xref <- (x1+x2)/2 - legend_xsize/2
yref <- y2 - 2*delta1 - legend_ysize
}
if (pos == "bottom") {
xref <- (x1+x2)/2 - legend_xsize/2
yref <- y1 + delta1
}
if (pos == "center") {
xref <- (x1+x2)/2 - legend_xsize/2
yref <- (y1+y2)/2-legend_ysize/2 - delta2
}
return(list(xref = xref, yref = yref))
}
################################################################################
### labelLayer utils
# Rcpp stuff
#' @useDynLib cartography, .registration = TRUE
#' @importFrom Rcpp evalCpp
NULL
# Label placement
#' @name wordlayout
#' @title wordlayout
#' @description wordlayout
#' @param x long
#' @param y lat
#' @param words labels
#' @param cex cex
#' @param xlim xlim
#' @param ylim ylim
#' @param tstep tstep
#' @param rstep rstep
#' @param ... other stuf
#' @return coords
#' @noRd
wordlayout <- function(x, y, words, cex=1,
xlim=c(-Inf,Inf), ylim=c(-Inf,Inf),
tstep=.1, rstep=.1, ...){
tails <- "g|j|p|q|y"
n <- length(words)
sdx <- sd(x,na.rm=TRUE)
sdy <- sd(y,na.rm=TRUE)
if(sdx==0)
sdx <- 1
if(sdy==0)
sdy <- 1
if(length(cex)==1)
cex <- rep(cex,n)
set.seed(999)
boxes <- list()
for(i in 1:length(words)){
r <-0
theta <- runif(1,0,2*pi)
x1 <- xo <- x[i]
y1 <- yo <- y[i]
wid <- strwidth(words[i],cex=cex[i],...) + 0.4 *
strwidth("R", cex=cex[i], ...)
ht <- strheight(words[i],cex=cex[i],...) + 0.4 *
strheight("R", cex=cex[i], ...)
#mind your ps and qs
if(grepl(tails,words[i]))
ht <- ht + ht*.2
isOverlaped <- TRUE
while(isOverlaped){
if(!is_overlap(x1-.5*wid,y1-.5*ht,wid,ht,boxes) &&
x1-.5*wid>xlim[1] && y1-.5*ht>ylim[1] &&
x1+.5*wid<xlim[2] && y1+.5*ht<ylim[2]){
boxes[[length(boxes)+1]] <- c(x1-.5*wid,y1-.5*ht,wid,ht)
isOverlaped <- FALSE
}else{
theta <- theta+tstep
r <- r + rstep*tstep/(2*pi)
x1 <- xo+sdx*r*cos(theta)
y1 <- yo+sdy*r*sin(theta)
}
}
}
result <- do.call(rbind,boxes)
colnames(result) <- c("x","y","width","ht")
rownames(result) <- words
result
}
# shadow around the labels
#' @name shadowtext
#' @title shadowtext
#' @description shadowtext
#' @param x lon
#' @param y lat
#' @param labels labels
#' @param col col
#' @param bg bg
#' @param theta number of iteration
#' @param r radius
#' @param ...
#' @noRd
shadowtext <- function(x, y=NULL, labels, col='white', bg='black',
theta= seq(0, 2*pi, length.out=50), r=0.1, ... ) {
xo <- r*strwidth('A')
yo <- r*strheight('A')
for (i in theta) {
text(x + cos(i)*xo, y + sin(i)*yo, labels, col=bg, ... )
}
text(x, y, labels, col=col, ... )
}
# import stuffs
#' @import graphics
#' @importFrom stats aggregate na.omit quantile runif sd median
# @importFrom rgeos createSPComment
#' @importFrom utils download.file
#' @importFrom grDevices colorRampPalette
NULL
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.