td_bcm -> td_bcnm

DESCRIPTION

@@ -14,8 +14,8 @@ Imports:
   methods,
   grDevices
 Suggests: 
-    knitr,
-    rmarkdown,
-    testthat
+  knitr,
+  rmarkdown,
+  testthat
 Config/testthat/edition: 3
 VignetteBuilder: knitr

NAMESPACE

@@ -1,32 +1,33 @@
 # Generated by roxygen2: do not edit by hand
 
 S3method(coef,td_bclm)
-S3method(coef,td_bcm)
+S3method(coef,td_bcnm)
 S3method(coef,td_ipm)
-S3method(fitted,td_bcm)
+S3method(fitted,td_bcnm)
 S3method(fitted,td_ipm)
-S3method(logLik,td_bcm)
+S3method(logLik,td_bcnm)
 S3method(logLik,td_ipm)
 S3method(plot,td_um)
 S3method(predict,td_bclm)
-S3method(predict,td_bcm)
+S3method(predict,td_bcnm)
 S3method(predict,td_ipm)
 S3method(print,td_bclm)
-S3method(print,td_bcm)
+S3method(print,td_bcnm)
 S3method(print,td_fn)
 S3method(print,td_ipm)
-S3method(residuals,td_bcm)
+S3method(residuals,td_bcnm)
 S3method(residuals,td_ipm)
 export(AUC)
 export(ED50)
 export(adj_amt_indiffs)
 export(kirby_score)
 export(nonsys)
 export(td_bclm)
-export(td_bcm)
+export(td_bcnm)
 export(td_fn)
 export(td_ipm)
 export(wileyto_score)
+importFrom(grDevices,rgb)
 importFrom(graphics,lines)
 importFrom(graphics,points)
 importFrom(graphics,title)

R/data-docs.R

@@ -1,6 +1,6 @@
 #' Binary choice data for a single participant
 #' 
-#' 70 binary choices made by a single participant. Along with the columns required by \code{td_bcm}, the reaction time (\code{rt}) is recorded.
+#' 70 binary choices made by a single participant. Along with the columns required by \code{td_bcnm}, the reaction time (\code{rt}) is recorded.
 #' @name td_bc_single_ptpt
 #' @docType data
 #' @author Isaac Kinley \email{isaac.kinley@gmail.com}
@@ -10,7 +10,7 @@ NULL
 
 #' Binary choice data for a study
 #' 
-#' Data from 421 participants, who each made 70 binary choices. Along with the columns required by \code{td_bcm}, the reaction time (\code{rt}) is recorded. Participants are identified by the alphnumeric code in the \code{id} column.
+#' Data from 421 participants, who each made 70 binary choices. Along with the columns required by \code{td_bcnm}, the reaction time (\code{rt}) is recorded. Participants are identified by the alphnumeric code in the \code{id} column.
 #' @name td_bc_study
 #' @docType data
 #' @author Isaac Kinley \email{isaac.kinley@gmail.com}

R/generics.R

@@ -1,6 +1,6 @@
 
 #' @export
