From 17086f6e5313c34603f05192c3a88ea90eb3a129 Mon Sep 17 00:00:00 2001 From: Isaac Kinley Date: Sat, 31 Aug 2024 15:13:33 -0400 Subject: [PATCH] Fix documentation --- NAMESPACE | 1 + R/generics.R | 4 ++-- R/methods.R | 1 + R/td_bclm.R | 14 +++++++------- R/utils.R | 20 +++++++++++++++++++- man/ED50.Rd | 2 ++ man/kirby_score.Rd | 2 +- man/predict.td_ipm.Rd | 6 +++--- man/wileyto_score.Rd | 23 +++++++++++++++++++++++ tests/testthat/test-utils.R | 6 ++++++ 10 files changed, 65 insertions(+), 14 deletions(-) create mode 100644 man/wileyto_score.Rd diff --git a/NAMESPACE b/NAMESPACE index 23861cc..be220db 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -25,6 +25,7 @@ export(td_bclm) export(td_bcm) export(td_fn) export(td_ipm) +export(wileyto_score) importFrom(graphics,lines) importFrom(graphics,points) importFrom(graphics,title) diff --git a/R/generics.R b/R/generics.R index f6dc7d4..1080645 100644 --- a/R/generics.R +++ b/R/generics.R @@ -117,8 +117,8 @@ predict.td_bclm <- function(object, newdata = NULL, type = c('indiff', 'link', ' #' #' Generate predictions from a temporal discounting indifference point model #' @param object A temporal discounting indifference point model. See \code{td_ipm}. -#' @param del Vector of delays for which to predict indifference points. If omitted, the data used to fit the model will be used for prediction. -#' @param newdata Optionally, a data frame to use for prediction. This overrides the \code{del} argument. +#' @param newdata A data frame to use for prediction. If omitted, the data used to fit the model will be used for prediction. +#' @param type Type of prediction, either \code{'indiff'} (indifference points) or \code{'response'} (whether the participants would is predicted to choose the immediate (1) or delayed reward (0)) #' @param ... Additional arguments currently not used. #' @return A vector of predictions #' @examples diff --git a/R/methods.R b/R/methods.R index b054fce..a965ab4 100644 --- a/R/methods.R +++ b/R/methods.R @@ -3,6 +3,7 @@ #' #' Compute the median effective delay #' @param mod A temporal discounting model. +#' @param val_del Delayed value, if applicable (i.e., if magnitude effects are accounted for) #' @return A vector of predictions #' @examples #' \dontrun{ diff --git a/R/td_bclm.R b/R/td_bclm.R index 7f2b8e2..9e81689 100644 --- a/R/td_bclm.R +++ b/R/td_bclm.R @@ -74,16 +74,16 @@ td_bclm <- function(data, # By negative derivative derivative_1 <- 1/2*(p['.B_tA'] - (p['.B_tA']^2*data$del + 2*p['.B_tA']*p['.B_xA']*data$val_del + p['.B_I']*p['.B_tA'] - 2*p['.B_tA']*p['.B_xR'])/sqrt(p['.B_tA']^2*data$del^2 + 4*p['.B_xA']^2*data$val_del^2 + p['.B_I']^2 - 4*p['.B_I']*p['.B_xR'] + 4*p['.B_xR']^2 + 2*(p['.B_I']*p['.B_tA'] - 2*p['.B_tA']*p['.B_xR'])*data$del + 4*(p['.B_tA']*p['.B_xA']*data$del + p['.B_I']*p['.B_xA'] + 2*p['.B_xA']*p['.B_xR'])*data$val_del))/(p['.B_xA']*data$val_del) derivative_2 <- 1/2*(p['.B_tA'] + (p['.B_tA']^2*data$del + 2*p['.B_tA']*p['.B_xA']*data$val_del + p['.B_I']*p['.B_tA'] - 2*p['.B_tA']*p['.B_xR'])/sqrt(p['.B_tA']^2*data$del^2 + 4*p['.B_xA']^2*data$val_del^2 + p['.B_I']^2 - 4*p['.B_I']*p['.B_xR'] + 4*p['.B_xR']^2 + 2*(p['.B_I']*p['.B_tA'] - 2*p['.B_tA']*p['.B_xR'])*data$del + 4*(p['.B_tA']*p['.B_xA']*data$del + p['.B_I']*p['.B_xA'] + 2*p['.B_xA']*p['.B_xR'])*data$val_del))/(p['.B_xA']*data$val_del) - if (derivative_1[1] < 0 & derivative_2[1] > 0) { + + derivative_1 <- mean(derivative_1, na.rm = T) + derivative_2 <- mean(derivative_2, na.rm = T) + if (derivative_1 < 0 & derivative_2 > 0) { out <- out_1 - } else if (derivative_1[1] > 0 & derivative_2[1] < 0) { + } else if (derivative_1 > 0 & derivative_2 < 0) { out <- out_2 } else { - # Which starts closest to 1? - first_val_1 <- 1/2*(p['.B_tA']*0 + p['.B_I'] - 2*p['.B_xR'] - sqrt(p['.B_tA']^2*0^2 + 4*p['.B_xA']^2*data$val_del^2 + p['.B_I']^2 - 4*p['.B_I']*p['.B_xR'] + 4*p['.B_xR']^2 + 2*(p['.B_I']*p['.B_tA'] - 2*p['.B_tA']*p['.B_xR'])*0 + 4*(p['.B_tA']*p['.B_xA']*0 + p['.B_I']*p['.B_xA'] + 2*p['.B_xA']*p['.B_xR'])*data$val_del))/(p['.B_xA']*data$val_del) - first_val_2 <- 1/2*(p['.B_tA']*0 + p['.B_I'] - 2*p['.B_xR'] + sqrt(p['.B_tA']^2*0^2 + 4*p['.B_xA']^2*data$val_del^2 + p['.B_I']^2 - 4*p['.B_I']*p['.B_xR'] + 4*p['.B_xR']^2 + 2*(p['.B_I']*p['.B_tA'] - 2*p['.B_tA']*p['.B_xR'])*0 + 4*(p['.B_tA']*p['.B_xA']*0 + p['.B_I']*p['.B_xA'] + 2*p['.B_xA']*p['.B_xR'])*data$val_del))/(p['.B_xA']*data$val_del) - - closest <- which.min(c(abs(first_val_1 - 1) - abs(first_val_2 - 1))) + # Which is within a reasonable range? + closest <- which.min(c(abs(mean(out_1, na.rm = T) - 0.5) - abs(mean(out_2, na.rm = T) - 0.5))) if (closest == 1) { out <- out_1 } else { diff --git a/R/utils.R b/R/utils.R index 28a6e4b..58a08d6 100644 --- a/R/utils.R +++ b/R/utils.R @@ -184,7 +184,7 @@ adj_amt_indiffs <- function(data, block_indic = 'del', order_indic = NULL) { #' Kirby score a questionnaire #' -#' Score a set of responses according to the method of Kirby (1999). This is described in detail in \url{https://doi.org/10.1007/s40614-016-0070-9}{Kaplan et al. (2016)}. +#' Score a set of responses according to the method of Kirby et al. (1999). This is described in detail in \url{https://doi.org/10.1007/s40614-016-0070-9}{Kaplan et al. (2016)}. #' @param data Responses to score. #' @param discount_function Should \eqn{k} values be computed according to the hyperbolic or exponential discount function? The original method uses the hyperbolic, but in principle the exponential is also possible. #' @return An object of class \code{td_ipm}. @@ -238,3 +238,21 @@ kirby_score <- function(data, discount_function = c('hyperbolic', 'exponential') return(mod) } + +#' Wileyto score a questionnaire +#' +#' Score a set of responses according to the method of \url{https://doi.org/10.3758/BF03195548}{Wileyto et al. (2004)}. This function is a thin wrapper to \code{td_bclm}. +#' @param data Responses to score. +#' @returns An object of class \code{td_bclm}. +#' @examples +#' \dontrun{ +#' data("td_bc_single_ptpt") +#' mod <- wileyto_score(data) +#' } +#' @export +wileyto_score <- function(data) { + + mod <- td_bclm(data, model = 'hyperbolic.1') + return(mod) + +} \ No newline at end of file diff --git a/man/ED50.Rd b/man/ED50.Rd index d21dca1..897cd2b 100644 --- a/man/ED50.Rd +++ b/man/ED50.Rd @@ -8,6 +8,8 @@ ED50(mod, val_del = NULL) } \arguments{ \item{mod}{A temporal discounting model.} + +\item{val_del}{Delayed value, if applicable (i.e., if magnitude effects are accounted for)} } \value{ A vector of predictions diff --git a/man/kirby_score.Rd b/man/kirby_score.Rd index 9279bff..9ed01b1 100644 --- a/man/kirby_score.Rd +++ b/man/kirby_score.Rd @@ -15,7 +15,7 @@ kirby_score(data, discount_function = c("hyperbolic", "exponential")) An object of class \code{td_ipm}. } \description{ -Score a set of responses according to the method of Kirby (1999). This is described in detail in \url{https://doi.org/10.1007/s40614-016-0070-9}{Kaplan et al. (2016)}. +Score a set of responses according to the method of Kirby et al. (1999). This is described in detail in \url{https://doi.org/10.1007/s40614-016-0070-9}{Kaplan et al. (2016)}. } \examples{ \dontrun{ diff --git a/man/predict.td_ipm.Rd b/man/predict.td_ipm.Rd index 58b3794..65bf862 100644 --- a/man/predict.td_ipm.Rd +++ b/man/predict.td_ipm.Rd @@ -4,14 +4,14 @@ \alias{predict.td_ipm} \title{Model Predictions} \usage{ -\method{predict}{td_ipm}(object, del = NULL, newdata = NULL, ...) +\method{predict}{td_ipm}(object, newdata = NULL, type = c("indiff", "response"), ...) } \arguments{ \item{object}{A temporal discounting indifference point model. See \code{td_ipm}.} -\item{del}{Vector of delays for which to predict indifference points. If omitted, the data used to fit the model will be used for prediction.} +\item{newdata}{A data frame to use for prediction. If omitted, the data used to fit the model will be used for prediction.} -\item{newdata}{Optionally, a data frame to use for prediction. This overrides the \code{del} argument.} +\item{type}{Type of prediction, either \code{'indiff'} (indifference points) or \code{'response'} (whether the participants would is predicted to choose the immediate (1) or delayed reward (0))} \item{...}{Additional arguments currently not used.} } diff --git a/man/wileyto_score.Rd b/man/wileyto_score.Rd new file mode 100644 index 0000000..1f69703 --- /dev/null +++ b/man/wileyto_score.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{wileyto_score} +\alias{wileyto_score} +\title{Wileyto score a questionnaire} +\usage{ +wileyto_score(data) +} +\arguments{ +\item{data}{Responses to score.} +} +\value{ +An object of class \code{td_bclm}. +} +\description{ +Score a set of responses according to the method of \url{https://doi.org/10.3758/BF03195548}{Wileyto et al. (2004)}. This function is a thin wrapper to \code{td_bclm}. +} +\examples{ +\dontrun{ +data("td_bc_single_ptpt") +mod <- wileyto_score(data) +} +} diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 55cc913..0b80063 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -49,4 +49,10 @@ test_that('inconsistent responses produce a warning', { set.seed(123) td_bc_single_ptpt$imm_chosen <- round(runif(nrow(td_bc_single_ptpt))) expect_warning(kirby_score(td_bc_single_ptpt)) +}) + +### wileyto_score +data("td_bc_single_ptpt") +test_that('wileyto scoring', { + expect_s3_class(wileyto_score(td_bc_single_ptpt), 'td_bclm') }) \ No newline at end of file