version 0.3.0

cran · Nov 14, 2023 · fbfec0d · fbfec0d
1 parent c67442c
commit fbfec0d
Show file tree

Hide file tree

Showing 22 changed files with 374 additions and 38 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Package: beezdiscounting
 Title: Behavioral Economic Easy Discounting
-Version: 0.2.0
-Date: 2023-11-02
+Version: 0.3.0
+Date: 2023-11-14
 Authors@R: 
     person("Brent", "Kaplan", email = "bkaplan.ku@gmail.com", role = c("aut", "cre", "cph"),
            comment = c(ORCID = "0000-0002-3758-6776"))
@@ -20,7 +20,7 @@ Depends: R (>= 2.10)
 Imports: dplyr, gtools, magrittr, psych, stringr, tidyr
 LazyData: true
 NeedsCompilation: no
-Packaged: 2023-11-02 17:46:55 UTC; brent
+Packaged: 2023-11-14 21:49:54 UTC; brent
 Author: Brent Kaplan [aut, cre, cph] (<https://orcid.org/0000-0002-3758-6776>)
 Repository: CRAN
-Date/Publication: 2023-11-02 19:00:02 UTC
+Date/Publication: 2023-11-14 22:40:02 UTC
diff --git a/MD5 b/MD5
@@ -1,33 +1,40 @@
-d33cb3984eb9a08d4bd5d9ee0637142e *DESCRIPTION
-5522e33eb88c512bfc1d08830eccf3d7 *NAMESPACE
-fda5ee2f3e8df853ee075bcf8940e215 *NEWS.md
-ab9f1299ec0c841ad4f924117d252f9e *R/beezdiscounting-package.R
-cd069940a1562dcc7adb05799ad427a8 *R/five.fivetrial.R
-d56ba418257b7705fadf017b4995c626 *R/fivetrial.R
+d5f450c1f607626c18ea9cfba9c82448 *DESCRIPTION
+342530d95ad4b766e49b7677528929d8 *NAMESPACE
+0ef00a31a908b6a98dd7929264b4eb84 *NEWS.md
+3e6057f8f13c934dbeacc735cac3b3b1 *R/beezdiscounting-package.R
+83389fa41fca7c90365b22949a5b85f9 *R/five.fivetrial_dd.R
+2e8675631127528847c1269e68036233 *R/five.fivetrial_pd.R
+1bee5e182cdfc1e578475450a31b6f3e *R/fivetrial.R
 9894fe75ea7a66300b487b4837c8d30f *R/mcq.R
 61db9a8cc0978926481fc46c55acca12 *R/mcq27.R
 2c4b07c6df0f02b1043041b0daf9bf22 *R/sysdata.rda
 b56ff2b193ecba52f9ec7f3b10cca008 *R/utils-pipe.R
 d916bcf04673165715fe983294b3deb0 *R/utils.R
-d3370e31b3e7dd81a8a9b37347df2042 *README.md
+64856f39312cf53585c4f0843112f0c0 *README.md
 ea124a494ad7922985532ad3b308e4d5 *build/partial.rdb
-64187c42c1e51d09730a0c46f1e17295 *data/five.fivetrial.rda
+5761877b984f869ad59040f83ebbc25b *data/five.fivetrial_dd.rda
+8615198f52cac43ab1a638d6dd0b611a *data/five.fivetrial_pd.rda
 71ddc0b43cc6405100ef6606e996d6e7 *data/mcq27.rda
 db865a9dedc30063e4865e0493bfa7c5 *inst/5.5_Trial_Discounting_Template_1k.qsf
 d9ad748b67535601df5f2c23bd0ef2ad *inst/CITATION
-7f8f1853ab58cfe884a3c8a040e21e2d *man/ans_dd.Rd
+d6fe4e3f3879ab6b636db1cb8ad992d7 *man/ans_dd.Rd
+fbe6ec487156dbff0caea203c2bb9918 *man/ans_pd.Rd
 c6297fe0132f141edb3f784594217b08 *man/beezdiscounting-package.Rd
-adadeb20c1caae90a0a6b3b6e725c750 *man/calc_dd.Rd
-ba13fc31ec0115299c550462d7b205c2 *man/five.fivetrial.Rd
+80f4cf80ce0895b7083a039b4d4d26c4 *man/calc_dd.Rd
+81cdc236d15ee9041f3d89d72a07cb27 *man/calc_pd.Rd
+8d0f911d17cbb3f94fe88b5714e07175 *man/five.fivetrial_dd.Rd
+c8fb1499940617c08e9185ab68aad600 *man/five.fivetrial_pd.Rd
 28926d9e3a31876cc148a7e422ea0cf7 *man/generate_data_mcq.Rd
 7a46e4c5a7346fecea7adcbf37b03186 *man/inn.Rd
 e9ae858d6314fd3f23551d3debc89634 *man/long_to_wide_mcq.Rd
 8c0548d2c0392d16bc57a3ba08d90f85 *man/long_to_wide_mcq_excel.Rd
 795ba03a0c6138f9c081a62a46331ffe *man/mcq27.Rd
 8f4aad003a999fae004ba9361f9a99d6 *man/pipe.Rd
-815143364b15c4a8479ded940898f2cd *man/score_dd.Rd
+3116fde558785a0dc0a007e27b660cba *man/score_dd.Rd
 1be2a8451941d0321de8f8f9f12890bf *man/score_mcq27.Rd
 c08b4be1371c67dd13a071fca064ca6b *man/score_one_mcq27.Rd
-07ba486fcdc7eaa0294f756f20f280df *man/timing_dd.Rd
+08957df8391b0439c806b52d750f4818 *man/score_pd.Rd
+65559d83c565dcf643f7a8fd17912ba3 *man/timing_dd.Rd
+e25a935467bc508f57c6ce700ad63ee0 *man/timing_pd.Rd
 8f1c66ed27d00bf88894f84bb9df0c1b *man/wide_to_long_mcq.Rd
 b91ee494fc68133e1bc2c0f79646ad0d *man/wide_to_long_mcq_excel.Rd
diff --git a/NAMESPACE b/NAMESPACE
@@ -2,13 +2,17 @@
 
 export("%>%")
 export(ans_dd)
+export(ans_pd)
 export(calc_dd)
+export(calc_pd)
 export(generate_data_mcq)
 export(long_to_wide_mcq)
 export(long_to_wide_mcq_excel)
 export(score_dd)
 export(score_mcq27)
+export(score_pd)
 export(timing_dd)
+export(timing_pd)
 export(wide_to_long_mcq)
 export(wide_to_long_mcq_excel)
 importFrom(magrittr,"%>%")

diff --git a/NEWS.md b/NEWS.md
@@ -1,3 +1,20 @@
+# beezdiscounting 0.3.0
+
+## New features
+
+* Add functions for scoring 5.5 trial probability discounting task (from the Qualtrics template) including: `calc_pd()`
+(and `score_pd()`, `timing_pd()`, and `ans_pd`).
+
+## Minor fix
+
+* Subsetting issue is fixed in `score_dd()` that would unintentionally drop all rows if both conditions were `FALSE`.
+
+## Other changes
+
+* Rename example data from `five.fivetrial` to `five.fivetrial_dd` for delay discounting.
+
+* Add example data `five.fivetrial_pd` for probability discounting.
+
 # beezdiscounting 0.2.0
 
 ## New features

diff --git a/R/beezdiscounting-package.R b/R/beezdiscounting-package.R
@@ -10,4 +10,5 @@ utils::globalVariables(c(
     "attentionflag", "kval", "ed50",
     "Attend-SS", "Attend-LL", "magnitude",
     "question", "measure", "value",
-    "subjectid", "questionid"))
+    "subjectid", "questionid",
+    "hval", "ep50"))
diff --git a/R/five.fivetrial.R → R/five.fivetrial_dd.R b/R/five.fivetrial.R → R/five.fivetrial_dd.R
@@ -1,7 +1,7 @@
-#' Example Qualtrics output from the 5.5 trial discounting template.
+#' Example Qualtrics output from the 5.5 trial delay discounting template.
 #'
