From afdd7b6df9ea254a5dbef921e2ff6bf6dd62b122 Mon Sep 17 00:00:00 2001
From: mtennekes <mtennekes@gmail.com>
Date: Sun, 4 Feb 2024 21:45:59 +0100
Subject: [PATCH] #811

---
 R/misc_stars.R          | 10 ++++++++
 R/step1_helper_facets.R | 14 +++--------
 R/tmapGetShapeMeta.R    | 10 +++++---
 R/tmapShape.R           |  3 +++
 sandbox/issues.R        | 51 ++++++++++++++++++++++++++++++++++++++++-
 5 files changed, 73 insertions(+), 15 deletions(-)

diff --git a/R/misc_stars.R b/R/misc_stars.R
index 843d9121..d8fc71af 100644
--- a/R/misc_stars.R
+++ b/R/misc_stars.R
@@ -141,3 +141,13 @@ transwarp = function(x, crs, raster.warp) {
 	if (!is.null(shpcolors)) attr(y[[1]], "colors") = shpcolors
 	y
 }
+
+has_rotate_or_shear = function (x) 
+{
+	dimensions = st_dimensions(x)
+	if (has_raster(x)) {
+		r = attr(dimensions, "raster")
+		!any(is.na(r$affine)) && any(r$affine != 0)
+	}
+	else FALSE
+}
diff --git a/R/step1_helper_facets.R b/R/step1_helper_facets.R
index 8fd5ebc3..bfa8c814 100644
--- a/R/step1_helper_facets.R
+++ b/R/step1_helper_facets.R
@@ -304,28 +304,20 @@ step1_rearrange_facets = function(tmo, o) {
 		
 		smeta = tmapGetShapeMeta2(shp, smeta, c(o, tmg$tmf))
 		if (dev) timing_add(s3 = "get_shape_meta2")
-		
-		
-		
+
 		tmg$tmf = within(tmg$tmf, {
 			
-			
-			
 			gl = list(NULL, NULL, NULL)
 			gn = c(1L, 1L, 1L)
 
-			# assign("gl", gl, envir = .TMAP)
-			# assign("gn", gn, envir = .TMAP)
-			# assign("gisf", is.wrap, envir = .TMAP)
-			
 			for (i in 1L:3L) {
 				byi = get(paste0("by", i))
 				if (!is.null(byi)) {
 					if (byi == "VARS__") {
-						if (!is.null(vl)) gl[[i]] = vl
+						gl[i] = list(vl)
 						gn[i] = vn
 					} else if (byi %in% smeta$vars) {
-						gl[[i]] = smeta$vars_levs[[byi]]
+						gl[i] = list(smeta$vars_levs[[byi]])
 						gn[i] = length(gl[[i]])
 					} else if (byi %in% smeta$dims) {
 						gl[[i]] = smeta$dims_val[[match(byi, smeta$dims)]]	
diff --git a/R/tmapGetShapeMeta.R b/R/tmapGetShapeMeta.R
index b5d29e4e..6c86b757 100644
--- a/R/tmapGetShapeMeta.R
+++ b/R/tmapGetShapeMeta.R
@@ -75,11 +75,15 @@ tmapGetShapeMeta2.stars = function(shp, smeta, o) {
 #' @method tmapGetShapeMeta2 SpatRaster
 #' @export
 tmapGetShapeMeta2.SpatRaster = function(shp, smeta, o) {
-	
-	# slow, needs to be improved with terra functions, e.g. unique and levels
+	if (terra::ncell(shp) > o$raster.max.cells) {
+		# NOTE: this option is not ideal, because categories may be undiscovered
+		# NOTE2: maybe the same should be done with large stars?
+		shp = terra::spatSample(shp, 1e5, method = "regular", as.raster = TRUE)
+	}
 	smeta$vars_levs = lapply(terra::values(shp, dataframe=TRUE), function(dat) {
 		get_fact_levels_na(dat, o)
-	})
+	})		
+
 	names(smeta$vars_levs) = names(shp)
 	smeta
 }
diff --git a/R/tmapShape.R b/R/tmapShape.R
index 9c4acd85..b3fae02b 100644
--- a/R/tmapShape.R
+++ b/R/tmapShape.R
@@ -128,11 +128,14 @@ tmapShape.SpatRaster = function(shp, is.main, crs, bbox, unit, filter, shp_name,
 	
 	#if (is.null(bbox)) bbox = st_bbox(shp)
 	
+	
 	dtcols = setdiff(names(dt), "tmapID__")
 	
 	names(ctabs) = dtcols
 	names(cats) = dtcols
 	
+	make_by_vars(dt, tmf, smeta)
+	
 	if (is.null(filter)) filter = rep(TRUE, nrow(dt))
 	dt[, ':='(sel__ = filter)] # tmapID__ = 1L:nrow(dt), 
 	
diff --git a/sandbox/issues.R b/sandbox/issues.R
index b155eca3..8bf493be 100644
--- a/sandbox/issues.R
+++ b/sandbox/issues.R
@@ -310,6 +310,8 @@ st_crs(s) <- 4326
 st_crs(s0) <- 4326
 st_geotransform(s0) <- c(5, 1.5, 0.2, 0, 0.2, 1.5)
 
+
+
 s0_4326 = st_transform(s0, crs = 4326)
 
 stars:::is_curvilinear(s0)
@@ -449,7 +451,54 @@ tm_shape(nc.32119) + tm_polygons(c("SID74", "SID79"), fill.free = FALSE, fill.le
 
 library(terra)
 library(tmap)
-lc = rast("https://osf.io/download/m92d7")
+lc = rast("sandbox/land_cover.tif") # https://osf.io/download/m92d7")
+
+?terra
+
+levels(lc)
+
+unique(landr)
+
+tm_shape(lc) + tm_raster()
+
+landr = rast(land)
+
+class(landr)
+str(landr)
+terra::lapp(landr, class)
+
+levels(landr)
+
+terra::levels(land)
+
+
+lc2 = terra::spatSample(lc, 1e5, method = "regular", as.raster = T)
+
+tm_shape(lc2) + tm_raster("land_cover") + tm_facets("land_cover")
+tm_shape(lc) + tm_raster("land_cover") + tm_facets("land_cover")
+
+tm_shape(land) + tm_raster("trees") + tm_facets("cover_cls")
+tm_shape(land) + tm_raster("cover_cls") + tm_facets("cover_cls")
+
+
+# to do: 
+
+
+
+
+unique(lc)
+
+x = terra::head(lc, 10)
+
+x = terra::unique(lc)
+
+o = list(drop.NA.facets = TRUE, facet.max = 9)
+
+a = bench::mark(
+	a1 <- get_fact_levels_na(terra::values(lc, dataframe=TRUE)[[1]], o),
+	a2 <- freq(lc),
+	a3 <- unique(lc), check = FALSE
+)
 
 system.time({plot(lc)})