R/input_data.R

In tsahota/NMproject: Script Based 'NONMEM' Model Development

#' Read input dataset of an nm object
#'
#' @description
#'
#' `r lifecycle::badge("stable")`
#'
#' Uses `data_path` field of object to locate data and read in.
#'
#' @param m An nm object.
#' @param filter Logical (default = `FALSE`). Applies NONMEM ignore statement to
#'   filter dataset.
#' @param na Character. Passed to [utils::read.csv()]
#' @param ... Additional arguments passed to either [read_derived_data()] (if
#'   [write_derived_data()] was used to create derived dataset) or
#'   [utils::read.csv()]
#'
#' @examples
#'
#' # create example object m1 from package demo files
#' exdir <- system.file("extdata", "examples", "theopp", package = "NMproject")
#' m1 <- new_nm(run_id = "m1", 
#'              based_on = file.path(exdir, "Models", "ADVAN2.mod"),
#'              data_path = file.path(exdir, "SourceData", "THEOPP.csv"))
#'
#'
#' d <- input_data(m1)
#' head(d)
#' 
#' ## only non-ignored rows
#' d_nonignore <- input_data(m1, filter = TRUE)
#'
#' @export
input_data <- function(m, filter = FALSE, na = ".", ...) {
  UseMethod("input_data")
}
#' @export
input_data.nm_generic <- function(m, filter = FALSE, na = ".", ...) {
  file_name <- data_path(m)
  if (is.na(file_name)) {
    return(dplyr::tibble())
  }

  if (normalizePath(dirname(file_name), mustWork = FALSE) == normalizePath("DerivedData", mustWork = FALSE)) {
    d <- read_derived_data(basename(tools::file_path_sans_ext(file_name)), ...)
  } else {
    d <- utils::read.csv(file_name, na = na, ...)
  }

  if (filter) {
    data_filter <- parse(text = data_filter_char(m, data = d))
    d <- subset(d, eval(data_filter))
  }
  d
}
#' @export
input_data.nm_list <- function(m, filter = FALSE, na = ".", ...) {
  data_paths <- data_path(m)
  if (length(unique(data_paths)) != 1) stop("multiple data files detected. Aborting...")
  m <- as_nm_generic(m[[1]])
  d <- input_data(m, filter = filter, na = na, ...)
  d
}

#' Get/set ignore statement from control file contents
#'
#' @description
#'
#' `r lifecycle::badge("stable")`
#'
#' @param ctl An nm object.
#' @param ignore_char Optional character. Ignore statement to set in $DATA.
#'
#' @return If `ignore_char` is specified returns an nm object with modified
#'   `ctl_contents` field.  If no IGNORE present, returns `FALSE`. Otherwise
#'   returns the value of the IGNORE statement in $DATA.
#' 
#' @seealso [data_ignore_char()], [data_filter_char()]
#'   
#' @examples
#'
#' # create example object m1 from package demo files
#' exdir <- system.file("extdata", "examples", "theopp", package = "NMproject")
#' m1 <- new_nm(run_id = "m1", 
#'              based_on = file.path(exdir, "Models", "ADVAN2.mod"),
#'              data_path = file.path(exdir, "SourceData", "THEOPP.csv")) %>%
#'   fill_input()
#'
#'
#' ignore(m1) ## display ignore statement, currently none
#' m1 %>% dollar("DATA")
#' 
#' m1 <- m1 %>% ignore("ID > 10") ## changes ignore to ignore IDs > 10.
#'
#' m1 %>% dollar("DATA")
#' 
#' @export
ignore <- function(ctl, ignore_char) {
  UseMethod("ignore")
}
#' @export
ignore.nm_generic <- function(ctl, ignore_char) {
  m <- ctl
  if (missing(ignore_char)) {
    return(data_ignore_char(m))
  }
  ctl <- ctl_contents(m)
  ctl <- update_ignore(ctl, ignore_char)
  m <- m %>% ctl_contents_simple(ctl)
  m
}
#' @export
ignore.nm_list <- Vectorize_nm_list(ignore.nm_generic, replace_arg = "ignore_char")

update_ignore <- function(ctl, ignore_char) {
  ctl <- ctl_list(ctl)

  ignore_present <- any(grepl(".*IGNORE\\s*=\\s*\\(", ctl$DATA))
  if (ignore_present) {
    ## remove any row that matches exactly
    ctl$DATA <- ctl$DATA[!grepl("^(\\s*)IGNORE\\s*=\\s*\\(*\\S[^\\)]+\\)*(\\s*)$", ctl$DATA)]
    ## remove only bracketed IGNORE statement if other things are on the line.
    ctl$DATA <- gsub(
      "(.*)IGNORE\\s*=\\s*\\(+\\S[^\\)]+\\)+(.*)",
      "\\1\\2", ctl$DATA
    )
  }

  ignore_char <- gsub("\\s*\\|\\s*", ", ", ignore_char)

  ignore_char <- gsub("==", ".EQ.", ignore_char)
  ignore_char <- gsub("!=", ".NE.", ignore_char)
  ignore_char <- gsub(">", ".GT.", ignore_char)
  ignore_char <- gsub("<", ".LT.", ignore_char)
  ignore_char <- gsub(">=", ".GE.", ignore_char)
  ignore_char <- gsub("<=", ".LE.", ignore_char)
  ignore_char <- gsub("\\s+(\\.\\S+\\.)\\s+", "\\1", ignore_char)

  ignore_char <- paste0("IGNORE=(", ignore_char, ")")

  last_line <- ctl$DATA[length(ctl$DATA)]

  if (grepl("^\\s*$", last_line)) {
    ctl$DATA[length(ctl$DATA)] <- ignore_char
  } else {
    ctl$DATA <- append(ctl$DATA, ignore_char)
  }
  ctl$DATA <- append(ctl$DATA, "")
  ctl
}