R/util_eval.R

In nlrx: Setup, Run and Analyze 'NetLogo' Model Simulations from 'R' via 'XML'

#' Evaluate if variables list of an experiment object is empty
#'
#' @description Evaluate if variables list of an experiment object is empty
#' @param nl nl object
#' @details
#' util_eval_variables checks if the variables list of an experiment within a nl object is empty.
#' It reports an error message if no variables were defined.
#' @aliases util_eval_variables
#' @rdname util_eval_variables
#' @keywords internal
util_eval_variables <- function(nl) {

  # Check if there are any variables defined
  if (length(getexp(nl, "variables")) == 0) {
    stop("Error: Experiment Variable list is empty.
         You need to define a variable list with at least one element!",
      call. = FALSE
    )
  }
}



#' Evaluate variables list of an experiment object for distinct simdesign
#'
#' @description Evaluate variables list of an experiment object for distinct simdesign
#' @param nl nl object
#' @details
#' util_eval_variables_distinct checks if the variables list of an experiment within a nl object has enough information to create a \link[nlrx]{simdesign_distinct}.
#' It reports an error message if at least one variable does not have a vector of distinct values or if there is a mismatch in length of these values vectors.
#' @aliases util_eval_variables_distinct
#' @rdname util_eval_variables_distinct
#' @keywords internal
util_eval_variables_distinct <- function(nl) {

  vars <- getexp(nl, "variables")
  vars.values.missing <- lapply(vars, function(x) is.null(x$values))
  vars.length.mismatch <- var(unlist(lapply(
    vars,
    function(x) length(x$values)
  ))) != 0

  vars.missing <- data.frame(cbind(
    values.missing = unlist(vars.values.missing),
    length = unlist(vars.length.mismatch)
  ))


  vars.missing$variable <- rownames(vars.missing)
  values.missing <- vars.missing %>% dplyr::filter(values.missing == TRUE)

  # Check if there are missing values
  if (nrow(values.missing) > 0) {
    stop(paste0(
      "Error: Variable definition incomplete for variables: ",
      values.missing$variable, ".
          To setup a distinct simulation design you need to provide for each
          variable a vector of distinct values (e.g. list(values=c(1,2,3,4)))."
    ), call. = FALSE)
  }

  length.mismatch <- vars.missing %>% dplyr::filter(length == TRUE)

  # Check if there are any variables defined
  if (nrow(length.mismatch) > 0) {
    stop(paste0("Error: Mismatch in vector length of variable values.
          The length of provided values vectors of experiment variables is not
                equal across all variables."), call. = FALSE)
  }
}






#' Evaluate variables list of an experiment object for full-factorial simdesign
#'
#' @description Evaluate variables list of an experiment object for full-factorial simdesign
#' @param nl nl object
#' @details
#' util_eval_variables_ff checks if the variables list of an experiment within a nl object has enough information to create a \link[nlrx]{simdesign_ff}.
#' It reports an error message if at least one variable does not have a defined sequence (min, max, step) or a vector of distinct values.
#' @aliases util_eval_variables_ff
#' @rdname util_eval_variables_ff
#' @keywords internal
util_eval_variables_ff <- function(nl) {

  # The function checks if there is enough variable information to create a ff
  # simdesign
  # The ff design needs either a set of min, max and step or distinct values

  vars <- getexp(nl, "variables")
  vars.values.missing <- lapply(vars, function(x) is.null(x$values))
  vars.dist.missing <- lapply(vars, function(x) is.null(x$min) |
                                is.null(x$max) | is.null(x$step))
  vars.missing <- data.frame(cbind(values.missing = unlist(vars.values.missing),
                                   dist.missing = unlist(vars.dist.missing)))
  vars.missing$variable <- rownames(vars.missing)
  vars.missing <- vars.missing %>% dplyr::filter(values.missing == TRUE &
                                                   dist.missing == TRUE)

  # Check if there are any variables defined
  if (nrow(vars.missing) > 0) {
    stop(paste0("Error: Variable definition incomplete for variables: ",
    vars.missing$variable, ". To setup a full factorial simulation design you
    need to provide for each variable either a vector of distinct values
    (e.g. list(values=c(1,2,3,4))) or a sequence with min, max and step
    (e.g. list(min=1, max=4, step=1))."), call. = FALSE)
  }
}


#' Evaluate variables list of an experiment object for sensitivity analysis simdesigns
#'
#' @description Evaluate variables list of an experiment object for sensitivity analysis simdesigns
#' @param nl nl object
#' @details
#' util_eval_variables_sa checks if the variables list of an experiment within a nl object has enough information to create a sensitivity analysis simdesign.
#' It reports an error message if at least one variable does not have a defined distribution (min, max, qfun).
#' @aliases util_eval_variables_sa
#' @rdname util_eval_variables_sa
#' @keywords internal
util_eval_variables_sa <- function(nl) {

  # The function checks if there is enough variable information to create a
  # sensitivity analysis simdesign
  # The sa designs need a set of min, max and qfun

  vars <- getexp(nl, "variables")
  vars.dist.missing <- lapply(vars, function(x) is.null(x$min) |
      is.null(x$max) |
      is.null(x$qfun))
  vars.missing <- data.frame(dist.missing = unlist(vars.dist.missing))
  vars.missing$variable <- rownames(vars.missing)
  vars.missing <- vars.missing %>% dplyr::filter(dist.missing == TRUE)

  # Check if there are any variables defined
  if (nrow(vars.missing) > 0) {
    stop(paste0(
      "Error: Variable definition incomplete for variables: ",
      vars.missing$variable, ". To setup a sensitivity analysis simulation
      design you need to provide for each variable a distribution with min, max
      and qfun (e.g. list(min=1, max=4, qfun=\"qunif\"))."
    ), call. = FALSE)
  }
}



#' Evaluate variables list of an experiment object for optimization simdesigns
#'
#' @description Evaluate variables list of an experiment object for optimization simdesigns
#' @param nl nl object
#' @details
#' util_eval_variables_op checks if the variables list of an experiment within a nl object has enough information to create an optimization simdesign.
#' It reports an error message if at least one variable does not have a defined range (min, max).
#' @aliases util_eval_variables_op
#' @rdname util_eval_variables_op
#' @keywords internal
util_eval_variables_op <- function(nl) {

  # The function checks if there is enough variable information to create an
  # optimization simdesign
  # The optimization designs need a set of min and max

  vars <- getexp(nl, "variables")
  vars.dist.missing <- lapply(vars, function(x) is.null(x$min) | is.null(x$max))
  vars.missing <- data.frame(dist.missing = unlist(vars.dist.missing))
  vars.missing$variable <- rownames(vars.missing)
  vars.missing <- vars.missing %>% dplyr::filter(dist.missing == TRUE)

  # Check if there are any variables defined
  if (nrow(vars.missing) > 0) {
    stop(paste0(
      "Error: Variable definition incomplete for variables: ",
      vars.missing$variable, ". To setup an optimization simulation design you
    need to provide for each variable a distribution with min and max
    (e.g. list(min=1, max=4))."
    ), call. = FALSE)
  }
}




#' Evaluate if constants list of an experiment object is empty
#'
#' @description Evaluate if constants list of an experiment object is empty
#' @param nl nl object
#' util_eval_constants checks if the constants list of an experiment within a nl object is empty.
#' It reports an error message if no constants were defined. This evaluation is only done for \link[nlrx]{simdesign_simple}.
#' @aliases util_eval_constants
#' @rdname util_eval_constants
#' @keywords internal
util_eval_constants <- function(nl) {
  if (length(getexp(nl, "constants")) == 0) {
    stop("Error: Experiment constants list is empty.
         You need to define a constants list with at least one element!
         If your model does not have any globals, please create a dummy global, either on the GUI or in the model code (globals[])
         and add the dummy global to the constants list with an appropriate dummy value!",
      call. = FALSE
    )
  }
}

#' Evaluate all slots of an experiment object
#'
#' @description Evaluate all slots of an experiment object
#' @param nl nl object
#' @details
#' util_eval_experiment checks if the information stored within the experiment slots are valid.
#' @aliases util_eval_experiment
#' @rdname util_eval_experiment
#' @keywords internal
util_eval_experiment <- function(nl) {
  notvalid <- c()

  if (is.na(getexp(nl, "expname"))) {
    notvalid <- c(notvalid, "expname")
  }
  if (!getexp(nl, "tickmetrics") %in% c("true", "false")) {
    notvalid <- c(notvalid, "tickmetrics must be either \"true\" or \"false\"")
  }
  if (is.na(getexp(nl, "outpath"))) {
    notvalid <- c(notvalid, "outpath")
  }
  if (anyNA(getexp(nl, "metrics"))) {
    notvalid <- c(notvalid, "metrics")
  }

  if (length(notvalid) > 0) {
    stop(paste0("To add a simdesign to a nl object you need to define a proper experiment first. The following elements are missing without default:\n",
                paste(notvalid, collapse = "\n")), call. = FALSE)
  }

  # Check if experiment name contains white spaces:
  if (grepl("\\s", getexp(nl, "expname"))) {
    stop(paste0("Experiment names are not allowed to contain whitespaces!"))
  }

  # Check if a NetLogo parameter has been defined in variables AND constants:
  if (any(names(getexp(nl, "variables")) %in% names(getexp(nl, "constants")))) {
    stop(paste0(
      "Same netlogo parameter present in variables AND constants:\n",
      paste(names(getexp(nl, "variables"))[names(getexp(nl, "variables")) %in%
                                             names(getexp(nl, "constants"))],
            collapse = "\n")), call. = FALSE)
  }
}

#' Evaluate all slots of a simdesign object
#'
#' @description Evaluate all slots of a simdesign object
#' @param nl nl object
#' @details
#' util_eval_simdesign checks if the information stored within the simdesign slots are valid.
#' @aliases util_eval_simdesign
#' @rdname util_eval_simdesign
#' @keywords internal
util_eval_simdesign <- function(nl) {
  notvalid <- c()

  if (is.na(getsim(nl, "simmethod"))) {
    notvalid <- c(notvalid, "simmethod")
  }
  if (purrr::is_empty(getsim(nl, "siminput"))) {
    notvalid <- c(notvalid, "siminput")
  }
  if (anyNA(getsim(nl, "simseeds"))) {
    notvalid <- c(notvalid, "simseeds")
  }

  if (length(notvalid) > 0) {
    stop(paste0("Error: To run a simulation you have to add a simdesign to a nl object with a properly defined experiment.
    Please first initialize a nl object, then add a proper experiment, and finally add a simdesign by using one of the provided simdesign functions.
    The following elements are missing without default:\n",
                paste(notvalid, collapse = "\n")), call. = FALSE)
  }
}


.util_check_siminput_tibble <- function(nl, new_simdesign) {

  ## Check if there are any NAs in the variables columns:

  if (isTRUE(anyNA(new_simdesign@siminput[names(nl@experiment@variables)]))) {
    warning("The generated siminput tibble of the simdesign contains NA values.
            You may need to increase the number of samples!",
            call. = FALSE)
  }


}