R/app.r

In adamlilith/fasterRaster: Faster Raster and Spatial Vector Processing Using 'GRASS GIS'

#' Apply a function to a set of rasters
#'
#' @description `app()` applies a function to a set of "stacked" rasters. It is similar to the [terra::app()] and [terra::lapp()] functions.
#'
#' `appFuns()` provides a table of **GRASS** functions that can be used by `app()` and their equivalents in **R**.
#'
#' `appCheck()` tests whether a formula supplied to `app()` has any "forbidden" function calls.
#' 
#' The `app()` function operates in a manner somewhat different from [terra::app()]. The function to be applied *must* be written as a character string. For example, if the `GRaster` had layer names "`x1`" and "`x2`", then the function might be like `"= max(sqrt(x1), log(x2))"`. Rasters **cannot** have the same names as functions used in the formula. In this example, the rasters could not be named "max", "sqrt", or "log". Note that the name of a `GRaster` is given by [names()]--this can be different from the name of the object in **R**.
#' 
#' The `app()` function will automatically check for `GRaster` names that appear also to be functions that appear in the formula. However, you can check a formula before running `app()` by using the `appCheck()` function. You can obtain a list of `app()` functions using `appFuns()`. Note that these are sometimes different from how they are applied in **R**.
#'
#' Tips:
#' * Make sure your `GRaster`s have `names()`. The function matches on these, not the name of the variable you use in **R** for the `GRaster`.
#' * Use `null()` instead of `NA`, and use `isnull()` instead of `is.na()`.
#' * If you want to calculate values using while ignoring `NA` (or `null`) values, see the functions that begin with `n` (like `nmean`).
#' * Be mindful of the data type that a function returns. In **GRASS**, these are `CELL` (integer), `FCELL` (floating point values--precise to about the 7th decimal place), and `DCELL` (double-floating point values--precise to about the 15th decimal place; commensurate with the **R** `numeric` type). In cases where you want a `GRaster` to be treated like a float or double type raster, wrap the name of the `GRaster` in the `float()` or `double()` functions. This is especially useful if the `GRaster` might be assumed to be the `CELL` type because it only contains integer values. You can get the data type of a raster using [datatype()] with the `type` argument set to `GRASS`. You can change the data type of a `GRaster` using [as.int()], [as.float()], and [as.doub()]. Note that categorical rasters are really `CELL` (integer) rasters with an associated "levels" table. You can also change a `CELL` raster to a `FCELL` raster by adding then subtracting a decimal value, as in `x - 0.1 + 0.1`. See `vignette("GRasters", package = "fasterRaster")`.
#' * The `rand()` function returns integer values by default. If you want non-integer values, use the tricks mentioned above to datatype non-integer values. For example, if you want uniform random values in the range between 0 and 1, use something like `= float(rand(0 + 0.1, 1 + 0.1) - 0.1)`.
#'
#' @param x A `GRaster` with one or more named layers.
#'
#' @param fun Character: The function to apply. This must be written as a character string that follows these rules:
#' 
#' * It must use typical arithmetic operators like `+`, `-`, `*`, `/` and/or functions that can be seen using `appFuns(TRUE)`.
#' * The [names()] of the rasters do not match any of the functions in the `appFuns(TRUE)` table. Note that `x` and `y` are forbidden names :(
#'
#' The help page for **GRASS** module `r.mapcalc` will be especially helpful. You can see this page using `grassHelp("r.mapcalc")`.
#' 
#' @param datatype Character: This ensures that rasters are treated as a certain type before they are operated on. This is useful when using rasters that have all integer values, which **GRASS** can assume represent integers, even if they are not supposed to. In this case, the output of operations on this raster might be an integer if otherwise not corrected. Partial matching is used, and options include:
#' * `"integer"`: Force all rasters to integers by truncating their values. The output may still be of type `float` if the operation creates non-integer values.
#' * `"float"`: Force rasters to be considered floating-point values.
#' * `"double"`: Force rasters to be considered double-floating point values.
#' * `"auto"` (default): Ensure that rasters are represented by their native [datatype()] (i.e., "CELL" rasters as integers, "FCELL" rasters as floating-point, and "DCELL" as double-floating point).
#'
#' @param seed Numeric integer vector or `NULL` (default): A number for the random seed. Used only for `app()` function `rand()`, that generates a random number. If `NULL`, a seed will be generated. Defining the seed is useful for replicating a raster made with `rand()`. This must be an integer!
#' 
#' @param warn Logical (function `appFuns()`): If `TRUE` (default), display a warning when `allFuns()` is not called interactively.
#'
#' @param msgOnGood Logical (function `appCheck()`): If `TRUE` (default), display a message if no overt problems with the raster names and formula are detected.
#' 
#' @param failOnBad Logical (function `appCheck()`): If `TRUE` (default), fail if overt problems with raster names and the formula are detected.
#'
#' @returns A `GRaster`.
#'
#' @seealso [terra::app()], [terra::lapp()], [subst()], [classify()], and especially **GRASS** manual page for module `r.mapcalc` (see `grassHelp("r.mapcalc")`)
#'
#' @example man/examples/ex_app.r
#'
#' @name app
#' @aliases app,lapp
#' @rdname app
#' @exportMethod app
methods::setMethod(
    f = "app",
    signature = c(x = "GRaster"),
    function(x, fun, datatype = "auto", seed = NULL) {

    fun <- trimws(fun)
    if (substr(fun, 1L, 2L) != "=") fun <- paste0("= ", substr(fun, 2L, nchar(fun)))
    if (substr(fun, 2L, 2L) != " ") fun <- paste0("= ", substr(fun, 2L, nchar(fun)))
    if (substr(fun, 1L, 2L) == "==") stop("Argument `fun` cannot begin with a double equals sign.")

    appCheck(x, fun, msgOnGood = FALSE, failOnBad = TRUE)

    .locationRestore(x)
    .region(x)

    # replace raster names with sources
    # replacing from longest to shortest to avoid issues with nestedness
    xn <- names(x)
    nchars <- nchar(xn)
    xn <- xn[order(nchars, decreasing = TRUE)]

    datatype <- omnibus::pmatchSafe(datatype, c("integer", "float", "double", "auto"))
    if (datatype == "integer") datatype = "int"

    for (name in xn) {

        i <- which(name == names(x))
        src <- sources(x)[i]

        # datatype data type  
        dt <- datatype(x, "GRASS")[i]
        if (datatype == "auto") {
            src <- if (dt == "CELL") {
                paste0("int(", src, ")")
            } else if (dt == "FCELL") {
                paste0("float(", src, ")")
            } else if (dt == "DCELL") {
                paste0("double(", src, ")")
            }
        } else {
            if (dt != "FCELL") {
                src <- paste0(datatype, "(", src, ")")
            }
        }

        fun <- gsub(fun, pattern = name, replacement = src)
    }

    src <- .makeSourceName("app", "raster")
    fun <- paste(src, fun)

    args <- list(
        cmd = "r.mapcalc",
        expression = fun,
        flags = c(.quiet(), "overwrite"),
        intern = TRUE
    )
    if (is.null(seed)) {
		args$flags <- c(args$flags, "s")
	} else {
		args$seed <- seed
	}
    do.call(rgrass::execGRASS, args = args)
    .makeGRaster(src, "layer")

    } # EOF
)

