R/dm_join_phase_clim.R

In dendRoAnalyst: A Tool for Processing and Analyzing Dendrometer Data

#' @title Join climate summaries to dendrometer phase windows
#'
#' @description
#' Summarizes climate conditions within each phase window of
#' \code{phase.zg()} or \code{phase.sc()} output and appends those summaries to
#' \code{ZG_cycle} or \code{SC_cycle}.
#'
#' The climate input can be:
#' \itemize{
#'   \item the output of \code{read.climate()}
#'   \item a raw climate data frame
#'   \item a valid climate file path readable by \code{read.climate()}
#' }
#'
#' Climate variables are summarized over each phase interval defined by the
#' \code{Start} and \code{End} columns of the phase-cycle table.
#'
#' @param x Object returned by \code{phase.zg()} or \code{phase.sc()}.
#' @param clim_df Climate input. This can be a standardized climate object
#'   returned by \code{read.climate()}, a raw climate data frame, or a valid
#'   climate file path.
#' @param mean_vars Character vector of climate variables to summarize by mean
#'   within each phase window.
#' @param min_vars Character vector of climate variables to summarize by minimum
#'   within each phase window.
#' @param max_vars Character vector of climate variables to summarize by maximum
#'   within each phase window.
#' @param sum_vars Character vector of climate variables to summarize by sum
#'   within each phase window.
#' @param median_vars Character vector of climate variables to summarize by median
#'   within each phase window.
#' @param suffix Character suffix appended to the generated climate summary
#'   columns. Default is \code{"_phase"}.
#'
#' @return
#' The same phase object with climate summaries appended to \code{ZG_cycle} or
#' \code{SC_cycle}. The returned object has class
#' \code{c("ZG_output_clim", "ZG_output", ...)} or
#' \code{c("SC_output_clim", "SC_output", ...)}.
#'
#' @examples
#' \donttest{
#' data(gf_nepa17)
#' data(ktm_clim_hourly)
#'
#' zg <- phase.zg(df = gf_nepa17[1:800, ], TreeNum = 1)
#'
#' zg_clim <- dm_join_phase_clim(
#'   zg,
#'   ktm_clim_hourly,
#'   mean_vars = c("temp", "VPD", "RH"),
#'   max_vars  = c("temp", "VPD"),
#'   sum_vars  = c("prec")
#' )
#'
#' head(zg_clim$ZG_cycle)
#' }
#'
#' @importFrom dplyr bind_cols
#' @importFrom tibble as_tibble
#' @importFrom stats median
#' @export
dm_join_phase_clim <- function(x,
                               clim_df,
                               mean_vars = NULL,
                               min_vars = NULL,
                               max_vars = NULL,
                               sum_vars = NULL,
                               median_vars = NULL,
                               suffix = "_phase") {

  if (!inherits(x, "ZG_output") && !inherits(x, "SC_output")) {
    stop("'x' must be an object returned by phase.zg() or phase.sc().")
  }

  # standardize climate input
  clim <- if (inherits(clim_df, "dm_clim")) {
    tibble::as_tibble(clim_df)
  } else if (is.data.frame(clim_df) || (is.character(clim_df) && length(clim_df) == 1 && file.exists(clim_df))) {
    tibble::as_tibble(read.climate(clim_df, verbose = FALSE))
  } else {
    stop(
      "'clim_df' must be one of: output of read.climate(), ",
      "a raw climate data frame, or a valid climate file path."
    )
  }

  if (!"TIME" %in% names(clim)) {
    stop("Climate input must contain a 'TIME' column after standardization.")
  }

  clim$TIME <- as.POSIXct(clim$TIME)

  numeric_vars <- setdiff(names(clim)[vapply(clim, is.numeric, logical(1))], "TIME")

  if (all(c(
    is.null(mean_vars), is.null(min_vars), is.null(max_vars),
    is.null(sum_vars), is.null(median_vars)
  ))) {
    mean_vars <- numeric_vars
  }

  check_vars <- function(vars, allowed, arg_name) {
    if (is.null(vars)) return(character(0))
    miss <- setdiff(vars, allowed)
    if (length(miss) > 0) {
      stop(sprintf(
        "Unknown or non-numeric variable(s) in %s: %s",
        arg_name, paste(miss, collapse = ", ")
      ))
    }
    vars
  }

  mean_vars   <- check_vars(mean_vars, numeric_vars, "mean_vars")
  min_vars    <- check_vars(min_vars, numeric_vars, "min_vars")
  max_vars    <- check_vars(max_vars, numeric_vars, "max_vars")
  sum_vars    <- check_vars(sum_vars, numeric_vars, "sum_vars")
  median_vars <- check_vars(median_vars, numeric_vars, "median_vars")

  cycle_name <- if (inherits(x, "ZG_output")) "ZG_cycle" else "SC_cycle"
  cyc <- tibble::as_tibble(x[[cycle_name]])

  if (!all(c("Start", "End") %in% names(cyc))) {
    stop(sprintf("'%s' must contain 'Start' and 'End' columns.", cycle_name))
  }

  cyc$Start <- as.POSIXct(cyc$Start)
  cyc$End   <- as.POSIXct(cyc$End)

  safe_agg <- function(z, FUN) {
    if (length(z) == 0 || all(is.na(z))) return(NA_real_)
    FUN(z, na.rm = TRUE)
  }

  summarise_window <- function(start_time, end_time) {
    idx <- clim$TIME >= start_time & clim$TIME <= end_time
    sub <- clim[idx, , drop = FALSE]

    out <- list(n_clim = sum(idx, na.rm = TRUE))

    for (v in mean_vars) {
      out[[paste0(v, "_mean", suffix)]] <- safe_agg(sub[[v]], mean)
    }
    for (v in min_vars) {
      out[[paste0(v, "_min", suffix)]] <- safe_agg(sub[[v]], min)
    }
    for (v in max_vars) {
      out[[paste0(v, "_max", suffix)]] <- safe_agg(sub[[v]], max)
    }
    for (v in sum_vars) {
      out[[paste0(v, "_sum", suffix)]] <- safe_agg(sub[[v]], sum)
    }
    for (v in median_vars) {
      out[[paste0(v, "_median", suffix)]] <- safe_agg(sub[[v]], stats::median)
    }

    tibble::as_tibble(out)
  }

  clim_stats <- dplyr::bind_rows(
    lapply(seq_len(nrow(cyc)), function(i) {
      summarise_window(cyc$Start[i], cyc$End[i])
    })
  )

  out <- x
  out[[cycle_name]] <- dplyr::bind_cols(cyc, clim_stats)

  if (inherits(x, "ZG_output")) {
    class(out) <- unique(c("ZG_output_clim", class(x)))
  } else {
    class(out) <- unique(c("SC_output_clim", class(x)))
  }

  out
}