-#' An example dataset containing four participants' data (two typical discounting 
+#' An example dataset containing four participants' data (two typical discounting
 #' patterns and two patterns suggesting potential misattention to the task).
 #'
 #' @format Example Qualtrics output
-"five.fivetrial"
+"five.fivetrial_dd"
diff --git a/R/five.fivetrial_pd.R b/R/five.fivetrial_pd.R
@@ -0,0 +1,6 @@
+#' Example Qualtrics output from the 5.5 trial probability discounting template.
+#'
+#' An example dataset containing four participants' data.
+#'
+#' @format Example Qualtrics output
+"five.fivetrial_pd"
diff --git a/R/fivetrial.R b/R/fivetrial.R
@@ -7,7 +7,7 @@
 #' @export
 #'
 #' @examples
-#' score_dd(five.fivetrial)
+#' score_dd(five.fivetrial_dd)
 score_dd <- function(df) {
   dd1 <- df |>
     dplyr::select(ResponseId, paste0("I", seq(1, 31, by = 2)), "AttendSS" = `Attend-SS`,
@@ -31,8 +31,10 @@ score_dd <- function(df) {
     ddframe$kval[ddframe$index == indexes[i]] <- ifelse (ddframe$response[ddframe$index == indexes[i]] %in% "ss",
                                                             recodess[i], recodell[i])
   }
-  ddframe <- ddframe[-which(ddframe$ResponseId %in% ddframe$ResponseId[ddframe$index %in% "AttendSS"] & ddframe$index %in% "I1"), ]
-  ddframe <- ddframe[-which(ddframe$ResponseId %in% ddframe$ResponseId[ddframe$index %in% "AttendLL"] & ddframe$index %in% "I31"), ]
+  subset_indices <- which(ddframe$ResponseId %in% ddframe$ResponseId[ddframe$index %in% "AttendSS"] & ddframe$index %in% "I1")
+  ddframe <- if (length(subset_indices) != 0) ddframe[-subset_indices, ] else ddframe
+  subset_indices <- which(ddframe$ResponseId %in% ddframe$ResponseId[ddframe$index %in% "AttendLL"] & ddframe$index %in% "I31")
+  ddframe <- if (length(subset_indices) != 0) ddframe[-subset_indices, ] else ddframe
   ddframe$attentionflag[ddframe$index %in% "AttendSS" & ddframe$response %in% "ss"] <- "Yes"
   ddframe$attentionflag[ddframe$index %in% "AttendLL" & ddframe$response %in% "ll"] <- "Yes"
   ddframe$attentionflag[ddframe$ResponseId %in% ddframe$ResponseId[which(ddframe$attentionflag == "Yes")]]  <- "Yes"
@@ -54,7 +56,7 @@ score_dd <- function(df) {
 #' @export
 #'
 #' @examples
-#' timing_dd(five.fivetrial)
+#' timing_dd(five.fivetrial_dd)
 timing_dd <- function(df) {
   timing <- dplyr::select(df, ResponseId, dplyr::contains("Timing"))
   colnames(timing) <- gsub("Timing_First Click", "firstclick", colnames(timing))
@@ -91,7 +93,7 @@ timing_dd <- function(df) {
 #' @export
 #'
 #' @examples
-#' ans_dd(five.fivetrial)
+#' ans_dd(five.fivetrial_dd)
 ans_dd <- function(df) {
   ans <- df |>
     dplyr::select(ResponseId, paste0("I", 1:31), dplyr::starts_with("Attend")) |>
@@ -111,10 +113,133 @@ ans_dd <- function(df) {
 #' @export
 #'
 #' @examples
-#' calc_dd(five.fivetrial)
+#' calc_dd(five.fivetrial_dd)
 calc_dd <- function(df) {
     return(dplyr::left_join(timing_dd(df), ans_dd(df), by = c("ResponseId", "index")) |>
            dplyr::left_join(dplyr::select(score_dd(df), ResponseId, attentionflag, kval, ed50),
                             by = c("ResponseId")) |>
            dplyr::arrange(ResponseId, q))
 }
+
+#' Score 5.5 trial probability discounting from Qualtrics template
+#'
+#' @param df A dataframe containing all the columns
+#'
+#' @return A dataframe with id, indexes, response, h value, and effective probability 50.
+#' @importFrom stats complete.cases
+#' @export
+#'
+#' @examples
+#' score_pd(five.fivetrial_pd)
+score_pd <- function(df) {
+  pd1 <- df |>
+    dplyr::select(ResponseId, paste0("I", seq(1, 31, by = 2)), "AttendSS" = `Attend-SS`,
+                  "AttendLL" = `Attend-LL`) |>
+    dplyr::select(-dplyr::contains("Timing"), -dplyr::contains("DO"))
+  pdframe <- pd1 |>
+    tidyr::pivot_longer(cols = 2:ncol(pd1), names_to = "index", values_to = "response") %>%
+    dplyr::filter(complete.cases(.)) |>
+    dplyr::mutate(response = ifelse(stringr::str_detect(response, "for sure"), "sc", "lu"))
+  pdframe$hval <- NA
+  pdframe$attentionflag <- "No"
+  indexes <- paste0("I", seq(1, 31, by = 2))
+  recodesc <- c("99", "56.72448", "35.510562", "19.390719", "10.173495", "5.290003",
+                "2.934058", "1.601445", "0.850963", "0.457604", "0.256064",
+                "0.134491", "0.074501", "0.035898", "0.022875", "0.012403")
+  recodelu <- c("80.628779", "43.714986", "27.856777", "13.422618", "7.435436", "3.905279",
+                "2.185294", "1.175139", "0.624436", "0.340825", "0.189036",
+                "0.098295", "0.051571", "0.028161", "0.017629", "0.010101")
+  for (i in seq_along(indexes)) {
+    if (length(pdframe$response[pdframe$index == indexes[i]]) == 0) next
+    pdframe$hval[pdframe$index == indexes[i]] <- ifelse (pdframe$response[pdframe$index == indexes[i]] %in% "sc",
+                                                         recodesc[i], recodelu[i])
+  }
+  subset_indices <- which(pdframe$ResponseId %in% pdframe$ResponseId[pdframe$index %in% "AttendSS"] & pdframe$index %in% "I1")
+  pdframe <- if (length(subset_indices) != 0) pdframe[-subset_indices, ] else pdframe
+  subset_indices <- which(pdframe$ResponseId %in% pdframe$ResponseId[pdframe$index %in% "AttendLL"] & pdframe$index %in% "I31")
+  pdframe <- if (length(subset_indices) != 0) pdframe[-subset_indices, ] else pdframe
+  pdframe$attentionflag[pdframe$index %in% "AttendSS" & pdframe$response %in% "sc"] <- "Yes"
+  pdframe$attentionflag[pdframe$index %in% "AttendLL" & pdframe$response %in% "lu"] <- "Yes"
+  pdframe$attentionflag[pdframe$ResponseId %in% pdframe$ResponseId[which(pdframe$attentionflag == "Yes")]]  <- "Yes"
+  pdframe$hval[pdframe$index %in% "AttendSS" & pdframe$response %in% "lu"] <- "99"
+  pdframe$hval[pdframe$index %in% "AttendLL" & pdframe$response %in% "sc"] <- "0.010101"
+
+  pdframe$hval <- as.numeric(pdframe$hval)
+  pdframe$ep50 <- 1/pdframe$hval
+  return(pdframe)
+
+}
+
+#' Extract timing metrics from 5.5 trial probability discounting from Qualtrics template
+#'
+#' @param df A dataframe containing all the columns
+#'
+#' @return A dataframe with ResponseId, indexes, values and timing
+#' @importFrom stats complete.cases
+#' @export
+#'
+#' @examples
+#' timing_pd(five.fivetrial_pd)
+timing_pd <- function(df) {
+  timing <- dplyr::select(df, ResponseId, dplyr::contains("Timing"))
+  colnames(timing) <- gsub("Timing_First Click", "firstclick", colnames(timing))
+  colnames(timing) <- gsub("Timing_Last Click", "lastclick", colnames(timing))
+  colnames(timing) <- gsub("Timing_Page Submit", "pagesubmit", colnames(timing))
+  colnames(timing) <- gsub("Timing_Click Count", "totalclicks", colnames(timing))
+  timing <- timing |>
+    tidyr::pivot_longer(cols = 2:ncol(timing), names_to = "question", values_to = "value") %>%
+    dplyr::filter(complete.cases(.))
+  timing$q <- NA
+  timing$question <- gsub("Attend-LL", "AttendLL", timing$question)
+  timing$question <- gsub("Attend-SS", "AttendSS", timing$question)
+  timing <- timing |>
+    tidyr::separate(question, c("index", "measure"), sep = "-") |>
+    tidyr::spread(measure, value)
+  timing$q[timing$index %in% c("I16")] <- 1
+  timing$q[timing$index %in% c("I8", "I24")] <- 2
+  timing$q[timing$index %in% c("I4", "I12", "I20", "I28")] <- 3
+  timing$q[timing$index %in% c("I2", "I6", "I10", "I14", "I18", "I22", "I26", "I30")] <- 4
+  timing$q[timing$index %in% c("I1", "I3", "I5", "I7", "I9", "I11", "I13", "I15", "I17", "I19",
+                               "I21", "I23", "I25", "I27", "I29", "I31")] <- 5
+  timing$q[timing$index %in% c("AttendSS", "AttendLL")] <- 6
+  timing[4:7] <- sapply(timing[4:7], as.numeric)
+  return(dplyr::arrange(timing, ResponseId, q))
+
+}
+
+#' Converts answers from 5.5 trial probability discounting from Qualtrics template
+#'
+#' @param df A dataframe containing all the columns
+#'
+#' @return A dataframe with the ResponseId, index, and response (sc or lu).
+#' @importFrom stats complete.cases
+#' @export
+#'
+#' @examples
+#' ans_pd(five.fivetrial_pd)
+ans_pd <- function(df) {
+  ans <- df |>
+    dplyr::select(ResponseId, paste0("I", 1:31), dplyr::starts_with("Attend")) |>
+    dplyr::select(-dplyr::contains("Timing"), -dplyr::contains("_DO")) %>%
+    tidyr::pivot_longer(cols = 2:ncol(.), names_to = "index", values_to = "response") %>%
+    dplyr::filter(complete.cases(.)) |>
+    dplyr::mutate(response = ifelse(stringr::str_detect(response, "for sure"), "sc", "lu"))
+  ans$index <- gsub("-", "", ans$index)
+  return(ans)
+}
+
+#' Calculate scores, answers, and timing for 5.5 trial probability discounting from Qualtrics template
+#'
+#' @param df A dataframe containing all the columns from the template.
+#'
+#' @return A dataframe with h/ep50 values, answers, timing
+#' @export
+#'
+#' @examples
+#' calc_pd(five.fivetrial_pd)
+calc_pd <- function(df) {
+  return(dplyr::left_join(timing_pd(df), ans_pd(df), by = c("ResponseId", "index")) |>
+           dplyr::left_join(dplyr::select(score_pd(df), ResponseId, attentionflag, hval, ep50),
+                            by = c("ResponseId")) |>
+           dplyr::arrange(ResponseId, q))
+}