#' @aliases appFuns
#' @rdname app
#' @export
appFuns <- function(warn = TRUE) {
	
	appFunsTable <- NULL
    utils::data("appFunsTable", envir = environment(), package = "fasterRaster")

	if (interactive()) {
	
    	showableCols <- c("Type", "GRASS_Function", "R_Function", "Definition", "Returns")

		shiny::shinyApp(
			ui = shiny::fluidPage(DT::DTOutput("tbl")),
			server = function(input, output) {
				output$tbl <- DT::renderDT(
					# appFunsTable[ , showableCols],
					appFunsTable[ , c("Type", "GRASS_Function", "R_Function", "Definition", "Returns")],
					caption = shiny::HTML("Functions that can be used in the <b>fasterRaster</b> app() function and their equivalents in <b>R</b>.<br/>Note that in GRASS, 'null()' is the same as 'NA'."),
					options = list(
						pageLength = nrow(appFunsTable),
						width = "100%",
						scrollX = TRUE
					)
					# options = list(lengthChange = FALSE)
				)
			}
		)
        
    } else if (warn) {
        warning("You must be running R interactively to view the table using appFuns().")
    }

}

#' @aliases appCheck
#' @rdname app
#' @exportMethod appCheck
methods::setMethod(
    f = "appCheck",
    signature = c(x = "GRaster", fun = "character"),
    function(x, fun, msgOnGood = TRUE, failOnBad = TRUE) {

    # any forbidden names in rasters?
    ns <- names(x)
    
	appFunsTable <- NULL
    utils::data("appFunsTable", envir = environment(), package = "fasterRaster")

    if (inherits(appFunsTable, "data.table")) {
        funs <- appFunsTable[["GRASS_Function"]]
    } else {
        funs <- appFunsTable$GRASS_Function
    }

    parens <- regexec(funs, pattern = "\\(")
    parens <- unlist(parens)
    parens <- parens - 1L
    funs <- substr(funs, 1L, parens)
    
    bads <- funs[funs %in% ns]

    if (length(bads) == 0L) {
        if (msgOnGood) {
            cat("Raster name(s) are likely acceptable.\n")
            utils::flush.console()
        }
    } else {

        realBads <- character()
        for (bad in bads) {
            if (grepl(fun, pattern = bad)) realBads <- c(realBads, bad)
        }

        if (length(realBads) > 0L) {
            
            msg <- "At least one raster has a forbidden name that seems to appear in the equation:"
            if (failOnBad) {
                stop(msg, "\n", paste(realBads, collapse = " "))
            } else {
                warning(msg)
                return(realBads)
            }
        } else if (msgOnGood) {
            msg <- "The GRasters have one or more forbidden names, but they do not seem to appear in\n  the equation. Use the equation with caution, or rename your GRasters."
            warning(msg)
        }
    }

    invisible(bads)

    } # EOF
)