R/HW_cluster.R

In CUG-hydro/heatwave: What the Package Does (One Line, Title Case)

#' @name HW_cluster
#' @title Heatwave SpatioTemporal cluster
#'
#' @param arr 3d boolean array
#' @inheritParams SpatioTemporalCluster::cluster_SpatioTemporal_julia
#' @param ncell_connect the default is 1deg*1deg
#'
#' @keywords internal
#' @importFrom lubridate leap_year
#' @importFrom SpatioTemporalCluster cluster_SpatioTemporal_julia
HW_cluster <- function(arr, dates, ncell_connect = 16, .parallel = FALSE, TRS = NULL, ...) {
    years <- year(dates)
    year_grps <- unique(years) %>% set_names(., .)
    ndim = dim(TRS) %>% length()

    lst = plyr::llply(year_grps, function(year) {
        runningId(year)
        ind <- which(years == year)
        
        if (is.null(TRS)) {
            arr_year = arr[, , ind] # boolean
        } else {
            if (ndim == 3) {
                ind_doy = 1:366
                if (!leap_year(year)) ind_doy %<>% .[-60]
                # as.Date(sprintf("2020-%03d", 1:366), "%Y-%j")[60], 02-29
                arr_year = default_false(arr[, , ind] %>=% TRS[, , ind_doy])
            } else {
                arr_year = default_false(arr[, , ind] %>=% TRS)
            }
        }
        r <- HW_cluster_byYear(arr_year, ncell_connect, ...)
    }, .parallel = .parallel)
    abind::abind(lst, along = 3)
}

#' @rdname HW_cluster
#' @export
HW_cluster_byYear <- function(arr,
    ncell_connect = 1L,
    ncell_overlap = ncell_connect,
    factor = 10000, diag = FALSE, ...)
{
    cluster_SpatioTemporal_julia(arr, method = 'tree',
                                 ncell_connect, ncell_overlap, factor, diag, ...)
}