R/glue_filenames_by.R

In tsostarics/stimulist:

#' Glue filenames by glue string
#'
#' Requires the {glue} package. Similar syntax to add_stimuli_by(), but here
#' you're specifying a glue string for a particular stimulus. Glue strings
#' utilize {brackets} to evaluate an expression within a string. In this case,
#' you'll be replacing a label in brackets with its value in the
#' completed_experiment data frame.
#'
#' This must be run after using fill_experiment.
#'
#' @param design Experiment design
#' @param ... A list of formulas mapping stimuli to glue-formatted strings
#' @param as_levels Whether to use the labels or integers representing each level
#'
#' @export
#'
#' @importFrom rlang enexprs enquos enexpr syms ensyms
#' @importFrom stringr str_extract str_match_all
glue_filenames_by <- function(design, ..., as_levels = FALSE) {
  requireNamespace("glue", quietly = TRUE)
  formulas <- lapply(enexprs(...), as.character)
  if (!all(vapply(formulas, length, 1L) == 3L)) {
    stop("You must provide formulas of the style `varname ~ string`")
  } else if (any(vapply(formulas, function(x) any(grepl(" [*+] ", x)), T))) {
    stop("RHS of formula should only have a single string, not multiple with + or *.")
  } else if (rlang::is_na(design[["complete_experiment"]])) {
    stop("You need to run fill_experiment() before glue_filenames_by()")
  }

  for (f in formulas) {
    glue_vars <- .extract_gluevars(f[[3L]])
    glue_dependencies <- .check_orderings(design, glue_vars)
    fill_vars <- .get_containing_vars(design[["complete_experiment"]], f[[2L]])
    glue_strings <- .expand_glue(f[[3L]], glue_dependencies, fill_vars, as_levels)


    for (i in seq_len(length(fill_vars))) {
      design[["complete_experiment"]][[fill_vars[i]]] <- glue::glue(glue_strings[i], .envir = design[["complete_experiment"]])
    }

    # Save glue formula in the stimuli so save_stimuli_template can use it too
    which_stimulus <- vapply(design[['stimuli']], function(x) f[[2L]] %in% names(x), TRUE)
    glueformula <- f
    # Retain the as_levels setting generated by .expand_glue, but remove the _1s
    if (as_levels)
      glueformula[[3L]] <- gsub(r"(_1))})",r"())})",glue_strings[[1L]])
    attr(design[['stimuli']][which_stimulus][[1L]], 'glueformula') <- glueformula
  }
  .set_glue_printmsg(design, formulas, as_levels)
}

.expand_glue <- function(glue_string, varname, to_fill, as_levels) {
  bracket <- ifelse(as_levels, r"())})", "}")
  extracted <- str_extract(to_fill, "_\\d+$")
  appendages <- paste0(ifelse(is.na(extracted), "", extracted), bracket)
  appendages <- ifelse(is.na(appendages), "", appendages)
  regex_pattern <- paste0("(?<=", paste0(varname, collapse = "|"), r"()})")
  ordered_gluestrings <-
    vapply(appendages,
      function(x) {
        gsub(regex_pattern, x, glue_string, perl = TRUE)
      },
      FUN.VALUE = "char",
      USE.NAMES = FALSE
    )

  if (as_levels) {
    glue_vars <- paste0(.extract_gluevars(glue_string), collapse = "|")
    factor_regex <- paste0(r"({(?=)", glue_vars, ")")
    closing_regex <- paste0(r"((?<=)", glue_vars, ")}")
    ordered_gluestrings <-
      vapply(ordered_gluestrings,
        function(x) {
          gsub(closing_regex,
            r"())})",
            gsub(factor_regex,
              r"({as.integer(factor()",
              x,
              perl = TRUE
            ),
            perl = TRUE
          )
        },
        FUN.VALUE = "char",
        USE.NAMES = FALSE
      )
  }
  ordered_gluestrings
}

.extract_gluevars <- function(gluestring) {
  str_match_all(gluestring, "\\{([^\\}]+)\\}")[[1L]][, 2L]
}

.check_orderings <- function(design, gluevars) {
  have_orderings <- vapply(gluevars, function(x) x %in% names(design[["orderings"]]), TRUE)
  gluevars[have_orderings]
}

.set_glue_printmsg <- function(design, formulas, as_levels) {
  new_printmsg <- paste0(
    attr(design[["complete_experiment"]], "printmsg"),
    "Filenames specified"
  )
  new_printmsg <- ifelse(as_levels,
    paste0(
      new_printmsg,
      " (using numbering by alphabetical order of levels):\n"
    ),
    paste0(
      new_printmsg,
      ":\n"
    )
  )
  formula_specifications <-
    vapply(
      formulas,
      function(x) paste0("  ", x[[2]], " values glued with: ", x[[3]], "\n"), "char"
    )
  new_printmsg <-
    paste0(new_printmsg, paste0(formula_specifications, collapse = ""))
  attr(design[["complete_experiment"]], "printmsg") <- new_printmsg
  design
}

.get_containing_vars <- function(completed_df, var) {
  output <- names(completed_df)[grepl(var, names(completed_df))]
  if (identical(output, character(0))) {
    stop(paste0("`", var, "` not found in the experimental design."))
  }
  output
}