From 0e17daf1c49b69f990ec77275e80cfd471210aee Mon Sep 17 00:00:00 2001 From: edzer Date: Sat, 19 Aug 2023 11:15:37 +0200 Subject: [PATCH] key width issues --- NAMESPACE | 1 + R/init.R | 2 +- R/plot.R | 19 +++++++++++++++---- man/plot.Rd | 9 +++++---- vignettes/stars1.Rmd | 3 ++- vignettes/stars7.Rmd | 2 +- 6 files changed, 25 insertions(+), 11 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index e6645dfd..b58847b8 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -193,6 +193,7 @@ importFrom(graphics,plot) importFrom(graphics,plot.new) importFrom(graphics,plot.window) importFrom(graphics,rasterImage) +importFrom(graphics,strwidth) importFrom(graphics,text) importFrom(graphics,title) importFrom(methods,as) diff --git a/R/init.R b/R/init.R index 2cc6898a..9a616f29 100644 --- a/R/init.R +++ b/R/init.R @@ -1,4 +1,4 @@ -#' @importFrom graphics image.default image par plot title box text axis plot.new plot.window rasterImage layout lcm contour hist +#' @importFrom graphics image.default image par plot title box text axis plot.new plot.window rasterImage layout lcm contour hist strwidth #' @importFrom grDevices dev.capabilities dev.size grey rgb col2rgb #' @importFrom utils head tail setTxtProgressBar txtProgressBar packageVersion methods modifyList #' @importFrom stats na.omit runif aggregate setNames predict quantile var complete.cases na.pass time diff --git a/R/plot.R b/R/plot.R index 29f943e9..287506c7 100644 --- a/R/plot.R +++ b/R/plot.R @@ -6,6 +6,16 @@ make_label = function(x, i = 1) { names(x)[i] } +kw_dflt = function(x, key.pos) { + if (is.null(key.pos) || key.pos <= 0) + lcm(0) + else if (key.pos %in% c(2,4) && is.factor(x[[1]])) + lcm(max(strwidth(levels(x[[1]]), "inches")) * 2.54 * 1.1 + par("ps")/12) # cm + else + lcm(1.8 * par("ps")/12) +} + + #' plot stars object, with subplots for each level of first non-spatial dimension #' #' plot stars object, with subplots for each level of first non-spatial dimension, and customization of legend key @@ -51,12 +61,13 @@ make_label = function(x, i = 1) { #' } #' plot(x, hook = hook2, col = grey(c(.2,.25,.3,.35))) #' if (isTRUE(dev.capabilities()$rasterImage == "yes")) { -#' lc = system.file("tif/lc.tif", package = "stars") -#' plot(read_stars(lc), key.pos=4, key.width=lcm(5)) +#' lc = read_stars(system.file("tif/lc.tif", package = "stars")) +#' levels(lc[[1]]) = abbreviate(levels(lc[[1]]), 6) # so it's not only legend +#' plot(lc, key.pos=4) #' } plot.stars = function(x, y, ..., join_zlim = TRUE, main = make_label(x, 1), axes = FALSE, downsample = TRUE, nbreaks = 11, breaks = "quantile", col = grey(1:(nbreaks-1)/nbreaks), - key.pos = get_key_pos(x, ...), key.width = lcm(1.8 * par("ps")/12), key.length = 0.618, + key.pos = get_key_pos(x, ...), key.width = kw_dflt(x, key.pos), key.length = 0.618, key.lab = main, reset = TRUE, box_col = grey(.8), center_time = FALSE, hook = NULL, mfrow = NULL) { @@ -301,7 +312,7 @@ image.stars = function(x, ..., band = 1, attr = 1, asp = NULL, rgb = NULL, xlim = st_bbox(extent)$xlim, ylim = st_bbox(extent)$ylim, text_values = FALSE, text_color = 'black', axes = FALSE, interpolate = FALSE, as_points = FALSE, key.pos = NULL, logz = FALSE, - key.width = lcm(1.8 * par("ps")/12), key.length = 0.618, add.geom = NULL, border = NA, + key.width = kw_dflt(x, key.pos), key.length = 0.618, add.geom = NULL, border = NA, useRaster = isTRUE(dev.capabilities()$rasterImage == "yes"), extent = x) { dots = list(...) diff --git a/man/plot.Rd b/man/plot.Rd index a8a564e7..678b16eb 100644 --- a/man/plot.Rd +++ b/man/plot.Rd @@ -20,7 +20,7 @@ breaks = "quantile", col = grey(1:(nbreaks - 1)/nbreaks), key.pos = get_key_pos(x, ...), - key.width = lcm(1.8 * par("ps")/12), + key.width = kw_dflt(x, key.pos), key.length = 0.618, key.lab = main, reset = TRUE, @@ -49,7 +49,7 @@ as_points = FALSE, key.pos = NULL, logz = FALSE, - key.width = lcm(1.8 * par("ps")/12), + key.width = kw_dflt(x, key.pos), key.length = 0.618, add.geom = NULL, border = NA, @@ -168,8 +168,9 @@ hook2 = function(..., row, col, nr, nrow, ncol, value, bbox) { } plot(x, hook = hook2, col = grey(c(.2,.25,.3,.35))) if (isTRUE(dev.capabilities()$rasterImage == "yes")) { - lc = system.file("tif/lc.tif", package = "stars") - plot(read_stars(lc), key.pos=4, key.width=lcm(5)) + lc = read_stars(system.file("tif/lc.tif", package = "stars")) + levels(lc[[1]]) = abbreviate(levels(lc[[1]]), 6) # so it's not only legend + plot(lc, key.pos=4) } tif = system.file("tif/L7_ETMs.tif", package = "stars") x = read_stars(tif) diff --git a/vignettes/stars1.Rmd b/vignettes/stars1.Rmd index fbc97f68..aa574d81 100644 --- a/vignettes/stars1.Rmd +++ b/vignettes/stars1.Rmd @@ -339,10 +339,11 @@ two circular polygons: ```{r} s = system.file("tif/lc.tif", package = "stars") r = read_stars(s, proxy = FALSE) |> droplevels() +levels(r[[1]]) = abbreviate(levels(r[[1]]), 10) # shorten text labels st_point(c(3190631, 3125)) |> st_sfc(crs = st_crs(r)) |> st_buffer(25000) -> pol1 st_point(c(3233847, 21027)) |> st_sfc(crs = st_crs(r)) |> st_buffer(10000) -> pol2 if (isTRUE(dev.capabilities()$rasterImage == "yes")) { - plot(r, key.width = lcm(4), reset = FALSE, key.pos = 4) + plot(r, reset = FALSE, key.pos = 4) plot(c(pol1, pol2), col = NA, border = c('yellow', 'green'), lwd = 2, add = TRUE) } ``` diff --git a/vignettes/stars7.Rmd b/vignettes/stars7.Rmd index d26f1924..ba15ed9c 100644 --- a/vignettes/stars7.Rmd +++ b/vignettes/stars7.Rmd @@ -281,7 +281,7 @@ train = as.data.frame(train) train$x = NULL # remove geometry rf = randomForest(use ~ ., train) # ~ . : use all other attributes pr = predict(r, rf) -plot(pr, key.width = lcm(5), reset = FALSE, key.pos = 4) +plot(pr, reset = FALSE, key.pos = 1) # add country outline: plot(m, add = TRUE) ```