R/utils.R

In psychelzh/dataproc.iquizoo: Utility Functions for Data Processing of Iquizoo Games

#' Calculate basic speed and accuracy scores
#'
#' This function calculates reaction time and accuracy scores, which are very
#' basic to most tests.
#'
#' A major part of behavior tests is the speed and accuracy metrics, which are
#' actually the only ones that any test collects. Based on these two metrics,
#' two basic groups of scores can be obtained. The first group contains the mean
#' and standard deviations of response times the number, and the second contains
#' the number and percent of correct responses.
#'
#' @template common
#' @param ... Other arguments passed to [check_outliers_rt()].
#' @param by The column name(s) in `data` used to be grouped by. If set to
#'   `NULL`, all data will be treated as from one subject.
#' @templateVar name_acc TRUE
#' @templateVar name_rt TRUE
#' @template names
#' @param rt_rm_out A logical value indicating if outliers should be removed
#'   from reaction time.
#' @param rt_unit The unit of response time in `data`.
#' @return A [tibble][tibble::tibble-package] contains the required scores.
#' @keywords internal
calc_spd_acc <- function(data, ...,
                         by = NULL, name_acc = "acc", name_rt = "rt",
                         rt_rm_out = TRUE, rt_unit = c("ms", "s")) {
  check_dots_used()
  rt_unit <- match.arg(rt_unit)
  # set reaction time unit to seconds for better value range
  if (rt_unit == "ms") data[[name_rt]] <- data[[name_rt]] / 1000
  if (rt_rm_out) {
    data <- data |>
      mutate(
        "{name_rt}" := if_else(
          check_outliers_rt(.data[[name_rt]], ...),
          NA, .data[[name_rt]]
        ),
        .by = all_of(by)
      )
  }
  data |>
    # rt of 0 means no response and should be converted as `NA
    mutate(na_if(.data[[name_rt]], 0)) |>
    summarise(
      nc = sum(.data[[name_acc]] == 1),
      pc = .data$nc / n(),
      pcsd = stats::sd(.data[[name_acc]] == 1),
      mrt = mean(.data[[name_rt]][.data[[name_acc]] == 1], na.rm = TRUE),
      mrt_all = mean(.data[[name_rt]], na.rm = TRUE),
      rtsd = stats::sd(
        .data[[name_rt]][.data[[name_acc]] == 1],
        na.rm = TRUE
      ),
      ies = .data$mrt / .data$pc,
      rcs = .data$pc / .data$mrt_all,
      lisas = case_when(
        .data$pc == 1 ~ .data$mrt,
        .data$pc == 0 ~ 0,
        TRUE ~ .data$mrt + (1 - .data$pc) / .data$pcsd * .data$rtsd
      ),
      .by = all_of(by)
    )
}

#' Signal Detection Theory
#'
#' Calculate sensitivity index and bias based on signal detection theory. The
#' correction for extreme proportions of zero and one is the "log-linear" rule
#' recommended by Hautus (1995).
#'
#' @template common
#' @param type_signal The type of signal stimuli. It should be one of the values
#'   in the `name_type` column of `data`.
#' @param ... For future extensions. Should be empty.
#' @param by The column name(s) in `data` used to be grouped by. If set to
#'   `NULL`, all data will be treated as from one subject.
#' @templateVar name_acc TRUE
#' @template names
#' @param name_type The column name of the `data` input whose values are the
#'   stimuli types. Based on `type_signal`, the other types of stimuli will be
#'   treated as non-signal stimuli.
#' @return A [tibble][tibble::tibble-package] contains sensitivity index and
#'   bias (and other temporary measures).
#' @keywords internal
calc_sdt <- function(data, type_signal, ...,
                     by = NULL, name_acc = "acc", name_type = "type") {
  check_dots_empty()
  if (!type_signal %in% data[[name_type]]) {
    abort("Signal type not found in data")
  }
  if (length(unique(data[[name_type]])) < 2) {
    abort("No non-signal stimuli found in data")
  }
  if (length(unique(data[[name_type]])) > 2) {
    warn(
      paste(
        "Found more than one types of non-signal stimuli in data,",
        "will treat all of them as non-signal"
      )
    )
  }
  data |>
    mutate(
      type_fac = factor(
        .data[[name_type]] == type_signal,
        labels = c("n", "s")
      )
    ) |>
    summarise(
      c = sum(.data[[name_acc]] == 1),
      e = n() - .data$c,
      .by = all_of(c(by, "type_fac"))
    ) |>
    mutate(
      across(
        all_of(c("c", "e")),
        list(
          p = ~ .x / (.data$c + .data$e),
          # log-linear rule of correction extreme proportion
          z = ~ stats::qnorm((.x + 0.5) / (.data$c + .data$e + 1))
        )
      )
    ) |>
    pivot_wider(
      names_from = "type_fac",
      values_from = c("c", "e", "c_p", "e_p", "c_z", "e_z")
    ) |>
    rename(
      hit = .data$c_p_s,
      fa = .data$e_p_n,
      miss = .data$e_p_s,
      cr = .data$c_p_n
    ) |>
    mutate(
      dprime = .data$c_z_s - .data$e_z_n,
      c = -(.data$c_z_s + .data$e_z_n) / 2,
      commissions = .data$e_n,
      omissions = .data$e_s
    )
}

