From 75cd3b2c89c654159eba8e3ac007b5075ee3770c Mon Sep 17 00:00:00 2001 From: Edzer Pebesma Date: Thu, 16 Jun 2022 22:06:40 +0200 Subject: [PATCH] handle 0 and gaps in color/attr tables; #484 --- R/raster.R | 33 +++++++++++---------------- R/read.R | 66 ++++++++++++++++++++++++++++-------------------------- R/stars.R | 2 +- R/subset.R | 2 +- 4 files changed, 49 insertions(+), 54 deletions(-) diff --git a/R/raster.R b/R/raster.R index 094806941..9184d3015 100644 --- a/R/raster.R +++ b/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], diff --git a/R/read.R b/R/read.R index a70d72677..15891d83a 100644 --- a/R/read.R +++ b/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) { diff --git a/R/stars.R b/R/stars.R index 4d0cd8978..24e591503 100644 --- a/R/stars.R +++ b/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 diff --git a/R/subset.R b/R/subset.R index 725de30bf..acbc1b6b3 100644 --- a/R/subset.R +++ b/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) {