From f0a9205a58b2225d352135e2855643d14a85db72 Mon Sep 17 00:00:00 2001 From: mtennekes Date: Sun, 28 Jan 2024 21:44:48 +0100 Subject: [PATCH] fixed #818 for regular stars --- R/onLoad.R | 2 +- R/step1_rearrange.R | 4 +- R/step3_trans.R | 2 +- R/tmapGrid_layers.R | 15 +++- R/tmapLeafletInit.R | 62 ------------- R/tmapLeaflet_layers.R | 28 +++++- R/tmapScaleDiscrete.R | 4 +- R/tmapShape.R | 21 ++++- sandbox/issues.R | 198 +++++++++++++++++++++++++++++++++++++++++ 9 files changed, 259 insertions(+), 77 deletions(-) diff --git a/R/onLoad.R b/R/onLoad.R index 87880d41..59583e39 100644 --- a/R/onLoad.R +++ b/R/onLoad.R @@ -1,6 +1,6 @@ # envir = environment() .onLoad = function(...) { - options(tmap.style = "white", tmap.mode = "plot", tmap.design.mode = FALSE, + options(tmap.style = "white", tmap.mode = "view", tmap.design.mode = FALSE, tmap.devel.mode = FALSE) assign("tmapOptions", .defaultTmapOptions, envir = .TMAP) diff --git a/R/step1_rearrange.R b/R/step1_rearrange.R index 53deea44..c82a151b 100644 --- a/R/step1_rearrange.R +++ b/R/step1_rearrange.R @@ -131,7 +131,7 @@ step1_rearrange = function(tmel) { # get main crs (used in step 3, not necessarily in the plot (e.g. view mode will use 4326/3857)) crs_main = if (any_data_layer) get_crs(tms) else NA - + if (inherits(crs_option, "leaflet_crs")) { crs_leaflet = crs_option crs = leaflet2crs(crs_leaflet) @@ -152,7 +152,6 @@ step1_rearrange = function(tmel) { main_class = "stars" # basemaps } - if (dev) timing_add(s2 = "facet meta") @@ -196,6 +195,7 @@ step1_rearrange = function(tmel) { o$crs_leaflet = crs_leaflet o$crs_main = crs_main + o = c(o, tmf) # process shapes: put non-spatial data in data.table, keep spatial data separately diff --git a/R/step3_trans.R b/R/step3_trans.R index fba925f1..9fde737f 100644 --- a/R/step3_trans.R +++ b/R/step3_trans.R @@ -47,6 +47,7 @@ step3_trans = function(tm) { if (al$trans_isglobal) shpDT = trans_shp(al, shpDT) } + adi$layers = lapply(adi$layers, function(al) { # step 3.c1: apply non global transformation function if (al$trans_isglobal) { @@ -68,7 +69,6 @@ step3_trans = function(tm) { adi }) - list(tmo = bd, aux = aux, cmp = cmp, o = o) } diff --git a/R/tmapGrid_layers.R b/R/tmapGrid_layers.R index 9634283a..8f0db270 100644 --- a/R/tmapGrid_layers.R +++ b/R/tmapGrid_layers.R @@ -287,8 +287,19 @@ tmapGridRaster <- function(shpTM, dt, gp, bbx, facet_row, facet_col, facet_page, m <- matrix(color, ncol=nrow(shp), nrow=ncol(shp), byrow = TRUE) - y_is_neg <- all(diff(stars::st_get_dimension_values(shp, "y")) < 0) - if (!y_is_neg) { + y_is_pos <- local({ + vals = stars::st_get_dimension_values(shp, "y") + if (!is.null(vals)) { + !all(diff(vals) < 0) + } else { + rst = attr(shp, "raster") + name_y = names(get_xy_dim(shp))[2] + delta = shp[[name_y]]$delta + delta > 0 + } + }) + + if (y_is_pos) { m <- m[nrow(m):1L, ] } m[is.na(m)] = NA #"#0000FF" diff --git a/R/tmapLeafletInit.R b/R/tmapLeafletInit.R index 70ff25ef..4c95f2b0 100644 --- a/R/tmapLeafletInit.R +++ b/R/tmapLeafletInit.R @@ -68,69 +68,7 @@ tmapLeafletInit = function(o, return.asp = FALSE, vp) { lf }) }) - - - - # bases = if ("bases" %in% ls(envir = .TMAP_LEAFLET)) get("bases", envir = .TMAP_LEAFLET) else NA - # overlays = if ("overlays" %in% ls(envir = .TMAP_LEAFLET)) get("overlays", envir = .TMAP_LEAFLET) else NA - # overlays_tiles = if ("overlays_tiles" %in% ls(envir = .TMAP_LEAFLET)) get("overlays_tiles", envir = .TMAP_LEAFLET) else character(0) - # - # layerIds = list() - # start_pane_id = 401 - # - # # should the layer control include base layers? TRUE if |basemaps| > 1 || names/groups are specified - # basename.specified = FALSE - # - # - # - # ### find z indeces and create tmapXXX panes - # zids <- lapply(gp, function(gpl) { - # po <- gpl$plot.order - # - # po2 <- substr(po, 4, nchar(po)) - # po2[po2 == "symbols"] <- "symbol" - # po2[po2 == "tiles"] <- "tile" - # po2[po2 == "lines"] <- "line" - # - # zi <- sapply(po2, function(p) { - # if (p == "grid") gt$grid.zindex else gpl[[paste0(p, ".zindex")]] - # }) - # - # if (!is.null(gpl$tile.gtype) && gpl$tile.gtype == "base") { - # zi[names(zi) == "tile"] <- 0 - # } - # zi - # }) - # zids_vec <- unlist(zids, use.names = FALSE) - # - # # For tmapProxy: only use pane with a higher z number than existing ones - # # Only use free panes: every layer must be in a different pane - # z_free <- setdiff(start_pane_id:(start_pane_id+length(zids_vec)*2-1), na.omit(zids_vec)) - # zids_vec[is.na(zids_vec)] <- rep(z_free, length.out = sum(is.na(zids_vec))) - # zids_len <- sapply(zids, length) - # zindices <- split(zids_vec, unlist(mapply(rep, 1:length(zids), each = zids_len, SIMPLIFY = FALSE), use.names = FALSE)) - # tmap_zindices <- sort(unique(unname(setdiff(zids_vec, 0)))) - # - # ## get/set existing panes - # if (!proxy) { - # assign("pane_ids", tmap_zindices, envir = .TMAP_CACHE) - # z_panes <- integer() - # } else { - # z_panes <- get("pane_ids", envir = .TMAP_CACHE) - # assign("pane_ids", union(tmap_zindices, z_panes), envir = .TMAP_CACHE) - # } - # - # # add new panes - # for (z in setdiff(tmap_zindices, z_panes)) { - # lf <- addMapPane(lf, paneName(z), zIndex = z) - # } - # - # - # - # - # - # .TMAP_LEAFLET$lfs = lfs .TMAP_LEAFLET$nrow = o$nrows .TMAP_LEAFLET$ncol = o$ncols diff --git a/R/tmapLeaflet_layers.R b/R/tmapLeaflet_layers.R index 14b5e1f5..8d839016 100644 --- a/R/tmapLeaflet_layers.R +++ b/R/tmapLeaflet_layers.R @@ -234,18 +234,38 @@ tmapLeafletRaster = function(shpTM, dt, gp, pdt, popup.format, hdt, idt, bbx, fa m <- matrix(col_ids, ncol = ncol(shp)) + #matrix(color, ncol = ncol(shp)) + + #m <- matrix(tmapID, ncol = ncol(shp)) + + + #m = tmapID + + #m[1,5] = 4 + shp2 = st_as_stars(m, dimensions = shp) lf = get_lf(facet_row, facet_col, facet_page) - #shp2 = transwarp(shp, crs = st_crs(3857), raster.warp = TRUE) - lf |> leafem::addStarsImage(shp2, band = 1, colors = pal_col, opacity = pal_opacity, group = group) |> assign_lf(facet_row, facet_col, facet_page) } else { - shpTM <- shapeTM(sf::st_as_sf(shp), tmapID) - tmapLeafletPolygons(shpTM, dt, facet_row, facet_col, facet_page, id, pane, group, o) + #shp2 = st_as_stars(list(values = tmapID), dimensions = shp) + #shpTM <- shapeTM(sf::st_geometry(sf::st_as_sf(shp2)), as.vector(tmapID)) + + m = matrix(tmapID, nrow = nrow(shp), ncol = ncol(shp)) + shp2 = structure(list(tmapID = m), class = "stars", dimensions = shp) + + shp3 = sf::st_geometry(sf::st_as_sf(shp2)) + + crs = get_option_class(tmap_options_mode("view")$crs, "sf") + + shpTM = shapeTM(sf::st_transform(shp3, crs), tmapID) + + + gp$lty = "solid" + tmapLeafletPolygons(shpTM, dt, pdt, popup.format = NULL, hdt = NULL, idt = NULL, gp, bbx, facet_row, facet_col, facet_page, id, pane, group, o) #grid.shape(s, gp=gpar(fill=color, col=NA), bg.col=NA, i, k) } NULL diff --git a/R/tmapScaleDiscrete.R b/R/tmapScaleDiscrete.R index 8858827c..e2249edd 100644 --- a/R/tmapScaleDiscrete.R +++ b/R/tmapScaleDiscrete.R @@ -98,7 +98,9 @@ tmapScaleDiscrete = function(x1, scale, legend, o, aes, layer, layer_args, sortR na.show = update_na.show(label.show, legend$na.show, anyNA) - if (is.na(sortRev)) { + if (is.null(sortRev)) { + ids = NULL + } else if (is.na(sortRev)) { ids[] = 1L } else if (sortRev) { ids = (as.integer(n) + 1L) - ids diff --git a/R/tmapShape.R b/R/tmapShape.R index 6a5d3f89..56bd1e5d 100644 --- a/R/tmapShape.R +++ b/R/tmapShape.R @@ -5,7 +5,6 @@ tmapReproject = function(...) { #' @method tmapReproject stars #' @export tmapReproject.stars = function(shp, tmapID, bbox = NULL, ..., crs) { - shp[[1]] = tmapID shp2 = transwarp(shp, crs, raster.warp = TRUE) @@ -249,8 +248,12 @@ tmapShape.stars = function(shp, is.main, crs, bbox, unit, filter, shp_name, smet shpclass = "sfc" - } else { + } else { + shp0 = shp + dt0 = as.data.table(shp0, center = FALSE) + shp = downsample_stars(shp, max.raster = o$raster.max.cells / (o$fn[1] * o$fn[2])) + if (!is.null(crs) && sf::st_crs(shp) != crs) { shp = transwarp(shp, crs, raster.warp = TRUE) } @@ -267,10 +270,18 @@ tmapShape.stars = function(shp, is.main, crs, bbox, unit, filter, shp_name, smet attr(shp3, "dimensions")[[rst$dimensions[2]]]$values = 1L:ncol(shp) attr(attr(shp3, "dimensions"), "raster")$curvilinear = FALSE } else { - shp2 = stars::st_set_dimensions(shp, rst$dimensions[1], values = {if (dimsxy[[1]]$delta > 0) 1L:nrow(shp) else nrow(shp):1L}) - shp3 = stars::st_set_dimensions(shp2, rst$dimensions[2], values = {if (dimsxy[[2]]$delta < 0) 1L:ncol(shp) else ncol(shp):1L}) + #shp2 = stars::st_set_dimensions(shp, rst$dimensions[1], values = {if (dimsxy[[1]]$delta > 0) 1L:nrow(shp) else nrow(shp):1L}) + #shp3 = stars::st_set_dimensions(shp2, rst$dimensions[2], values = {if (dimsxy[[2]]$delta < 0) 1L:ncol(shp2) else ncol(shp2):1L}) + + shp2 = stars::st_set_dimensions(shp, rst$dimensions[1], values = 1L:nrow(shp)) + shp3 = stars::st_set_dimensions(shp2, rst$dimensions[2], values = 1L:ncol(shp)) + + #shp3 = shp } + shp0b = shp3 + + dt = as.data.table(shp3, center = FALSE) # Circumvent bug in tests on Windows tryCatch( @@ -290,6 +301,8 @@ tmapShape.stars = function(shp, is.main, crs, bbox, unit, filter, shp_name, smet shp = dimsxy shpclass = "stars" + + shpTM = shapeTM(shp = shp, tmapID = 1L:(nrow(shp) * ncol(shp)), bbox = bbox) } diff --git a/sandbox/issues.R b/sandbox/issues.R index b33cb571..6f0292ba 100644 --- a/sandbox/issues.R +++ b/sandbox/issues.R @@ -170,6 +170,36 @@ tm_shape(cat_raster) + col.legend = tm_legend("Land cover")) +# issue 2 +library(osfr) +library(rnaturalearth) +#> Support for Spatial objects (`sp`) will be deprecated in {rnaturalearth} and will be removed in a future release of the package. Please use `sf` objects with {rnaturalearth}. For example: `ne_download(returnclass = 'sf')` + +dir.create("testdata") +osf_retrieve_node("xykzv") |> + osf_ls_files(n_max = Inf) |> + osf_download(path = "testdata", + conflicts = "overwrite") + + +lc = rast("testdata/land_cover.tif") +cameroon = ne_countries(country = "Cameroon", returnclass = "sf") |> + st_transform(crs = st_crs(lc)) + +lc_cameroon = crop(lc, cameroon, mask = TRUE) + +lc_palette_df = read.csv("testdata/lc_palette.csv") +coltb = lc_palette_df[c("value", "color")] +coltab(lc_cameroon) = coltb +plot(lc_cameroon) # raster with color table + +tm_shape(lc_cameroon) + + tm_raster() + +tm_shape(lc) + + tm_raster() + + # 819 L7file = system.file("tif/L7_ETMs.tif", package = "stars") L7 = read_stars(L7file) @@ -202,3 +232,171 @@ tm_shape(L7) + # Error: palette should be a character value # In addition: Warning message: # In value[[3L]](cond) : could not rename the data.table + + + + + + + + + + + + + +# in #733 +tm_shape(World) + + tm_polygons(c("income_grp", "economy"), title = c("Legend Title 1", "Legend Title 2")) + + +tm_shape(World) + + tm_polygons(c("income_grp", "economy"), fill.legend = tm_legend(title = c("Legend Title 1", "Legend Title 2"))) + +tm_shape(World) + + tm_polygons(c("income_grp", "economy"), fill.legend = list(tm_legend(title = "Legend Title 1"), + tm_legend(title = "Legend Title 2"))) + +tm_shape(World) + + tm_polygons(c("income_grp", "economy"), fill.legend = list(tm_legend(title = "Legend Title 1"), + tm_legend(title = "Legend Title 2")))+ +tm_layout(main.title = "Main Title", + main.title.position = "center", + main.title.color = "blue", + title = c("Title 1", "Title 2"), + title.color = "red", + panel.labels = c("Panel Label 1", "Panel Label 2"), + panel.label.color = "purple", + legend.text.color = "brown") + + +tm_shape(World) + + tm_polygons(c("income_grp", "economy"), fill.legend = list(tm_legend(title = "Legend Title 1"), + tm_legend(title = "Legend Title 2")))+ + tm_title("Main", position = tm_pos_out("center", "top")) + + + + +#810 +tm_shape(World, bbox = as.vector(sf::st_bbox(World))) + + tm_polygons() + + +reprex::reprex({ + sf::st_bbox(c(-180, -89, 180, 83)) + sf::st_bbox(c(xmin = -180, ymin = -89, xmax = 180, ymax = 83)) +}) + + + +# 818 + +library(stars) +library(mapview) +m = matrix(1:20, 4) +s0 = st_as_stars(m) +s = s0 +st_crs(s) <- 4326 +st_crs(s0) <- 4326 + +st_geotransform(s0) <- c(5, 1.5, 0.2, 0, 0.2, 1.5) + +library(tmap) +tmap_mode("plot") +tmap_mode("view") +tm_shape(World) + + tm_borders() + +tm_shape(s) + + tm_raster(col_alpha=0.5) + + tm_shape(s0,raster.warp = FALSE) + tm_raster() + +tm_shape(s, crs = 3857) + tm_raster() +tm_shape(s0, crs = 3857) + tm_raster() + +tm_shape(s0) + tm_raster() + +tm_shape(World) + tm_polygons() + + +s +(s2 = stars::st_warp(s, crs = 3857)) + +tm_shape(s) + tm_raster("A1", col.scale = tm_scale_discrete()) +tm_shape(s2) + tm_raster("A1", col.scale = tm_scale_discrete()) +tm_shape(s, crs = 3857) + tm_raster("A1", col.scale = tm_scale_discrete()) + +mapview(s) +mapview(s2) +s$A1[] +s2$A1[] + + +st_crs(s) +s$A1 + +s2 = transwarp(s, crs = 3857) + +plot(s) +plot(s2) + +s$A1[] +s2$A1[] + +c("#FF0000", "#FF4D00", "#FF9900", "#FFE500", + "#CCFF00", "#80FF00", "#33FF00", "#00FF19", + "#00FF66", "#00FFB2", "#00FFFF", "#00B3FF", + "#0066FF", "#001AFF", "#3300FF", "#7F00FF", + "#CC00FF", "#FF00E6", "#FF0099", "#FF004D") + + +###### + +# original matrix is m: +m +s$A1 + +# adding rainbow colors: +leaflet() |> addTiles() |> leafem::addStarsImage(s, colors = rainbow(20)) + + + + +mtch = match(1:20, s2$A1) + +leaflet() |> addTiles() |> leafem::addStarsImage(s2, colors = rainbow(20)) + + +leaflet() |> addTiles() |> leafem::addStarsImage(s2, colors = rainbow(20)[mtch]) +mapview(s2) + +# tmapShape L 23 +tmapReproject.dimensions + + + + +####################### + +library(stars) +library(mapview) +#m = matrix(1:4, 2) +m = matrix(c(3,4,1,2), 2) + +s0 = st_as_stars(m) +s = s0 +st_crs(s) <- 4326 +st_crs(s0) <- 4326 + +st_geotransform(s0) <- c(5, 1.5, 0.2, 0, 0.2, 1.5) + + +tm_shape(s, crs = 3857) + tm_raster() +#tm_shape(s0, crs = 3857) + tm_raster() + +tm_shape(s) + tm_raster() +#tm_shape(s0) + tm_raster() + +mapview::mapview(s) +plot(s) +plot(s)