#' 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
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.