trans functions improved #847, pseudo_log with sigma, and log2, log10…

… labels

NAMESPACE

@@ -124,6 +124,7 @@ export(opt_tm_bubbles)
 export(opt_tm_cartogram)
 export(opt_tm_cartogram_dorling)
 export(opt_tm_cartogram_ncont)
+export(opt_tm_donuts)
 export(opt_tm_dots)
 export(opt_tm_labels)
 export(opt_tm_lines)
@@ -154,6 +155,7 @@ export(tm_chart_violin)
 export(tm_compass)
 export(tm_const)
 export(tm_credits)
+export(tm_donuts)
 export(tm_dots)
 export(tm_extra_innner_margin)
 export(tm_facets)
@@ -206,7 +208,10 @@ export(tm_scale_bivariate)
 export(tm_scale_categorical)
 export(tm_scale_continuous)
 export(tm_scale_continuous_log)
+export(tm_scale_continuous_log10)
 export(tm_scale_continuous_log1p)
+export(tm_scale_continuous_log2)
+export(tm_scale_continuous_pseudo_log)
 export(tm_scale_continuous_sqrt)
 export(tm_scale_discrete)
 export(tm_scale_intervals)

R/misc_trans_data.R

@@ -1,6 +1,6 @@
 trans_log = list(
-	fun = log,
-	rev = exp,
+	fun = function(x, base = exp(1)) log(x, base),
+	rev = function(x, base = exp(1)) base^x,
 	domain = c(1e-100, Inf)
 )
 
@@ -28,12 +28,9 @@ trans_log1p = list(
 	domain = c(0, Inf)
 )
 