-print.td_bcm <- function(x, ...) {
+print.td_bcnm <- function(x, ...) {
   cat(sprintf('\nTemporal discounting binary choice model\n\n'))
   cat(sprintf('Discount function: %s, with coefficients:\n\n', x$config$discount_function$name))
   print(coef(x))
@@ -52,19 +52,19 @@ print.td_fn <- function(x, ...) {
 #' Model Predictions
 #'
 #' Generate predictions from a temporal discounting binary choice model
-#' @param object A temporal discounting binary choice model. See \code{td_bcm}.
+#' @param object A temporal discounting binary choice model. See \code{td_bcnm}.
 #' @param newdata Optionally, a data frame to use for prediction. If omitted, the data used to fit the model will be used for prediction.
 #' @param type The type of prediction required. As in predict.glm, \code{"link"} (default) and \code{"response"} give predictions on the scales of the linear predictors and response variable, respectively. \code{"indiff"} gives predicted indifference points. In this case, \code{newdata} needs only a \code{del} column.
 #' @param ... Additional arguments currently not used.
 #' @return A vector of predictions
 #' @examples
 #' \dontrun{
 #' data("td_bc_single_ptpt")
-#' mod <- td_bcm(td_bc_single_ptpt, discount_function = 'hyperbolic')
+#' mod <- td_bcnm(td_bc_single_ptpt, discount_function = 'hyperbolic')
 #' indiffs <- predict(mod, newdata = data.frame(del = 1:100), type = 'indiff')
 #' }
 #' @export
-predict.td_bcm <- function(object, newdata = NULL, type = c('link', 'response', 'indiff'), ...) {
+predict.td_bcnm <- function(object, newdata = NULL, type = c('link', 'response', 'indiff'), ...) {
 
   if (is.null(newdata)) {
     newdata <- object$data
@@ -118,7 +118,7 @@ predict.td_bclm <- function(object, newdata = NULL, type = c('indiff', 'link', '
   type <- match.arg(type)
   if (type == 'indiff') {
 
-    return(predict.td_bcm(object, newdata = newdata, type = type))
+    return(predict.td_bcnm(object, newdata = newdata, type = type))
 
   } else {
 
@@ -174,11 +174,11 @@ predict.td_ipm <- function(object, newdata = NULL, type = c('indiff', 'response'
 #' Get fitted values
 #' 
 #' Get fitted values of a temporal discounting binary choice model
-#' @param object An object of class \code{td_bcm}
+#' @param object An object of class \code{td_bcnm}
 #' @param ... Additional arguments currently not used.
 #' @return A named vector of fitted values
 #' @export
-fitted.td_bcm <- function(object, ...) {predict(object, type = 'response')}
+fitted.td_bcnm <- function(object, ...) {predict(object, type = 'response')}
 
 #' Get fitted values
 #' 
@@ -192,16 +192,16 @@ fitted.td_ipm <- function(object, ...) {predict(object)}
 #' Extract model coefficients
 #' 
 #' Get coefficients of a temporal discounting binary choice model
-#' @param object An object of class \code{td_bcm}
+#' @param object An object of class \code{td_bcnm}
 #' @param ... Additional arguments currently not used.
 #' @return A named vector of coefficients
 #' @export
-coef.td_bcm <- function(object, ...) {object$optim$par}
+coef.td_bcnm <- function(object, ...) {object$optim$par}
 
 #' Extract model coefficients
 #' 
 #' Get coefficients of a temporal discounting binary choice model
-#' @param object An object of class \code{td_bcm}
+#' @param object An object of class \code{td_bcnm}
 #' @param df_par Boolean specifying whether the coefficients returned should be the parameters of a discount function (versus the beta parameters from the regression)
 #' @param ... Additional arguments currently not used.
 #' @return A named vector of coefficients
@@ -251,12 +251,12 @@ coef.td_ipm <- function(object, ...) {object$optim$par}
 #' Residuals from temporal discounting model
 #'
 #' Get residuals from a temporal discounting binary choice model
-#' @param object A temporal discounting binary choice model. See \code{td_bcm}.
+#' @param object A temporal discounting binary choice model. See \code{td_bcnm}.
 #' @param type The type of residuals to be returned. See \code{residuals.glm}.
 #' @param ... Additional arguments currently not used.
 #' @return A vector of residuals
 #' @export
-residuals.td_bcm <- function(object, type = c('deviance', 'pearson', 'response'), ...) {
+residuals.td_bcnm <- function(object, type = c('deviance', 'pearson', 'response'), ...) {
 
   # args <- list(...)
   # type <- args$type
@@ -278,7 +278,7 @@ residuals.td_bcm <- function(object, type = c('deviance', 'pearson', 'response')
 #' Residuals from temporal discounting model
 #'
 #' Get residuals from a temporal discounting indifference point model
-#' @param object A temporal discounting model. See \code{td_bcm}.
+#' @param object A temporal discounting model. See \code{td_bcnm}.
 #' @param type The type of residuals to be returned. See \code{residuals.nls}.
 #' @param ... Additional arguments currently not used.
 #' @return A vector of residuals
@@ -311,9 +311,9 @@ residuals.td_ipm <- function(object, type = c('response', 'pearson'), ...) {
 #' Extract log-likelihood
 #' 
 #' Compute log-likelihood for a temporal discounting binary choice model.
-#' @param mod An object of class \code{td_bcm}
+#' @param mod An object of class \code{td_bcnm}
 #' @export
-logLik.td_bcm <- function(mod) {
+logLik.td_bcnm <- function(mod) {
   p <- laplace_smooth(predict(mod, type = 'response'))
   x <- mod$data$imm_chosen
   val <- sum(ll(p, x))
@@ -493,7 +493,7 @@ plot.td_um <- function(x, type = c('summary', 'endpoints', 'link'), legend = T,
         # Plot of probabilities and data against linear predictors
 
         # Get score range
-        if (is(x, 'td_bcm')) {
+        if (is(x, 'td_bcnm')) {
           score_func <- do.call(get_score_func_frame, x$config)
           scores <- score_func(x$data, coef(x))
         } else if (is(x, 'td_bclm')) {
@@ -509,7 +509,7 @@ plot.td_um <- function(x, type = c('summary', 'endpoints', 'link'), legend = T,
              ...)
         # Plot probabilities
         plotting_scores <- seq(-lim, lim, length.out = 1000)
-        if (is(x, 'td_bcm')) {
+        if (is(x, 'td_bcnm')) {
           prob_func <- do.call(get_prob_func_frame, x$config)
           p <- prob_func(plotting_scores, coef(x))
         } else if (is(x, 'td_bclm')) {

R/methods.R

@@ -8,7 +8,7 @@
 #' @examples
 #' \dontrun{
 #' data("td_bc_single_ptpt")
-#' mod <- td_bcm(td_bc_single_ptpt)
+#' mod <- td_bcnm(td_bc_single_ptpt)
 #' print(ED50(mod))
 #' }
 #' @export
@@ -49,7 +49,7 @@ ED50 <- function(mod, val_del = NULL) {
 #' @examples
 #' \dontrun{
 #' data("td_bc_single_ptpt")
-#' mod <- td_bcm(td_bc_single_ptpt)
+#' mod <- td_bcnm(td_bc_single_ptpt)
 #' print(AUC(mod))
 #' }
 #' @export
@@ -104,13 +104,13 @@ AUC <- function(mod, min_del = 0, max_del = NULL, val_del = NULL, verbose = T, .
 #'  \item C1: No indifference point can exceed the previous by more than 0.2
 #'  \item C2: Last indifference point must be lower than first by at least 0.1
 #' }
-#' @param obj Either a \code{data.frame} with columns \code{indiff} and \code{del}, or a discounting model of class \code{td_bcm} or \code{td_ipm}, fit using the \code{"model-free"} discount function.
+#' @param obj Either a \code{data.frame} with columns \code{indiff} and \code{del}, or a discounting model of class \code{td_bcnm} or \code{td_ipm}, fit using the \code{"model-free"} discount function.
 #' @returns Named logical vector specifying whether nonsystematic discounting is exhibited according to C1/C2.
 #' @examples
 #' \dontrun{
 #' # On a model
 #' data("td_bc_single_ptpt")
-#' mod <- td_bcm(td_bc_single_ptpt, discount_function = 'model-free')
+#' mod <- td_bcnm(td_bc_single_ptpt, discount_function = 'model-free')
 #' any(nonsys(mod))
 #' 
 #' # On a dataframe
@@ -127,7 +127,7 @@ nonsys <- function(obj) {
     require_columns(obj, c('indiff', 'del'))
     indiffs <- obj$indiff
     delays <- obj$del
-  } else if (inherits(obj, c('td_bcm', 'td_ipm'))) {
+  } else if (inherits(obj, c('td_bcnm', 'td_ipm'))) {
     if (obj$config$discount_function$name != 'model-free') {
       stop('Discount function must be "model-free" to check for non-systematic discounting.')
     } else {
@@ -137,7 +137,7 @@ nonsys <- function(obj) {
       delays <- as.numeric(gsub('del_', '', names(cf)))
     }
   } else {
-    stop('Input must be a data.frame or a model of class td_bcm or td_ipm.')
+    stop('Input must be a data.frame or a model of class td_bcnm or td_ipm.')
   }
 
   idx <- order(delays)

R/td_bcm.R → R/td_bcnm.R

@@ -12,11 +12,11 @@
 #' @param optim_args Additional arguments to pass to \code{optim()}. Default is \code{list(silent = T)}.
 #' @param silent Boolean (true by default). The call to \code{optim()} occurs within a \code{try()} wrapper. The value of \code{silent} is passed along to \code{try()}.
 #' @param ... Additional arguments to provide finer-grained control over the model configuration.
-#' @return An object of class \code{td_bcm} with components \code{data} (containing the data used for fitting), \code{config} (containing the internal configuration of the model, including the \code{discount_function}), and \code{optim} (the output of \code{optim()}).
+#' @return An object of class \code{td_bcnm} with components \code{data} (containing the data used for fitting), \code{config} (containing the internal configuration of the model, including the \code{discount_function}), and \code{optim} (the output of \code{optim()}).
 #' @examples
 #' \dontrun{
 #' data("td_bc_single_ptpt")
-#' mod <- td_bcm(td_bc_single_ptpt, discount_function = "hyperbolic", fixed_ends = T)
+#' mod <- td_bcnm(td_bc_single_ptpt, discount_function = "hyperbolic", fixed_ends = T)
 #' # Custom discount function
 #' custom_discount_function <- td_fn(
 #'   name = 'custom',
@@ -25,10 +25,10 @@
 #'   par_lims = list(k = c(0, Inf), b = c(0, 1)),
 #'   ED50 = function(p) 'non-analytic'
 #' )
-#' mod <- td_bcm(td_bc_single_ptpt, discount_function = custom_discount_function, fit_err_rate = T)
+#' mod <- td_bcnm(td_bc_single_ptpt, discount_function = custom_discount_function, fit_err_rate = T)
 #' }
 #' @export
-td_bcm <- function(
+td_bcnm <- function(
     data,
     discount_function = c('all',
                           'hyperbolic',
@@ -138,7 +138,7 @@ td_bcm <- function(
   best_crit <- Inf
   best_mod <- list()
   cand_mod <- list(data = data)
-  class(cand_mod) <- c('td_bcm', 'td_um')
+  class(cand_mod) <- c('td_bcnm', 'td_um')
   for (cand_fn in cand_fns) {
     config <- args
     config$discount_function <- cand_fn

R/td_fn.R

@@ -13,7 +13,7 @@
 #' @examples 
 #' \dontrun{
 #' data("td_bc_single_ptpt")
-#' mod <- td_bcm(td_bc_single_ptpt, discount_function = "hyperbolic", fixed_ends = T)
+#' mod <- td_bcnm(td_bc_single_ptpt, discount_function = "hyperbolic", fixed_ends = T)
 #' # Custom discount function
 #' custom_discount_function <- td_fn(
 #'   name = 'custom',
@@ -22,7 +22,7 @@
 #'   par_lims = list(k = c(0, Inf), b = c(0, 1)),
 #'   ED50 = function(...) 'non-analytic'
 #' )
-#' mod <- td_bcm(td_bc_single_ptpt, discount_function = custom_discount_function, fit_err_rate = T)
+#' mod <- td_bcnm(td_bc_single_ptpt, discount_function = custom_discount_function, fit_err_rate = T)
 #' }
 #' @export
 td_fn <- function(predefined = c('hyperbolic',

R/tempodisco-package.R

@@ -2,4 +2,5 @@
 #' @importFrom stats optim predict qlogis residuals integrate coef BIC AIC glm binomial fitted approx predict.glm
 #' @importFrom graphics lines points title
 #' @importFrom methods is
+#' @importFrom grDevices rgb
 NULL

README.md

@@ -29,7 +29,7 @@ Additionally, 2 other discount functions are tested: a "model-free" function in
 
 ## Example usage
 
-### Fitting binary choice models: `td_bcm` and `td_bclm`
+### Fitting binary choice models: `td_bcnm` and `td_bclm`
 
 To fit a binary choice model, we need data from a single participant formatted as follows:
 
@@ -48,13 +48,13 @@ Here, each row corresponds to a difference decision. *val_imm* specifies the val
 From here, we can fit a binary choice model:
 
 ```R
-mod <- td_bcm(td_bc_single_ptpt)
+mod <- td_bcnm(td_bc_single_ptpt)
 ```
 
 By default, all of the discount functions above are tested. If we are interested in only a subset of these, we can specify them as follows:
 
 ```R
-mod <- td_bcm(td_bc_single_ptpt, discount_function = c('hyperbolic', 'exponential'))
+mod <- td_bcnm(td_bc_single_ptpt, discount_function = c('hyperbolic', 'exponential'))
 ```
 
 From here, we can plot the model and get various useful pieces of information: