R/slope_rast.R

In rtrend: Trend Estimating Tools

#' slope_arr
#'
#' @return t, A 3d array, with the dim of `[nx, ny, 2]`.
#' - `t[,,1]`: slope
#' - `t[,,2]`: pvalue
#' @keywords internal
#' @export
slope_arr <- function(arr, fun = rtrend::slope_mk, return.list = FALSE, .progress = "text", ...) {
  I_grid <- apply_3d(arr) %>% which.notna()
  mat <- array_3dTo2d(arr, I_grid)

  res <- apply_par(mat, 1, fun, .progress = .progress)
  ans <- array_2dTo3d(res, I_grid, dim(arr)[1:2]) # trend

  if (return.list) {
    list(slope = ans[, , 1], pvalue = ans[, , 2])
  } else {
    ans
  }
}

#' calculate slope of rast object
#'
#' @inheritParams plyr::llply
#'
#' @param r A yearly rast object, which should have time attribute
#' @param period `c(year_begin, year_end)`
#' @param outfile The path of outputed tiff file. If specified, `slope` and
#' `pvalue` will be written into `outfile`.
#' @param overwrite logical. If `TRUE`, `outfile` is overwritten.
#' @param fun the function used to calculate slope, see [slope()] for details.
#' @param ... other parameters ignored
#'
#' @return A terra rast object, with bands of `slope` and `pvalue`.
#'
#' @example R/examples/ex-slope_rast.R
#'
#' @seealso [terra::rast()]
#' @importFrom terra as.array plot rast ext time writeRaster `values<-`
#' @export
slope_rast <- function(r, period = c(2001, 2020), outfile = NULL,
                       fun = rtrend::slope_mk,
                       ...,
                       overwrite = FALSE,
                       .progress = "text") {
  if (is.character(r)) r <- rast(r, ...)
  if (!is.null(period)) {
    r %<>% rast_filter_time(period)
    # `r` should have time information
  }
  arr <- as.array(r) # 3d array
  t <- slope_arr(arr, fun = fun, return.list = FALSE, .progress = .progress) # 3d array

  r_target <- rast(r, nlyrs = 2) %>%
    set_names(c("slope", "pvalue"))
  values(r_target) <- t # !note that `t` should be a 3d array
  # `vals`, and `values`, result is different
  if (!is.null(outfile)) {
    if (!file.exists(outfile) || overwrite) {
      # if (file.exists(outfile)) file.remove(outfile)
      writeRaster(r_target, outfile, overwrite = TRUE)
    }
  }
  r_target
}

#' @importFrom lubridate year
#' @rdname slope_rast
#' @export
rast_filter_time <- function(r, period = c(2001, 2020)) {
  year <- year(time(r))
  ind <- which(year >= period[1] & year <= period[2])
  r[[ind]]
}

# slope_nc <- function(file, varname = 0) {
#     period = c("2001-01-01", "2020-12-31")
#     arr <- ncread(file, varname, DatePeriod = period)$data[[1]]
#     info = ncdim_get(file)

#     t = slope_arr(arr)
#     r = get_grid.lonlat(info$lon, info$lat)
#     r@data = t %>% list2df()
#     r
# }

# list2df <- function(x) {
#     lapply(x, as.numeric) %>% as.data.frame()
# }