Merge branch 'release/2.6.3'

psychelzh · Jan 13, 2024 · be778d3 · be778d3
2 parents c868175 + 7028899
commit be778d3
Show file tree

Hide file tree

Showing 62 changed files with 558 additions and 695 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Type: Package
 Package: preproc.iquizoo
 Title: Utility Functions for Data Processing of Iquizoo Games
-Version: 2.6.2
+Version: 2.6.3
 Authors@R:
     person("Liang", "Zhang", , "[email protected]", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0001-9041-1150"))

diff --git a/NEWS.md b/NEWS.md
@@ -1,3 +1,15 @@
+# preproc.iquizoo 2.6.3
+
+## Breaking Changes
+
+* Added `"cutoff"` method in response time outlier detection, which is used in `srt()` now.
+* Added `"transform"` method in response time outlier detection, which was stated to be used but the code was not right. Now it is used as default if not specified.
+
+## Miscellaneous
+
+* Let internal function `calc_sdt()` throw error when type column is not valid.
+* Enhanced code quality of internal functions.
+
 # preproc.iquizoo 2.6.2
 
 ## Bug Fixes

diff --git a/R/bart.R b/R/bart.R
@@ -13,15 +13,14 @@ bart <- function(data, .by = NULL, .input = NULL, .extra = NULL) {
   .input <- list(name_feedback = "feedback", name_nhit = "nhit") |>
     update_settings(.input)
   data |>
-    group_by(pick(all_of(.by))) |>
     summarise(
       mean_pumps = .data[[.input$name_nhit]] |>
         # keep not exploded trials only
         .subset(.data[[.input$name_feedback]] == 1) |>
         mean(),
       mean_pumps_raw = mean(.data[[.input$name_nhit]]),
       num_explosion = sum(.data[[.input$name_feedback]] == 0),
-      .groups = "drop"
+      .by = all_of(.by)
     ) |>
     vctrs::vec_restore(data)
 }
diff --git a/R/bps.R b/R/bps.R
@@ -6,10 +6,15 @@
 #' @template common
 #' @template options
 #' @return An object with the same class as `data` contains following values:
+#'
 #'   \item{pc}{Percent of correct responses.}
-#'   \item{p_sim_foil}{Percent of similar responses for "foil" stimuli.}
-#'   \item{p_sim_lure}{Percent of similar responses for "lure" stimuli.}
+#'
 #'   \item{p_sim_target}{Percent of similar responses for "target" stimuli.}
+#'
+#'   \item{p_sim_lure}{Percent of similar responses for "lure" stimuli.}
+#'
+#'   \item{p_sim_foil}{Percent of similar responses for "foil" stimuli.}
+#'
 #'   \item{bps_score}{BPS score.}
 #' @export
 bps <- function(data, .by = NULL, .input = NULL, .extra = NULL) {
@@ -29,16 +34,14 @@ bps <- function(data, .by = NULL, .input = NULL, .extra = NULL) {
     filter(.data[[.input$name_phase]] == .extra$phase_test)
   merge(
     data_test_phase |>
-      group_by(pick(all_of(.by))) |>
       summarise(
         pc = mean(.data[[.input$name_acc]] == 1),
-        .groups = "drop"
+        .by = all_of(.by)
       ),
     data_test_phase |>
-      group_by(pick(all_of(c(.by, .input$name_type)))) |>
       summarise(
         p_sim = mean(.data[[.input$name_resp]] == .extra$resp_sim),
-        .groups = "drop"
+        .by = all_of(c(.by, .input$name_type))
       ) |>
       pivot_wider(
         names_from = all_of(.input$name_type),

diff --git a/R/counts.R b/R/counts.R
@@ -52,16 +52,14 @@ countcorrect <- function(data, .by = NULL, .input = NULL, .extra = NULL) {
         unnest(all_of(.input$name_acc))
     }
     data <- data |>
-      group_by(pick(all_of(.by))) |>
       summarise(
         # `NA` might be produced in parsing characters and should be ignored
         "{.input$name_nc}" := sum(.data[[.input$name_acc]] == 1, na.rm = TRUE),
-        .groups = "drop"
+        .by = all_of(.by)
       )
   }
   data |>
-    group_by(pick(all_of(.by))) |>
-    summarise(nc = sum(.data[[.input$name_nc]]), .groups = "drop") |>
+    summarise(nc = sum(.data[[.input$name_nc]]), .by = all_of(.by)) |>
     vctrs::vec_restore(data)
 }
 
@@ -72,20 +70,18 @@ countcorrect2 <- function(data, .by = NULL, .input = NULL, .extra = NULL) {
     update_settings(.input)
   if (!all(has_name(data, .input[c("name_nc", "name_ne")]))) {
     data <- data |>
-      group_by(pick(all_of(.by))) |>
       summarise(
         "{.input$name_nc}" := sum(.data[[.input$name_acc]] == 1),
         "{.input$name_ne}" := sum(.data[[.input$name_acc]] == 0),
-        .groups = "drop"
+        .by = all_of(.by)
       )
   }
   data |>
-    group_by(pick(all_of(.by))) |>
     summarise(
       nc_cor = sum(
         .data[[.input$name_nc]] - .data[[.input$name_ne]]
       ),
-      .groups = "drop"
+      .by = all_of(.by)
     ) |>
     vctrs::vec_restore(data)
 }
@@ -96,13 +92,12 @@ sumweighted <- function(data, .by = NULL, .input = NULL, .extra = NULL) {
   .input <- list(name_weight = "nstim", name_acc = "acc") |>
     update_settings(.input)
   data |>
-    group_by(pick(all_of(.by))) |>
     summarise(
       nc_weighted = sum(
         .data[[.input$name_weight]] *
           (.data[[.input$name_acc]] == 1)
       ),
-      .groups = "drop"
+      .by = all_of(.by)
     ) |>
     vctrs::vec_restore(data)
 }
@@ -113,10 +108,9 @@ sumscore <- function(data, .by = NULL, .input = NULL, .extra = NULL) {
   .input <- list(name_score = "score") |>
     update_settings(.input)
   data |>
-    group_by(pick(all_of(.by))) |>
     summarise(
       nc_score = sum(as.numeric(.data[[.input$name_score]])),
-      .groups = "drop"
+      .by = all_of(.by)
     ) |>
     vctrs::vec_restore(data)
 }
diff --git a/R/cpt.R b/R/cpt.R
@@ -29,13 +29,11 @@ cpt <- function(data, .by = NULL, .input = NULL, .extra = NULL) {
     # some tests records stimuli not presented
     filter(.data[[.input$name_acc]] != -1) |>
     mutate(
-      # standardize stimuli type
-      type_cor = if_else(
-        .data[[.input$name_type]] == .extra$type_signal,
-        "s", "n"
-      ),
       # remove rt from non-signal trials
-      rt_cor = ifelse(.data$type_cor == "s", .data[[.input$name_rt]], NA)
+      rt_cor = if_else(
+        .data[[.input$name_type]] == .extra$type_signal,
+        .data[[.input$name_rt]], NA
+      )
     )
   merge(
     calc_spd_acc(
@@ -46,9 +44,10 @@ cpt <- function(data, .by = NULL, .input = NULL, .extra = NULL) {
     ),
     calc_sdt(
       data_cor,
+      .extra$type_signal,
       by = .by,
       name_acc = .input$name_acc,
-      name_type = "type_cor"
+      name_type = .input$name_type
     ),
     by = .by
   ) |>

diff --git a/R/driving.R b/R/driving.R
@@ -32,11 +32,10 @@ driving <- function(data, .by = NULL, .input = NULL, .extra = NULL) {
         )
       )
     ) |>
-    group_by(pick(all_of(.by))) |>
     summarise(
       still_ratio = sum(.data$still_dur_yellow) /
         sum(.data[[.input$name_yellow_dur]]),
-      .groups = "drop"
+      .by = all_of(.by)
     ) |>
     vctrs::vec_restore(data)
 }
diff --git a/R/fname.R b/R/fname.R
@@ -50,7 +50,6 @@ fname <- function(data, .by = NULL, .input = NULL, .extra = NULL) {
       )
   }
   data |>
-    group_by(pick(all_of(.by))) |>
     summarise(
       iln = .data[[.input$name_acc]] |>
         .subset(.data[[.input$name_phase]] == .extra$phase_name) |>
@@ -63,7 +62,7 @@ fname <- function(data, .by = NULL, .input = NULL, .extra = NULL) {
       .data[[.input$name_acc]] |>
         .subset(.data[[.input$name_phase]] == .extra$phase_cmbn) |>
         parse_combined(),
-      .groups = "drop"
+      .by = all_of(.by)
     ) |>
     mutate(
       fnn = .data$iln + .data$crn,

diff --git a/R/igt.R b/R/igt.R
@@ -18,13 +18,12 @@ igt <- function(data, .by = NULL, .input = NULL, .extra = NULL) {
   .extra <- list(pools_advantage = c("a", "b")) |>
     update_settings(.extra)
   data |>
-    group_by(pick(all_of(.by))) |>
     summarise(
       sum_outcome = sum(.data[[.input$name_outcome]]),
       perc_good = mean(
         .data[[.input$name_pool]] %in% .extra$pools_advantage
       ),
-      .groups = "drop"
+      .by = all_of(.by)
     ) |>
     vctrs::vec_restore(data)
 }
diff --git a/R/jlo.R b/R/jlo.R
@@ -15,41 +15,48 @@
 #'     errors.}
 #' @export
 jlo <- function(data, .by = NULL, .input = NULL, .extra = NULL) {
-  .input <- list(name_resp = "resp", name_angle = "angle", name_acc = "acc") |>
+  .input <- list(
+    name_resp = "resp",
+    name_angle = "angle",
+    name_acc = "acc"
+  ) |>
     update_settings(.input)
-  .extra <- list(resp_anticlock = "left", resp_clockwise = "right") |>
+  .extra <- list(
+    resp_anticlock = "left",
+    resp_clockwise = "right"
+  ) |>
     update_settings(.extra)
   data |>
     mutate(
-      resp_angle = stringr::str_split(.data[[.input$name_resp]], "-") |>
-        purrr::map_dbl(
-          ~ sum(
-            case_match(
-              .,
-              !!!purrr::map2(
-                .extra[c("resp_anticlock", "resp_clockwise")],
-                c(1, -1),
-                new_formula
-              )
-            ) * 6
-          )
-        ),
-      resp_err_raw = abs(
-        .data$resp_angle - .data[[.input$name_angle]]
-      ) %% 180, # ignore vector head and tail
-      resp_err = ifelse(
-        .data$resp_err_raw > 90, # measure errors as acute angles
-        180 - .data$resp_err_raw,
-        .data$resp_err_raw
+      resp_err = calc_angle_err(
+        .data[[.input$name_resp]],
+        .data[[.input$name_angle]],
+        resp_anti = .extra$resp_anticlock,
+        resp_clock = .extra$resp_clockwise
       )
     ) |>
-    group_by(pick(all_of(.by))) |>
     summarise(
       nc = sum(.data[[.input$name_acc]] == 1),
       mean_ang_err = mean(.data$resp_err),
       # make sure it is between 0 and 1
       mean_log_err = mean(log2(.data$resp_err / 90 + 1)),
-      .groups = "drop"
+      .by = all_of(.by)
     ) |>
     vctrs::vec_restore(data)
 }
+
+# helper function
+calc_angle_err <- function(resp, angle, resp_anti, resp_clock) {
+  calc_resp_angle <- function(resp) {
+    # each rotation is set as 6 degree
+    (sum(resp == resp_anti) - sum(resp == resp_clock)) * 6
+  }
+  resp_angle <- purrr::map_dbl(
+    stringr::str_split(resp, "-"),
+    calc_resp_angle
+  )
+  # ignore vector head and tail
+  err_raw <- abs(resp_angle - angle) %% 180
+  # measure errors as acute angles
+  if_else(err_raw > 90, 180 - err_raw, err_raw)
+}
diff --git a/R/locmem.R b/R/locmem.R
@@ -28,12 +28,11 @@ locmem <- function(data, .by = NULL, .input = NULL, .extra = NULL) {
       .keep = "unused"
     ) |>
     unnest("dist") |>
-    group_by(pick(all_of(.by))) |>
     summarise(
       nc_loc = sum(.data$dist == 0),
       mean_dist_err = mean(.data$dist),
       mean_log_err = mean(log(.data$dist + 1)),
-      .groups = "drop"
+      .by = all_of(.by)
     ) |>
     vctrs::vec_restore(data)
 }
@@ -54,10 +53,9 @@ locmem2 <- function(data, .by = NULL, .input = NULL, .extra = NULL) {
         .keep = "unused"
       ) |>
       unnest("acc_order") |>
-      group_by(pick(all_of(.by))) |>
       summarise(
         nc_order = sum(.data$acc_order == 1),
-        .groups = "drop"
+        .by = all_of(.by)
       ),
     by = .by
   ) |>

diff --git a/R/london.R b/R/london.R
@@ -20,12 +20,11 @@ london <- function(data, .by = NULL, .input = NULL, .extra = NULL) {
     update_settings(.input)
   merge(
     data |>
-      group_by(pick(all_of(.by))) |>
       summarise(
         prop_perfect = mean(
           .data[[.input$name_stepsused]] == .data[[.input$name_minmove]]
         ),
-        .groups = "drop"
+        .by = all_of(.by)
       ),
     calc_spd_acc(
       data,

diff --git a/R/nback.R b/R/nback.R
@@ -102,14 +102,7 @@ dualnback <- function(data, .by = NULL, .input = NULL, .extra = NULL) {
                         type_signal = "same") {
   data_cor <- data |>
     # filler trials should be ignored
-    filter(!.data[[name_type]] == type_filler) |>
-    mutate(
-      # standardize stimuli type
-      type_cor = if_else(
-        .data[[name_type]] == type_signal,
-        "s", "n"
-      )
-    )
+    filter(!.data[[name_type]] == type_filler)
   merge(
     calc_spd_acc(
       data_cor,
@@ -119,9 +112,10 @@ dualnback <- function(data, .by = NULL, .input = NULL, .extra = NULL) {
     ),
     calc_sdt(
       data_cor,
+      type_signal,
       by = by,
       name_acc = name_acc,
-      name_type = "type_cor"
+      name_type = name_type
     ),
     by = by
   ) |>

diff --git a/R/nle.R b/R/nle.R
@@ -18,11 +18,10 @@ nle <- function(data, .by = NULL, .input = NULL, .extra = NULL) {
       err = abs(.data[[.input$name_number]] -
                   .data[[.input$name_resp]])
     ) |>
-    group_by(pick(all_of(.by))) |>
     summarise(
       mean_abs_err = mean(.data$err),
       mean_log_err = mean(log(.data$err + 1)),
-      .groups = "drop"
+      .by = all_of(.by)
     ) |>
     vctrs::vec_restore(data)
 }