scalebar improved #809

R/process_meta.R

@@ -67,10 +67,10 @@ preprocess_meta = function(o, cdt) {
  per_col = any(is.na(cdt$by1__) & !is.na(cdt$by2__) & cdt$class == "autoout"),
  per_facet = any(!is.na(cdt$by1__) & !is.na(cdt$by2__) & cdt$class == "autoout"))
  }
- legend.present.fix = c(any(cdt$class == "out" & cdt$cell.v == "bottom"), 
- any(cdt$class == "out" & cdt$cell.h == "left"),
- any(cdt$class == "out" & cdt$cell.v == "top"),
- any(cdt$class == "out" & cdt$cell.h == "right"))
+ legend.present.fix = c(any(cdt$class == "out" & identical(cdt$cell.v, "bottom")), 
+ any(cdt$class == "out" & identical(cdt$cell.h, "left")),
+ any(cdt$class == "out" & identical(cdt$cell.v, "top")),
+ any(cdt$class == "out" & identical(cdt$cell.h, "right")))
  }
 
 

R/step1_rearrange.R

@@ -239,6 +239,8 @@ impute_comp = function(a, o) {
  # special case: position, in case c("left", "top") is used
  if (is.character(a$position)) a$position = str2pos(a$position)
  if (is.numeric(a$position)) a$position = num2pos(a$position)
+ if (inherits(a$position, "tm_pos")) a$position = complete_options(a$position, o$component.position[[a$position$type]])
+
 
  a = complete_options(a, ot)
 

R/step2_helper_data.R

@@ -17,8 +17,7 @@ update_l = function(o, l, v, mfun) {
 
  if ("position" %in% names(l) && is.character(l$position)) l$position = str2pos(l$position)
  if ("position" %in% names(l) && is.numeric(l$position)) l$position = num2pos(l$position)
-
-
+ if ("position" %in% names(l) && inherits(l$position, "tm_pos")) l$position = complete_options(l$position, o$component.position[[l$position$type]])
 
  l = complete_options(l, oleg)
  l$call = call
@@ -205,7 +204,6 @@ getdts = function(aes, unm, p, q, o, dt, shpvars, layer, mfun, args, plot.order)
  l = update_l(o = o, l = l, v = v, mfun = mfun)
 
 
-
  if (length(s) == 0) stop("mapping not implemented for aesthetic ", nm, call. = FALSE)
  f = s$FUN
  s$FUN = NULL

R/step4_plot.R

@@ -699,9 +699,17 @@ step4_plot = function(tm, vp, return.asp, show) {
 
  legs_out = copy(cdt[!is_in])
  legs_out[, page:=as.integer(NA)]
- legs_out[, bbox:=list()]
- legs_out[, units:=list()]
 
+ # legs_out[, bbox:=list()]
+ # legs_out[, units:=list()]
+
+ # ad-hoc method: take first bbox and units
+ bbox_nb = d$bbox[1]
+ attr(bbox_nb, "borrow") = list(col = d$col[1], row = d$row[1])
+ legs_out[, bbox:=bbox_nb]
+ legs_out[, units:=d$units[1]]
+
+
  cdt = data.table::rbindlist(c(list(legs_out), legs_in))
 
  cdt$comp = mapply(function(cmp, bbx, u) {

R/tmapGridComp.R

@@ -388,6 +388,9 @@ tmapGridCompWidth.tm_scalebar = function(comp, o) {
  #textP = comp$padding[c(3,1)] * textS * o$lin
 
  marW = comp$margins[c(2,4)] * textS * o$lin
+
+
+
  ws = c(marW[1], 0, marW[2])
 
  sides = switch(comp$position$align.h, left = "second", right = "first", "both")
@@ -396,7 +399,7 @@ tmapGridCompWidth.tm_scalebar = function(comp, o) {
 
  comp$Win = sum(ws)
  comp$wsu = wsu
- 
+
  # in case breaks are used: adjust the legend width later (in tmapGridLegend)
  comp$WnativeID = 3
  if (!is.null(comp$breaks)) {
@@ -421,11 +424,17 @@ tmapGridLegPlot.tm_scalebar = function(comp, o, fH, fW) {
  widths = wsu,
  heights = hsu))
 
+ #fW_fact = 1
 
  unit = comp$units$unit
  unit.size = 1/comp$units$to
- xrange = comp$bbox[3] - comp$bbox[1]
- crop_factor = as.numeric(wsu[3]) / fW 
+ #xrange = (comp$bbox[3] - comp$bbox[1]) * fW_fact
+
+ xrange = fW * comp$cpi
+
+ W = as.numeric(wsu[3])
+
+ crop_factor = W / fW 
  just = 0
 
  if (is.na(unit.size)) {
@@ -437,18 +446,28 @@ tmapGridLegPlot.tm_scalebar = function(comp, o, fH, fW) {
  xrange2 = xrange/unit.size
 
  # to find the label width of first and last item, only used as proxy
- tcks = pretty(c(0, xrange2*crop_factor), 4)
- tcksL = format(tcks, trim=TRUE)
- rngL = c(tcksL[1], paste(unit, tail(tcksL, 1), unit))
- rngW = ((text_width_inch(rngL) / 2) + o$lin * 0.5) * comp$text.size
-
- # available width for scale bar
- sbW = as.numeric(wsu[3]) - sum(rngW)
-
- crop_factor2 = sbW / fW 
 
+
  if (is.null(comp$breaks)) {
- ticks2 = pretty(c(0, xrange2*crop_factor2), round(comp$width * 8))
+
+ # determine resolution
+ for (i in 10:1) {
+ tcks = pretty(c(0, xrange2*crop_factor), i)
+
+ tcks3 = (tcks / xrange2) * fW
+
+ tcksL = format(tcks, trim=TRUE)
+
+ labW = text_width_inch(tcksL) * comp$text.size
+
+ tickW = tcks3[-1] - head(tcks3, -1)
+
+ if (all(tickW > labW[-1])) {
+ sbW = W - labW
+ break
+ }
+ }
+ ticks2 = tcks
  } else {
  ticks2 = comp$breaks
  }

R/tmapGridLegend.R

@@ -24,6 +24,7 @@ process_comp_box = function(comp, sc, o) {
 
 tmapGridCompCorner = function(comp, o, stack, pos.h, pos.v, maxH, maxW, offsetIn.h, offsetIn.v, marginIn, are_nums, fH, fW) {
 
+
  n = length(comp)
  # if (stack == "vertical") {
  # maxH = totH - marginInTot 
@@ -35,7 +36,7 @@ tmapGridCompCorner = function(comp, o, stack, pos.h, pos.v, maxH, maxW, offsetIn
  legWin = vapply(comp, "[[", FUN.VALUE = numeric(1), "Win") # vapply(comp, leg_standard$fun_width, FUN.VALUE = numeric(1), o = o)
  legHin = vapply(comp, "[[", FUN.VALUE = numeric(1), "Hin")#vapply(comp, leg_standard$fun_height, FUN.VALUE = numeric(1), o = o)
 
- 
+
  group.just = c(pos.h, pos.v)
  group.frame = comp[[1]]$group.frame
 
@@ -283,33 +284,52 @@ tmapGridLegend = function(comp, o, facet_row = NULL, facet_col = NULL, facet_pag
  #########
  # 5 is rect category consisting of "center"s or numbers
 
- ## update scale_bar width
+ ## update scale_bar width: identified by the WnativeID = 3 item (null for other components)
  comp = mapply(function(cmp, bb) {
  bbw = bb[3] - bb[1]
  if (!is.null(cmp$WnativeID)) {
+ bbox_nb = attr(bbox, "borrow")
+ if (is.null(bbox_nb)) {
+ bb_facet = sum(colsIn)
+ } else {
+ bb_facet = sum(g$colsIn[g$cols_facet_ids[bbox_nb$col]])
+ }
+
  oldIn = as.numeric(cmp$wsu[cmp$WnativeID])
+
  if (is.null(cmp$WnativeRange)) {
- newIn = min(totW, cmp$width * sum(colsIn))
-
- #cmp$WnativeRange = bbw * cmp$units$to
- #newIn = totW - cmp$Win + oldIn
+ newIn = min(totW, bb_facet * cmp$width)
  } else {
- bbw2 = bbw / sum(colsIn) * totW
- newIn = (min(1, ((cmp$WnativeRange / bbw2) / cmp$units$to)) * totW) + (o$lin * cmp$text.size * 3.5)
+ newIn = totW
  }
+ #if (is.null(cmp$WnativeRange)) {
+ # no specified scare bar width range
+ # newIn = min(totW, cmp$width * sum(colsIn))
+ #} else {
+ #bbw2 = bbw / sum(colsIn) * totW
+ # newIn = min(totW, sum(colsIn))
+ #newIn = (min(1, ((cmp$WnativeRange / bbw2) / cmp$units$to)) * totW) + (o$lin * cmp$text.size * 3.5)
+ #}
  cmp$wsu[cmp$WnativeID] = unit(newIn, "inch")
  cmp$Win = cmp$Win + (newIn - oldIn)
+
+
+ # get cpi: coordinates per inch
+
+
+ cmp$cpi = unname(bbw / bb_facet)
  }
  cmp
  }, comp, bbox, SIMPLIFY = FALSE)
 
+
  qH = rep(totH, 5)
  qW = rep(totW, 5)
 
  legWin = vapply(comp, "[[", FUN.VALUE = numeric(1), "Win") # vapply(comp, leg_standard$fun_width, FUN.VALUE = numeric(1), o = o)
  legHin = vapply(comp, "[[", FUN.VALUE = numeric(1), "Hin")#vapply(comp, leg_standard$fun_height, FUN.VALUE = numeric(1), o = o)
 
- 
+
  # get total value (width or height)
  getH = function(s, lH) {
  if (!length(s)) return(NULL)

R/tmap_options.R

@@ -235,6 +235,11 @@
  text.fontfamily = "",
 
 
+ component.position = list('in' = list(pos.h = "left", pos.v = "top",
+ align.h = "left", align.v = "top", just.h = "left", just.v = "top"),
+ out = list(cell.h = "right", cell.v = "center",
+ pos.h = "left", pos.v = "top",
+ align.h = "left", align.v = "top", just.h = "left", just.v = "top")),
 
  # legend 
  legend.show = TRUE,
@@ -377,13 +382,12 @@
 
  scalebar.show = FALSE,
  scalebar.breaks=NULL,
- scalebar.width=.3, 
+ scalebar.width=0.3, 
  scalebar.text.size = .5,
  scalebar.text.color=NA,
  scalebar.color.dark="black", 
  scalebar.color.light="white",
  scalebar.lwd=1,
- scalebar.position=NA,
  scalebar.bg.color=NA,
  scalebar.bg.alpha=NA,
  scalebar.size = NULL,