Nothing
summarise_nm_model <- function(file, model, software, rounding) {
sum <- dplyr::bind_rows(
sum_software(software), # Software name
sum_version(model, software), # Software version
sum_file(file), # Model file
sum_run(file), # Model run (model file without extension)
sum_directory(file), # Model directory
sum_reference(model, software), # Reference model
sum_timestart(model, software), # Run start time
sum_timestop(model, software), # Run stop time
sum_probn(model, software), # Problem no.
sum_label(model, software), # Model label
sum_description(model, software), # Model description
sum_input_data(model, software), # Model input data used
sum_nobs(model, software), # Number of observations
sum_nind(model, software), # Number of individuals
sum_nsim(model, software), # Number of simulations
sum_simseed(model, software), # Simulation seed
sum_subroutine(model, software), # Des solver
sum_runtime(model, software), # Estimation runtime
sum_covtime(model, software), # Covariance matrix runtime
sum_term(model, software), # Run termination message
sum_warnings(model, software), # Run warnings (e.g. boundary)
sum_errors(model, software), # Run errors (e.g termination error)
sum_nsig(model, software), # Number of significant digits
sum_condn(model, software, rounding), # Condition number
sum_nesample(model, software), # Number of esample
sum_esampleseed(model, software), # esample seed number
sum_ofv(model, software), # Objective function value
sum_method(model, software), # Estimation method or sim
sum_shk(model, software, 'eps', rounding), # Epsilon shrinkage
sum_shk(model, software, 'eta', rounding) # Eta shrinkage
)
# Complete missing cases for consistency
tmp <- sum %>%
dplyr::filter(.$problem != 0)
if (nrow(tmp) == 0) return(sum)
tmp %>%
tidyr::complete(!!!rlang::syms(c('problem', 'label')),
fill = list(subprob = 0, value = 'na')) %>%
dplyr::bind_rows(dplyr::filter(sum, sum$problem == 0)) %>%
dplyr::arrange_at(.vars = c('problem', 'label', 'subprob')) %>%
dplyr::mutate(descr = dplyr::case_when(
.$label == 'software' ~ 'Software',
.$label == 'version' ~ 'Software version',
.$label == 'file' ~ 'Run file',
.$label == 'run' ~ 'Run number',
.$label == 'dir' ~ 'Run directory',
.$label == 'ref' ~ 'Reference model',
.$label == 'probn' ~ 'Problem number',
.$label == 'timestart' ~ 'Run start time',
.$label == 'timestop' ~ 'Run stop time',
.$label == 'descr' ~ 'Run description',
.$label == 'label' ~ 'Run label',
.$label == 'data' ~ 'Input data',
.$label == 'nobs' ~ 'Number of observations',
.$label == 'nind' ~ 'Number of individuals',
.$label == 'nsim' ~ 'Number of simulations',
.$label == 'simseed' ~ 'Simulation seed',
.$label == 'subroutine' ~ 'ADVAN',
.$label == 'runtime' ~ 'Estimation runtime',
.$label == 'covtime' ~ 'Covariance step runtime',
.$label == 'term' ~ 'Termination message',
.$label == 'warnings' ~ 'Run warnings',
.$label == 'errors' ~ 'Run errors',
.$label == 'nsig' ~ 'Number of significant digits',
.$label == 'condn' ~ 'Condition number',
.$label == 'nesample' ~ 'Number of ESAMPLE',
.$label == 'esampleseed' ~ 'ESAMPLE seed number',
.$label == 'ofv' ~ 'Objective function value',
.$label == 'method' ~ 'Estimation method',
.$label == 'epsshk' ~ 'Epsilon shrinkage',
.$label == 'etashk' ~ 'Eta shrinkage')) %>%
dplyr::select(dplyr::one_of('problem', 'subprob', 'descr', 'label', 'value'))
}
# Default template for function output
sum_tpl <- function(label, value) {
dplyr::tibble(problem = 0,
subprob = 0,
label = label,
value = value)
}
# Software name
sum_software <- function(software) {
sum_tpl('software', software)
}
# Software version
sum_version <- function(model, software) {
if (software == 'nonmem') {
x <- model %>%
dplyr::filter(.$problem == 0) %>%
dplyr::filter(stringr::str_detect(.$code, 'NONLINEAR MIXED EFFECTS MODEL PROGRAM'))
if (nrow(x) == 0) return(sum_tpl('version', 'na'))
sum_tpl('version', stringr::str_match(x$code, 'VERSION\\s+(.+)$')[, 2])
}
}
# Model file name
sum_file <- function(file) {
sum_tpl('file', basename(file))
}
# Model run name
sum_run <- function(file) {
sum_tpl('run', update_extension(basename(file), ''))
}
# Model file directory
sum_directory <- function(file) {
sum_tpl('dir', dirname(file))
}
# Reference model
sum_reference <- function(model, software) {
if (software == 'nonmem') {
x <- model %>%
dplyr::filter(.$problem == 0) %>%
dplyr::filter(stringr::str_detect(tolower(.$comment), stringr::regex('based on\\s*:', ignore_case = TRUE)))
if (nrow(x) == 0) return(sum_tpl('ref', 'na'))
sum_tpl('ref', stringr::str_match(x$comment, ':\\s*(.+)$')[1, 2]) # Note: only take the first match
}
}
# Run start time
sum_timestart <- function(model, software) {
if (software == 'nonmem') {
x <- model %>%
dplyr::slice(1) %>%
dplyr::filter(stringr::str_detect(.$code, '\\s+\\d{2}:\\d{2}:\\d{2}\\s+'))
if (nrow(x) == 0) return(sum_tpl('timestart', 'na'))
sum_tpl('timestart', x$code)
}
}
# Run stop time
sum_timestop <- function(model, software) {
if (software == 'nonmem') {
x <- model %>%
dplyr::slice(nrow(model)) %>%
dplyr::filter(stringr::str_detect(.$code, '\\s+\\d{2}:\\d{2}:\\d{2}\\s+'))
if (nrow(x) == 0) return(sum_tpl('timestop', 'na'))
sum_tpl('timestop', x$code)
}
}
# Problem no.
sum_probn <- function(model, software) {
if (software == 'nonmem') {
x <- unique(model$problem[model$problem != 0])
if (length(x) == 0) return(sum_tpl('probn', 'na'))
dplyr::tibble(
problem = x,
subprob = 0,
label = 'probn',
value = as.character(x))
}
}
# Model Label
sum_label <- function(model, software) {
if (software == 'nonmem') {
x <- model %>%
dplyr::filter(.$subroutine == 'pro')
if (nrow(x) == 0) return(sum_tpl('label', 'na'))
x %>%
dplyr::mutate(subprob = 0,
label = 'label',
value = as.character(.$code)) %>%
dplyr::select(dplyr::one_of('problem', 'subprob', 'label', 'value'))
}
}
# Model description
sum_description <- function(model, software) {
if (software == 'nonmem') {
x <- dplyr::filter(.data = model, model$level == 0)
start <- which(stringr::str_detect(tolower(x$comment),
stringr::regex('2.\\s*description\\s*:',
ignore_case = TRUE)))
if (length(start) == 1) {
end <- which(stringr::str_detect(tolower(x$comment), '(3|x\\d)\\.\\s*\\w+'))
end <- end[(end - start) > 0]
end <- ifelse(length(end) == 0, nrow(x), min(end) - 1)
x <- dplyr::slice(.data = x, seq(start, end)) %>%
{stringr::str_replace(.$comment, '^\\s*;\\s*', '')} %>%
stringr::str_c(collapse = ' ') %>%
{sum_tpl('descr', stringr::str_match(., ':\\s*(.+)$')[, 2])}
return(value = x)
}
sum_tpl('descr', 'na')
}
}
# Input data
sum_input_data <- function(model, software) {
if (software == 'nonmem') {
x <- model %>%
dplyr::filter(.$subroutine == 'dat') %>%
dplyr::distinct(!!rlang::sym('level'), .keep_all = TRUE) # Assumes that the data is on the first row
if (nrow(x) == 0) return(sum_tpl('data', 'na'))
x %>%
dplyr::mutate(subprob = 0,
label = 'data',
value = stringr::str_match(.$code, '^\\s*?([^\\s]+)\\s+')[, 2]) %>% # Note: only take the first match
dplyr::select(dplyr::one_of('problem', 'subprob', 'label', 'value'))
}
}
# Number of observations
sum_nobs <- function(model, software) {
if (software == 'nonmem') {
x <- model %>%
dplyr::filter(.$subroutine == 'lst') %>%
dplyr::filter(stringr::str_detect(.$code, stringr::fixed('TOT. NO. OF OBS RECS')))
if (nrow(x) == 0) return(sum_tpl('nobs', 'na'))
x %>%
dplyr::mutate(subprob = 0,
label = 'nobs',
value = stringr::str_extract(.$code, '\\d+')) %>%
dplyr::select(dplyr::one_of('problem', 'subprob', 'label', 'value'))
}
}
# Number of individuals
sum_nind <- function(model, software) {
if (software == 'nonmem') {
x <- model %>%
dplyr::filter(.$subroutine == 'lst') %>%
dplyr::filter(stringr::str_detect(.$code, stringr::fixed('TOT. NO. OF INDIVIDUALS')))
if (nrow(x) == 0) return(sum_tpl('nind', 'na'))
x %>%
dplyr::mutate(subprob = 0,
label = 'nind',
value = stringr::str_extract(.$code, '\\d+')) %>%
dplyr::select(dplyr::one_of('problem', 'subprob', 'label', 'value'))
}
}
# Simulation number
sum_nsim <- function(model, software) {
if (software == 'nonmem') {
x <- model %>%
dplyr::filter(.$subroutine == 'sim') %>%
dplyr::filter(stringr::str_detect(.$code, stringr::fixed('NSUB')))
if (nrow(x) == 0) return(sum_tpl('nsim', 'na'))
x %>%
dplyr::mutate(subprob = 0,
label = 'nsim',
value = stringr::str_match(.$code, 'NSUB.*=\\s*(\\d+)')[, 2]) %>%
dplyr::select(dplyr::one_of('problem', 'subprob', 'label', 'value'))
}
}
# Simulation seed
sum_simseed <- function(model, software) {
if (software == 'nonmem') {
x <- model %>%
dplyr::filter(.$subroutine == 'sim') %>%
dplyr::filter(stringr::str_detect(.$code, '\\(\\d+\\)'))
if (nrow(x) == 0) return(sum_tpl('simseed', 'na'))
x %>%
dplyr::mutate(subprob = 0,
label = 'simseed',
value = stringr::str_match(.$code, '\\((\\d+)\\)')[, 2]) %>%
dplyr::select(dplyr::one_of('problem', 'subprob', 'label', 'value'))
}
}
# DES solver
sum_subroutine <- function(model, software) {
if (software == 'nonmem') {
x <- model %>%
dplyr::filter(.$subroutine == 'sub') %>%
dplyr::filter(stringr::str_detect(.$code, stringr::fixed('ADVAN')))
if (nrow(x) == 0) return(sum_tpl('subroutine', 'na'))
x %>%
dplyr::mutate(subprob = 0,
label = 'subroutine',
value = stringr::str_match(.$code, 'ADVAN(\\d+)')[, 2]) %>%
dplyr::select(dplyr::one_of('problem', 'subprob', 'label', 'value'))
}
}
# Estimation runtime
sum_runtime <- function(model, software) {
if (software == 'nonmem') {
x <- model %>%
dplyr::filter(.$subroutine == 'lst') %>%
dplyr::filter(stringr::str_detect(.$code, 'Elapsed estimation\\s+time'))
if (nrow(x) == 0) return(sum_tpl('runtime', 'na'))
x %>%
dplyr::group_by_at(.vars = 'problem') %>%
dplyr::mutate(subprob = (1:n()) - 1) %>%
dplyr::ungroup() %>%
dplyr::mutate(label = 'runtime',
value = as.ctime(stringr::str_match(.$code, '([\\.\\d]+)')[, 2])) %>%
dplyr::select(dplyr::one_of('problem', 'subprob', 'label', 'value'))
}
}
# Covariance matrix runtime
sum_covtime <- function(model, software) {
if (software == 'nonmem') {
x <- model %>%
dplyr::filter(.$subroutine == 'lst') %>%
dplyr::filter(stringr::str_detect(.$code, 'Elapsed covariance\\s+time in seconds:\\s+\\d'))
if (nrow(x) == 0) return(sum_tpl('covtime', 'na'))
x %>%
dplyr::mutate(subprob = 0,
label = 'covtime',
value = as.ctime(stringr::str_match(.$code, '([\\.\\d]+)')[, 2])) %>%
dplyr::select(dplyr::one_of('problem', 'subprob', 'label', 'value'))
}
}
# Run termination
sum_term <- function(model, software) {
if (software == 'nonmem') {
x <- dplyr::filter(model, model$subroutine == 'lst')
start <- which(stringr::str_detect(x$code, stringr::fixed('0MINIMIZATION')))
end <- which(stringr::str_detect(x$code, stringr::fixed(" NO. OF FUNCTION EVALUATIONS USED:")))
if (length(start) == 0 | length(end) == 0 | length(start)!=length(end)) return(sum_tpl('term', 'na'))
x %>%
dplyr::slice(purrr::map2(start, end, ~seq(.x,.y)) %>% purrr::flatten_int()) %>%
dplyr::group_by_at(.vars = 'problem') %>%
tidyr::nest() %>%
dplyr::ungroup() %>%
dplyr::mutate(value = purrr::map_chr(.$data, function(y) {
drop <- min(which(stringr::str_detect(y$code, 'NO. OF')))
dplyr::slice(.data = y, seq(1, (drop - 1))) %>%
{stringr::str_trim(.$code)} %>%
stringr::str_trunc(width = 56) %>%
stringr::str_c(collapse = '\n') %>%
stringr::str_replace('0MINIM', 'MINIM')})) %>%
dplyr::mutate(subprob = 0, label = 'term') %>%
dplyr::select(dplyr::one_of('problem', 'subprob', 'label', 'value'))
}
}
# Run warnings (e.g. boundary)
sum_warnings <- function(model, software) {
if (software == 'nonmem') {
x <- model %>%
dplyr::filter(.$subroutine == 'oth') %>%
dplyr::filter(stringr::str_detect(.$code, 'WARNINGS AND ERRORS|\\(WARNING'))
if (nrow(x) == 0) return(sum_tpl('warnings', 'na'))
x %>%
dplyr::mutate(problem = stringr::str_match(.$code, 'FOR PROBLEM\\s+(\\d+)')[, 2]) %>%
tidyr::fill(!!rlang::sym('problem')) %>%
dplyr::mutate(problem = as.numeric(.$problem)) %>%
dplyr::filter(!stringr::str_detect(.$code, 'FOR PROBLEM\\s+(\\d+)')) %>%
dplyr::mutate(code = stringr::str_trim(.$code)) %>%
dplyr::mutate(code = stringr::str_trunc(.$code, width = 56)) %>%
dplyr::distinct(!!!rlang::syms(c('problem', 'code'))) %>%
dplyr::group_by_at(.vars = 'problem') %>%
tidyr::nest() %>%
dplyr::ungroup() %>%
dplyr::mutate(value = purrr::map_chr(.$data, ~stringr::str_c(.$code, collapse = '\n'))) %>%
dplyr::mutate(subprob = 0, label = 'warnings') %>%
dplyr::select(dplyr::one_of('problem', 'subprob', 'label', 'value'))
}
}
# Run errors (e.g termination error)
sum_errors <- function(model, software) {
if (software == 'nonmem') {
sum_tpl('errors', 'na') # To be added
}
}
# Number of significant digits
sum_nsig <- function(model, software) {
if (software == 'nonmem') {
x <- model %>%
dplyr::filter(.$subroutine == 'lst') %>%
dplyr::filter(stringr::str_detect(.$code, stringr::fixed('NO. OF SIG. DIGITS')))
if (nrow(x) == 0) return(sum_tpl('nsig', 'na'))
x %>%
dplyr::mutate(subprob = 0,
label = 'nsig',
value = stringr::str_match(.$code, ':\\s+([\\.\\d]+)')[, 2]) %>%
dplyr::select(dplyr::one_of('problem', 'subprob', 'label', 'value'))
}
}
# Condition number
sum_condn <- function(model, software, rounding) {
if (software == 'nonmem') {
x <- model %>%
dplyr::filter(.$subroutine == 'lst') %>%
dplyr::slice(which(stringr::str_detect(.$code, stringr::fixed('EIGENVALUES OF COR'))) + 4)
if (nrow(x) == 0) return(sum_tpl('condn', 'na'))
x %>%
dplyr::group_by_at(.vars = 'problem') %>%
tidyr::nest() %>%
dplyr::ungroup() %>%
dplyr::mutate(subprob = 0,
label = 'condn',
value = purrr::map_chr(.$data, function(x) {
stringr::str_trim(x$code, side = 'both') %>%
stringr::str_split(pattern = '\\s+') %>%
purrr::flatten_chr() %>%
as.numeric() %>%
{max(.)/min(.)} %>%
round(digits = rounding) %>%
as.character()})) %>%
dplyr::select(dplyr::one_of('problem', 'subprob', 'label', 'value'))
}
}
# Number of ESAMPLE (i.e. NPDE)
sum_nesample <- function(model, software) {
if (software == 'nonmem') {
x <- model %>%
dplyr::filter(.$subroutine == 'tab') %>%
dplyr::filter(stringr::str_detect(.$code, stringr::fixed('ESAMPLE')))
if (nrow(x) == 0) return(sum_tpl('nesample', 'na'))
x %>%
dplyr::mutate(subprob = 0,
label = 'nesample',
value = stringr::str_match(.$code, 'ESAMPLE\\s*=\\s*(\\d+)')[, 2]) %>%
dplyr::select(dplyr::one_of('problem', 'subprob', 'label', 'value'))
}
}
# ESAMPLE seed number
sum_esampleseed <- function(model, software) {
if (software == 'nonmem') {
x <- model %>%
dplyr::filter(.$subroutine == 'tab') %>%
dplyr::filter(stringr::str_detect(.$code, stringr::fixed('SEED')))
if (nrow(x) == 0) return(sum_tpl('esampleseed', 'na'))
x %>%
dplyr::mutate(subprob = 0,
label = 'esampleseed',
value = stringr::str_match(.$code, 'SEED\\s*=\\s*(\\d+)')[, 2]) %>%
dplyr::select(dplyr::one_of('problem', 'subprob', 'label', 'value'))
}
}
# Objective function value
sum_ofv <- function(model, software) {
if (software == 'nonmem') {
x <- model %>%
dplyr::filter(.$subroutine == 'lst') %>%
dplyr::filter(stringr::str_detect(.$code, stringr::fixed('#OBJV')))
if (nrow(x) == 0) return(sum_tpl('ofv', 'na'))
x %>%
dplyr::mutate(value = stringr::str_match(.$code, '\\*\\s+(.+)\\s+\\*')[, 2]) %>%
dplyr::group_by_at(.vars = 'problem') %>%
dplyr::mutate(subprob = (1:n()) - 1, label = 'ofv') %>%
dplyr::select(dplyr::one_of('problem', 'subprob', 'label', 'value')) %>%
dplyr::ungroup()
}
}
# Estimation method or sim
sum_method <- function(model, software) {
if (software == 'nonmem') {
x <- model %>%
dplyr::filter(.$subroutine %in% c('sim', 'est')) %>%
dplyr::filter(stringr::str_detect(.$code, '(?<!RAN)METH|NSUB'))
if (nrow(x) == 0) return(sum_tpl('method', 'na'))
x %>%
dplyr::mutate(value = stringr::str_match(.$code, '(?<!RAN)METH[OD]*\\s*=\\s*([^\\s]+)')[, 2],
inter = stringr::str_detect(.$code, '\\sINTER'),
lapl = stringr::str_detect(.$code, '\\sLAPLA'),
like = stringr::str_detect(.$code, '\\sLIKE')) %>%
dplyr::mutate(value = dplyr::if_else(.$subroutine == 'sim', 'sim', .$value)) %>%
dplyr::mutate(value = dplyr::case_when(.$value %in% c('0', 'ZERO') ~ 'FO',
.$value == '1' ~ 'FOCE',
stringr::str_detect(.$value, 'COND') ~ 'FOCE',
TRUE ~ tolower(.$value))) %>%
dplyr::mutate(value = stringr::str_c(stringr::str_to_lower(.$value), dplyr::if_else(.$inter, '-i', ''),
dplyr::if_else(.$lapl, ' laplacian', ''),
dplyr::if_else(.$like, ' likelihood', ''))) %>%
dplyr::group_by_at(.vars = 'problem') %>%
dplyr::mutate(subprob = (1:n()) - 1, label = 'method') %>%
dplyr::select(dplyr::one_of('problem', 'subprob', 'label', 'value')) %>%
dplyr::ungroup()
}
}
# Epsilon/Eta shrinkage
sum_shk <- function(model, software, type, rounding) {
if (software == 'nonmem') {
# Get shrinkage from: 1) psn, 2) shr file 3) nonmem lst
## Method 3 (worse one)
x <- model %>%
dplyr::filter(.$subroutine == 'lst') %>%
dplyr::group_by_at(.vars = 'problem') %>%
tidyr::nest() %>%
dplyr::ungroup() %>%
dplyr::mutate(start = purrr::map_int(.x = .$data, .f = function(x) {
stringr::str_c(stringr::str_to_upper(type), 'SHRINK[^V]') %>%
stringr::regex(ignore_case = TRUE) %>%
{stringr::str_detect(string = x$code, pattern = .)} %>%
which() %>%
{ifelse(length(.) == 0, NA_integer_, .)}
})) %>%
filter(!is.na(.$start))
if (nrow(x) == 0) return(sum_tpl(stringr::str_c(type, 'shk'), 'na'))
x <- x %>%
dplyr::mutate(rows = purrr::map2(.x = .$data, .y = .$start, .f = function(x, start) {
x$code[start:nrow(x)] %>%
{start + (which.max(stringr::str_detect(., '^\\s+\\D')[-1]) - 1)} %>%
{seq(start, .)}})) %>%
dplyr::mutate(code = purrr::map2_chr(.x = .$data, .y = .$rows,
~stringr::str_c(.x$code[.y], collapse = ' '))) %>%
dplyr::mutate(code = stringr::str_match(.$code, '\\Q(%)\\E:*\\s*(.+)')[, 2]) %>%
dplyr::mutate(code = stringr::str_split(.$code, '\\s+')) %>%
dplyr::mutate(value = purrr::map(.$code, ~round(as.numeric(.), digits = rounding)),
grouping = purrr::map(.$code, ~stringr::str_c(' [', 1:length(.), ']', sep = ''))) %>%
dplyr::group_by_at(.vars = 'problem') %>%
dplyr::mutate(subprob = (1:n()) - 1) %>%
dplyr::ungroup()
## TEMP handling
if (tidyr_new_interface()) {
x <- x %>% tidyr::unnest(cols = dplyr::one_of('value', 'grouping'))
} else {
x <- x %>% tidyr::unnest(dplyr::one_of('value', 'grouping'))
}
## END TEMP
x %>%
dplyr::filter(.$value != 100) %>%
dplyr::mutate(value = stringr::str_c(.$value, .$grouping)) %>%
dplyr::group_by_at(.vars = c('problem', 'subprob')) %>%
tidyr::nest() %>%
dplyr::ungroup() %>%
dplyr::mutate(label = stringr::str_c(type, 'shk'),
value = purrr::map_chr(.$data, ~stringr::str_c(.$value, collapse = ', '))) %>%
dplyr::select(dplyr::one_of('problem', 'subprob', 'label', 'value')) %>%
dplyr::ungroup()
}
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.