[WIP] Add creativity related functions

DESCRIPTION

@@ -27,6 +27,7 @@ Imports:
 Suggests:
     covr,
     mockery,
+    proxy,
     readr,
     roxygen2,
     testthat (>= 3.0.0),

NAMESPACE

@@ -2,6 +2,7 @@
 
 export(ant_alert)
 export(ant_orient)
+export(aut)
 export(bart)
 export(bps)
 export(capacity)
@@ -12,6 +13,7 @@ export(countcorrect)
 export(countcorrect2)
 export(cpt)
 export(crt)
+export(dat)
 export(driving)
 export(drm)
 export(dualnback)
@@ -40,6 +42,7 @@ export(sumweighted)
 export(switchcost)
 export(symncmp)
 export(synwin)
+export(vg)
 export(wrangle_data)
 import(dplyr)
 import(rlang)

NEWS.md

@@ -4,6 +4,10 @@
 
 * Added `wrangle_data()` and `preproc_data()` functions, which were previously in tarflow.iquizoo package.
 
+## New Features
+
+* Added support for three creativity related tasks.
+
 ## Bug Fixes
 
 * Fixed an edge case when `fit_numerosity()` will stuck in infinite loop.

R/aut.R

@@ -0,0 +1,72 @@
+#' Alternate Uses Task (AUT)
+#'
+#' The Alternate Uses Task (AUT) is a test of divergent thinking, which is a
+#' component of creativity. The test-taker is given a common object and asked
+#' to list as many uses for that object as they can think of. The test is
+#' scored based on the number of uses generated, the originality of the uses,
+#' the flexibility of the uses, and the fluency of the uses. The originality
+#' score is based on the number of participants who generated the same use for
+#' the object. The flexibility score is based on the number of categories of
+#' uses generated. The fluency score is based on the total number of uses
+#' generated.
+#'
+#' @template common
+#' @template options
+#' @return An object with the same class as `data` contains following values:
+#'
+#'   \item{originality}{The originality score.}
+#'
+#'   \item{flexibility}{The flexibility score.}
+#'
+#'   \item{fluency}{The fluency score.}
+#'
+#' @export
+aut <- function(data, .by = NULL, .input = NULL, .extra = NULL) {
+  .input <- list(
+    name_tool = "tool",
+    name_use = "use",
+    name_use_type = "use_type",
+    name_grader = "subj",
+    name_score_origin = "score_origin"
+  ) |>
+    update_settings(.input)
+  .extra <- list(
+    grade_types = data.frame(),
+    grade_scores = data.frame()
+  ) |>
+    update_settings(.extra)
+  data |>
+    left_join(
+      .extra$grade_types,
+      by = c(.input$name_tool, .input$name_use),
+      relationship = "many-to-many"
+    ) |>
+    left_join(
+      .extra$grade_scores,
+      by = c(.input$name_grader, .input$name_tool, .input$name_use_type),
+    ) |>
+    filter(.data[[.input$name_use_type]] != "0") |>
+    group_by(pick(all_of(c(.by, .input$name_grader, .input$name_tool)))) |>
+    summarise(
+      originality = sum(.data[[.input$name_score_origin]]),
+      flexibility = n_distinct(.data[[.input$name_use_type]]),
+      fluency = n(),
+      .groups = "drop_last"
+    ) |>
+    # average across tools
+    summarise(
+      across(
+        c("originality", "flexibility", "fluency"),
+        mean
+      ),
+      .groups = "drop_last"
+    ) |>
+    # average across graders
+    summarise(
+      across(
+        c("originality", "flexibility", "fluency"),
+        mean
+      ),
+      .groups = "drop"
+    )
+}

R/dat.R

