#' base blueprint class
#' @importFrom R6 R6Class
#' @importFrom purrr map map2 is_list set_names map_dbl map_lgl discard keep flatten
#' @importFrom rlang is_bare_numeric
#' @importFrom glue glue
#' @export
Blueprint <-
R6::R6Class("blueprint",
public = list(
partials = NULL,
type = NULL,
routine = NULL,
initialize = function(type = "nonmem") {
# TODO: remove, just using this as a placeholder
message(sprintf("initializing new blueprint of type: %s", type))
if (missing(type)) {
type <- NULL
}
SUPPORTED_TYPES <- c("nonmem", "mrgsolve")
if (!(type %in% SUPPORTED_TYPES) && !is.null(type)) {
stop(glue("only support types: {paste0(SUPPORTED_TYPES, collapse = ',')}"))
}
if (!is.null(type)) {
self$type <- type
self$partials <- load_partials(type)
private$equation_mapper <- equation_derivations(type)
} else {
message("no type specified, no pre-loaded templates initialized")
}
},
add_constants = function(..., .overwrite = TRUE) {
param_list <- dots(...)
param_names <- names(param_list)
constructed_params <- map(param_names, function(.pn) {
param_info <- param_list[[.pn]]
if (is.null(param_info)) {
return(NULL)
}
# if numeric assume shorthand value only
# CL = 4.5
if (is_bare_numeric(param_info)) {
return(const(param_info, comment = .pn))
}
if (!inherits(param_info, "const")) {
stop(sprintf("incorrect specification for %s, please use const()", .pn))
}
return(param_info)
})
final_parameters <- modifyList(private$constants,
set_names(constructed_params, param_names))
# if get a case where everything is overwritten set to empty list
if(is.null(final_parameters)) {
final_parameters <- list()
}
private$constants <- purrr::map2(final_parameters, names(final_parameters), function(.p, .n) {
.p$name <- .n
return(.p)
})
return(names(constructed_params))
},
add_ignores = function(ignores, ..., .overwrite = FALSE) {
if (.overwrite) {
private$ignore_strings <- ignores
return(self)
}
private$ignore_strings <- c(private$ignore_strings, ignores)
return(self)
},
add_accepts = function(accepts, ..., .overwrite = FALSE) {
if (.overwrite) {
private$accept_strings <- accepts
return(self)
}
private$accept_strings <- c(private$accept_strings, accepts)
return(self)
},
add_hooks = function(...) {
# TODO(devin) check that hooks are only single character element for each
.dots <- dots(...)
names(.dots) <- purrr::map_chr(names(.dots), function(.n) {
if (is.null(.n)) {
stop("all hooks must be named")
}
# can accept full name hooks:pre:pk or pre:pk
# as can just clean out the hooks: if exists then recreate
# requires less logic than detecting and conditionally adding
paste0("hooks:", gsub("^hooks:", replacement = "", .n))
})
private$hooks <- modifyList(private$hooks, .dots)
self
},
# add_params adds parameters specified either shorthand CL = 5,
# or via param(), it returns a vector of parameter names
# for any created
add_params = function(..., .overwrite = TRUE) {
param_list <- dots(...)
param_names <- names(param_list)
# clear out any null parameters
null_indices <- purrr::map_lgl(param_list, is.null)
to_remove <- param_names[null_indices]
purrr::walk(to_remove, function(.x) {
private$parameters[[.x]] <- NULL
})
param_list <- param_list[!null_indices]
param_names <- param_names[!null_indices]
if (!length(param_list)) {
return(invisible())
}
constructed_params <- map2(param_list, param_names, function(param_info, .pn) {
# if numeric assume shorthand value only
# CL = 4.5
if (is_bare_numeric(param_info)) {
return(parameter(param_info, name = .pn))
}
if (!inherits(param_info, "parameter")) {
stop(sprintf("incorrect specification for %s,
please construct a parameter specification with `parameter()`", .pn))
}
# for now will force a name for all parameters, through the add_param
# call, eg add_param(<name> = parameter()), so even if a name
# is set, it will override.
param_info <- update(param_info, name = .pn)
# if link null, set equal to name
if (is.null(link(param_info))) {
param_info <- update(param_info, link = name(param_info))
}
return(param_info)
})
# in case anything was just given as a parameter block
constructed_param_names <- purrr::map(constructed_params, ~ name(.x))
final_parameters <- modifyList(private$parameters,
set_names(constructed_params, constructed_param_names)) %>%
discard(is.null)
# if get a case where everything is overwritten set to empty list
if (!length(final_parameters)) {
# don't want a named list just a bare empty list
final_parameters <- list()
}
private$parameters <- final_parameters
return(names(constructed_params))
},
get_param = function(.x, .value_only = FALSE){
param_info <- private$parameters[[.x]]
if (.value_only) {
return(set_names(.x, param_info$value))
}
return(param_info)
},
get_params = function(.value_only = FALSE){
if (.value_only) {
return(
set_names(map_dbl(private$parameters, ~ .x$value), names(private$parameters))
)
}
return(private$parameters)
},
add_hierarchies = function(...){
# TODO: currently basically add_param but tweaked to save to omega - should refactor
omega_list <- dots(...)
omega_names <- names(omega_list)
omega_names <- omega_names[!is.null(omega_names)]
if (length(omega_list) != length(omega_names)) {
stop("all elements must be named - even blocks!")
}
constructed_omegas <- map(omega_names, function(.pn) {
omega_info <- omega_list[[.pn]]
if (is.null(omega_info)) {
return(NULL)
}
# if numeric assume shorthand value only
# CL = 4.5
if (is_bare_numeric(omega_info)) {
return(omega_param(omega_info, .pn, fixed = FALSE))
}
# for now going to make the big assumption people will
# actually use block()/omega_param to create full omegas specifications,
# maybe should create an actual class and check for it
# but for now going to trust
if (!inherits(omega_info, "omega") && !inherits(omega_info, "block")) {
stop(sprintf("incorrect specification for %s, please use omega_param() or block()", .pn))
}
return(omega_info)
})
final_omegas <- modifyList(private$omegas,
set_names(constructed_omegas, omega_names)) %>%
discard(is.null)
# if get a case where everything is overwritten set to empty list
if (!length(final_omegas)) {
# don't want a named list just a bare empty list
final_omegas <- list()
}
block_names <- final_omegas %>%
keep(~ .x$block) %>%
map(~ .x$params) %>%
flatten()
diag_names <- final_omegas %>%
discard(~ .x$block) %>%
names(.)
both_names <- intersect(block_names, diag_names)
if (length(both_names)) {
stop(glue::glue("detected omega elements in both a diagonal and block element for: {params}",
params = paste0(both_names, collapse = ", ")))
}
private$omegas <- final_omegas
return(names(constructed_omegas))
},
add_residual_error = function(...){
# support additive, additive + prop, and prop error to start
ACCEPTED_NAMES <- c("ADD", "PROP")
# TODO: currently basically add_param but tweaked to save to sigma - should refactor
sigma_list <- dots(...)
sigma_names <- names(sigma_list)
sigma_names <- sigma_names[!is.null(sigma_names)]
if (length(sigma_list) != length(sigma_names)) {
stop("all elements must be named - even blocks!")
}
constructed_sigmas <- map2(sigma_list, sigma_names, function(sigma_info, .pn) {
if (is.null(sigma_info)) {
return(NULL)
}
# if numeric assume shorthand value only
# CL = 4.5
if (is_bare_numeric(sigma_info)) {
if (!(.pn %in% ACCEPTED_NAMES)) {
stop(glue("the only residual error names currently supported are:
{paste0(ACCEPTED_NAMES, collapse = ',')}"))
}
return(sigma_param(sigma_info, .pn, FALSE, comment = .pn))
}
if (!inherits(sigma_info, "sigma") && !inherits(sigma_info, "block")) {
stop(sprintf("incorrect specification for %s, please use sigma_param() or block()", .pn))
}
if (inherits(sigma_info, "block")) {
if (!all(names(sigma_info) %in% ACCEPTED_NAMES)) {
# improve this error message
stop(glue("the only residual error names currently supported are:
{paste0(ACCEPTED_NAMES, collapse = ',')}"))
}
}
return(sigma_info)
})
constructed_sigmas <- purrr::map2(constructed_sigmas,
sigma_names,
.f = function(.sigma, .name) {
if (is.null(.sigma$name)) {
.sigma$name <- .name
}
return(.sigma)
})
final_sigmas <- modifyList(private$sigmas,
set_names(constructed_sigmas, sigma_names)) %>%
discard(is.null)
# if get a case where everything is overwritten set to empty list
if (!length(final_sigmas)) {
final_sigmas <- list()
}
block_names <- final_sigmas %>%
keep(~ .x$block) %>%
map(~ .x$params) %>%
flatten()
diag_names <- final_sigmas %>%
discard(~ .x$block) %>%
names(.)
both_names <- intersect(block_names, diag_names)
if (length(both_names)) {
stop(glue::glue("detected omega elements in both a diagonal and block element for: {params}",
params = paste0(both_names, collapse = ", ")))
}
private$sigmas <- final_sigmas
return(names(constructed_sigmas))
},
get_all_elements = function() {
return(
list(
constants = private$constants,
parameters = private$parameters,
omegas = private$omegas,
sigmas = private$sigmas
)
)
},
render = function() {
if (is.null(private$templ)) {
stop("no template defined")
}
settings <- purrr::map(self$get_all_elements(), strip_names)
ipred <- ifelse(self$type == "mrgsolve", "CP", "IPRED")
resid_error <- get_residual_error_eqn(
purrr::flatten_chr(map(settings$sigmas, names)),
ipred,
self$type
)
.options <- list(
equations = private$equation_mapper(self$get_all_elements()),
routine = self$routine,
input = paste0(names(private$dat), collapse = " "),
ignore = private$ignore_strings,
accept = private$accept_strings,
data = private$datpath,
residual_error_eqn = resid_error
)
whisker::whisker.render(self$template,
purrr::reduce(list(settings, .options, private$hooks),
modifyList),
partials = self$partials
)
}
),
# active bindings available via self
active = list(
data = function(.data) {
if (missing(.data)) {
return(private$dat)
}
private$dat <- .data
},
datapath = function(.datapath) {
if (missing(.datapath)) {
return(private$datpath)
}
private$datpath <- .datapath
},
template = function(.template) {
if (missing(.template)) {
return(private$templ)
}
private$templ <- .template
}
),
private = list(
# given a a dataset to extract information for the model
datpath = NULL,
dat = NULL,
templ = NULL,
hooks = list(),
constants = list(),
accept_strings = NULL,
ignore_strings = NULL,
parameters = list(),
omegas = list(),
sigmas = list(),
equation_mapper = NULL
)
)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.