R/create_xpose_data.R

In Certara.DarwinReporter: Data Visualization Utilities for 'pyDarwin' Machine Learning Pharmacometric Model Development

#' Imports files from key model output folders
#'
#' Use to create xpose data object from files in NLME or NONMEM key model output folders.
#'
#' @param darwin_data Object of class \code{darwin_data}.
#' @param dir File path to key models directory.
#' @param ... Additional args.
#'
#' @examples
#' if (interactive()) {
#' ddb <- darwin_data(project_dir = "./darwin_search_09") |>
#'    import_key_models(dir = "./darwin_search_09/key_models")
#' }
#'
#' @return Object of class \code{darwin_data}.
#' @export
#'
import_key_models <-
  function(darwin_data, dir, ...) {

    args <- list(...)
    # imported during darwin_data()
    if (is.null(darwin_data)) {
      update_dd <- FALSE
    } else {
      stopifnot(inherits(darwin_data, "darwin_data"))
      update_dd <- TRUE
    }
    stopifnot(dir.exists(dir))

    if(!is.null(args$software)) {
      software <- args$software
    } else {
      software <- darwin_data$software
    }

    run_dirs <- setdiff(list.dirs(dir, recursive = FALSE),
                        dir)

    if (software == "nlme") {
    xpdb_key_models <- lapply(run_dirs, function(x) {
      Certara.Xpose.NLME::xposeNlme(dir = x, modelName = basename(x))
    })
    file_ext <- ".mmdl"
    } else {
    file_lst <- sapply(run_dirs, function(x) {
      file_name <- basename(x)
      file_path <- paste0(file_name, ".lst")
    })
    file_ext <- ".mod"
    file_path_lst <- file.path(names(file_lst), file_lst)

    xpdb_key_models <- lapply(file_path_lst, function(x) {
      xpose::xpose_data(file = x)
    })
    }

    key_model_names <- unlist(lapply(basename(run_dirs), zero_pad_last, num_zeros = 2))

    names(xpdb_key_models) <- key_model_names

    valid_data <- sapply(xpdb_key_models, function(x) {
      if (is.null(x[["data"]])) {
        FALSE
      } else {
        TRUE
      }
    })

    if (length(run_dirs[!valid_data] > 0)) {
      warning("Missing TABLE data for the following model output directories: \n",
              paste0(run_dirs[!valid_data], collapse = "\n"))
    }
    run_dirs <- as.list(run_dirs)
    names(run_dirs) <- names(xpdb_key_models)

    code <- lapply(run_dirs, function(x) {
      ctl <- readLines(file.path(x, paste0(basename(x), file_ext)))
    })

    names(code) <- names(xpdb_key_models)

    if (update_dd) {
    update(darwin_data,
           key_models_dir = dir,
           key_models = list(run_dirs = run_dirs,
                             code = code,
                             xpose_data = xpdb_key_models))
    } else {
      list(run_dirs = run_dirs,
           code = code,
           xpose_data = xpdb_key_models)
    }

  }


search_space_dimensions <- function(code) {

  if (is.null(code)) {
    stop("must use `import_key_modelss()`")
  }

  dimensions <- lapply(code, function(x) {
    phenotype <- x[grepl(";; Phenotype", x)]
    matches <- gregexpr("\\('([^']+)', ([0-9]+)\\)", phenotype)
    matched_substrings <- regmatches(phenotype, matches)[[1]]
    dimension <- gsub("\\('([^']+)', [0-9]+\\)", "\\1", matched_substrings)
    result <- as.numeric(gsub("\\('[^']+', ([0-9]+)\\)", "\\1", matched_substrings))
    data.frame(dimension = dimension, result = result)
  })

  df_combined <- dplyr::bind_rows(dimensions, .id = "key_models") %>%
    tidyr::spread(key = key_models, value = result)

  df_combined
}

#' Summarise overall table by key models
#'
#' Generate a summary \code{data.frame} by key models, which includes columns
#' such as condition number, number of parameters, -2LL, AIC, BIC, fitness, and
#' penalty values.
#'
#' @param darwin_data Object of class \code{darwin_data}.
#'
#' @return \code{data.frame}
#' @export
#'
summarise_overall_by_key_models <- function(darwin_data) {
  stopifnot(inherits(darwin_data, "darwin_data"))

  key_models_xpdb <- darwin_data$key_models$xpose_data
  fitness_penalties_by_key_models_df <- summarise_fitness_penalties_by_key_models(darwin_data)
  software <- darwin_data$software
  if (!is.null(software) && software == "nlme") {
    overall_table <- lapply(key_models_xpdb, overall_table_nlme) %>%
      dplyr::bind_rows(.id = "model_name") %>%
      dplyr::select(-logLik)
  } else {
    overall_table <- lapply(key_models_xpdb, overall_table_nonmem) %>%
      dplyr::bind_rows(.id = "model_name") %>%
      dplyr::select(-ofv)
  }

  overall_table$model_name <-
    unlist(
      lapply(
        overall_table$model_name,
        zero_pad_last,
        num_zeros = 2
      )
    )

  overall_table <- dplyr::left_join(overall_table, fitness_penalties_by_key_models_df,
                                    by = c("model_name" = "model_iteration"))
  return(overall_table)
}

overall_table_nonmem <- function(xpdb) {
  suppressMessages(
  xpdb[["summary"]] %>%
    dplyr::filter(label %in% c("ofv", "nind", "nobs") & problem == 1) %>%
    dplyr::select(label, value) %>%
    tidyr::pivot_wider(names_from = label, values_from = value) %>%
    dplyr::select(ofv, nobs, nind) %>%
    dplyr::mutate(Condition = ifelse(length(xpdb$summary$value[xpdb$summary$label == "condn" & xpdb$summary$problem == 1]) > 0, as.numeric(xpdb$summary$value[xpdb$summary$label == "condn" & xpdb$summary$problem == 1]), NA)) %>%
    dplyr::mutate(nparm = nrow(xpose::get_prm(xpdb))) %>%
    dplyr::mutate(`-2LL` = ifelse(any(grepl("CONTAINS CONSTANT", xpdb$code$code)), as.numeric(ofv), as.numeric(ofv) + as.numeric(nobs) * log(2 * pi))) %>%
    dplyr::mutate(ofv = as.numeric(ofv)) %>%
    dplyr::mutate(AIC = `-2LL` + 2 * nparm) %>%
    dplyr::mutate(BIC = `-2LL` + log(as.numeric(nobs)) * nparm)
  )
}

overall_table_nlme <- function(xpdb) {
    xpdb %>%
    get_overallNlme() %>%
    dplyr::mutate(RetCode = as.integer(RetCode), nObs = as.integer(nObs), nSub = as.integer(nSub), nParm = as.integer(nParm))
}