@@ -0,0 +1,39 @@
+#' Divergent Association Test
+#'
+#' Note you must input words distance matrix as a `dist` object for this
+#' function to work.
+#'
+#' @template common
+#' @template options
+#' @return An object with the same class as `data` contains following values:
+#'   \item{score}{Divergent Association Test score.}
+#' @export
+dat <- function(data, .by = NULL, .input = NULL, .extra = NULL) {
+  if (!requireNamespace("proxy", quietly = TRUE)) {
+    stop("Please install the `proxy` package to use this function.")
+  }
+  .input <- list(name_words = "words") |>
+    update_settings(.input)
+  .extra <- list(
+    # only keep the first 7 words by default (Olson et al. 2021)
+    minimum = 7,
+    w2v = data.frame() # note this must be set by the user
+  ) |>
+    update_settings(.extra)
+  data |>
+    summarise(
+      score = .data[[.input$name_words]] |>
+        stringr::str_split_1("-") |>
+        get_dat_score(.extra$minimum, .extra$w2v),
+      .by = all_of(.by)
+    ) |>
+    vctrs::vec_restore(data)
+}
+
+get_dat_score <- function(words, minimum, w2v) {
+  w2v_matched <- w2v[match(words, rownames(w2v)), ]
+  if (nrow(w2v_matched) < minimum) {
+    return(NA_real_)
+  }
+  mean(proxy::dist(w2v_matched[seq_len(minimum), ], method = "cosine"))
+}

R/vg.R

@@ -0,0 +1,34 @@
+#' Verb Generation
+#'
+#' This test requires the user to generate a verb that is semantically related
+#' to each given noun. The score is the average cosine distance between the
+#' generated verb and the given nouns.
+#'
+#' @template common
+#' @template options
+#' @return An object with the same class as `data` contains following values:
+#'
+#'   \item{score}{Average cosine distance between the generated verbs and the
+#'     given nouns.}
+#' @export
+vg <- function(data, .by = NULL, .input = NULL, .extra = NULL) {
+  .input <- list(
+    name_noun = "noun",
+    name_verb = "verb",
+    name_dist = "dist_cos"
+  ) |>
+    update_settings(.input)
+  .extra <- list(
+    min_prop_miss = 0.2,
+    dists = data.frame() # note this must be set by the user
+  ) |>
+    update_settings(.extra)
+  data |>
+    left_join(.extra$dists, by = c(.input$name_noun, .input$name_verb)) |>
+    filter(mean(!is.na(.data[[.input$name_verb]])) >= .extra$min_prop_miss) |>
+    summarise(
+      score = mean(.data[[.input$name_dist]], na.rm = TRUE),
+      .by = all_of(.by)
+    ) |>
+    vctrs::vec_restore(data)
+}

tests/testthat/_snaps/dat.md

@@ -0,0 +1,35 @@
+# Basic test
+
+    {
+      "type": "list",
+      "attributes": {
+        "names": {
+          "type": "character",
+          "attributes": {},
+          "value": ["id", "score"]
+        },
+        "row.names": {
+          "type": "integer",
+          "attributes": {},
+          "value": [1, 2]
+        },
+        "class": {
+          "type": "character",
+          "attributes": {},
+          "value": ["data.frame"]
+        }
+      },
+      "value": [
+        {
+          "type": "integer",
+          "attributes": {},
+          "value": [1, 2]
+        },
+        {
+          "type": "double",
+          "attributes": {},
+          "value": [1.01973648, "NA"]
+        }
+      ]
+    }
+

tests/testthat/test-dat.R

@@ -0,0 +1,13 @@
+test_that("Basic test", {
+  data <- data.frame(id = 1:2, words = c("A-B-C-D-E-F-G", "A-I"))
+  dists <- withr::with_seed(
+    1,
+    {
+      nobs <- 7
+      mat <- matrix(rnorm(100 * nobs), nrow = nobs)
+      rownames(mat) <- LETTERS[1:nobs]
+    }
+  )
+  dat(data, .by = "id", .extra = list(w2v = mat)) |>
+    expect_snapshot_value(style = "json2")
+})