From 984a85a9fea2b06407b09bc42ffcb1faac04d291 Mon Sep 17 00:00:00 2001 From: Liang Zhang Date: Tue, 28 Nov 2023 18:08:40 +0800 Subject: [PATCH 1/3] Support three creativity related tasks Signed-off-by: Liang Zhang --- DESCRIPTION | 1 + NAMESPACE | 3 +++ R/aut.R | 72 +++++++++++++++++++++++++++++++++++++++++++++++++++++ R/dat.R | 39 +++++++++++++++++++++++++++++ R/vg.R | 34 +++++++++++++++++++++++++ man/aut.Rd | 39 +++++++++++++++++++++++++++++ man/dat.Rd | 27 ++++++++++++++++++++ man/vg.Rd | 30 ++++++++++++++++++++++ 8 files changed, 245 insertions(+) create mode 100644 R/aut.R create mode 100644 R/dat.R create mode 100644 R/vg.R create mode 100644 man/aut.Rd create mode 100644 man/dat.Rd create mode 100644 man/vg.Rd diff --git a/DESCRIPTION b/DESCRIPTION index d563142..b5382b4 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -27,6 +27,7 @@ Imports: Suggests: covr, mockery, + proxy, readr, roxygen2, testthat (>= 3.0.0), diff --git a/NAMESPACE b/NAMESPACE index 40a2f5e..da54ad0 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/aut.R b/R/aut.R new file mode 100644 index 0000000..d0fbf7a --- /dev/null +++ b/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" + ) +} diff --git a/R/dat.R b/R/dat.R new file mode 100644 index 0000000..72381e6 --- /dev/null +++ b/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")) +} diff --git a/R/vg.R b/R/vg.R new file mode 100644 index 0000000..2f90ea0 --- /dev/null +++ b/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) +} diff --git a/man/aut.Rd b/man/aut.Rd new file mode 100644 index 0000000..1be70f6 --- /dev/null +++ b/man/aut.Rd @@ -0,0 +1,39 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/aut.R +\name{aut} +\alias{aut} +\title{Alternate Uses Task (AUT)} +\usage{ +aut(data, .by = NULL, .input = NULL, .extra = NULL) +} +\arguments{ +\item{data}{Raw data of class \code{data.frame}.} + +\item{.by}{The column name(s) in \code{data} used to be grouped by. If set to +\code{NULL} (default), all data will be treated as from one subject and there +will be no grouping columns in the value returned.} + +\item{.input, .extra}{Each is a \code{\link[=list]{list()}} containing all the input variable +names and special values for certain variables. See more in the details +section.} +} +\value{ +An object with the same class as \code{data} contains following values: + +\item{originality}{The originality score.} + +\item{flexibility}{The flexibility score.} + +\item{fluency}{The fluency score.} +} +\description{ +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. +} diff --git a/man/dat.Rd b/man/dat.Rd new file mode 100644 index 0000000..39425eb --- /dev/null +++ b/man/dat.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/dat.R +\name{dat} +\alias{dat} +\title{Divergent Association Test} +\usage{ +dat(data, .by = NULL, .input = NULL, .extra = NULL) +} +\arguments{ +\item{data}{Raw data of class \code{data.frame}.} + +\item{.by}{The column name(s) in \code{data} used to be grouped by. If set to +\code{NULL} (default), all data will be treated as from one subject and there +will be no grouping columns in the value returned.} + +\item{.input, .extra}{Each is a \code{\link[=list]{list()}} containing all the input variable +names and special values for certain variables. See more in the details +section.} +} +\value{ +An object with the same class as \code{data} contains following values: +\item{score}{Divergent Association Test score.} +} +\description{ +Note you must input words distance matrix as a \code{dist} object for this +function to work. +} diff --git a/man/vg.Rd b/man/vg.Rd new file mode 100644 index 0000000..749f590 --- /dev/null +++ b/man/vg.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/vg.R +\name{vg} +\alias{vg} +\title{Verb Generation} +\usage{ +vg(data, .by = NULL, .input = NULL, .extra = NULL) +} +\arguments{ +\item{data}{Raw data of class \code{data.frame}.} + +\item{.by}{The column name(s) in \code{data} used to be grouped by. If set to +\code{NULL} (default), all data will be treated as from one subject and there +will be no grouping columns in the value returned.} + +\item{.input, .extra}{Each is a \code{\link[=list]{list()}} containing all the input variable +names and special values for certain variables. See more in the details +section.} +} +\value{ +An object with the same class as \code{data} contains following values: + +\item{score}{Average cosine distance between the generated verbs and the +given nouns.} +} +\description{ +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. +} From 62b3913ec3596adb0f0ba8887fbabd692f7eadb9 Mon Sep 17 00:00:00 2001 From: Liang Zhang Date: Tue, 28 Nov 2023 17:32:56 +0800 Subject: [PATCH 2/3] Add one test case for `dat()` Signed-off-by: Liang Zhang --- tests/testthat/_snaps/dat.md | 35 +++++++++++++++++++++++++++++++++++ tests/testthat/test-dat.R | 13 +++++++++++++ 2 files changed, 48 insertions(+) create mode 100644 tests/testthat/_snaps/dat.md create mode 100644 tests/testthat/test-dat.R diff --git a/tests/testthat/_snaps/dat.md b/tests/testthat/_snaps/dat.md new file mode 100644 index 0000000..24257ee --- /dev/null +++ b/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"] + } + ] + } + diff --git a/tests/testthat/test-dat.R b/tests/testthat/test-dat.R new file mode 100644 index 0000000..ec67b0c --- /dev/null +++ b/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") +}) From dafd40c81cc4171c658727e7740eff0a5746d2d3 Mon Sep 17 00:00:00 2001 From: Liang Zhang Date: Tue, 28 Nov 2023 17:35:06 +0800 Subject: [PATCH 3/3] NEWS bulletin Signed-off-by: Liang Zhang --- NEWS.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/NEWS.md b/NEWS.md index d66b004..11645c6 100644 --- a/NEWS.md +++ b/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.