R/simulate_preprocess.R

In campsis: Generic PK/PD Simulation Platform Campsis

#' Pre-process destination engine. Throw an error message if the destination
#' engine is not installed.
#'
#' @param dest destination engine (from simulate argument, default settings or S4 simulation engine)
#' @return 'rxode2' or 'mrgsolve'
#' @keywords internal
#'
preprocess_dest <- function(dest) {
  if (isS4(dest)) {
    # Do nothing, dest can also be the simulation engine in its S4 form
  } else {
    if (is.null(dest) || is.na(dest)) {
      if (find.package("mrgsolve", quiet = TRUE) %>% length() > 0) {
        dest <- "mrgsolve" # First choice
      } else if (find.package("rxode2", quiet = TRUE) %>% length() > 0) {
        dest <- "rxode2" # Second choice
      } else {
        stop("Simulation engine 'rxode2' or 'mrgsolve' is required to run Campsis")
      }
    } else {
      if (!(dest %in% c("rxode2", "mrgsolve"))) {
        stop("Argument 'dest' must be one of: 'rxode2', 'mrgsolve' or NULL")
      }
      if (find.package(dest, quiet = TRUE) %>% length() == 0) {
        stop(paste0("Simulation engine '", dest, "' is not installed"))
      }
    }
  }
  return(dest)
}

#' Pre-process events.
#'
#' @param events interruption events
#' @keywords internal
#'
preprocess_events <- function(events) {
  if (is.null(events)) {
    return(Events())
  } else {
    return(events)
  }
}

#' Pre-process scenarios.
#'
#' @param scenarios scenarios
#' @keywords internal
#'
preprocess_scenarios <- function(scenarios) {
  if (is.null(scenarios)) {
    return(Scenarios())
  } else {
    return(scenarios)
  }
}

#' Pre-process tablefun argument.
#'
#' @param fun function or lambda formula
#' @return a function in any case
#' @importFrom assertthat assert_that
#' @importFrom rlang as_function is_formula
#' @keywords internal
#'
preprocess_tablefun <- function(fun) {
  if (is.null(fun)) {
    fun <- function(x) {
      x
    }
    return(fun)
  } else {
    assertthat::assert_that(
      is.function(fun) || rlang::is_formula(fun),
      msg = paste0("tablefun must be a function or a purrr-style lambda formula")
    )
    if (rlang::is_formula(fun)) {
      fun <- rlang::as_function(fun)
      class(fun) <- "function" # Cast needed to work with S4 class system
    }
    return(fun)
  }
}

#' Pre-process outfun argument.
#'
#' @param outfun function, lambda formula, 'outfun' or 'outfuns' object
#' @return an 'outfuns' object in any case
#' @importFrom assertthat assert_that
#' @keywords internal
#'
preprocess_outfun <- function(outfun) {
  fun <- NULL
  if (is.null(outfun)) {
    fun <- DefaultOutfun()
  } else if (is.function(outfun) || rlang::is_formula(outfun)) {
    fun <- Outfun(fun = outfun)
  } else if (is(outfun, "outfun")) {
    fun <- outfun
  } else if (is(outfun, "outfuns")) {
    if (length(outfun) == 0) {
      outfun <- outfun %>% add(DefaultOutfun())
    }
    return(outfun)
  } else {
    stop("outfun must be a function, formula, Outfun() or Outfuns() object.")
  }
  return(Outfuns() %>% add(fun))
}

#' Preprocess 'outvars' argument. 'Outvars' is a character vector which tells
#' Campsis the mandatory columns to keep in the output dataframe.
#'
#' @param outvars character vector or function
#' @return outvars
#' @importFrom assertthat assert_that
#' @keywords internal
#'
preprocess_outvars <- function(outvars) {
  if (is.null(outvars)) {
    return(character(0))
  } else {
    assertthat::assert_that(
      is.character(outvars),
      msg = "outvars must be a character vector with the column names to keep"
    )

    # In any cases, we should never see these special variables
    outvars <- outvars[!(toupper(outvars) %in% c("ID", "EVID", "CMT", "AMT", "TIME", "ARM"))]
    return(outvars)
  }
}

#' Preprocess 'replicates' argument.
#'
#' @param replicates number of replicates
#' @param model Campsis model (class 'campsis_model' or 'replicated_campsis_model')
#' @return number of replicates to simulate
#' @importFrom assertthat assert_that
#' @keywords internal
#'
preprocess_replicates <- function(replicates, model) {
  assertthat::assert_that(
    is.numeric(replicates) && replicates %% 1 == 0 && replicates > 0,
    msg = "replicates not a positive integer"
  )
  replicates <- as.integer(replicates)

  if (is(model, "replicated_campsis_model")) {
    rows <- nrow(model@replicated_parameters)
    if (replicates == 1) {
      replicates <- rows # This way, the user does not have to specify 'replicates'.
    } else {
      # If he did, we check the consistency
      if (replicates != rows) {
        stop("Number of replicates must be equal to the number of sampled parameter rows in the replicated model")
      }
    }
  }
  return(replicates)
}