-pseudo_log_sigma = 1
-pseudo_log_base = exp(1)
-
 trans_pseudo_log = list(
-	fun = function(x) asinh(x/(2 * pseudo_log_sigma))/log(pseudo_log_base), 
-	rev = function(x) 2 * pseudo_log_sigma * sinh(x * log(pseudo_log_base)), 
+	fun = function(x, base = exp(1), sigma = 1) asinh(x/(2 * sigma))/log(base), 
+	rev = function(x, base = exp(1), sigma = 1) 2 * sigma * sinh(x * log(base)), 
 	#d_transform = function(x) 1/(sqrt(4 + x^2/pseudo_log_sigma^2) * pseudo_log_sigma * log(pseudo_log_base)) 
 	#d_inverse = function(x) 2 * pseudo_log_sigma * cosh(x * log(pseudo_log_base)) * log(pseudo_log_base))
 	domain = c(-Inf, Inf)

R/tm_scale_.R

@@ -241,7 +241,8 @@ tm_scale_continuous = function(n = NULL,
 							   labels = NULL,
 							   label.na = NA,
 							   label.null = NA,
-							   label.format = list()) {
+							   label.format = list(),
+							   trans.args = list()) {
 
 	structure(c(list(FUN = "tmapScaleContinuous"), as.list(environment())), class = c("tm_scale_continuous", "tm_scale", "list"))
 }
@@ -298,10 +299,25 @@ tm_scale_rank = function(n = NULL,
 #' @param ... passed on to `tm_scale_continuous`
 #' @rdname tm_scale_continuous
 #' @name tm_scale_continuous_log
-tm_scale_continuous_log = function(...) {
-	tm_scale_continuous(trans = "log", ...)
+tm_scale_continuous_log = function(..., base = exp(1)) {
+	tm_scale_continuous(trans = "log", trans.args = list(base = base))
 }
 
+#' @export
+#' @rdname tm_scale_continuous
+#' @name tm_scale_continuous_log2
+tm_scale_continuous_log2 = function(...) {
+	tm_scale_continuous(trans = "log", trans.args = list(base = 2))
+}
+
+#' @export
+#' @rdname tm_scale_continuous
+#' @name tm_scale_continuous_log10
+tm_scale_continuous_log10 = function(...) {
+	tm_scale_continuous(trans = "log", trans.args = list(base = 10))
+}
+
+
 #' @export
 #' @rdname tm_scale_continuous
 #' @name tm_scale_continuous_log1p
@@ -316,6 +332,15 @@ tm_scale_continuous_sqrt = function(...) {
 	tm_scale_continuous(trans = "sqrt", ...)
 }
 
+#' @export
+#' @rdname tm_scale_continuous
+#' @name tm_scale_continuous_pseudo_log
+tm_scale_continuous_pseudo_log = function(..., base = exp(1), sigma = 1) {
+	tm_scale_continuous(trans = "pseudo_log", trans.args = list(base = base, sigma = sigma), ...)
+}
+
+
+
 # 
 # #' @export
 # #' @rdname tm_scale_continuous

R/tmapScaleContinuous.R

@@ -66,6 +66,14 @@ tmapScaleContinuous = function(x1, scale, legend, chart, o, aes, layer, layer_ar
 
 		tr = get(paste0("trans_", trans))
 
+		trargs = formals(tr$fun)
+		trargs$x = NULL
+		trargs_match = intersect(names(trargs), names(trans.args))
+		if (!is.null(trargs_match) && length(trargs_match)) {
+			trargs[trargs_match] = trans.args[trargs_match]
+		}
+
+
 		xrange = range(x1, na.rm = TRUE)
 
 		if (xrange[1] < tr$domain[1]) stop("Values found that are lower than the valid domain", call. = FALSE)
@@ -94,7 +102,7 @@ tmapScaleContinuous = function(x1, scale, legend, chart, o, aes, layer, layer_ar
 				if (any(ticks > limits[2])) stop("(Some) ticks are higher than the upper limit. Please remove these ticks or adjust the upper limit.", call. = FALSE)
 			}
 			n = length(ticks) - 1
-			ticks_t = tr$fun(ticks)
+			ticks_t = do.call(tr$fun, c(list(x = ticks), trargs))
 		}
 
 		if (limits.specified) {
@@ -110,9 +118,9 @@ tmapScaleContinuous = function(x1, scale, legend, chart, o, aes, layer, layer_ar
 			}
 		}
 
-		x_t = tr$fun(x1)
-		limits_t = tr$fun(limits)
-		domain_t = tr$fun(tr$domain)	
+		x_t = do.call(tr$fun, c(list(x = x1), trargs))
+		limits_t = do.call(tr$fun, c(list(x = limits), trargs))
+		domain_t = do.call(tr$fun, c(list(x = tr$domain), trargs))	
 
 		if (!vnum) {
 			breaks = cont_breaks(limits_t, n=o$precision)
@@ -226,13 +234,21 @@ tmapScaleContinuous = function(x1, scale, legend, chart, o, aes, layer, layer_ar
 			if (!is.null(sortRev)) ids[isna] = 0L
 		}
 
+		labels_exp = !ticks.specified && trans == "log" && trargs$base != exp(1)
+
+
 		if (ticks.specified) {
 			b_t = ticks_t
-			b = tr$rev(b_t)
+			b = do.call(tr$rev, c(list(x = b_t), trargs))
 		} else {
-			b  = prettyTicks(tr$rev(seq(limits_t[1], limits_t[2], length.out = n)))
+			if (labels_exp) {
+				b = do.call(tr$rev, c(list(x = pretty(limits_t, n = n)), trargs))
+			} else {
+				b  = prettyTicks(do.call(tr$rev, c(list(x = seq(limits_t[1], limits_t[2], length.out = n)), trargs)))	
+			}
+
 			if (!(aes %in% c("col", "fill"))) b = b[b!=0]
-			b_t = tr$fun(b)
+			b_t = do.call(tr$fun, c(list(x = b), trargs))
 		}
 		sel = if (length(b_t) == 2) TRUE else (b_t>=limits_t[1] & b_t<=limits_t[2])
 		b_t = b_t[sel]
@@ -278,7 +294,11 @@ tmapScaleContinuous = function(x1, scale, legend, chart, o, aes, layer, layer_ar
 
 		# create legend labels for continuous cases
 		if (is.null(labels)) {
-			labels = do.call("fancy_breaks", c(list(vec=b, as.count = FALSE, intervals=FALSE, interval.closure="left"), label.format)) 	
+			if (labels_exp) {
+				labels = paste(trargs$base, b_t, sep = "^")
+			} else {
+				labels = do.call("fancy_breaks", c(list(vec=b, as.count = FALSE, intervals=FALSE, interval.closure="left"), label.format)) 	
+			}
 		} else {
 			labels = rep(labels, length.out=nbrks_cont)
 			attr(labels, "align") <- label.format$text.align