some fixes/changes and new model_parameters vignette

NEWS.md

@@ -1,5 +1,7 @@
 # calmr 0.6.3
 * Added `set_calmr_palette()` function to control the colour/fill scales used to plot results ([#1](https://github.com/victor-navarro/calmr/issues/1)).
+* Fixed bug in `make_experiment()` that was triggered by empty phases and no miniblocks.
+* Changed `get_timings()` to require a specific model name.
 
 # calmr 0.6.2
 * Aggregation of ANCCR data now ignores time; time entries are averaged.

R/assertions.R

@@ -59,8 +59,8 @@ is_design <- function(object) {
   )
 }
 
-.assert_timings <- function(timings, design) {
-  def_timings <- get_timings(design)
+.assert_timings <- function(timings, design, model) {
+  def_timings <- get_timings(design, model)
   if (!is.null(timings)) {
     stopifnot(
       "Timing lists must be equally named" =

R/class_experiment.R

@@ -399,7 +399,7 @@ methods::setMethod(
 #' @aliases timings<-
 #' @export
 methods::setMethod("timings<-", "CalmrExperiment", function(x, value) {
-  .assert_timings(value, design(x))
+  .assert_timings(value, design(x), x@model)
   x@timings <- value
   x
 })

R/get_timings.R

@@ -1,73 +1,89 @@
 #' Get timing design parameters
 #' @param design A `data.frame` containing the experimental design.
+#' @param model One of [supported_timed_models()].
 #' @return A list of timing design parameters.
 #' @export
 #' @examples
 #' block <- get_design("blocking")
-#' get_timings(block)
-get_timings <- function(design) {
+#' get_timings(block, model = "TD")
+get_timings <- function(design, model) {
   parsed_design <- .assert_parsed_design(design)
+  model <- .assert_timed_model(model)
   # Get trial names from design
   trialnames <- mapping(parsed_design)$trial_names
   # Get transition names from design
   transitions <- mapping(parsed_design)$transitions
   # Get period functionals from design
   period_functionals <- mapping(parsed_design)$period_functionals
+  # Get require timings for the model
+  mod_timings <- .model_timings(model)
 
+  # global parameters
+  global_pars <- .default_global_timings()[mod_timings$global]
+
+  # trial parameters
+  trial_pars <- NULL
   def_trials <- .default_trial_timings()
-  trial_pars <- data.frame(trial = trialnames)
-  for (p in seq_along(def_trials$name)) {
-    trial_pars[, def_trials$name[p]] <- def_trials$default_value[p]
+  if (any(def_trials$name %in% mod_timings$trials)) {
+    trial_pars <- data.frame(trial = trialnames)
+    for (p in which(def_trials$name %in% mod_timings$trials)) {
+      trial_pars[, def_trials$name[p]] <- def_trials$default_value[p]
+    }
   }
-
-  def_periods <- .default_stimulus_timings()
-  period_pars <- data.frame()
-  for (t in trialnames) {
-    for (p in names(period_functionals[[t]])) {
-      period_pars <- rbind(
-        period_pars,
-        data.frame(
-          trial = t, period = p,
-          stimulus = period_functionals[[t]][[p]]
+  def_periods <- .default_period_timings()
+  period_pars <- NULL
+  if (any(def_periods$name %in% mod_timings$periods)) {
+    period_pars <- data.frame()
+    for (t in trialnames) {
+      for (p in names(period_functionals[[t]])) {
+        period_pars <- rbind(
+          period_pars,
+          data.frame(
+            trial = t, period = p,
+            stimulus = period_functionals[[t]][[p]]
+          )
         )
-      )
+      }
+    }
+    for (p in which(def_periods$name %in% mod_timings$periods)) {
+      period_pars[, def_periods$name[p]] <- def_periods$default_value[p]
     }
   }
-  for (p in seq_along(def_periods$name)) {
-    period_pars[, def_periods$name[p]] <- def_periods$default_value[p]
-  }
-
-  trans_pars <- list()
-  if (length(transitions)) {
-    def_trans <- .default_transition_timings()
 
+  trans_pars <- NULL
+  def_trans <- .default_transition_timings()
+  if (
+    length(transitions) &&
+      any(def_trans$name %in% mod_timings$transitions)
+  ) {
     trans_pars <- data.frame(trial = rep(
       names(transitions), sapply(transitions, length)
     ), transition = unname(unlist(transitions)))
 
-    for (p in seq_along(def_trans$name)) {
+    for (p in which(def_trans$name %in% mod_timings$transitions)) {
       trans_pars[, def_trans$name[p]] <- def_trans$default_value[p]
     }
   }
   # bundle into list
-  c(
-    .default_global_timings(),
+  all_pars <- c(
+    global_pars,
     list(
       trial_ts = trial_pars,
       period_ts = period_pars,
       transition_ts = trans_pars
     )
   )
+  all_pars[!sapply(all_pars, is.null)]
 }
 
 # Default timing parameter information
 .default_trial_timings <- function() {
   list(name = c(
     "post_trial_delay",
     "mean_ITI", "max_ITI"
-  ), default_value = c(1, 30, 90, 1))
+  ), default_value = c(1, 30, 90))
 }
-.default_stimulus_timings <- function() {
+.default_period_timings <- function() {
   list(
     name = c("stimulus_duration"),
     default_value = c(1)
@@ -84,3 +100,24 @@ get_timings <- function(design) {
     "time_resolution" = 0.5
   )
 }
+
+.model_timings <- function(model) {
+  timings_map <- list(
+    "ANCCR" = list(
+      "global" = c("use_exponential"),
+      "transitions" = c("transition_delay"),
+      "periods" = c(),
+      "trials" = c("post_trial_delay", "mean_ITI", "max_ITI")
+    ),
+    "TD" = list(
+      "global" = c("use_exponential", "time_resolution"),
+      "transitions" = c("transition_delay"),
+      "periods" = c("stimulus_duration"),
+      "trials" = c("post_trial_delay", "mean_ITI", "max_ITI")
+    )
+  )
+  if (is.null(mode)) {
+    return(timings_map)
+  }
+  timings_map[[model]]
+}

R/make_experiment.R

@@ -54,7 +54,7 @@ make_experiment <- function(
   # assert timing parameters
   if (model %in% supported_timed_models()) {
     timings <- .assert_timings(timings,
-      design = design
+      design = design, model
     )
   }
 
@@ -79,6 +79,7 @@ make_experiment <- function(
     pb("Building experiment")
     exper
   }, simplify = FALSE, future.seed = TRUE)
+
   # unnest once
   allexps <- unlist(allexps, recursive = FALSE)
   # hack timings
@@ -125,6 +126,7 @@ make_experiment <- function(
   # finally, convert lists to data.frames and bind across phases per group
   gs <- unlist(lapply(des, "[[", "group"))
   ugs <- unique(gs)
+
   lapply(ugs, function(g) {
     d <- do.call(rbind, lapply(samples[which(gs == g)], as.data.frame))
     d$trial <- seq_len(nrow(d))
@@ -145,11 +147,11 @@ make_experiment <- function(
     tps <- c() # note the redefining
     tstps <- c()
     for (b in 1:gcd) {
-      ts <- unlist(sapply(
+      ts <- unlist(lapply(
         seq_along(trial_names),
         function(n) rep(which(masterlist %in% trial_names[n]), per_block[n])
       ))
-      tsts <- unlist(sapply(
+      tsts <- unlist(lapply(
         seq_along(trial_names),
         function(n) rep(is_test[n], per_block[n])
       ))
@@ -163,11 +165,11 @@ make_experiment <- function(
       tstps <- c(tstps, tsts)
     }
   } else {
-    tps <- unlist(sapply(
+    tps <- unlist(lapply(
       seq_along(trial_names),
       function(n) rep(which(masterlist %in% trial_names[n]), trial_repeats[n])
     ))
-    tstps <- unlist(sapply(
+    tstps <- unlist(lapply(
       seq_along(trial_names),
       function(n) rep(is_test[n], trial_repeats[n])
     ))
@@ -178,7 +180,6 @@ make_experiment <- function(
       tstps <- tstps[ri]
     }
   }
-
   return(list(
     tp = tps,
     tn = masterlist[tps],

_pkgdown.yml

@@ -2,21 +2,26 @@ url: https://victornavarro.org/calmr/
 template:
   bootstrap: 5
 
+navbar:
+  structure:
+    left:  [intro, reference, articles, news]
+
 articles:
 - title: Model reference
   navbar: Model reference
   contents:
+  - articles/model_parameters
   - RW1972
   - MAC1975
   - PKH1982
   - SM2007
   - HD2022
   - ANCCR
+  - TD
   - RAND
 - title: Demos
   navbar: Demos
   contents:
-  - calmr_basics
   - calmr_app
   - calmr_fits
   - heidi_similarity