#' Preprocess the simulation settings.
#'
#' @param settings simulation settings
#' @param dest destination engine
#' @return updated simulation settings
#' @importFrom assertthat assert_that
#' @keywords internal
#'
preprocess_settings <- function(settings, dest) {
  # Check if NOCB is specified
  enable <- settings@nocb@enable
  if (is.na(enable)) {
    if (dest == "mrgsolve") {
      enable <- TRUE
    } else {
      enable <- FALSE
    }
  }
  # Assign final value
  settings@nocb@enable <- enable

  # Preprocess slice_size
  if (is.na(settings@hardware@slice_size)) {
    if (dest == "mrgsolve") {
      settings@hardware@slice_size <- as.integer(500)
    } else {
      # There seems to be an issue in rxode2 when dealing with large datasets
      # From what I notice, a too large slice size (e.g. > 25) slows down rxode2
      # while mrgsolve can work with a large slice size without any problem...
      settings@hardware@slice_size <- as.integer(6)
    }
  }

  return(settings)
}

#' Preprocess 'dosing' argument.
#'
#' @param dosing dosing argument, logical value
#' @return user value, if not specified, return FALSE (observations only)
#' @importFrom assertthat assert_that
#' @keywords internal
#'
preprocess_dosing <- function(dosing) {
  if (is.null(dosing)) {
    dosing <- FALSE
  }
  assertthat::assert_that(
    is.logical(dosing) && dosing %>% length() == 1 && !is.na(dosing),
    msg = "dosing not a logical value TRUE/FALSE"
  )
  return(dosing)
}

#' Preprocess subjects ID's.
#'
#' @param dataset current dataset, data frame form
#' @return list of consecutive ID's
#' @importFrom assertthat assert_that
#' @keywords internal
#'
preprocess_ids <- function(dataset) {
  ids <- unique(dataset$ID)
  maxID <- max(ids)
  assertthat::assert_that(all(ids == seq_len(maxID)), msg = "ID's must be consecutive numbers, starting at 1")
  return(ids)
}

#' Preprocess ARM column. Add ARM equation in model automatically.
#'
#' @param dataset current dataset, data frame form
#' @param model model
#' @return updated model
#' @importFrom assertthat assert_that
#' @keywords internal
#'
preprocess_arm_column <- function(dataset, model) {
  if ("ARM" %in% colnames(dataset)) {
    pkRecord <- model@model %>% get_by_name("MAIN")
    pkRecord <- pkRecord %>% add(Equation("ARM", "ARM"))
    model@model <- model@model %>% replace(pkRecord)
  }
  if ("EVENT_RELATED" %in% colnames(dataset)) {
    pkRecord <- model@model %>% get_by_name("MAIN")
    pkRecord <- pkRecord %>% add(Equation("EVENT_RELATED", "EVENT_RELATED"))
    model@model <- model@model %>% replace(pkRecord)
  }
  return(model)
}

#' Preprocess 'slices' argument.
#'
#' @param slices slices argument corresponding to the number of subjects simulated at once
#' @return slices if not NULL, otherwise total number of subjects
#' @importFrom assertthat assert_that
#' @keywords internal
#'
preprocess_slices <- function(slices, maxID) {
  if (is.null(slices)) {
    return(maxID)
  } else {
    assertthat::assert_that(is.numeric(slices) && slices %% 1 == 0 && slices > 0, msg = "slices not a positive integer")
    return(slices)
  }
}

#' Return the 'DROP_OTHERS' string that may be used in the 'outvars' vector for
#' RxODE/mrgsolve to drop all others variables that are usually output in the resulting data frame.
#'
#' @return a character value
#' @keywords internal
#'
drop_others <- function() {
  return("DROP_OTHERS")
}

#' Process 'DROP_OTHERS'.
#'
#' @param x the current data frame
#' @param outvars variables to keep
#' @param drop_others logical value
#' @return processed data frame
#' @keywords internal
#'
process_drop_others <- function(x, outvars = character(0), drop_others) {
  if (!drop_others) {
    return(x)
  }
  outvars_ <- outvars[!(outvars %in% drop_others())]
  out <- c("ID", "TIME", "ARM", "EVENT_RELATED", outvars_)
  names <- colnames(x)
  return(x[, names[names %in% out]])
}