Skip to content

Commit

Permalink
Update use_model_template
Browse files Browse the repository at this point in the history 
- Adapt the  `use_model_template` function to the new `version` argument for `bmmodels`

- Minor change to the `bmmformula` function to remove redundancies in model specific `bmf2bf` functions
  • Loading branch information
@GidonFrischkorn
GidonFrischkorn committed Mar 26, 2024
1 parent 9581428 commit b3e85cb
Show file tree
Hide file tree
Showing 2 changed files with 23 additions and 28 deletions.
12 changes: 6 additions & 6 deletions R/bmmformula.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -242,15 +242,15 @@ bmf2bf.bmmodel <- function(model, formula) {
resp <- model$resp_vars
constants <- model$fixed_parameters


if (length(resp) > 1) {
formula <- NextMethod("bmf2bf")
return(formula)
brms_formula <- NextMethod("bmf2bf")
} else {
resp <- resp[[1]]

# set base brms formula based on response
brms_formula <- brms::bf(paste0(resp, "~ 1"))
}
resp <- resp[[1]]

# set base brms formula based on response
brms_formula <- brms::bf(paste0(resp, "~ 1"))

# for each dependent parameter, check if it is used as a non-linear predictor of
# another parameter and add the corresponding brms function
Expand Down
39 changes: 17 additions & 22 deletions R/helpers-model.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -399,7 +399,7 @@ use_model_template <- function(model_name,
"#############################################################################!\n",
"# A check_data.* function should be defined for each class of the model.\n",
"# If a model shares methods with other models, the shared methods should be\n",
"# defined in data-helpers.R. Put here only the methods that are specific to\n",
"# defined in helpers-data.R. Put here only the methods that are specific to\n",
"# the model. See ?check_data for details.\n",
"# (YOU CAN DELETE THIS SECTION IF YOU DO NOT REQUIRE ADDITIONAL DATA CHECKS)\n\n")

Expand All @@ -408,8 +408,8 @@ use_model_template <- function(model_name,
"# Convert bmmformula to brmsformla methods ####\n",
"#############################################################################!\n",
"# A bmf2bf.* function should be defined if the default method for consructing\n",
"# the brmsformula from the bmmformula does not apply\n",
"# The shared method for all `bmmodels` is defined in helpers-formula.R.\n",
"# the brmsformula from the bmmformula does not apply (e.g if aterms are required).\n",
"# The shared method for all `bmmodels` is defined in bmmformula.R.\n",
"# See ?bmf2bf for details.\n",
"# (YOU CAN DELETE THIS SECTION IF YOUR MODEL USES A STANDARD FORMULA WITH 1 RESPONSE VARIABLE)\n\n")

Expand All @@ -428,25 +428,26 @@ use_model_template <- function(model_name,
"# ?postprocess_brm for details\n\n")


model_object <- glue(".model_<<model_name>> <- function(resp_var1 = NULL, required_arg1 = NULL, required_arg2 = NULL, links = NULL, ...) {\n",
" out <- structure(",
model_object <- glue(".model_<<model_name>> <- function(resp_var1 = NULL, required_arg1 = NULL, required_arg2 = NULL, links = NULL, version = NULL, ...) {\n",
" out <- structure(\n",
" list(\n",
" resp_vars = nlist(resp_var1),\n",
" other_vars = nlist(required_arg1, required_arg2),\n",
" domain = '',\n",
" task = '',\n",
" name = '',\n",
" citation = '',\n",
" version = '',\n",
" version = version,\n",
" requirements = '',\n",
" parameters = list(),\n",
" links = list(),\n",
" fixed_parameters = list()\n",
" fixed_parameters = list(),\n",
" default_priors = list(par1 = list(), par2 = list()),\n",
" void_mu = FALSE\n",
" ),\n",
" class = c('bmmodel', '<<model_name>>')\n",
" )\n",
" if(!is.null(version)) class(out) <- c(class(out), paste0(\"<<model_name>>_\",version))\n",
" out$links[names(links)] <- links\n",
" out\n",
"}\n\n",
Expand All @@ -461,18 +462,19 @@ use_model_template <- function(model_name,
"#' @param resp_var1 A description of the response variable\n",
"#' @param required_arg1 A description of the required argument\n",
"#' @param required_arg2 A description of the required argument\n",
"#' @param links A list of links for the parameters.",
"#' @param links A list of links for the parameters.\n",
"#' @param version A character label for the version of the model. Can be empty or NULL if there is only one version. \n",
"#' @param ... used internally for testing, ignore it\n",
"#' @return An object of class `bmmodel`\n",
"#' @export\n",
"#' @examples\n",
"#' \\dontrun{\n",
"#' # put a full example here (see 'R/model_mixture3p.R' for an example)\n",
"#' }\n",
"<<model_name>> <- function(resp_var1, required_arg1, required_arg2, links = NULL, ...) {\n",
"<<model_name>> <- function(resp_var1, required_arg1, required_arg2, links = NULL, version = NULL, ...) {\n",
" stop_missing_args()\n",
" .model_<<model_name>>(resp_var1 = resp_var1, required_arg1 = required_arg1,",
" required_arg2 = required_arg2, links = links, ...)\n",
" required_arg2 = required_arg2, links = links, version = version, ...)\n",
"}\n\n",
.open = "<<", .close = ">>")

Expand All @@ -496,17 +498,7 @@ use_model_template <- function(model_name,
" resp_var2 <- model$resp_vars$resp_arg2\n\n",
" # set the base brmsformula based \n",
" brms_formula <- brms::bf(paste0(resp_var1,\" | \", vreal(resp_var2), \" ~ 1\" ),)\n\n",
" # add bmmformula to the brms_formula\n",
" # check if parameters are used as non-linear predictors in other formulas\n",
" # and use the brms::lf() or brms::nlf() accordingly.\n",
" dpars <- names(formula)\n",
" for (pform in formula) {\n",
" if (is_nl(pform)) {\n",
" brms_formula <- brms_formula + brms::nlf(pform)\n",
" } else {\n",
" brms_formula <- brms_formula + brms::lf(pform)\n",
" }\n",
" }\n\n",
" # return the brms_formula to add the remaining bmmformulas to it.\n",
" brms_formula\n",
"}\n\n",
.open = "<<", .close = ">>")
Expand Down Expand Up @@ -558,6 +550,9 @@ use_model_template <- function(model_name,
out_template <- " nlist(formula, data)\n"
}

family_comment <- ifelse(custom_family,
" # construct the family & add to formula object \n",
" # add family to formula object")

configure_model_method <- glue::glue("#' @export\n",
"configure_model.<<model_name>> <- function(model, data, formula) {\n",
Expand All @@ -568,7 +563,7 @@ use_model_template <- function(model_name,
" my_precomputed_var <- attr(data, 'my_precomputed_var')\n\n",
" # construct brms formula from the bmm formula\n",
" formula <- bmf2bf(model, formula)\n\n",
" # construct the family\n",
family_comment,
family_template,
stan_vars_template,
" # return the list\n",
Expand Down

0 comments on commit b3e85cb

Please sign in to comment.