#' Interactive function to build an l1 model specification for setup_glm_pipeline
#'
#' @param gpa a \code{glm_pipeline_arguments} object containing an analysis pipeline to which $l1_models
#' should be added. If $l1_models is already present, these will be amended.
#' @param trial_data a data.frame containing trial-level data for one or more subjects
#' @param l1_model_set optional existing l1_model_set to be modified
#' @param from_spec_file optional YAML or JSON file containing settings to populated into l1 models
#' @param onset_cols an optional character vector of columns in \code{trial_data} that should be
#' in the set of event onsets
#' @param onset_regex an optional PCRE-compatible regular expression for identifying potential
#' event onset columns in \code{trial_data}
#' @param duration_cols an optional character vector of columns in \code{trial_data} that should be
#' in the set of event durations
#' @param duration_regex an optional PCRE-compatible regular expression for identifying potential
#' event duration columns in \code{trial_data}
#' @param value_cols an optional character vector of columns in \code{trial_data} that should be in the set of signal values
#' @param value_regex an optional PCRE-compatible regular expression for identifying potential
#' event value columns in \code{trial_data}
#' @param isi_cols an optional character vector of columns in \code{trial_data} that should be in the set of signal isi/iti
#' @param isi_regex an optional PCRE-compatible regular expression for identifying potential
#' isi/iti columns in \code{trial_data}
#'
#' @details if \code{gpa} is not passed in, then we will work from trial_data and l1_model_set.
#'
#' @return a \code{l1_model_set} object containing events, signals, and models, compatible with build_design_matrix
#' @author Michael Hallquist
#' @importFrom checkmate assert_data_frame assert_class assert_subset
#' @importFrom dplyr bind_cols select mutate
#' @importFrom yaml read_yaml
#' @importFrom jsonlite read_json
#' @export
<- (gpa=, trial_data=, l1_model_set=, from_spec_file=,
onset_cols=, onset_regex=".*(onset|time).*",
duration_cols=, duration_regex=".*duration.*",
value_cols=, value_regex=, isi_cols=, isi_regex="^(iti|isi).*") {
# Maybe allow glm object to be passed in that would have trial_data and variable_mapping.
# I guess that would be like "add_l1_model"
lg <- lgr::get_logger("glm_pipeline/build_l1_models")
lg$set_threshold(gpa$lgr_threshold)
checkmate::assert_class(gpa, "glm_pipeline_arguments", null.ok = )
if (!(gpa)) {
lg$info("In build_l1_models, using existing gpa object to build l1 models (ignoring trial_data argument etc.)")
use_gpa <-
trial_data <- gpa$trial_data
l1_model_set <- gpa$l1_models
} {
lg$("In build_l1_models, using trial_data passed in, rather than gpa object")
use_gpa <-
}
checkmate::assert_data_frame(trial_data, null.ok = )
checkmate::assert_class(l1_model_set, "l1_model_set", null.ok = )
checkmate::assert_subset(onset_cols, (trial_data)) #make sure that all onset columns are in the data frame
checkmate::assert_string(onset_regex, null.ok = )
checkmate::assert_subset(duration_cols, (trial_data)) # make sure that all duration columns are in the data frame
checkmate::assert_string(duration_regex, null.ok = )
checkmate::assert_subset(value_cols, (trial_data)) #make sure all parametric regressor columns are in the data frame
checkmate::assert_string(value_regex, null.ok = )
checkmate::assert_subset(("id", "session", "run_number", "trial"), (trial_data)) # required metadata in trial_data
if ((l1_model_set)) {
## initialize overall l1 design object (holds events, signals, and models)
l1_model_set <- (onsets=, durations=, values=, wi_factors=, events=, signals=, models=)
(l1_model_set) <- ("list", "l1_model_set")
new_l1 <-
} {
new_l1 <-
}
if (!(from_spec_file)) {
checkmate::assert_file_exists(from_spec_file)
lg$info("In build_l1_models, populated fields from: %s", from_spec_file)
ext <- (from_spec_file, withdot = )
if (ext == "yaml") {
spec_list <- yaml::read_yaml(from_spec_file)
} if (ext == "json") {
spec_list <- jsonlite::read_json(from_spec_file, simplifyVector = )
} {
msg <- ("Cannot understand how to input spec file: %s", from_spec_file)
lg$error(msg)
(msg)
}
spec_list <- propagate_spec_names(spec_list)
l1_model_set <- (l1_model_set, spec_list, trial_data, ("onsets", "durations", "isis", "values", "wi_factors"))
l1_model_set <- (l1_model_set, spec_list, trial_data, lg)
l1_model_set <- signals_from_spec(l1_model_set, spec_list, trial_data, lg)
l1_model_set <- (l1_model_set, spec_list, lg)
new_l1 <- # always assume that the spec file has enough info not to walk through each stage
blm1_complete <- # drop out of model builder when working from a spec file
} {
blm1_complete <-
}
int_vars <- (trial_data, checkmate::test_integerish)
char_vars <- (trial_data, checkmate::test_character)
fac_vars <- (trial_data, checkmate::test_factor)
num_vars <- (trial_data, checkmate::test_numeric)
possible_factors <- ((int_vars | char_vars | fac_vars)) # possible factors must be int, char, or factor
possible_factors <- (possible_factors, ("id", "session", "run_number", "trial"))
possible_pms <- ((int_vars | num_vars)) # possible parametric modulators must be numeric
possible_pms <- (possible_pms, ("id", "session", "run_number", "trial"))
# relies on scope of parent function for onset_cols etc.
take_l1_actions <- (l1_model_set, actions) {
checkmate::assert_integerish(actions, lower = 1, upper = 8)
for (aa actions) {
if (aa == 1) {
# onsets
l1_model_set <- (l1_model_set, trial_data,
field_name = "onsets", field_desc = "onset",
select_cols = onset_cols, select_regex = onset_regex
)
} if (aa == 2) {
# durations
l1_model_set <- (l1_model_set, trial_data,
field_name = "durations", field_desc = "duration",
select_cols = duration_cols, select_regex = duration_regex
)
} if (aa == 3) {
# iti/isi
l1_model_set <- (l1_model_set, trial_data,
field_name = "isis", field_desc = "ISI/ITI",
select_cols = isi_cols, select_regex = isi_regex, force_selection=
)
} if (aa == 4) {
# parametric values
l1_model_set <- (l1_model_set, trial_data,
field_name = "values", field_desc = "parametric value",
select_cols = value_cols, select_regex = value_regex, force_selection=,
limit_cols = possible_pms
)
} if (aa == 5) {
# within-subject factors
l1_model_set <- (l1_model_set, trial_data,
field_name = "wi_factors", field_desc = "within-subject factor", force_selection=,
limit_cols = possible_factors
)
} if (aa == 6) {
# events
l1_model_set <- (l1_model_set, trial_data=trial_data, lg=lg)
} if (aa == 7) {
# signals
l1_model_set <- (l1_model_set, trial_data, lg=lg)
} if (aa == 8) {
# models
l1_model_set <- (l1_model_set, lg=lg)
}
}
(l1_model_set)
}
if ((new_l1)) {
(
"Welcome to the l1 model builder. This process will walk you through setting up all level 1 fMRI models for you analyses.",
"This process consists of eight steps: ",
" 1. Selection of event onset columns. Event onsets must be in seconds relative to the scan start.",
" 2. Selection of event duration columns. Event durations must be in seconds relative to the scan start.",
" 3. Optional selection of interstimulus/intertrial intervals. These must be ISI/ISI durations in seconds.",
" 4. Selection of all parametric modulator (continuous) event values.",
" 5. Optional selection of within-subject factor columns that can be used in specifying signals.",
" 6. Build 'events' which consist of onset times, durations, and optional ITI/ISI.",
" 7. Build 'signals', which consist of an event, an event value (amplitude), and convolution and regressor settings.",
" 8. Build 'models', which consist of a set of signals and GLM contrasts for signal-related regressors.",
sep = "\n"
)
l1_model_set <- take_l1_actions(l1_model_set, 1:8) # run user through each step in sequence
} {
("Modifying existing l1 model structure\n")
}
# drop into l1 model menu, whether new or modification, unless working from a spec file
while ((blm1_complete)) {
blm1_action <- ((
"Update event onset columns", # 1
"Update event duration columns", # 2
"Update ITI/ISI columns", # 3
"Update parametric value columns", # 4
"Update within-subject factor columns", # 5
"Update events (each consists of an onset and duration)", # 6
"Update signals (event, factor, parametric value, regressor settings)", # 7
"Update models (consisting of signals and contrasts)", # 8
"Done with level 1 model building" # 9
), = "Level 1 model builder")
if (blm1_action < 9) {
l1_model_set <- take_l1_actions(l1_model_set, blm1_action)
} if (blm1_action == 9) {
("Completing level 1 model building\n")
blm1_complete <-
}
}
if ((use_gpa)) {
gpa$l1_models <- l1_model_set
(gpa)
} {
(l1_model_set)
}
}
#' Onset, duration, value column selection helper function
#' @param l1_model_set an l1_model_set object containing onsets etc.
#' @param trial_data a trial + subjects x events data.frame that contains potential onset columns
#' @param field_name the element of \code{l1_model_set} containing columns of a certain purpose (onset, duration, value)
#' @param field_desc the text description of the field being modified (e.g., 'parametric value')
#' @param select_cols a character vector of current columns specified by the user to be added/included
#' @param select_regex a PCRE-compatible regular expression for identifying columns
#' @param limit_cols a vector of variable names in \code{trial_data} that constrains what can be chosen
#' @param force_selection do not allow an empty return for this field
#' @param alpha_sort whether to display eligible columns in alphabetical order
#' @param prompt_input whether to ask user to confirm selections
#'
#' @return a modified version of l1_model_set that has \code{field_name} updated according to user specification
#' @importFrom glue glue
#' @keywords internal
<- (l1_model_set, trial_data, field_name = , field_desc = , select_cols = , select_regex = ,
limit_cols=, force_selection = , alpha_sort = , prompt_input=) {
# record of columns before any adjustments.
current_cols <- l1_model_set[field_name]]
# never allow id, session, or run_number as columns
all_cols <- (trial_data)
if (!(limit_cols)) {
possible_cols <- limit_cols
} {
possible_cols <- (all_cols, ("id", "session", "run_number"))
}
if ((alpha_sort)) possible_cols <- (possible_cols)
new_cols <- (select_cols, current_cols) # any new columns in the argument compared to the l1_model_set?
chosen_cols <- current_cols # start with current columns
if ((new_cols) > 0L) {
(glue("Current {field_desc} columns in the l1 model structure are: {c_string(current_cols)}\n", .trim=))
(glue("The arguments to build_l1_models also included: {c_string(new_cols)}\n", .trim=))
if ((prompt_input)) {
res <- 1L
} {
res <- (("Yes", "No"), = glue("Do you want to add these columns to possible {field_desc}s?"))
}
if (res == 1L) {
# add chosen_cols to l1 set
chosen_cols <- (current_cols, new_cols) # else just keep current_cols
}
}
# handle regex detection of new columns
if (!(select_regex)) {
detected_cols <- (select_regex, possible_cols, value = , perl = )
uniq_detect <- (detected_cols, chosen_cols) # only bother the user if the regex reveals new columns
if ((detected_cols) > 0L && (uniq_detect) > 0L) {
(glue("\n\n---\nDetected the following possible event {field_desc} columns:\n\n {c_string(detected_cols)}\n\n"))
res <- (("Yes", "No"), = glue("Do you want to add these columns to possible {field_desc}s?"))
if (res == 1) {
# add these to any that were manually specified/current
chosen_cols <- ((chosen_cols, detected_cols))
}
}
}
done_cols <-
while ((done_cols)) {
if ((prompt_input)) {
action <- 3L # Done
} {
(glue("\n\n---\nCurrent {field_desc} columns: {c_string(chosen_cols)}\n\n", .trim=))
action <- ((
glue("Add/modify {field_desc} columns"),
glue("Delete {field_desc} columns"),
glue("Done with {field_desc} selection")
),
= glue("Would you like to modify the event {field_desc} columns?")
)
}
if (action == 1L) { # Add/modify
# if user selects 0 to cancel, select.list still returns character(0) instead of the current values
new_cols <- (possible_cols,
multiple = , preselect = chosen_cols,
= glue("Choose all columns denoting event {field_desc}s\n(Command/Control-click to select multiple)")
)
if (!(new_cols, (0))) chosen_cols <- new_cols
} if (action == 2L) { # Delete
if ((chosen_cols) == 0L && (force_selection)) {
(glue("No {field_desc} yet. Please add at least one.\n"))
} if ((chosen_cols) == 1L && (force_selection)) {
(glue("Cannot delete the last {field_desc}. Add others before deleting this.\n"))
} {
which_del <- (chosen_cols, = glue("Which {field_desc} column would you like to remove?"))
if (which_del > 0) {
proceed <- (("Proceed", "Cancel"),
= glue("Are you sure you want to delete {chosen_cols[which_del]}?")
)
if (proceed == 1) {
(" Deleting ", chosen_cols[which_del], "\n")
chosen_cols <- chosen_cols-which_del]
# TODO: need mechanism for cascade deleting events, signals, and models that depend on this field!
} {
(" Not deleting ", chosen_cols[which_del], "\n")
}
}
}
} if (action == 3L) { # Done
done_cols <-
(glue("\nThe following columns were chosen as possible event {field_desc}s.\n", .trim=))
(glue(" {c_string(chosen_cols)}\n", .trim=))
}
}
l1_model_set[field_name]] <- chosen_cols
(l1_model_set)
}
#' helper function to build events consisting of onsets and durations
#' @param l1_model_set an l1_model_set object that may have extant events in it
#' @param trial_data the trial_data object from the \code{gpa} object
#' @return a modified copy of l1_model_set with events added/updated
#' @keywords internal
#' @importFrom dplyr select mutate
#' @importFrom checkmate test_number
#' @importFrom glue glue
<- (l1_model_set, spec_list = , trial_data, lg=) {
("Specify all events that can be added to a GLM model. Events consist of an onset time and duration\n")
summarize_events <- (l1_model_set) {
("Summary of events available in l1 models:\n--------\n")
if (!(l1_model_set$events)) {
(l1_model_set$events, (x) {
("Event name: ", x$, "\n")
(" Event onset: ", x$onset, "\n")
(
" mean [min -- max]: ",
((x$$onset, na.rm = ), 2), "[",
((x$$onset, na.rm = ), 2), "--",
((x$$onset, na.rm = ), 2), "]\n"
)
(" First 6 values:", ((x$$onset), collapse = ", "), "\n\n")
(" Event duration: ", x$duration, "\n")
(
" mean [min -- max]: ",
((x$$duration, na.rm = ), 2), "[",
((x$$duration, na.rm = ), 2), "--",
((x$$duration, na.rm = ), 2), "]\n"
)
(" First 6 values:", (((x$$duration), 2), collapse = ", "), "\n\n")
if (!(x$isi)) {
(" Event ISI/ITI: ", x$isi, "\n")
(
" mean [min -- max]: ",
((x$$isi, na.rm = ), 2), "[",
((x$$isi, na.rm = ), 2), "--",
((x$$isi, na.rm = ), 2), "]\n"
)
}
})
} {
("No events in l1 models\n")
}
}
if (!(spec_list)) {
l1_model_set <- events_from_spec(l1_model_set, spec_list, trial_data)
prompt_input <-
} {
prompt_input <-
}
events_complete <-
while ((events_complete)) {
summarize_events(l1_model_set)
if (prompt_input) {
action <- (("Add event", "Delete event", "Done with event specification"))
} {
action <- 3L
}
if (action == 1L) { # add
eobj <- ()
# ---- event name ----
complete <-
while ((complete)) {
<- "Enter the event name: "
nm <- ()
if (nm != "") {
if (nm %in% (l1_model_set$events)) {
("Event cannot have the same name as an existing event!\n")
} {
eobj$ <- nm
complete <-
}
}
}
# ---- event onset ----
complete <-
while ((complete)) {
oo <- (l1_model_set$onsets, ="Choose event onset")
if (oo != 0) {
eobj$onset <- l1_model_set$onsets[oo]
complete <-
}
}
# ---- event duration ----
complete <-
while ((complete)) {
choices <- ("Specify fixed duration", l1_model_set$durations)
oval <- (choices, = "Choose event duration")
if (oval == 1) {
duration <-
while (!checkmate::test_number(duration, lower = 0, upper = 5000)) {
duration <- ((("Enter the duration value (in seconds) for ", eobj$, ": ")))
}
if (duration > 50) {
lg$warn("Duration more than 50s specified. Make sure that your durations are in seconds, not milliseconds!")
}
eobj$duration <- duration
complete <-
} if (oval > 1L) {
eobj$duration <- choices[oval]
complete <-
}
}
# optional selection of ISI if chosen in initial setup
choose_isi <- (("Yes", "No"), = "Do you want to specify an ITI or ISI that follows this event?")
if (choose_isi == 1L) {
complete <-
while ((complete)) {
choices <- ("Specify fixed ISI/ITI", l1_model_set$isis)
oval <- (choices, = "Choose event ISI/ITI")
if (oval == 1) {
isi <-
while (!checkmate::test_number(isi, lower = 0, upper = 5000)) {
isi <- ((("Enter the ISI/ITI value (in seconds) for ", eobj$, ": ")))
}
if (isi > 50) {
lg$warn("ISI/ITI more than 50s specified. Make sure that your ISI/ITI values are in seconds, not milliseconds!")
}
eobj$isi <- isi
complete <-
} if (oval > 1L) {
eobj$isi <- choices[oval]
complete <-
}
}
}
# populate data frame for event
eobj <- populate_event_data(eobj, trial_data)
(eobj) <- ("list", "l1_model_set_events") # set 'l1_model_set_events' class
l1_model_set$events[nm]] <- eobj
} if (action == 2L) { # delete
event_names <- (l1_model_set$events)
which_del <- (event_names, ="Which event would you like to delete?")
if (which_del > 0) {
proceed <- (("Proceed", "Cancel"), = glue("Are you sure you want to delete {event_names[which_del]}?"))
if (proceed==1) {
(glue(" Deleting {event_names[which_del]}\n"))
l1_model_set$events[which_del]] <-
} {
(glue(" Not deleting {event_names[which_del]}\n"))
}
}
} if (action == 3L) {
events_complete <-
}
}
(l1_model_set)
}
# helper function to print signal setup
summarize_l1_signals <- (sl) {
if ((sl) == 0L) {
(())
}
("Summary of signals available in l1 models:\n--------\n")
((sl), (ii) {
this <- sl[ii]]
("--------\nSignal ", ii, "\n\n")
(" Name:", this$, "\n")
(" Event alignment:", this$event, "\n")
if ((this$trial_subset)) {
(" Trial subset: FALSE", "\n")
} if ((this$trial_subset)) {
(glue(" Trial subset: {this$trial_subset_expression}"), "\n")
(
glue(" Proportion of trials included: overall = {round(this$trial_subset_statistics['overall'], 2)}"),
glue(
" By id: mean = {round(this$trial_subset_statistics['mean'], 2)}, ", "sd = {round(this$trial_subset_statistics['sd'], 2)}, ",
"min = {round(this$trial_subset_statistics['min'], 2)}, ", "max = {round(this$trial_subset_statistics['max'], 2)}"
), sep="\n"
)
}
if (this$value_type %in% ("unit", "number")) {
(" Regressor value (constant): ", this$value_fixed[1L], "\n")
} {
(
" Parametric value: ", this$parametric_modulator, ", mean [min -- max]: ",
((this$value$value, na.rm = ), 2), " [ ",
((this$value$value, na.rm = ), 2), " -- ",
((this$value$value, na.rm = ), 2), " ] \n", sep=""
)
}
(" HRF Normalization:", this$normalization, "\n")
(" Add signal derivative:", (this$add_deriv), "\n")
(" Demean convolved signal:", (this$demean_convolved), "\n")
(" Within-subject factor:", c_string(this$wi_factors), "\n")
(" Generate beta series:", (this$beta_series), "\n")
(
" Multiply convolved regressor against time series:",
((this$ts_multiplier || (this$ts_multiplier)),
"FALSE", this$ts_multiplier
), "\n"
)
("\n--------\n")
})
}
summarize_l1_models <- (ml) {
if ((ml) == 0L) { (()) }
("Summary of l1 models:\n--------\n")
((ml), (ii) {
this <- ml[ii]]
("--------\nModel ", ii, "\n\n")
(" Name:", this$, "\n")
(" Signals:", (this$signals, collapse=", "), "\n")
if ((this$) < 20) {
(" Contrasts:\n\n")
((this$, 3))
("\n--------\n\n")
} { ("More than 20 regressor columns. Not printing contrasts\n") }
})
}
#' helper function to build level 1 signals
#' @param l1_model_set An \code{l1_model_set} object whose signals should be created or modified
#' @param trial_data A data.frame containing trial-level signal information
#'
#' @return a modified version of \code{l1_model_set} with updated \code{$signals}
#' @keywords internal
<- (l1_model_set, trial_data, block_data = , subtrial_data = , lg=) {
("\nNow, we will build up a set of signals that can be included as regressors in the level 1 model.\n")
checkmate::assert_class(lg, "Logger")
signal_list <- l1_model_set$signals
add_more <- 1
while (add_more != 4) {
summarize_l1_signals(signal_list)
add_more <- (("Add signal", "Modify signal", "Delete signal", "Done with signal setup"),
= "Signal setup menu"
)
if (add_more == 4) {
} if (add_more == 3) {
if ((signal_list) == 0L) {
("No signals added yet. Please add one first.\n")
} {
which_del <- ((signal_list), = "Which signal would you like to delete?")
if (which_del > 0) {
proceed <- (("Proceed", "Cancel"),
= ("Are you sure you want to delete ", (signal_list)[which_del], "?")
)
if (proceed == 1L) {
(" Deleting ", (signal_list)[which_del], "\n")
signal_list[which_del]] <-
# TODO: cascade delete any model that has this signal
} {
(" Not deleting ", (signal_list)[which_del], "\n")
}
}
}
} if (add_more %in% (1, 2)) {
modify <-
# prompt for signal details
if (add_more == 2) {
if ((signal_list) == 0L) {
("No signals available to modify.\n")
ss <- ()
} {
res <- 0L
while (res == 0L) {
res <- ((signal_list), = "Which signal do you want to modify?")
}
ss <- signal_list[res]]
signal_list[res]] <- # clear out old settings
modify <-
}
} {
ss <- ()
}
### ---- signal name ----
complete <-
while ((complete)) {
<- "Enter the signal name: "
if ((modify)) {
("Current signal name:", ss$, "\n")
<- "Enter the signal name (press return to leave unchanged): "
}
nm <- ()
if (nm != "") {
ss$ <- nm
complete <-
} if (nm == "" && (modify)) {
complete <-
}
}
### ---- event alignment ----
if ((modify)) {
(glue("Current signal alignment: {c_string(ss$event)}"), sep = "\n")
res <- (("No", "Yes"), = "Change signal alignment?")
if (res == 2) {
ss$event <-
} # clear out event so that it is respecified
}
while ((ss$event)) {
res <- ((l1_model_set$events), = "With which event is this signal aligned?")
if (res > 0) {
ss$event <- (l1_model_set$events)[res]
}
}
### ---- trial subsetting ----
if ((modify)) {
(glue("Current trial subset: {c_string(ss$trial_subset)}"), sep = "\n")
res <- (("No", "Yes"), = "Change trial subset?")
if (res == 2) {
ss$trial_subset <- ss$trial_subset_expression <- ss$trial_subset_statistics <-
} # clear out subset so that it is respecified
}
trial_set <-
while ((ss$trial_subset)) {
res <- (("No", "Yes"), = "Only model this signal for specific trials?")
if (res == 1L) {
ss$trial_subset <-
} if (res == 2L) {
while ((ss$trial_subset_expression)) {
("Specify an R-based expression that will be evaluated against trial_data and return TRUE/FALSE for each row.\n\n")
("For example, you might want to separate out trials on which reaction times were implausibly fast (e.g., less than 100 ms).\n")
(" In this case, if the column in trial_data is called rt and it's in seconds, you would type: rt < .1\n")
(" A compound expression can be used, too, like: rt < .5 & accurate == FALSE\n\n")
ss_expression <- ("Enter the trial subsetting expression: ")
trial_set <- ((trial_data, (( = ss_expression))),
error = (e) {
lg$error("Problem evaluating trial subsetting expression: %s. Error: %s", ss_expression, (e))
()
}
)
if ((trial_set)) {
("\nProblem with your subsetting expression. Please try again.\n")
} if ((trial_set) == 0) {
("\nExpression would retain zero trials! Please try again.\n\n")
} {
ss$trial_subset_expression <- ss_expression
ss$trial_subset <-
}
}
}
}
ss <- get_trial_subset_stats(ss, trial_data, trial_set)
### ---- value of regressor ----
if ((modify)) {
# repopulate value data.frame in case subset has changed
ss$value <- get_value_df(ss, trial_data)
(
"Current signal value:",
((ss$value) == 1L && (ss$value[1L]),
ss$value[1L],
(
((ss$parametric_modulator), "", (ss$parametric_modulator, ", ")),
((ss$value$value, na.rm = ), 2), " [",
((ss$value$value, na.rm = ), 2), " -- ",
((ss$value$value, na.rm = ), 2), "]\n"
)
), "\n"
)
res <- (("No", "Yes"), = "Change signal value?")
if (res == 2) {
# clear out event so that it is respecified
ss$value <- ss$value_fixed <- ss$value_type <- ss$parametric_modulator <-
}
}
while ((ss$value)) {
regtype <- ((
"Unit height (1.0)", "Other fixed value (will prompt for details)",
"Parametric modulator (will prompt for details)"
),
= "What should be the value of regressor (pre-convolution)?"
)
if (regtype == 1L) {
ss$value_type <- "unit"
ss$value_fixed <- 1.0
} if (regtype == 2L) {
val <-
while (!checkmate::test_number(val)) {
val <- (("Enter the regressor value/height (pre-convolution): "))
}
ss$value_type <- "number"
ss$value_fixed <- val
} if (regtype == 3L) {
val <- 0L
while (val == 0L) {
val <- (l1_model_set$values, ("Which value should be used for this signal?"))
if (val > 0) {
# TODO: have build_design matrix support a simple value vector, which requires
# same number of rows as metadata (avoid redundancy)
# basal data frame for each event
ss$parametric_modulator <- l1_model_set$values[val] # keep column name
ss$value_type <- "parametric"
}
}
}
# populate value data frame for this signal
ss$value <- get_value_df(ss, trial_data)
}
### ---- within-subject factor modulation ----
ss <- bl1_specify_wi_factors(ss, l1_model_set, trial_data, modify)
### ------ hrf normalization ------
if ((modify)) {
("Current HRF normalization:", ss$normalization, "\n")
res <- (("No", "Yes"), = "Change HRF normalization?")
if (res == 2) {
ss$normalization <-
} # clear out so that it is respecified
}
while ((ss$normalization)) {
opt <- ("none", "evtmax_1", "durmax_1")
res <- ((
"none",
"evtmax_1 (aka dmUBLOCK(1); HRF max of 1.0 for each event, regardless of duration)",
"durmax_1 (aka dmUBLOCK; HRF maxing at 1.0 as events become longer (1.0 around 15 sec)"
),
= "How should the HRF be normalized in convolution?"
)
if (res > 0) ss$normalization <- opt[res]
}
prompt_advanced <-
if ((modify)) {
(
"Current advanced option settings:\n",
" - Temporal derivative:", (ss$add_deriv), "\n",
" - Demean convolved signal:", (ss$demean_convolved), "\n",
" - Beta series:", (ss$beta_series), "\n",
" - Time series multiplier:", (ss$ts_multiplier), "\n\n"
)
res <- (("No", "Yes"), = "Change advanced settings?")
if (res == 2L) { # clear out so that it is respecified
ss$add_deriv <- ss$demean_convolved <- ss$beta_series <- ss$ts_multiplier <-
prompt_advanced <-
}
} {
("Advanced options defaults:",
" - No temporal derivative",
" - Demean convolved signal",
" - No beta series",
" - No time series multiplier (PPI)\n",
sep = "\n"
)
accept_defaults <- (("Yes", "No"), = "Accept default advanced options for this signal?")
if (accept_defaults == 2L) {
prompt_advanced <-
}
}
if ((prompt_advanced)) {
("Using defaults for signal: ", ss$, "\n")
ss$add_deriv <-
ss$demean_convolved <-
ss$beta_series <-
ss$ts_multiplier <-
} {
# derivative
while ((ss$add_deriv)) {
res <- (("No", "Yes"), = "Add temporal derivative?")
if (res == 1L) {
ss$add_deriv <-
} if (res == 2L) {
ss$add_deriv <-
}
}
# demean
while ((ss$demean_convolved)) {
res <- (("No", "Yes"), = "Demean signal post-convolution?")
if (res == 1L) {
ss$demean_convolved <-
} if (res == 2L) {
ss$demean_convolved <-
}
}
# beta series
while ((ss$beta_series)) {
res <- (("No", "Yes"),
= "Generate beta series for this signal (one regressor per trial)?"
)
if (res == 1L) {
ss$beta_series <-
} if (res == 2L) {
ss$beta_series <-
}
}
ss$ts_multiplier <-
# ts multiplier [not quite there]
## while (is.null(ss$ts_multiplier)) {
## res <- menu(c("No", "Yes"),
## title="Generate beta series for this signal (one regressor per trial)?")
## if (res == 1L) { ss$beta_series <- FALSE
## } else if (res == 2L) { ss$beta_series <- TRUE }
## }
}
signal_list[ss$]] <- ss
}
}
(signal_list) <- ("list", "l1_model_set_signals") # set 'l1_model_set_signals' class
# populate back into model set
l1_model_set$signals <- signal_list
(l1_model_set)
}
############### BUILD MODELS FROM SIGNALS AND EVENTS
#' helper function to create a set of level 1 models
#' @param l1_model_set a set of level 1 models
#' @param spec_list if creating models from a spec (YAML) file, this is the parsed list
#' @param lg the current logger
#' @keywords internal
<- (l1_model_set, spec_list=, lg=) {
checkmate::assert_class(lg, "Logger")
create_new_model <- (signal_list, to_modify=, spec_list=) {
checkmate::assert_class(to_modify, "l1_model_spec", null.ok=)
if ((to_modify)) {
mobj <- (level = 1L) #first-level model
(mobj) <- ("list", "l1_model_spec")
modify <-
} {
mobj <- to_modify
modify <-
}
### ------ model name ------
if ((modify)) {
("Current model name:", mobj$, "\n")
res <- (("No", "Yes"), ="Change model name?")
if (res == 2) { mobj$ <- } #clear out so that it is respecified
}
if (!(spec_list$)) { # populate from specification, if requested
mobj$ <- spec_list$
}
while ((mobj$) || mobj$ == "") {
res <- (("Enter the model name: "))
if (res != "") {
res <- (res)
if (res %in% (model_list)) {
("\nModel name:", res, "already exists. Names must be unique.\n")
("Current models:", ((model_list), collapse=", "), "\n")
} {
mobj$ <- res
}
}
}
if ((modify)) {
("Current model signals:", ((mobj$signals), collapse=", "), "\n")
res <- (("No", "Yes"), ="Change model signals (and contrasts)?")
if (res == 2) { #clear out so that it is respecified
mobj$signals <- mobj$regressors <- mobj$ <- mobj$contrast_spec <-
}
}
### ------ model signals ------
if (!(spec_list$signals)) {
checkmate::assert_subset(spec_list$signals, (signal_list))
mobj$signals <- spec_list$signals
} {
summarize_l1_signals(signal_list) # print summary of signals if user input is needed
}
while ((mobj$signals)) {
signals <- ((signal_list), multiple = , preselect = mobj$signals,
= "Choose all signals to include in this model\n(Command/Control-click to select multiple)")
if ((signals) == 0L) {
proceed <- (("Yes", "No"), ="Nothing entered. Do you want to cancel model setup?")
if (proceed == 1L) {
(()) #return nothing from function
}
} {
mobj$signals <- signals
}
}
#look up what the regressors will be for this.
mobj$regressors_list <- (signal_list[mobj$signals], get_regressors_from_signal, simplify=)
mobj$regressors <- (mobj$regressors_list)
# NOTE: at level 1, we always essentially have an additive model and rely on the user for contrast specification. Usually, this will
# just be a diagonal matrix. The only major exception I can think of is the within-subject factor situation where the columns of the design
# matrix depend on each other and need to be modeled as such. So, in this case, we basically want to populate part of the contrast matrix with
# contrasts for each wi-factor-modulated signal.
#contrast editor
mobj <- (mobj, signal_list, spec_list)
(mobj)
}
model_list <- l1_model_set$models
signal_list <- l1_model_set$signals
add_more <- 1
if (!(spec_list)) {
for (mm spec_list$l1_models) {
mobj <- create_new_model(signal_list, spec_list=mm)
model_list[mobj$]] <- mobj # add to set
}
add_more <- 4 # quit out of model builder when working from spec file
}
while (add_more != 4) {
summarize_l1_models(model_list)
add_more <- (("Add model", "Modify model", "Delete model", "Done with l1 model setup"),
="Level 1 model setup menu")
if (add_more == 1L) { #add
mm <- create_new_model(signal_list)
if (!(mm)) { #NULL indicates that user canceled model setup process
if (mm$ %in% (l1_model_set)) {
lg$warn("A model with the same name exists: ", mm$, ". Overwriting it.")
}
model_list[mm$]] <- mm #add to set
}
} if (add_more == 2L) { #modify
if ((model_list)) {
("No models available to modify. Add at least one model first")
} {
res <- 0L
while (res == 0L) { res <- ((model_list), ="Which model do you want to modify?") }
model_list[res]] <- create_new_model(signal_list, to_modify=model_list[res]])
}
} if (add_more == 3L) { #delete
which_del <- ((model_list), ="Which model would you like to delete?")
if (which_del > 0) {
proceed <- (("Proceed", "Cancel"),
=("Are you sure you want to delete ", (model_list)[which_del], "?"))
if (proceed==1) {
(" Deleting ", (model_list)[which_del], "\n")
model_list[which_del]] <-
} {
(" Not deleting ", (model_list)[which_del], "\n")
}
}
}
}
# add class 'l1_model_set_models'
(model_list) <- ("list", "l1_model_set_models")
l1_model_set$models <- model_list
l1_model_set$n_contrasts <- (model_list, (mm) { (mm$) })
(l1_model_set)
}
# helper function to specify within-subject factor modulation for a given signal
bl1_specify_wi_factors <- (ss, l1_model_set, trial_data, modify) {
if ((l1_model_set$wi_factors)) {
(ss) # nothing to do
}
if ((modify)) {
(glue("Current within-subject factor: {c_string(ss$wi_factors)}"), sep = "\n")
res <- (("No", "Yes"), = "Change within-subject factor?")
if (res == 2L) {
ss$wi_factors <- # clear out factor so that it is respecified
query_wi <-
} {
query_wi <-
}
} {
query_wi <-
}
if ((query_wi)) {
(ss) # nothing to do with specifying/changing within-subject factors
}
res <- (("No", "Yes"), = "Is this signal modulated by one or more within-subject factors?")
if (res == 1L) {
ss$wi_formula <- ss$wi_factors <- ss$wi_model <- # clear out within-subject specifications
(ss)
}
# if we arrive here, the user has asked us to specify a within-subject factor
(glue("Available within-subject factors: {c_string(l1_model_set$wi_factors)}\n"))
wi_formula <-
while ((wi_formula)) {
((
"\nSpecify the right-hand side of the within-subject model you wish to fit for the factors that modulate this signal.",
"For example, a one-factor model might look like: ~ trustee",
"And a two-factor additive model might look like: ~ trustee + share",
"Note that this syntax follows standard R model syntax. See ?lm for details."
), sep = "\n")
wi_formula <- (("Enter the model formula: "))
# always trim any LHS specification
wi_formula <- ("^[^~]*", "", wi_formula, perl = )
wi_formula <- ((wi_formula), error = (e) {
(e)
("Problem converting your syntax to formula. Try again\n")
()
})
wi_vars <- (wi_formula)
invalid_vars <- (wi_vars, l1_model_set$wi_factors)
if ((invalid_vars) > 0L) {
(glue("Invalid within-subject factors specified: {c_string(invalid_vars)}. Please try again.\n"))
wi_formula <-
}
}
# drop intercept from within-subject model to make contrasts more paradigmatic for L1 (i.e., avoid use of grand intercept)
ss$wi_formula <- ((wi_formula, ~ . - 1)) # always store formula as character to avoid storing environment
ss$wi_factors <- wi_vars
if (!checkmate::test_data_frame(ss$value)) {
("Signal value element is not a data.frame. Within-subject factors only setup to use data.frames right now.")
}
# repopulate trial data for this signal, including the selected wi_factors
ss$value <- get_value_df(ss, trial_data, wi_factors = wi_vars)
# fit dummy model to populate a set of dummy coefficients, then save those to the object
ss <- fit_wi_model(ss)
(ss)
}
get_value_df <- (signal, trial_data, wi_factors = ) {
trial_set <- get_trial_set_from_signal(signal, trial_data)
value_df <- trial_data %>%
dplyr::select(id, session, run_number, trial, !!wi_factors)
if (!(trial_set)) {
((trial_set) == (trial_data))
checkmate::assert_logical(trial_set)
value_df <- value_df[trial_set, , = ]
}
if (signal$value_type %in% ("unit", "number")) {
value_df$value <- signal$value_fixed
} if (signal$value_type == "parametric") {
value_df$value <- trial_data[signal$parametric_modulator]][trial_set]
} {
("Failing to populate value column")
}
(value_df)
}
