Document custom longitudinal models (#318)

DESCRIPTION

@@ -57,7 +57,8 @@ Suggests:
     flexsurv,
     purrr,
     vdiffr,
-    prodlim
+    prodlim,
+    loo
 Config/testthat/edition: 3
 Collate:
     'DataSubject.R'

NAMESPACE

@@ -200,6 +200,7 @@ export(brierScore)
 export(compileStanModel)
 export(enableLink)
 export(generateQuantities)
+export(getParameters)
 export(getPredictionNames)
 export(initialValues)
 export(linkDSLD)
@@ -211,6 +212,7 @@ export(merge)
 export(prior_beta)
 export(prior_cauchy)
 export(prior_gamma)
+export(prior_init_only)
 export(prior_invgamma)
 export(prior_logistic)
 export(prior_loglogistic)
@@ -267,6 +269,7 @@ importFrom(ggplot2.utils,geom_km)
 importFrom(glue,as_glue)
 importFrom(stats,.checkMFClasses)
 importFrom(stats,acf)
+importFrom(stats,as.formula)
 importFrom(stats,delete.response)
 importFrom(stats,model.frame)
 importFrom(stats,model.matrix)

R/Prior.R

@@ -337,7 +337,7 @@ prior_beta <- function(a, b) {
     )
 }
 
-#' Only Initial Values Specification
+#' Initial Values Specification
 #'
 #' @param dist (`Prior`)\cr a prior Distribution
 #' @family Prior
@@ -346,6 +346,7 @@ prior_beta <- function(a, b) {
 #' This is primarily used for hierarchical parameters whose distributions
 #' are fixed within the model and cannot be altered by the user.
 #'
+#' @export
 prior_init_only <- function(dist) {
     Prior(
         parameters = list(),

R/StanModel.R

@@ -69,7 +69,7 @@ as.list.StanModel <- function(x, ...) {
 
 #' @rdname getParameters
 #' @export
-getParameters.StanModel <- function(object) object@parameters
+getParameters.StanModel <- function(object, ...) object@parameters
 
 
 #' @export

R/defaults.R

@@ -11,7 +11,7 @@ NULL
 
 #' @rdname getParameters
 #' @export
-getParameters.default <- function(object) {
+getParameters.default <- function(object, ...) {
     if (missing(object) || is.null(object)) {
         return(NULL)
     }

R/generics.R

@@ -102,9 +102,10 @@ as.StanModule <- function(object, ...) {
 #' from a model.
 #'
 #' @param object where to obtain the parameters from.
+#' @param ... additional options.
 #'
-#' @keywords internal
-getParameters <- function(object) {
+#' @export
+getParameters <- function(object, ...) {
     UseMethod("getParameters")
 }
 
@@ -409,6 +410,9 @@ resolvePromise.default <- function(object, ...) {
 enableLink <- function(object, ...) {
     UseMethod("enableLink")
 }
+enableLink.default <- function(object, ...) {
+    object
+}
 
 
 
@@ -439,6 +443,7 @@ as_formula <- function(x, ...) {
     UseMethod("as_formula")
 }
 
+#' @importFrom stats as.formula
 #' @export
 as_formula.default <- function(x, ...) {
     as.formula(x, ...)

_pkgdown.yml

@@ -124,6 +124,7 @@ reference:
       - StanModel
       - StanModule
       - write_stan
+      - getParameters
 
   - title: Convenience Functions
     contents:

vignettes/custom-model-dsld.stan

@@ -0,0 +1,12 @@
+functions {
+    // Provide definition for the dsld link function
+    matrix link_dsld_contrib(matrix time, matrix link_function_inputs) {
+        int nrow = rows(time);
+        int ncol = cols(time);
+        // broadcast input vectors to match the size of the time matrix
+        matrix[nrow, ncol] baseline = rep_matrix(link_function_inputs[,1], ncol);
+        matrix[nrow, ncol] shrinkage = rep_matrix(link_function_inputs[,2], ncol);
+        matrix[nrow, ncol] growth = rep_matrix(link_function_inputs[,3], ncol);
+        return growth - baseline .* shrinkage .* exp(- shrinkage .* time);
+    }
+}

vignettes/custom-model-enable-link.stan

@@ -0,0 +1,7 @@
+transformed parameters {
+    // Define matrix required for link functions
+    matrix[n_subjects, 3] link_function_inputs;
+    link_function_inputs[,1] = baseline_idv;
+    link_function_inputs[,2] = shrinkage_idv;
+    link_function_inputs[,3] = growth_idv;
+}