R/factors.R

In r-spatial/stars: Spatiotemporal Arrays, Raster and Vector Data Cubes

#' cut methods for stars objects
#' 
#' cut methods for stars objects
#' @name cut_stars
#' @param x see \link[base]{cut}
#' @param breaks see \link[base]{cut}
#' @param ... see \link[base]{cut}
#' @return an array or matrix with a \code{levels} attribute; see details
#' @details R's \code{factor} only works for vectors, not for arrays or matrices. This is a work-around (or hack?) to keep the factor levels generated by \code{cut} and use them in plots.
#' @export
#' @examples
#' tif = system.file("tif/L7_ETMs.tif", package = "stars")
#' x = read_stars(tif)
#' cut(x, c(0, 50, 100, 255))
#' cut(x[,,,1], c(0, 50, 100, 255))
#' plot(cut(x[,,,1], c(0, 50, 100, 255)))
cut.array = function(x, breaks, ...) { 
	structure(cut(as.vector(x), breaks, ...), dim = dim(x))
}

#' @name cut_stars
#' @export
cut.matrix = cut.array

#' @name cut_stars
#' @export
#' @examples
#' tif = system.file("tif/L7_ETMs.tif", package = "stars")
#' x1 = read_stars(tif)
#' (x1_cut = cut(x1, breaks = c(0, 50, 100, Inf)))  # shows factor in summary
#' plot(x1_cut[,,,c(3,6)]) # propagates through [ and plot
cut.stars = function(x, breaks, ...) {
	my_cut = function(x, breaks, ...) structure(cut(x, breaks, ...), dim = dim(x))
	st_stars(lapply(x, my_cut, breaks = breaks, ...), st_dimensions(x))
}

#' @export
droplevels.stars = function(x, ...) {
	drop_level = function(x, ...) {
		d = dim(x)
		l = levels(x)
		co = attr(x, "colors")
		dim(x) = NULL
		x = droplevels(x, ...)
		sel = match(levels(x), l)
		structure(x, dim = d, colors = co[sel])
	}
	for (i in seq_along(x)) {
		if (inherits(x[[i]], "factor"))
			x[[i]] = drop_level(x[[i]], ...)
	}
	x
}

#' @export
droplevels.stars_proxy = function(x, ...) {
	collect(x, match.call(), "droplevels", env = environment())
}