Skip to content

Commit

Permalink
catched classInt error message, fixed rev palette bug
Browse files Browse the repository at this point in the history
  • Loading branch information
@mtennekes
mtennekes committed Nov 27, 2024
1 parent 626b4d0 commit 0dffeac
Show file tree
Hide file tree
Showing 3 changed files with 57 additions and 52 deletions.
102 changes: 54 additions & 48 deletions R/process_breaks.R
View file
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
fancy_breaks <- function(vec, as.count = FALSE, intervals=FALSE, interval.closure="left", fun=NULL, scientific=FALSE, big.num.abbr = c("mln" = 6, "bln" = 9), prefix = "", suffix = "", text.separator="to", text.less.than=c("less", "than"), text.or.more=c("or", "more"), text.align="left", text.to.columns=FALSE, digits=NA, html.escape = TRUE, ...) {
args <- list(...)
n <- length(vec)

if (!is.null(fun)) {
x <- do.call(fun, list(vec))
} else if (all(is.infinite(vec))) {
Expand All @@ -11,7 +11,7 @@ fancy_breaks <- function(vec, as.count = FALSE, intervals=FALSE, interval.closur
vec_fin <- unique(vec[!is.infinite(vec)])
frm <- gsub(" ", "", sprintf("%20.10f", abs(vec_fin)))
mag <- max(nchar(frm)-11)

if (as.count) {
steps <- (vec[-1] - vec[-n])
vec <- c(vec, vec - 1L, vec + 1L) # needed for: {1, 2, ... 9}
Expand All @@ -21,22 +21,22 @@ fancy_breaks <- function(vec, as.count = FALSE, intervals=FALSE, interval.closur
ndec <- max(10 - nchar(frm) + nchar(sub("0+$","",frm)))
if (is.na(digits)) {
digits <- max(min(ndec, 4-mag), 0)

# add sign to frm
frm_sign <- unique(paste0(ifelse(vec_fin<0, "-", "+"), frm))

# test if number of digits is sufficient for unique labels
if (!scientific) {
while (anyDuplicated(substr(frm_sign, 1, nchar(frm_sign)-10 + digits)) && (digits < 10)) {
digits <- digits + 1
}
}

}
}

if (!scientific || as.count) {

# check whether big number abbrevations should be used
ext <- ""
if (!is.na(big.num.abbr[1])) {
Expand All @@ -50,20 +50,20 @@ fancy_breaks <- function(vec, as.count = FALSE, intervals=FALSE, interval.closur
}
}
}

# set default values
if (!("big.mark" %in% names(args))) args$big.mark <- ","
if (!("format" %in% names(args))) args$format <- "f"
if (!("preserve.width" %in% names(args))) args$preserve.width <- "none"
x <- paste(do.call("formatC", c(list(x=vec, digits=digits), args)), ext, sep="")
x <- paste0(prefix, x, suffix)


} else {
if (!("format" %in% names(args))) args$format <- "g"
x <- do.call("formatC", c(list(x=vec, digits=digits), args))
}

if (as.count) {
x1 <- x[1:(n-1)]
x2 <- x[(n+2):(2*n)]
Expand All @@ -75,7 +75,7 @@ fancy_breaks <- function(vec, as.count = FALSE, intervals=FALSE, interval.closur
# xs <- (vec[-1] - vec[-n])
# x1p1 <- formatC(vec[-n] + 1L, format = "f", digits = 0)
}

if (intervals) {
if (scientific) {
if (as.count) {
Expand All @@ -93,65 +93,65 @@ fancy_breaks <- function(vec, as.count = FALSE, intervals=FALSE, interval.closur
lbls[1] <- paste("[", substr(lbls[1], 2, nchar(lbls[1])), sep="")
}
}


} else {
if (as.count) {
lbls <- x1
lbls[steps>1] <- paste(x1[steps>1], x2[steps>1], sep = paste0(" ", text.separator, " "))
if (vec[n]==Inf) lbls[n-1] <- paste(x1[n-1], paste(text.or.more, collapse = " "), sep = " ")
} else {
x[vec==-Inf] <- ""

lbls <- paste(x[-n], x[-1], sep = paste0(" ", text.separator, " "))
if (vec[1]==-Inf) lbls[1] <- paste(paste(text.less.than, collapse = " "), x[2], sep = " ")
if (vec[n]==Inf) lbls[n-1] <- paste(x[n-1], paste(text.or.more, collapse = " "), sep = " ")
}

if (text.to.columns) {
#xtra <- as.numeric(!is.na(text.align) && text.align=="right")


nc1 <- nchar(paste(x[-n], " ", sep = "")) + 1
nc2 <- rep(nchar(paste(text.separator, " ", sep = "")), n-1)

lbls_breaks <- matrix(c(nc1, nc1+nc2), ncol=2)

if (vec[1]==-Inf) {
if (length(text.less.than)==1) {
lbls_breaks[1,] <- rep(nchar(paste(text.less.than[1], " ", sep = "")) + 1, 2)
} else {
lbls_breaks[1,] <- cumsum(c(nchar(paste(text.less.than[1], " ", sep = "")) + 1, nchar(text.less.than[2])+1))
}
}
if (vec[n]==Inf) {
if (vec[n]==Inf) {
if (length(text.or.more)==1) {
lbls_breaks[n-1,] <- rep(nchar(paste(x[n-1], " ", sep = "")) + 1, 2)
lbls_breaks[n-1,] <- rep(nchar(paste(x[n-1], " ", sep = "")) + 1, 2)
} else {
lbls_breaks[n-1,] <- cumsum(c(nchar(paste(x[n-1], " ", sep = "")) + 1, nchar(text.or.more[1])+1))
}

}
attr(lbls, "brks") <- lbls_breaks
}




}
}

y <- if (intervals) lbls else x
attr(y, "align") <- text.align
y
}


num2breaks <- function(x, n, style, breaks, approx=FALSE, interval.closure="left", var = NULL, as.count = FALSE, args = list()) {

tmapOptions = tmap_options_mode()
show.warnings <- tmapOptions$show.warnings

nobs <- sum(!is.na(x))
# create intervals and assign colors
if (style=="fixed") {
Expand All @@ -160,7 +160,7 @@ num2breaks <- function(x, n, style, breaks, approx=FALSE, interval.closure="left
tooHigh = (x2 > max(breaks))
if (any(tooLow) && show.warnings) warning("Values have found that are less than the lowest break. They are assigned to the lowest interval", call. = FALSE)
if (any(tooHigh) && show.warnings) warning("Values have found that are higher than the highest break. They are assigned to the highest interval", call. = FALSE)

q <- list(var=x,
brks=breaks)
attr(q, "style") <- "fixed"
Expand All @@ -175,32 +175,38 @@ num2breaks <- function(x, n, style, breaks, approx=FALSE, interval.closure="left
stop("Numerical variable only contains missing values.", call.=FALSE)
}
}

nunique <- length(na.omit(unique(x)))


if (nunique == 1 && style!="pretty" && show.warnings) {
if (!is.null(var)) {
warning("Single unique value found for the variable \"", var, "\", so style set to \"pretty\"", call. = FALSE)
} else {
warning("Single unique value found, so style set to \"pretty\"", call. = FALSE)
}
}

tempx <- nunique <= n

if (tempx) {
x_orig <- x
if (length(na.omit(unique(x))) == 1) x <- pretty(x)
x <- seq(min(x, na.rm = TRUE), max(x, na.rm = TRUE), length.out = n + 1)
}

q <- suppressWarnings(do.call(classInt::classIntervals, c(list(x, n, style= style, intervalClosure=interval.closure), args)))


q <- tryCatch({
suppressWarnings(do.call(classInt::classIntervals, c(list(x, n, style= style, intervalClosure=interval.closure), args)))
}, error = function(e) {
stop("Calculating interval classes failed for the variable ", var, " with style = '", style, "'. The error message from classInt::classIntervals: ", e$message, call. = FALSE)
})



if (tempx) q$var <- x_orig

}

if (approx && style != "fixed") {
if (n >= length(unique(x)) && style=="equal") {
# to prevent classIntervals to set style to "unique"
Expand All @@ -209,7 +215,7 @@ num2breaks <- function(x, n, style, breaks, approx=FALSE, interval.closure="left
class(q) <- "classIntervals"
} else {
brks <- q$brks

# to prevent ugly rounded breaks such as -.5, .5, ..., 100.5 for n=101
qm1 <- suppressWarnings(do.call(classInt::classIntervals, c(list(x, n-1, style= style, intervalClosure=interval.closure), args)))
brksm1 <- qm1$brks
Expand Down Expand Up @@ -246,17 +252,17 @@ are_breaks_diverging <- function(brks) {
# if (!is.null(midpoint) && !is.na(midpoint)) return(TRUE)
# x <- na.omit(v)
# divx <- any(x<0) && any(x>0)
#
#
# if (divx || is.null(brks)) {
# return(divx)
# } else {
# are_breaks_diverging(brks)
# }
# }
#
#
use_div <- function(brks, midpoint = NULL) {
if (!is.null(midpoint) && !is.na(midpoint)) return(TRUE)

if (is.null(brks)) {
return(NA)
} else {
Expand Down Expand Up @@ -295,14 +301,14 @@ prettyTicks = function(x, dev = 0.1) {
steps = (x[-1] - head(x,-1)) / dff
all(abs(steps-steps[1]) < 1e-3)
})

if (is_equi) {
pretty(x, n = length(x))
} else {
s = x[-1] - head(x,-1)
s = c(s[1], s, tail(s,1))
s = pmin(head(s,-1), tail(s,-1))

mapply(function(xi, si) {
for (r in rev(.TMAP$round_to)) {
xir = round_num(xi, r)
Expand All @@ -319,4 +325,4 @@ prettyTicks = function(x, dev = 0.1) {
# x = c(1043,2045,4005, 6765)
# x = c(265, 280, 520, 1000)
# x = c(265, 520, 1000, 1280)
# prettyTicks(x)
# prettyTicks(x)
3 changes: 2 additions & 1 deletion R/tmapScale_defaults.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -427,6 +427,7 @@ tmapValuesRange_fontface = function(x, n, isdiv) {
#' @keywords internal
#' @rdname tmap_internal
tmapValuesVV_fill = function(x, value.na, isdiv, n, dvalues, are_breaks, midpoint, range, scale, rep, o, aes = "fill") {

#palid = tmapPalId(x[1])
if (x[1] %in% c("seq", "div", "unord", "ord", "biv")) {
# cols4all can also take "div", but does not take into account tmap style
Expand Down Expand Up @@ -929,7 +930,7 @@ tmapValuesCVV_fill = function(x, value.na, n, range, scale, rep, o) {
values = if (!ispalette && !arecolors) {
rep(x, length.out = n)
} else if (ispalette) {
getPal(m$fullname, n, rep = rep, range = range)
getPal(m$fullname, n, rep = rep, range = range, reversed = m$reverse)
} else if (!rep && (length(x) < n)) {
grDevices::colorRampPalette(x)(n)
} else {
Expand Down
4 changes: 1 addition & 3 deletions R/tmap_palettes.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -12,9 +12,7 @@ pals_v3 = c(BrBG = "brewer.br_bg", PiYG = "brewer.pi_yg", PRGn = "brewer.prgn",
OrRd = "brewer.or_rd", PuBu = "brewer.pu_bu", PuBuGn = "brewer.pu_bu_gn",
PuRd = "brewer.pu_rd", Purples = "brewer.purples", RdPu = "brewer.rd_pu",
Reds = "brewer.reds", YlGn = "brewer.yl_gn", YlGnBu = "brewer.yl_gn_bu",
YlOrBr = "brewer.yl_or_br", YlOrRd = "brewer.yl_or_rd", viridis = "matplotlib.viridis",
magma = "matplotlib.magma", plasma = "matplotlib.plasma", inferno = "matplotlib.inferno",
cividis = "matplotlib.cividis")
YlOrBr = "brewer.yl_or_br", YlOrRd = "brewer.yl_or_rd")


getPal = function(name, n = NA, rep = TRUE, range = NA, reversed = FALSE) {
Expand Down

0 comments on commit 0dffeac

Please sign in to comment.