R/list_nm_tables.R

Defines functions list_nm_tables

Documented in list_nm_tables

#' List NONMEM output tables
#'
#' @description List NONMEM output tables file names from a \code{nm_model} object.
#'
#' @param nm_model An xpose nm_model object generated with \code{\link{read_nm_model}}.
#'
#' @seealso \code{\link{read_nm_model}}, \code{\link{read_nm_tables}}
#' @examples
#' \dontrun{
#' read_nm_model(file = 'run001.lst') %>% 
#'   list_nm_tables()
#' }
#' 
#' @export
list_nm_tables <- function(nm_model = NULL) {
  
  if (is.null(nm_model) || !is.nm.model(nm_model)) {
    stop('Object of class `nm_model` required.', call. = FALSE)
  }
  
  # Prepare null object to be returned if no $table is found
  null_object <- as.nm.table.list(dplyr::tibble(problem = -1, file = '', 
                                                firstonly = NA, simtab = NA))
    
  # Get NM code associated with the tables
  table_list <- nm_model %>% 
    dplyr::filter(.$problem > 0, .$subroutine == 'tab') 
  
  if (nrow(table_list) == 0) return(null_object)
  
  table_list <- table_list %>% 
    dplyr::group_by_at(.vars = c('problem', 'level')) %>% 
    tidyr::nest() %>% 
    dplyr::ungroup() %>% 
    dplyr::mutate(string = purrr::map_chr(.$data, ~stringr::str_c(.$code, collapse = ' '))) %>% 
    dplyr::mutate(file = stringr::str_match(.$string, '\\s+FILE\\s*=\\s*([^\\s]+)')[, 2]) %>% 
    dplyr::filter(!is.na(.$file))
  
  if (nrow(table_list) == 0) return(null_object)
  
  # Find table names and firstonly option
  table_list <- table_list %>% 
    dplyr::mutate(file = file_path(attr(nm_model, 'dir'), .$file),
                  firstonly = stringr::str_detect(.$string, 'FIRSTONLY')) %>% 
    dplyr::select(dplyr::one_of('problem', 'file', 'firstonly'))
  
  # Prep simtab flag
  sim_flag <- nm_model %>% 
    dplyr::filter(.$problem > 0) %>% 
    dplyr::group_by_at(.vars = 'problem') %>% 
    tidyr::nest() %>% 
    dplyr::ungroup() %>% 
    dplyr::mutate(simtab = purrr::map_lgl(.$data, ~!any(stringr::str_detect(.$subroutine, 'est')))) %>% 
    dplyr::select(dplyr::one_of(c('problem', 'simtab')))
  
  # Merge and output
  table_list %>% 
    dplyr::left_join(sim_flag, by = 'problem') %>% 
    as.nm.table.list()
}

Try the xpose package in your browser

Any scripts or data that you put into this service are public.

xpose documentation built on June 30, 2021, 9:07 a.m.