handle 0 and gaps in color/attr tables; #484

R/raster.R

@@ -109,21 +109,13 @@ setAs("stars_proxy", "Raster", function(from) {
 get_terra_levels = function(x, min_v) {
 # create factor levels, as used by stars, from SpatRaster levels in a data.frame
 # see https://github.com/r-spatial/stars/pull/484
-	IDs = x[[1]]
-	if (any(IDs < 0))
+	levels = x[[1]]
+	if (any(levels < 0))
 		stop("negative IDs in SpatRaster levels not supported")
-	categories = x[[2]]
-	if (min(IDs) == 0) {
-		if (min_v == 0) # shift all:
-			IDs = IDs + 1
-		else { # remove ID 0:
-			categories = categories[IDs != 0]
-			IDs = IDs[IDs != 0]
-		}
-	}
-	ct = rep("_", max(IDs))
-	ct[IDs] = categories
-	make.unique(ct)
+	ex = setdiff(0:max(levels), levels)
+	exclude = rep(FALSE, max(levels) + 1)
+	exclude[ex + 1] = TRUE # 0-based vector
+	list(levels = levels, labels = x[[2]], exclude = exclude)
 }
 
 #' @name st_as_stars
@@ -179,21 +171,22 @@ st_as_stars.SpatRaster = function(.x, ..., ignore_file = FALSE) {
 		setNames(ret, attr_name)
 	} else { # ignore_file TRUE:
 		v = terra::values(.x, mat = FALSE)
-		dim(v) = dim(.x)[c(2,1,3)]
+		dimv = dim(v) = dim(.x)[c(2,1,3)]
 		if (all(terra::is.factor(.x))) {
 			if (length(terra::levels(.x)) > 1)
 				warning("ignoring categories/levels for all but first layer")
-			if ((min_v <- min(v, na.rm = TRUE)) == 0) # +warn here?
-				v = v + 1
 			l = terra::levels(.x)[[1]]
 			if (inherits(l, "data.frame"))
 				l = get_terra_levels(l, min_v)
+			else
+				stop("terra levels should return a list of data.frame's; pls update terra")
 			colors = try(rgb(terra::coltab(.x)[[1]], maxColorValue = 255), silent = TRUE)
 			if (inherits(colors, "try-error") || length(colors) == 0)
 				colors = NULL
-			else if (length(colors) == length(levels) + 1) # remove last color?
-				colors = colors[-length(colors)]
-			v = structure(v, class = "factor", levels = as.character(l), colors = colors)
+			#else if (length(colors) == length(levels) + 1) # remove last color?
+			#	colors = colors[-length(colors)]
+			v = factor(as.vector(v), levels = l$levels, labels = l$labels)
+			v = structure(v, dim = dimv, colors = colors, exclude = l$exclude)
 		}
 		dimensions = list(
 			x = create_dimension(from = 1, to = dim(v)[1], offset = e[1],

R/read.R

@@ -46,6 +46,7 @@ is_functions = function(x) {
 #' @param RAT character; raster attribute table column name to use as factor levels
 #' @param tolerance numeric; passed on to \link{all.equal} for comparing dimension parameters.
 #' @param ... passed on to \link{st_as_stars} if \code{curvilinear} was set
+#' param exclude character; vector with category values to exclude
 #' @return object of class \code{stars}
 #' @details In case \code{.x} contains multiple files, they will all be read and combined with \link{c.stars}. Along which dimension, or how should objects be merged? If \code{along} is set to \code{NA} it will merge arrays as new attributes if all objects have identical dimensions, or else try to merge along time if a dimension called \code{time} indicates different time stamps. A single name (or positive value) for \code{along} will merge along that dimension, or create a new one if it does not already exist. If the arrays should be arranged along one of more dimensions with values (e.g. time stamps), a named list can passed to \code{along} to specify them; see example.
 #'
@@ -99,7 +100,7 @@ read_stars = function(.x, ..., options = character(0), driver = character(0),
 		RasterIO = list(), proxy = is_functions(.x) || (!length(curvilinear) &&
 				is_big(.x, sub = sub, driver=driver, normalize_path = normalize_path, ...)),
 		curvilinear = character(0), normalize_path = TRUE, RAT = character(0),
-		tolerance = 1e-10) {
+		tolerance = 1e-10, exclude = "") {
 
 	x = if (is.list(.x)) {
 			f = function(y, np) enc2utf8char(maybe_normalizePath(y, np))
@@ -229,49 +230,50 @@ read_stars = function(.x, ..., options = character(0), driver = character(0),
 			at = list() # skip it: https://github.com/r-spatial/stars/issues/435
 		# FIXME: how to handle multiple color, category or attribute tables?
 		if (!proxy && (any(lengths(ct) > 0) || any(lengths(at) > 0))) {
-			r = range(data, na.rm = TRUE)
-			min_value = if (meta_data$ranges[1,2] == 1)
-					meta_data$ranges[1,1]
-				else
-					r[1]
-			max_value = if (meta_data$ranges[1,4] == 1)
-					meta_data$ranges[1,3]
-				else
-					r[2]
-			if (any(meta_data$ranges[1, c(2,4)] == 1))
+			if (any(meta_data$ranges[1, c(2,4)] == 1)) { # adjust data to min/max values from image metadata
+				r = range(data, na.rm = TRUE)
+				min_value = if (meta_data$ranges[1,2] == 1)
+						meta_data$ranges[1,1]
+					else
+						r[1]
+				max_value = if (meta_data$ranges[1,4] == 1)
+						meta_data$ranges[1,3]
+					else
+						r[2]
 				data[data < min_value | data > max_value] = NA
-			if (min_value < 0)
-				stop("categorical values should have minimum value >= 0")
+			}
 
-			if (any(lengths(ct) > 0)) {
+			# convert color table ct to a vector of R colors:
+			co = if (any(lengths(ct) > 0)) {
 				ct = ct[[ which(length(ct) > 0)[1] ]]
-				co = apply(ct, 1, function(x) rgb(x[1], x[2], x[3], x[4], maxColorValue = 255))
-				if (min_value > 0)
-					co = co[-seq_len(min_value)] # removes [0,...,(min_value-1)]
-				levels = seq(min_value, length.out = length(co))
+				apply(ct, 1, function(x) rgb(x[1], x[2], x[3], x[4], maxColorValue = 255))
 			} else
-				co = NULL
-
-			if (min_value == 0) {
-				data = data + 1
-				warning("categorical data values starting at 0 are shifted with one to start at 1")
-			}
+				NULL
 
 			if (any(lengths(at) > 0)) {
+				# select attribute table:
 				which.at = which(lengths(at) > 0)[1]
 				which.column = if (length(RAT))
 						RAT
 					else
 						which(sapply(at[[which.at]], class) == "character")[1]
-				at = at[[ which.at ]][[ which.column ]]
-				if (min_value > 0)
-					at = at[-1]
-				if (min_value == 0)
-					max_value = max_value + 1
-				levels = at[1:max_value]
+				labels = at = at[[ which.at ]][[ which.column ]]
+				levels = 0:(length(at) - 1)
+				if (length(exclude)) {
+					ex = at %in% exclude
+					labels = labels[!ex]
+					levels = levels[!ex]
+					min_value = min(levels)
+					if (!is.null(co))
+						co = co[!ex]
+				} else
+					ex = rep(FALSE, length(levels))
+				f = factor(as.vector(data), levels = levels, labels = labels)
+			} else {
+				f = factor(as.vector(data))
+				ex = rep(FALSE, length(levels(f)))
 			}
-
-			data = structure(data, class = "factor", levels = levels, colors = co)
+			data = structure(f, dim = dim(data), colors = co, exclude = ex)
 		}
 
 		dims = if (proxy) {

R/stars.R

@@ -862,7 +862,7 @@ st_redimension.stars = function(x, new_dims = st_dimensions(x),
 		}
 		value = if (inherits(value, c("factor", "POSIXct")))
 				structure(rep(value, length.out = prod(dim(x))), dim = dim(x), colors = attr(value, "colors"),
-					rgba = attr(value, "rgba"))
+					rgba = attr(value, "rgba"), exclude = attr(value, "exclude"))
 			else if (!is.array(value) || !isTRUE(all.equal(dim(value), dim(x), check.attributes = FALSE)))
 				array(value, dim(x))
 			else

R/subset.R

@@ -96,7 +96,7 @@
 	args[["drop"]] = FALSE
 	for (i in names(x))
 		x[[i]] = structure(eval(rlang::expr(x[[i]][ !!!args ])), levels = attr(x[[i]], "levels"),
-			colors = attr(x[[i]], "colors"))
+			colors = attr(x[[i]], "colors"), exclude = attr(x[[i]], "exclude"))
 
 	# now do dimensions:
 	if (do_select) {