#' Calculate threshold by staircase method
#'
#' Here we used the method suggested by Wetherill et al (1966).
#'
#' @param x The levels in data.
#' @return The mean threshold.
#' @keywords internal
calc_staircase_wetherill <- function(x) {
  find_reversals <- function(x) {
    find_peaks_val <- function(x) {
      mat <- pracma::findpeaks(x)
      if (is.null(mat)) {
        warn("Reversals not found from input", "no_reversals_found")
        return(NA_real_)
      }
      mat[, 1]
    }
    list(
      peaks = find_peaks_val(x),
      valleys = -find_peaks_val(-x)
    )
  }
  # remove repetitions in transformed method
  x <- rle(x)$values
  reversals <- find_reversals(x)
  reversals |>
    purrr::map(
      # keep equal number of peaks and valleys
      \(x) utils::tail(x, min(lengths(reversals)))
    ) |>
    purrr::list_c() |>
    mean()
}

#' Convert character responses
#'
#' Simple function converts character correctness to numeric one.
#'
#' @param x The character vector to be parsed.
#' @param delim Delimiter used to join correctness when forming the character.
#'   Usually is hyphen (i.e., `"-"`), which is the default.
#' @param convert_numeric A logical value indicating if the values should be
#'   converted to `numeric` ones.
#' @return A list of the parsed result, the same length as the input vector.
#' @keywords internal
parse_char_resp <- function(x, delim = "-", convert_numeric = TRUE) {
  parsed <- stringr::str_split(x, delim)
  if (convert_numeric) {
    parsed <- purrr::map(parsed, as.numeric)
  }
  parsed
}


#' Update settings with option settings
#'
#' Options are set in list can be tricky to update. This function makes partly
#' adding custom options work.
#'
#' @param origin The original settings.
#' @param updates The updates to settings
#' @return An update list of settings.
#' @keywords internal
update_settings <- function(origin, updates) {
  if (is.null(updates)) {
    return(origin)
  }
  utils::modifyList(origin, updates)
}

#' Outliers Detection for response time data
#'
#' @param x A vector of input reaction time data.
#' @param method The method used to detect outliers. If set to `"transform"`, a
#'   square root transformation is applied to the data before applying
#'   `"z_score"` method outlier detection, see Cousineau & Chartier (2010). If
#'   set to `"z_score"`, any value with absolute z-score larger than `threshold`
#'   is considered as outlier. If set to `"cutoff"`, the any value out of
#'   `threshold` range is considered as outlier.
#' @param threshold The threshold for determining whether a value is outlier or
#'   not. For `"transform"` and `"z_score"` method, the default is `2.5`. For
#'   `"cutoff"` method, the default is `c(0.2, Inf)`.
#' @return A logical vector of the detected outliers.
#' @keywords internal
check_outliers_rt <- function(x,
                              method = c("transform", "z_score", "cutoff"),
                              threshold = NULL) {
  method <- match.arg(method)
  if (is.null(threshold)) {
    threshold <- switch(method,
      cutoff = c(0.2, Inf), # assuming rt is in seconds
      transform = ,
      z_score = 2.5
    )
  }
  if (method == "transform") {
    x <- x |>
      scale(min(x, na.rm = TRUE), diff(range(x, na.rm = TRUE))) |>
      sqrt()
  }
  switch(method,
    cutoff = x < threshold[[1]] | x > threshold[[2]],
    transform = ,
    z_score = abs(scale(x)[, 1]) > threshold
  )
}