Skip to content

Commit

Permalink
some fixes/changes and new model_parameters vignette
Browse files Browse the repository at this point in the history
  • Loading branch information
victor-navarro committed Apr 8, 2024
1 parent 0496571 commit 509fdcd
Show file tree
Hide file tree
Showing 44 changed files with 476 additions and 131 deletions.
2 changes: 2 additions & 0 deletions NEWS.md
Original file line number Diff line number Diff line change
@@ -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.
Expand Down
4 changes: 2 additions & 2 deletions R/assertions.R
Original file line number Diff line number Diff line change
Expand Up @@ -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" =
Expand Down
2 changes: 1 addition & 1 deletion R/class_experiment.R
Original file line number Diff line number Diff line change
Expand Up @@ -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
})
93 changes: 65 additions & 28 deletions R/get_timings.R
Original file line number Diff line number Diff line change
@@ -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)
Expand All @@ -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]]
}
13 changes: 7 additions & 6 deletions R/make_experiment.R
Original file line number Diff line number Diff line change
Expand Up @@ -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
)
}

Expand All @@ -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
Expand Down Expand Up @@ -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))
Expand All @@ -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])
))
Expand All @@ -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])
))
Expand All @@ -178,7 +180,6 @@ make_experiment <- function(
tstps <- tstps[ri]
}
}

return(list(
tp = tps,
tn = masterlist[tps],
Expand Down
7 changes: 6 additions & 1 deletion _pkgdown.yml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
6 changes: 5 additions & 1 deletion docs/404.html

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

6 changes: 5 additions & 1 deletion docs/LICENSE.html

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

6 changes: 5 additions & 1 deletion docs/articles/calmr_app.html

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

6 changes: 5 additions & 1 deletion docs/articles/calmr_fits.html

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

Loading

0 comments on commit 509fdcd

Please sign in to comment.