R/Status_Trackers.R

In DrylandEcology/rSFSW2: Simulation Framework for SOILWAT2

#' Initialize a new input status tracker object
#' @return A data.frame
init_intracker <- function() {
  temp <- c("load_inputs", "calc_size", "spatial_setup", "prj_todos",
    "rng_setup", "dbW_paths", "dbW_sources", "dbW_current", "dbW_scenarios",
    "soil_data", "elev_data", "climnorm_data", "req_soillayers", "calc_bsevap",
    "table_lookup", "dbOut", "dbWork")

  # NA, don't prepare/check
  # TRUE, has been prepared/checked successfully
  # FALSE, needs yet to be prepared/checked
  as.data.frame(matrix(FALSE, nrow = length(temp), ncol = 4,
    dimnames = list(temp, c("prepared", "prep_time", "checked", "check_time"))))
}

#' Check whether input tracker design is up-to-date
#'
#' @inheritParams update_intracker
#' @return A logical value.
check_intracker_design <- function(ist) {
  temp <- init_intracker()

  identical(dimnames(ist), dimnames(temp))
}


#' Query whether an input tracker is not yet completed
#'
#' @param tracker A character string. One of the rownames of
#'   \code{SFSW2_prj_meta[["input_status"]]} as returned by function
#'   \code{\link{init_intracker}}.
#' @param status A character string. One of \code{"prepared"} and
#'   \code{"checked"}.
#' @return A logical value. \code{TRUE} if \code{tracker} and \code{status}
#'   exist in \code{SFSW2_prj_meta[["input_status"]]} and their cell is
#'   \code{FALSE} -- otherwise, \code{FALSE}
todo_intracker <- function(SFSW2_prj_meta, tracker, status) {
  x <- SFSW2_prj_meta[["input_status"]][tracker, status]

  # x is NA for non-existing rowname; x is NULL for non-existing colname
  !is.null(x) && !is.na(x) && identical(x, FALSE)
}


#' Query whether an input tracker is completed
#'
#' @inheritParams todo_intracker
#' @return A logical value. \code{FALSE} if \code{tracker} and \code{status}
#'   exist in \code{SFSW2_prj_meta[["input_status"]]} and their cell is
#'   \code{TRUE} -- otherwise, \code{TRUE}.
isdone_intracker <- function(SFSW2_prj_meta, tracker, status) {
  x <- SFSW2_prj_meta[["input_status"]][tracker, status]

  # x is NA for non-existing rowname; x is NULL for non-existing colname
  !is.null(x) && !is.na(x) && identical(x, TRUE)
}

#' Update input tracker status
#'
#' @param ist A data.frame representing an input tracker as generated by
#'   function \code{init_intracker}.
#' @param tracker A character string. One of the rownames of \code{ist}.
#' @param prepared A logical value or \code{NULL}. If not \code{NULL}, then the
#'   requested tracker will be updated with this value and its time stamp set.
#' @param checked A logical value or \code{NULL}. If not \code{NULL}, then the
#'   requested tracker will be updated with this value and its time stamp set.
#' @param clean_subsequent A logical value. If \code{TRUE} then trackers in rows
#'   greater than \code{tracker} will be reset to \code{FALSE}.
#'
#' @return The updated data.frame \code{ist}.
#'
#' @examples
#'  # Create a new tracker object: if using 'demo' code to run a project,
#'  # then the object 'SFSW2_prj_meta' will contain a tracker object with
#'  # name 'input_status'
#'  SFSW2_prj_meta <- list(input_status = rSFSW2:::init_intracker())
#'
#'  # Update the 'soil_data' trackers to indicate that data extraction has
#'  # already been carried out (e.g., soil data were entered separately)
#'  SFSW2_prj_meta[['input_status']] <- update_intracker(
#'    SFSW2_prj_meta[['input_status']], tracker = "soil_data", prepared = TRUE)
#'
#'  # Reset the 'dbW_scenarios' trackers to so that both data
#'  # population/extraction and checking steps are carried out again during
#'  # the next run
#'  SFSW2_prj_meta[['input_status']] <- update_intracker(
#'    SFSW2_prj_meta[['input_status']], tracker = "dbW_scenarios",
#'    prepared = FALSE, checked = FALSE)
#'
#'  # Save updated metadata with tracker object to project directory to prepare
#'  # for next run
#'  SFSW2_prj_meta[["fnames_in"]] <- list(fmeta = tempfile())
#'  saveRDS(SFSW2_prj_meta, file = SFSW2_prj_meta[["fnames_in"]][["fmeta"]])
#'
#'  #Clean up from example
#'  unlink(SFSW2_prj_meta[["fnames_in"]][["fmeta"]])
#'
#' @export
update_intracker <- function(ist, tracker, prepared = NULL, checked = NULL,
  clean_subsequent = FALSE) {

  irow <- which(tracker == dimnames(ist)[[1]])
  if (length(irow) != 1)
    stop("'update_intracker': 'tracker' does not exist (uniquely).")

  # Upate status of requested tracker
  if (!is.null(prepared)) {
    ist[irow, "prepared"] <- prepared
    ist[irow, "prep_time"] <- Sys.time()
  }
  if (!is.null(checked)) {
    ist[irow, "checked"] <- checked
    ist[irow, "check_time"] <- Sys.time()
  }

  # Set subsequent trackers to FALSE
  if (clean_subsequent && irow < dim(ist)[1])
    ist[(irow + 1):dim(ist)[1], ] <- FALSE

  ist
}