├── .Rbuildignore ├── .github └── workflows │ └── test-coverage.yaml ├── .gitignore ├── DESCRIPTION ├── NAMESPACE ├── R ├── dd_call_dd_analyze.R ├── dd_call_fit_dd_curves.R ├── dd_call_screen_options.R ├── dd_fit_bleichrodt.R ├── dd_fit_ebertprelec.R ├── dd_fit_exponential.R ├── dd_fit_greenmyerson.R ├── dd_fit_laibson.R ├── dd_fit_mazur.R ├── dd_fit_noise.R ├── dd_fit_rachlin.R ├── dd_fit_rodriguezlogue.R ├── dd_message_debug.R ├── dd_plot.R ├── dd_plot_cross_model.R ├── dd_plot_group.R ├── dd_plot_ind.R ├── dd_plot_ind_detailed.R ├── dd_plot_model.R ├── dd_probable_model.R ├── dd_screen_jb.R ├── dd_summary.R └── dd_utils.R ├── README.md ├── codecov.yml ├── demo ├── .gitignore ├── 00Index ├── test_grouped_fits.R ├── test_single_fits_ed50.R ├── test_single_fits_grouped.R ├── test_single_fits_grouped_ed50.R ├── test_single_fits_grouped_mbauc.R ├── test_single_fits_grouped_mbauc_log10.R ├── test_single_fits_mbauc.R ├── test_single_fits_mbauc_log10.R ├── test_single_fits_recovery.R └── test_single_fits_selection.R ├── discountingtools.Rproj ├── man ├── dd_analyze.Rd ├── dd_discount_func_bleichrodt_crdi.Rd ├── dd_discount_func_ebertprelec.Rd ├── dd_discount_func_exponential.Rd ├── dd_discount_func_greenmyerson.Rd ├── dd_discount_func_laibson.Rd ├── dd_discount_func_mazur.Rd ├── dd_discount_func_rachlin.Rd ├── dd_discount_func_rodriguezlogue.Rd ├── dd_discount_grad_bleichrodt_crdi.Rd ├── dd_discount_grad_exponential.Rd ├── dd_discount_grad_greenmyerson.Rd ├── dd_discount_grad_laibson.Rd ├── dd_discount_grad_mazur.Rd ├── dd_discount_grad_rachlin.Rd ├── dd_discount_grad_rodriguezlogue.Rd ├── dd_ed50_bleichrodt.Rd ├── dd_ed50_ebertprelec.Rd ├── dd_ed50_exponential.Rd ├── dd_ed50_greenmyerson.Rd ├── dd_ed50_laibson.Rd ├── dd_ed50_mazur.Rd ├── dd_ed50_rachlin.Rd ├── dd_ed50_rodriguezlogue.Rd ├── dd_fit_bleichrodt.Rd ├── dd_fit_ebertprelec.Rd ├── dd_fit_exponential.Rd ├── dd_fit_greenmyerson.Rd ├── dd_fit_laibson.Rd ├── dd_fit_mazur.Rd ├── dd_fit_noise.Rd ├── dd_fit_rachlin.Rd ├── dd_fit_rodriguezlogue.Rd ├── dd_grad_func_ebertprelec.Rd ├── dd_integrand_exponential_log10.Rd ├── dd_integrand_laibson_log10.Rd ├── dd_integrand_mazur_log10.Rd ├── dd_integrand_myersongreen_log10.Rd ├── dd_integrand_rachlin_log10.Rd ├── dd_integrand_rodriguezlogue.Rd ├── dd_integrand_rodriguezlogue_log10.Rd ├── dd_mbauc_bleichrodt.Rd ├── dd_mbauc_ebertprelec.Rd ├── dd_mbauc_exponential.Rd ├── dd_mbauc_greenmyerson.Rd ├── dd_mbauc_laibson.Rd ├── dd_mbauc_log10_bleichrodt.Rd ├── dd_mbauc_log10_ebertprelec.Rd ├── dd_mbauc_log10_exponential.Rd ├── dd_mbauc_log10_greenmyerson.Rd ├── dd_mbauc_log10_laibson.Rd ├── dd_mbauc_log10_mazur.Rd ├── dd_mbauc_log10_rachlin.Rd ├── dd_mbauc_log10_rodriguezlogue.Rd ├── dd_mbauc_mazur.Rd ├── dd_mbauc_rachlin.Rd ├── dd_mbauc_rodriguezlogue.Rd ├── dd_probable_model.Rd ├── dd_screen.Rd ├── dd_start_bleichrodt.Rd ├── dd_start_ebertprelec.Rd ├── dd_start_exponential.Rd ├── dd_start_greenmyerson.Rd ├── dd_start_laibson.Rd ├── dd_start_mazur.Rd ├── dd_start_rachlin.Rd ├── dd_start_rodriguezlogue.Rd ├── figures │ ├── grouped_fits.png │ ├── single_fits_ed50.png │ ├── single_fits_grouped.png │ ├── single_fits_grouped_ed50.png │ ├── single_fits_grouped_mbauc.png │ ├── single_fits_grouped_mbauc_log10.png │ ├── single_fits_mbauc.png │ ├── single_fits_mbauc_log10.png │ ├── single_fits_recovery.png │ └── single_fits_selection.png ├── fit_dd_curves.Rd ├── gauss_2F1.Rd ├── integrand_bleichrodt_crdi.Rd ├── integrand_bleichrodt_crdi_log10.Rd ├── integrand_ebertprelec.Rd ├── integrand_ebertprelec_log10.Rd ├── jacobianMatrix.Rd ├── johnsonBickelScreen.Rd ├── logLik.nls.lm.Rd ├── message_debug.Rd ├── plot.discountingtools.Rd ├── plot_cross_rainbow.Rd ├── plot_group_rainbow.Rd ├── plot_individual_detailed.Rd ├── plot_individual_rainbow.Rd ├── plot_model_characterization.Rd ├── residualFunction.Rd └── summary.discountingtools.Rd ├── tests ├── testthat.R └── testthat │ ├── Rplots.pdf │ ├── test-call_dd_fit_curves.R │ ├── test-ind-bleichrodt.R │ ├── test-ind-ebertprelec.R │ ├── test-ind-exponential.R │ ├── test-ind-greenmyerson.R │ ├── test-ind-laibson.R │ ├── test-ind-mazur-screen.R │ ├── test-ind-mazur.R │ ├── test-ind-rachlin.R │ ├── test-ind-rodriguezlogue.R │ ├── test-model_selection.R │ ├── test-plot-group.R │ └── test-plot-ind.R └── vignettes ├── .gitignore ├── discountingtools.R ├── discountingtools.Rmd └── discountingtools.html /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^testing\.R$ 4 | -------------------------------------------------------------------------------- /.github/workflows/test-coverage.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/master/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | branches: [main, master] 8 | 9 | name: test-coverage 10 | 11 | jobs: 12 | test-coverage: 13 | runs-on: ubuntu-latest 14 | env: 15 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 16 | 17 | steps: 18 | - uses: actions/checkout@v3 19 | 20 | - uses: r-lib/actions/setup-r@v2 21 | with: 22 | use-public-rspm: true 23 | 24 | - uses: r-lib/actions/setup-r-dependencies@v2 25 | with: 26 | extra-packages: any::covr 27 | needs: coverage 28 | 29 | - name: Test coverage 30 | run: | 31 | covr::codecov( 32 | quiet = FALSE, 33 | clean = FALSE, 34 | install_path = file.path(Sys.getenv("RUNNER_TEMP"), "package") 35 | ) 36 | shell: Rscript {0} 37 | 38 | - name: Show testthat output 39 | if: always() 40 | run: | 41 | ## -------------------------------------------------------------------- 42 | find ${{ runner.temp }}/package -name 'testthat.Rout*' -exec cat '{}' \; || true 43 | shell: bash 44 | 45 | - name: Upload test results 46 | if: failure() 47 | uses: actions/upload-artifact@v3 48 | with: 49 | name: coverage-test-failures 50 | path: ${{ runner.temp }}/package 51 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | inst/doc 5 | Parent Decision Making Data.csv 6 | testing.R 7 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: discountingtools 2 | Title: Delay Discounting Tools 3 | Version: 0.0.3.2 4 | Authors@R: person("Shawn", "Gilroy", email = "sgilroy1@lsu.edu", role = c("aut", "cre")) 5 | Maintainer: Shawn Gilroy 6 | Suggests: 7 | covr, 8 | knitr, 9 | rmarkdown, 10 | testthat (>= 3.0.0), 11 | tidyr, 12 | dplyr 13 | VignetteBuilder: knitr 14 | Description: This R package provides a base source of methods for applying approximate Bayesian model selection for discount models commonly (and less commonly) used in the existing literature. A range of models and fitting apparatus are included a Bayesian model averaging procedure is included to determine "true" models for individual instances of temporal discounting. Models presently included as a model candidates are the Exponential (Samuelson, 1937), the Hyperbolic (Mazur, 1987), the Generalized Hyperboloid (Rodriguez & Logue, 1997), the Quasi-Hyperbolic (Laibson, 1997), the Green & Myerson (Green & Myerson, 2004), the Ebert & Prelec Constant Sensitivity Model (Ebert & Prelec, 2007), and the Bleichrodt et al. Constant Relative Decreasing Impatience Model (Bleichrodt et al., 2009). An intercept-only model is also included (Noise) as a simpler alternative to the included models. Following the model selection procedure, generalized indices are performed upon the "true" model for each series. Generalized indices include the Effective Delay 50 (ED50; Yoon & Higgins, 2008) as well as numerical integration performed upon the "true" model in normal and log10 scaling. 15 | Depends: R (>= 4.1.0), minpack.lm, lattice, gsl, rlang, stats 16 | License: GPL (>= 2) 17 | Encoding: UTF-8 18 | LazyData: true 19 | Imports: grDevices 20 | URL: http://www.smallnstats.com 21 | RoxygenNote: 7.2.3 22 | Config/testthat/edition: 3 23 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(plot,discountingtools) 4 | S3method(summary,discountingtools) 5 | export(dd_analyze) 6 | export(dd_discount_func_bleichrodt_crdi) 7 | export(dd_discount_func_ebertprelec) 8 | export(dd_discount_func_exponential) 9 | export(dd_discount_func_greenmyerson) 10 | export(dd_discount_func_laibson) 11 | export(dd_discount_func_mazur) 12 | export(dd_discount_func_rachlin) 13 | export(dd_discount_func_rodriguezlogue) 14 | export(dd_ed50_exponential) 15 | export(dd_ed50_greenmyerson) 16 | export(dd_ed50_laibson) 17 | export(dd_ed50_mazur) 18 | export(dd_mbauc_exponential) 19 | export(dd_mbauc_greenmyerson) 20 | export(dd_mbauc_laibson) 21 | export(dd_mbauc_mazur) 22 | export(dd_mbauc_rachlin) 23 | export(dd_screen) 24 | export(fit_dd_curves) 25 | export(johnsonBickelScreen) 26 | export(plot.discountingtools) 27 | export(summary.discountingtools) 28 | importFrom(grDevices,rainbow) 29 | importFrom(graphics,legend) 30 | importFrom(graphics,lines) 31 | importFrom(gsl,hyperg_2F1) 32 | importFrom(lattice,barchart) 33 | importFrom(lattice,histogram) 34 | importFrom(lattice,panel.histogram) 35 | importFrom(lattice,panel.superpose) 36 | importFrom(minpack.lm,nls.lm) 37 | importFrom(minpack.lm,nls.lm.control) 38 | importFrom(rlang,enexpr) 39 | importFrom(stats,as.formula) 40 | -------------------------------------------------------------------------------- /R/dd_call_dd_analyze.R: -------------------------------------------------------------------------------- 1 | 2 | #' dd_analyze 3 | #' 4 | #' This call is the workhorse of the program. Based on the settings applied, this method applies all relevant methods and calculations to the supplied data. 5 | #' 6 | #' @param fittingObject core dd fitting object 7 | #' @param modelSelection (bool) this flag determines whether or not a model selection procedure will be applied in the results frame. 8 | #' 9 | #' @author Shawn Gilroy 10 | #' @export 11 | dd_analyze <- function(fittingObject, modelSelection = FALSE) { 12 | 13 | if (length(fittingObject[["models"]]) < 1) { 14 | stop("No model options were selected") 15 | } 16 | 17 | ## TODO: checks for screening call 18 | if ("screen" %in% names(fittingObject) | "filterPassing" %in% names(fittingObject)) { 19 | message_debug(fittingObject, "Beginning JB Screening") 20 | 21 | fittingObject = johnsonBickelScreen(fittingObject) 22 | } 23 | 24 | ## TODO: Check for filter passing 25 | if ("filterPassing" %in% names(fittingObject)) { 26 | message_debug(fittingObject, "Filtering based on JB Screen") 27 | 28 | if ("JB1" %in% fittingObject[[ "filterPassing" ]]) 29 | fittingObject$data = fittingObject$data[fittingObject$data$JB1 == TRUE, ] 30 | 31 | if ("JB2" %in% fittingObject[[ "filterPassing" ]]) 32 | fittingObject$data = fittingObject$data[fittingObject$data$JB2 == TRUE, ] 33 | } 34 | 35 | ## TODO: Check for analytical strategy 36 | if (fittingObject[[ "strategy" ]] == "group") { 37 | if (is.null(fittingObject$settings[["Group"]])) stop('No Group aesthetic specified') 38 | 39 | message_debug(fittingObject, "Casting Individual Ids to Group Ids") 40 | 41 | vecGroups = unique(fittingObject$data[,as.character(fittingObject$settings['Group'])]) 42 | newGrpIds = match(fittingObject$data[,as.character(fittingObject$settings['Group'])], vecGroups) 43 | fittingObject$data[,as.character(fittingObject$settings['Individual'])] <- newGrpIds 44 | } 45 | 46 | message_debug(fittingObject, "Beginning Model Fitting(s)") 47 | 48 | fittingObject[[ "ModelSelection" ]] = modelSelection 49 | 50 | # Add in noise model as a comparator 51 | if (!("noise" %in% fittingObject[["models"]]) & modelSelection == TRUE) 52 | fittingObject[["models"]] = c("noise", fittingObject[["models"]]) 53 | 54 | # loop through individual id's 55 | for (id in unique(fittingObject$data[[as.character(fittingObject$settings['Individual'])]])) { 56 | message_debug(fittingObject, paste("Fitting:", id)) 57 | 58 | fittingObject$results[[as.character(id)]] = list() 59 | 60 | for (model in fittingObject[["models"]]) { 61 | message_debug(fittingObject, paste("Fitting:", id, "Rotation:", model)) 62 | 63 | if (model == "noise") fittingObject = dd_fit_noise( fittingObject, id) 64 | if (model == "mazur") fittingObject = dd_fit_mazur( fittingObject, id) 65 | if (model == "exponential") fittingObject = dd_fit_exponential( fittingObject, id) 66 | if (model == "laibson") fittingObject = dd_fit_laibson( fittingObject, id) 67 | if (model == "greenmyerson") fittingObject = dd_fit_greenmyerson( fittingObject, id) 68 | if (model == "rachlin") fittingObject = dd_fit_rachlin( fittingObject, id) 69 | if (model == "ebertprelec") fittingObject = dd_fit_ebertprelec( fittingObject, id) 70 | if (model == "bleichrodt") fittingObject = dd_fit_bleichrodt( fittingObject, id) 71 | if (model == "rodriguezlogue") fittingObject = dd_fit_rodriguezlogue( fittingObject, id) 72 | } 73 | 74 | if (modelSelection == TRUE) { 75 | fittingObject = dd_probable_model(fittingObject, id) 76 | } 77 | } 78 | 79 | fittingObject 80 | } 81 | -------------------------------------------------------------------------------- /R/dd_call_fit_dd_curves.R: -------------------------------------------------------------------------------- 1 | #' fit_dd_curves 2 | #' 3 | #' This is the entry point for users. It constructs a core fitting object that is passed through the program, with branching options based on those specified by the user. 4 | #' 5 | #' @param data (dataframe) assigned data 6 | #' @param settings (named list) mappings 7 | #' @param maxValue (num) A parameter 8 | #' @param verbose (bool) output level (default FALSE) 9 | #' @param strategy (char) fit to individual ids (default) or group 10 | #' @param plan (char vector) This vector contains a list of possible model candidates. 11 | #' @param metrics (char vector) This vector contains a list of possible cross-model metrics. 12 | #' 13 | #' @author Shawn Gilroy 14 | #' @importFrom rlang enexpr 15 | #' @export 16 | fit_dd_curves <- function(data, settings, maxValue = NULL, strategy = "ind", verbose = FALSE, plan = NULL, metrics = c('lned50', 'mbauc', 'logmbauc')) { 17 | 18 | cached_settings = enexpr(settings) 19 | 20 | fittingObject = list() # Primary object 21 | fittingObject[[ "settings" ]] = cached_settings # Settings 22 | fittingObject[[ "data" ]] = data # Stored data 23 | fittingObject[[ "strategy" ]] = strategy # Analytical strategy 24 | fittingObject[[ "metrics" ]] = character(0) # Cross-model Metrics 25 | fittingObject[[ "results" ]] = list() # Result frame 26 | fittingObject[[ "maxValue" ]] = maxValue # Max level (A) 27 | fittingObject[[ "verbose" ]] = verbose # Output level 28 | fittingObject[[ "models" ]] = plan 29 | fittingObject[[ "metrics" ]] = metrics 30 | 31 | class(fittingObject) <- c("discountingtools") 32 | 33 | if (!("Delays" %in% names(cached_settings))) stop('No Delays aesthetic specified') 34 | if (!("Values" %in% names(cached_settings))) stop('No Values aesthetic specified') 35 | if (!("Individual" %in% names(cached_settings))) stop('No Individual aesthetic specified') 36 | 37 | if (is.null(fittingObject[["models"]])) stop('No models specified') 38 | if (is.null(fittingObject[["maxValue"]])) stop('No maximum value specified') 39 | 40 | if (!(strategy %in% c('ind', 'group'))) stop('Only `ind` or `group` strategies supported') 41 | 42 | fittingObject 43 | } 44 | -------------------------------------------------------------------------------- /R/dd_call_screen_options.R: -------------------------------------------------------------------------------- 1 | #' dd_screen_options 2 | #' 3 | #' This call applies screening criteria to a data dataset. Specifically, it can be used to apply criteria (no filtering) or apply criteria and filter based on one or more criteria (e.g., JB1, JB2) 4 | #' 5 | #' @param fittingObject core fitting object 6 | #' @param screen (bool) set screen TRUE or FALSE (i.e. NULL) 7 | #' @param JB1Flag (num) bounce constant per authors (set at initial defaults) 8 | #' @param JB2Flag (num) extremity change constant per authors (set at initial defaults) 9 | #' @param filterPassing (char vector) which JB criteria to retain in dataset, e.g. c("JB1", "JB2") 10 | #' 11 | #' @export 12 | dd_screen <- function(fittingObject, screen = TRUE, JB1Flag = 0.2, JB2Flag = 0.1, filterPassing = NULL) { 13 | message_debug(fittingObject, "Setting Screening Options") 14 | fittingObject[[ "screen" ]] = screen 15 | fittingObject[[ "JB1Flag" ]] = JB1Flag 16 | fittingObject[[ "JB2Flag" ]] = JB2Flag 17 | 18 | # TODO: validate passing 19 | # 20 | 21 | if (!is.logical(screen)) stop('screen must be a boolean') 22 | if (!is.numeric(JB1Flag)) stop('JB1Flag must be numeric') 23 | if (!is.numeric(JB2Flag)) stop('JB2Flag must be numeric') 24 | 25 | if (screen == TRUE) { 26 | if (!is.null(filterPassing)) { 27 | if (!(filterPassing %in% c('JB1', 'JB2'))) stop('Only `JB1` or `JB2` screening supported') 28 | 29 | fittingObject[[ "filterPassing" ]] = filterPassing 30 | } 31 | } 32 | 33 | fittingObject 34 | } 35 | -------------------------------------------------------------------------------- /R/dd_fit_exponential.R: -------------------------------------------------------------------------------- 1 | 2 | #' dd_fit_exponential 3 | #' 4 | #' This fits a hyperbolic model to the data. 5 | #' 6 | #' @param fittingObject core dd fitting object 7 | #' @param id id tag 8 | #' 9 | #' @author Shawn Gilroy 10 | #' @importFrom minpack.lm nls.lm nls.lm.control 11 | dd_fit_exponential <- function(fittingObject, id) { 12 | 13 | modelResults = list( 14 | Model = "exponential", 15 | Lnk = NA, 16 | RMSE = NA, 17 | BIC = NA, 18 | AIC = NA, 19 | ED50 = NA, 20 | MBAUC = NA, 21 | Log10MBAUC = NA 22 | ) 23 | 24 | currentData = fittingObject$data[ 25 | which(fittingObject$data[, 26 | as.character(fittingObject$settings['Individual'])] == id),] 27 | 28 | currentData$ddX = currentData[,as.character(fittingObject$settings['Delays'])] 29 | currentData$ddY = currentData[,as.character(fittingObject$settings['Values'])] 30 | currentData$ddY = currentData$ddY / as.numeric(fittingObject[[ "maxValue" ]]) 31 | 32 | startParams = dd_start_exponential(currentData) 33 | 34 | modelFitExponential <- NULL 35 | 36 | try(modelFitExponential <- nls.lm(par = startParams, 37 | fn = residualFunction, 38 | jac = jacobianMatrix, 39 | valueFunction = dd_discount_func_exponential, 40 | jacobianFunction = dd_discount_grad_exponential, 41 | x = currentData$ddX, 42 | value = currentData$ddY, 43 | control = nls.lm.control(maxiter = 1000)), 44 | silent = FALSE) 45 | 46 | if (!is.null(modelFitExponential)) { 47 | 48 | modelResults[[ "Lnk" ]] = modelFitExponential$par[["lnk"]] 49 | modelResults[[ "RMSE" ]] = sqrt(modelFitExponential$deviance/length(modelFitExponential$fvec)) 50 | modelResults[[ "BIC" ]] = stats::BIC(logLik.nls.lm(modelFitExponential)) 51 | modelResults[[ "AIC" ]] = stats::AIC(logLik.nls.lm(modelFitExponential)) 52 | modelResults[[ "ED50" ]] = dd_ed50_exponential(modelFitExponential$par[["lnk"]]) 53 | modelResults[[ "MBAUC" ]] = dd_mbauc_exponential( 54 | A = 1, 55 | Lnk = modelFitExponential$par[["lnk"]], 56 | startDelay = min(currentData$ddX), 57 | endDelay = max(currentData$ddX) 58 | ) 59 | modelResults[[ "Log10MBAUC" ]] = dd_mbauc_log10_exponential( 60 | A = 1, 61 | Lnk = modelFitExponential$par[["lnk"]], 62 | startDelay = min(currentData$ddX), 63 | endDelay = max(currentData$ddX) 64 | ) 65 | } 66 | 67 | modelResults[[ "Status" ]] = paste("Code:", modelFitExponential$info, 68 | "- Message:", modelFitExponential$message, 69 | sep = " ") 70 | 71 | fittingObject$results[[as.character(id)]][["exponential"]] = modelResults 72 | 73 | fittingObject 74 | } 75 | 76 | #' dd_start_exponential 77 | #' 78 | #' Extract starting parameters 79 | #' 80 | #' @param currentData current data set 81 | #' @param increment step size for span 82 | #' 83 | #' @author Shawn Gilroy 84 | dd_start_exponential <- function(currentData, increment = 1) { 85 | 86 | startlnK <- seq(-15, 15, increment) 87 | lengthLnK = length(startlnK) 88 | lengthX = nrow(currentData) 89 | MlnK = sort(rep(startlnK, lengthX)) 90 | 91 | sumSquares = rep(NA,lengthLnK) 92 | MX = rep(currentData$ddX, lengthLnK) 93 | MY = rep(currentData$ddY, lengthLnK) 94 | 95 | # Projections 96 | projection = exp(-exp(MlnK) * MX) 97 | sqResidual = (MY - projection)^2 98 | 99 | for (j in 1:lengthLnK) sumSquares[j] <- sum(sqResidual[(j - 1) * lengthX + 1:lengthX]) 100 | 101 | presort = data.frame(startlnK, sumSquares) 102 | sorted = presort[order(presort[ ,"sumSquares"]), ] 103 | ini.par = c(lnk = sorted$startlnK[1]) 104 | 105 | ini.par 106 | } 107 | 108 | #' dd_ed50_exponential 109 | #' 110 | #' @param Lnk log transformed rate parameter 111 | #' 112 | #' @author Shawn Gilroy 113 | #' @export 114 | dd_ed50_exponential <- function(Lnk) { 115 | return(log(log(2)/exp(Lnk))) 116 | } 117 | 118 | #' dd_mbauc_exponential 119 | #' 120 | #' @param A maximum value of good 121 | #' @param Lnk log transformed rate parameter 122 | #' @param startDelay start delay 123 | #' @param endDelay end delay 124 | #' 125 | #' @author Shawn Gilroy 126 | #' @export 127 | dd_mbauc_exponential <- function(A, Lnk, startDelay, endDelay) { 128 | expFinal = (-A * exp(-exp(Lnk) * endDelay)) / exp(Lnk) 129 | expInitial = (-A * exp(-exp(Lnk) * startDelay)) / exp(Lnk) 130 | 131 | return((expFinal - expInitial) / ((endDelay - startDelay) * A)) 132 | } 133 | 134 | #' dd_mbauc_log10_exponential 135 | #' 136 | #' @param A maximum value of good 137 | #' @param Lnk log transformed rate parameter 138 | #' @param startDelay start delay 139 | #' @param endDelay end delay 140 | #' 141 | #' @author Shawn Gilroy 142 | dd_mbauc_log10_exponential <- function(A, Lnk, startDelay, endDelay) { 143 | 144 | maximumArea = (log10(endDelay) - log10(startDelay)) * A 145 | 146 | area = stats::integrate(dd_integrand_exponential_log10, 147 | lower = log10(startDelay), 148 | upper = log10(endDelay), 149 | lnK = Lnk)$value/maximumArea 150 | 151 | return(area) 152 | } 153 | 154 | #' Exponential discounting function 155 | #' 156 | #' @param x observation at point n (X) 157 | #' @param lnk fitted parameter 158 | #' 159 | #' @return projected, subjective value 160 | #' @author Shawn Gilroy 161 | #' @export 162 | dd_discount_func_exponential <- function(x, lnk) 163 | { 164 | func <- exp(-exp(lnk)*x) 165 | eval(func) 166 | } 167 | 168 | #' Exponential Gradient Helper for Nonlinear Fitting 169 | #' 170 | #' @param x observation at point n (X) 171 | #' @param lnk fitted parameter 172 | #' 173 | #' @return projected, subjective value 174 | #' @author Shawn Gilroy 175 | dd_discount_grad_exponential <- function(x, lnk) 176 | { 177 | func <- expression(exp(-exp(lnk)*x)) 178 | c(eval(stats::D(func, "lnk"))) 179 | } 180 | 181 | #' Exponential Integrand helper (log10) 182 | #' 183 | #' This integrand helper is a projection of the integrand with delays represented in the log base 10 scale 184 | #' 185 | #' @param x observation at point n (X) 186 | #' @param lnK fitted parameter 187 | #' 188 | #' @return Numerical Integration Projection 189 | #' @author Shawn Gilroy 190 | dd_integrand_exponential_log10 <- function(x, lnK) { exp(-exp(lnK)*(10^x)) } 191 | -------------------------------------------------------------------------------- /R/dd_fit_greenmyerson.R: -------------------------------------------------------------------------------- 1 | 2 | #' dd_fit_greenmyerson 3 | #' 4 | #' This fits a hyperbolic model to the data. 5 | #' 6 | #' @param fittingObject core dd fitting object 7 | #' @param id id tag 8 | #' 9 | #' @author Shawn Gilroy 10 | #' @importFrom minpack.lm nls.lm nls.lm.control 11 | dd_fit_greenmyerson <- function(fittingObject, id) { 12 | 13 | modelResults = list( 14 | Model = "greenmyerson", 15 | Lnk = NA, 16 | S = NA, 17 | RMSE = NA, 18 | BIC = NA, 19 | AIC = NA, 20 | ED50 = NA, 21 | MBAUC = NA, 22 | Log10MBAUC = NA 23 | ) 24 | 25 | currentData = fittingObject$data[ 26 | which(fittingObject$data[, 27 | as.character(fittingObject$settings['Individual'])] == id),] 28 | 29 | currentData$ddX = currentData[,as.character(fittingObject$settings['Delays'])] 30 | currentData$ddY = currentData[,as.character(fittingObject$settings['Values'])] 31 | currentData$ddY = currentData$ddY / as.numeric(fittingObject[[ "maxValue" ]]) 32 | 33 | startParams = dd_start_greenmyerson(currentData) 34 | 35 | modelFitGreenMyerson <- NULL 36 | 37 | try(modelFitGreenMyerson <- nls.lm(par = startParams, 38 | fn = residualFunction, 39 | jac = jacobianMatrix, 40 | valueFunction = dd_discount_func_greenmyerson, 41 | jacobianFunction = dd_discount_grad_greenmyerson, 42 | x = currentData$ddX, 43 | value = currentData$ddY, 44 | control = nls.lm.control(maxiter = 1000)), 45 | silent = TRUE) 46 | 47 | if (!is.null(modelFitGreenMyerson)) { 48 | 49 | modelResults[[ "Lnk" ]] = modelFitGreenMyerson$par[["lnk"]] 50 | modelResults[[ "S" ]] = modelFitGreenMyerson$par[["s"]] 51 | modelResults[[ "RMSE" ]] = sqrt(modelFitGreenMyerson$deviance/length(modelFitGreenMyerson$fvec)) 52 | modelResults[[ "BIC" ]] = stats::BIC(logLik.nls.lm(modelFitGreenMyerson)) 53 | modelResults[[ "AIC" ]] = stats::AIC(logLik.nls.lm(modelFitGreenMyerson)) 54 | modelResults[[ "ED50" ]] = dd_ed50_greenmyerson( 55 | Lnk = modelFitGreenMyerson$par[["lnk"]], 56 | s = modelFitGreenMyerson$par[["s"]] 57 | ) 58 | modelResults[[ "MBAUC" ]] = dd_mbauc_greenmyerson( 59 | A = 1, 60 | Lnk = modelFitGreenMyerson$par[["lnk"]], 61 | s = modelFitGreenMyerson$par[["s"]], 62 | startDelay = min(currentData$ddX), 63 | endDelay = max(currentData$ddX) 64 | ) 65 | modelResults[[ "Log10MBAUC" ]] = dd_mbauc_log10_greenmyerson( 66 | A = 1, 67 | Lnk = modelFitGreenMyerson$par[["lnk"]], 68 | s = modelFitGreenMyerson$par[["s"]], 69 | startDelay = min(currentData$ddX), 70 | endDelay = max(currentData$ddX) 71 | ) 72 | modelResults[[ "Status" ]] = paste("Code:", modelFitGreenMyerson$info, 73 | "- Message:", modelFitGreenMyerson$message, 74 | sep = " ") 75 | } 76 | 77 | fittingObject$results[[as.character(id)]][["greenmyerson"]] = modelResults 78 | 79 | fittingObject 80 | } 81 | 82 | #' dd_start_laibson 83 | #' 84 | #' Extract starting parameters 85 | #' 86 | #' @param currentData current data set 87 | #' 88 | #' @author Shawn Gilroy 89 | dd_start_greenmyerson <- function(currentData) { 90 | 91 | startlnK <- seq(-12, 12, 1) 92 | starts <- seq(.01, 10, 0.01) 93 | 94 | lengthLnK <- length(startlnK) 95 | lengthX = nrow(currentData) 96 | lengthS <- length(starts) 97 | 98 | SSlnK <- rep(startlnK, lengthS) 99 | SSs <- sort(rep(starts, lengthLnK)) 100 | 101 | sumSquares <- rep(NA, lengthS * lengthLnK) 102 | 103 | SY <- rep(currentData$ddY, lengthS * lengthLnK) 104 | 105 | SlnK <- rep(sort(rep(startlnK,lengthX)), lengthS) 106 | Ss <- sort(rep(starts, lengthX * lengthLnK)) 107 | 108 | projection <- (1 + exp(SlnK) * currentData$ddX)^(-Ss) 109 | sqResidual <- (SY - projection)^2 110 | 111 | for (j in 1:(lengthS*lengthLnK)) sumSquares[j] <- sum(sqResidual[(j - 1) * lengthX + 1:lengthX]) 112 | 113 | presort <- data.frame(SSlnK, SSs, sumSquares) 114 | sorted <- presort[order(presort[,"sumSquares"]),] 115 | ini.par <- c(lnk = sorted$SSlnK[1], 116 | s = sorted$SSs[1]) 117 | 118 | ini.par 119 | } 120 | 121 | #' dd_ed50_greenmyerson 122 | #' 123 | #' @param Lnk parameter 124 | #' @param s parameter 125 | #' 126 | #' @author Shawn Gilroy 127 | #' @export 128 | dd_ed50_greenmyerson <- function(Lnk, s) { 129 | return(log( (2^(1/s) - 1)/exp(Lnk))) 130 | } 131 | 132 | #' dd_mbauc_rachlin 133 | #' 134 | #' @param A maximum value 135 | #' @param Lnk parameter value 136 | #' @param s parameter value 137 | #' @param startDelay time point 138 | #' @param endDelay time point 139 | #' 140 | #' @author Shawn Gilroy 141 | #' @export 142 | dd_mbauc_greenmyerson <- function(A, Lnk, s, startDelay, endDelay) { 143 | mgFinal = (A * ((exp(Lnk) * endDelay + 1)^(1 - s))) / (exp(Lnk) * (1 - s)) 144 | mgInitial = (A * ((exp(Lnk) * startDelay + 1)^(1 - s))) / (exp(Lnk) * (1 - s)) 145 | 146 | return((mgFinal - mgInitial) / ((endDelay - startDelay) * A)) 147 | } 148 | 149 | #' dd_mbauc_log10_greenmyerson 150 | #' 151 | #' @param A maximum value 152 | #' @param Lnk parameter value 153 | #' @param s parameter value 154 | #' @param startDelay time point 155 | #' @param endDelay time point 156 | #' 157 | #' @author Shawn Gilroy 158 | dd_mbauc_log10_greenmyerson <- function(A, Lnk, s, startDelay, endDelay) { 159 | 160 | maxX = log10(endDelay) 161 | minX = log10(startDelay) 162 | maximumArea = maxX - minX 163 | 164 | area = stats::integrate(dd_integrand_myersongreen_log10, 165 | lower = minX, 166 | upper = maxX, 167 | lnK = Lnk, 168 | s = s)$value/maximumArea 169 | 170 | return(area) 171 | } 172 | 173 | #' Green & Myerson Value Function 174 | #' 175 | #' @param x observation at point n (X) 176 | #' @param lnk fitted parameter 177 | #' @param s fitted parameter 178 | #' 179 | #' @return projected, subjective value 180 | #' @author Shawn Gilroy 181 | #' @export 182 | dd_discount_func_greenmyerson <- function(x, lnk, s) 183 | { 184 | func <- (1 + exp(lnk)*x)^(-s) 185 | eval(func) 186 | } 187 | 188 | #' Green & Myerson Gradient Helper for Nonlinear Fitting 189 | #' 190 | #' @param x observation at point n (X) 191 | #' @param lnk fitted parameter 192 | #' @param s fitted parameter 193 | #' 194 | #' @return projected, subjective value 195 | #' @author Shawn Gilroy 196 | dd_discount_grad_greenmyerson <- function(x, lnk, s) 197 | { 198 | func <- expression((1 + exp(lnk)*x)^(-s)) 199 | c(eval(stats::deriv(func, "lnk")), 200 | eval(stats::deriv(func, "s"))) 201 | } 202 | 203 | #' Green & Myerson Integrand helper (log10) 204 | #' 205 | #' This integrand helper is a projection of the integrand with delays represented in the log base 10 scale 206 | #' 207 | #' @param x observation at point n (X) 208 | #' @param lnK fitted parameter 209 | #' @param s fitted parameter 210 | #' 211 | #' @return Numerical Integration Projection 212 | #' @author Shawn Gilroy 213 | dd_integrand_myersongreen_log10 <- function(x, lnK, s) { (1 + exp(lnK)*(10^x))^(-s) } 214 | -------------------------------------------------------------------------------- /R/dd_fit_laibson.R: -------------------------------------------------------------------------------- 1 | 2 | #' dd_fit_laibson 3 | #' 4 | #' This fits a hyperbolic model to the data. 5 | #' 6 | #' @param fittingObject core dd fitting object 7 | #' @param id id tag 8 | #' 9 | #' @author Shawn Gilroy 10 | #' @importFrom minpack.lm nls.lm nls.lm.control 11 | dd_fit_laibson <- function(fittingObject, id) { 12 | 13 | modelResults = list( 14 | Model = "laibson", 15 | Beta = NA, 16 | Delta = NA, 17 | RMSE = NA, 18 | BIC = NA, 19 | AIC = NA, 20 | ED50 = NA, 21 | MBAUC = NA, 22 | Log10MBAUC = NA 23 | ) 24 | 25 | currentData = fittingObject$data[ 26 | which(fittingObject$data[, 27 | as.character(fittingObject$settings['Individual'])] == id),] 28 | 29 | currentData$ddX = currentData[,as.character(fittingObject$settings['Delays'])] 30 | currentData$ddY = currentData[,as.character(fittingObject$settings['Values'])] 31 | currentData$ddY = currentData$ddY / as.numeric(fittingObject[[ "maxValue" ]]) 32 | 33 | startParams = dd_start_laibson(currentData) 34 | 35 | modelFitLaibson <- NULL 36 | 37 | try(modelFitLaibson <- nls.lm(par = startParams, 38 | fn = residualFunction, 39 | jac = jacobianMatrix, 40 | valueFunction = dd_discount_func_laibson, 41 | jacobianFunction = dd_discount_grad_laibson, 42 | x = currentData$ddX, 43 | value = currentData$ddY, 44 | upper = c(beta = 1, delta = 1), 45 | lower = c(beta = 0, delta = 0), 46 | control = nls.lm.control(maxiter = 1000)), 47 | silent = TRUE) 48 | 49 | if (!is.null(modelFitLaibson)) { 50 | 51 | modelResults[[ "Beta" ]] = modelFitLaibson$par[["beta"]] 52 | modelResults[[ "Delta" ]] = modelFitLaibson$par[["delta"]] 53 | modelResults[[ "RMSE" ]] = sqrt(modelFitLaibson$deviance/length(modelFitLaibson$fvec)) 54 | modelResults[[ "BIC" ]] = stats::BIC(logLik.nls.lm(modelFitLaibson)) 55 | modelResults[[ "AIC" ]] = stats::AIC(logLik.nls.lm(modelFitLaibson)) 56 | modelResults[[ "ED50" ]] = dd_ed50_laibson( 57 | b = modelFitLaibson$par[["beta"]], 58 | d = modelFitLaibson$par[["delta"]] 59 | ) 60 | modelResults[[ "MBAUC" ]] = dd_mbauc_laibson( 61 | A = 1, 62 | b = modelFitLaibson$par[["beta"]], 63 | d = modelFitLaibson$par[["delta"]], 64 | startDelay = min(currentData$ddX), 65 | endDelay = max(currentData$ddX) 66 | ) 67 | modelResults[[ "Log10MBAUC" ]] = dd_mbauc_log10_laibson( 68 | A = 1, 69 | b = modelFitLaibson$par[["beta"]], 70 | d = modelFitLaibson$par[["delta"]], 71 | startDelay = min(currentData$ddX), 72 | endDelay = max(currentData$ddX) 73 | ) 74 | modelResults[[ "Status" ]] = paste("Code:", modelFitLaibson$info, 75 | "- Message:", modelFitLaibson$message, 76 | sep = " ") 77 | } 78 | 79 | fittingObject$results[[as.character(id)]][["laibson"]] = modelResults 80 | 81 | fittingObject 82 | } 83 | 84 | #' dd_start_laibson 85 | #' 86 | #' Extract starting parameters 87 | #' 88 | #' @param currentData current data set 89 | #' 90 | #' @author Shawn Gilroy 91 | dd_start_laibson <- function(currentData) { 92 | 93 | startbeta <- seq(0, 1, 0.1) 94 | startdelta <- seq(0, 1, 0.01) 95 | 96 | lengthX = nrow(currentData) 97 | lengthBeta <- length(startbeta) 98 | lengthDelta <- length(startdelta) 99 | 100 | startBeta <- rep(sort(rep(startbeta, lengthX)), lengthDelta) 101 | startdelta <- sort(rep(startdelta, lengthX * lengthBeta)) 102 | 103 | sumSquares <- rep(NA, lengthBeta * lengthDelta) 104 | 105 | SY <- rep(currentData$ddY, lengthBeta * lengthDelta) 106 | projection <- startBeta * startdelta^currentData$ddX 107 | 108 | sqResidual <- (SY - projection)^2 109 | 110 | SSbeta <- rep(startbeta, lengthDelta) 111 | SSdelta <- sort(rep(startdelta, lengthBeta)) 112 | 113 | for (j in 1:(lengthBeta * lengthDelta)) sumSquares[j] <- sum(sqResidual[(j - 1) * lengthX + 1:lengthX]) 114 | 115 | presort <- data.frame(SSbeta, 116 | SSdelta, 117 | sumSquares) 118 | 119 | sorted <- presort[order(presort[,"sumSquares"]),] 120 | ini.par <- c(beta = sorted$SSbeta[1], 121 | delta = sorted$SSdelta[1]) 122 | 123 | ini.par 124 | } 125 | 126 | #' dd_ed50_laibson 127 | #' 128 | #' @param b beta param 129 | #' @param d delta param 130 | #' 131 | #' @author Shawn Gilroy 132 | #' @export 133 | dd_ed50_laibson <- function(b, d) { 134 | return(log(log( (1/(2*b)),base = d))) 135 | } 136 | 137 | #' dd_mbauc_laibson 138 | #' 139 | #' @param A maximum value 140 | #' @param b parameter value 141 | #' @param d parameter value 142 | #' @param startDelay time point 143 | #' @param endDelay time point 144 | #' 145 | #' @author Shawn Gilroy 146 | #' @export 147 | dd_mbauc_laibson <- function(A, b, d, startDelay, endDelay) { 148 | bdFinal = (-A * b * exp(-(1 - d) * endDelay)) / (1 - d) 149 | bdInitial = (-A * b * exp(-(1 - d) * startDelay)) / (1 - d) 150 | 151 | return((bdFinal - bdInitial) / ((endDelay - startDelay) * A)) 152 | } 153 | 154 | #' dd_mbauc_log10_laibson 155 | #' 156 | #' @param A maximum value 157 | #' @param b parameter value 158 | #' @param d parameter value 159 | #' @param startDelay time point 160 | #' @param endDelay time point 161 | #' 162 | #' @author Shawn Gilroy 163 | dd_mbauc_log10_laibson <- function(A, b, d, startDelay, endDelay) { 164 | maxX = log10(endDelay) 165 | minX = log10(startDelay) 166 | 167 | maximumArea = (maxX - minX) * A 168 | 169 | area = stats::integrate(dd_integrand_laibson_log10, 170 | lower = minX, 171 | upper = maxX, 172 | beta = b, 173 | delta = d)$value/maximumArea 174 | 175 | return(area) 176 | } 177 | 178 | #' Beta Delta Value Function 179 | #' 180 | #' @param x observation at point n (X) 181 | #' @param beta fitted parameter 182 | #' @param delta fitted parameter 183 | #' 184 | #' @author Shawn Gilroy 185 | #' @export 186 | dd_discount_func_laibson <- function(x, beta, delta) 187 | { 188 | func <- beta*delta^x 189 | eval(func) 190 | } 191 | 192 | #' Beta Delta Gradient Helper for Nonlinear Fitting 193 | #' 194 | #' @param x observation at point n (X) 195 | #' @param beta fitted parameter 196 | #' @param delta fitted parameter 197 | #' 198 | #' @return projected, subjective value 199 | #' @author Shawn Gilroy 200 | dd_discount_grad_laibson <- function(x, beta, delta) 201 | { 202 | func <- expression(beta*delta^x) 203 | c(eval(stats::D(func, "delta")), 204 | eval(stats::D(func, "beta"))) 205 | } 206 | 207 | #' Beta Delta Integrand helper (log10) 208 | #' 209 | #' This integrand helper is a projection of the integrand with delays represented in the log base 10 scale 210 | #' 211 | #' @param x observation at point n (X) 212 | #' @param beta fitted parameter 213 | #' @param delta fitted parameter 214 | #' 215 | #' @return Numerical Integration Projection 216 | #' @author Shawn Gilroy 217 | dd_integrand_laibson_log10 <- function(x, beta, delta) { beta*delta^(10^x) } 218 | -------------------------------------------------------------------------------- /R/dd_fit_mazur.R: -------------------------------------------------------------------------------- 1 | 2 | #' dd_fit_mazur 3 | #' 4 | #' This fits a hyperbolic model to the data. 5 | #' 6 | #' @param fittingObject core dd fitting object 7 | #' @param id id tag 8 | #' 9 | #' @author Shawn Gilroy 10 | #' @importFrom minpack.lm nls.lm nls.lm.control 11 | dd_fit_mazur <- function(fittingObject, id) { 12 | 13 | modelResults = list( 14 | Model = "mazur", 15 | Lnk = NA, 16 | RMSE = NA, 17 | BIC = NA, 18 | AIC = NA, 19 | ED50 = NA, 20 | MBAUC = NA, 21 | Log10MBAUC = NA 22 | ) 23 | 24 | currentData = fittingObject$data[ 25 | which(fittingObject$data[, 26 | as.character(fittingObject$settings['Individual'])] == id),] 27 | 28 | currentData$ddX = currentData[,as.character(fittingObject$settings['Delays'])] 29 | currentData$ddY = currentData[,as.character(fittingObject$settings['Values'])] 30 | currentData$ddY = currentData$ddY / as.numeric(fittingObject[[ "maxValue" ]]) 31 | 32 | startParams = dd_start_mazur(currentData) 33 | 34 | modelFitHyperbolic <- NULL 35 | 36 | try(modelFitHyperbolic <- nls.lm(par = startParams, 37 | fn = residualFunction, 38 | jac = jacobianMatrix, 39 | valueFunction = dd_discount_func_mazur, 40 | jacobianFunction = dd_discount_grad_mazur, 41 | x = currentData$ddX, 42 | value = currentData$ddY, 43 | control = nls.lm.control(maxiter = 1000)), 44 | silent = TRUE) 45 | 46 | if (!is.null(modelFitHyperbolic)) { 47 | 48 | modelResults[[ "Lnk" ]] = modelFitHyperbolic$par[["lnk"]] 49 | modelResults[[ "RMSE" ]] = sqrt(modelFitHyperbolic$deviance/length(modelFitHyperbolic$fvec)) 50 | modelResults[[ "BIC" ]] = stats::BIC(logLik.nls.lm(modelFitHyperbolic)) 51 | modelResults[[ "AIC" ]] = stats::AIC(logLik.nls.lm(modelFitHyperbolic)) 52 | modelResults[[ "ED50" ]] = dd_ed50_mazur(modelFitHyperbolic$par[["lnk"]]) 53 | modelResults[[ "MBAUC" ]] = dd_mbauc_mazur( 54 | A = 1, 55 | Lnk = modelFitHyperbolic$par[["lnk"]], 56 | startDelay = min(currentData$ddX), 57 | endDelay = max(currentData$ddX) 58 | ) 59 | modelResults[[ "Log10MBAUC" ]] = dd_mbauc_log10_mazur( 60 | A = 1, 61 | Lnk = modelFitHyperbolic$par[["lnk"]], 62 | startDelay = min(currentData$ddX), 63 | endDelay = max(currentData$ddX) 64 | ) 65 | modelResults[[ "Status" ]] = paste("Code:", modelFitHyperbolic$info, 66 | "- Message:", modelFitHyperbolic$message, 67 | sep = " ") 68 | } 69 | 70 | fittingObject$results[[as.character(id)]][["mazur"]] = modelResults 71 | 72 | fittingObject 73 | } 74 | 75 | #' dd_start_mazur 76 | #' 77 | #' Extract starting parameters 78 | #' 79 | #' @param currentData current data set 80 | #' 81 | #' @author Shawn Gilroy 82 | dd_start_mazur <- function(currentData) { 83 | 84 | startlnK = seq(-12, 12, 1) 85 | lengthLnK = length(startlnK) 86 | lengthX = nrow(currentData) 87 | MlnK = sort(rep(startlnK, lengthX)) 88 | 89 | sumSquares = rep(NA,lengthLnK) 90 | MX = rep(currentData$ddX, lengthLnK) 91 | MY = rep(currentData$ddY, lengthLnK) 92 | 93 | projection = (1 + exp(MlnK)*MX)^(-1) 94 | sqResidual = (MY - projection)^2 95 | 96 | for (j in 1:lengthLnK) sumSquares[j] <- sum(sqResidual[(j - 1) * lengthX + 1:lengthX]) 97 | 98 | presort = data.frame(startlnK, sumSquares) 99 | sorted = presort[order(presort[ ,"sumSquares"]), ] 100 | ini.par = c(lnk = sorted$startlnK[1]) 101 | 102 | ini.par 103 | } 104 | 105 | #' dd_ed50_mazur 106 | #' 107 | #' @param Lnk log transformed rate parameter 108 | #' 109 | #' @author Shawn Gilroy 110 | #' @export 111 | dd_ed50_mazur <- function(Lnk) { 112 | return(log(1/(exp(Lnk)))) 113 | } 114 | 115 | #' dd_mbauc_mazur 116 | #' 117 | #' @param A maximum value 118 | #' @param Lnk logged parameter value 119 | #' @param startDelay time point 120 | #' @param endDelay time point 121 | #' 122 | #' @author Shawn Gilroy 123 | #' @export 124 | dd_mbauc_mazur <- function(A, Lnk, startDelay, endDelay) { 125 | hypFinal = (A * log((exp(Lnk) * endDelay) + 1)) / exp(Lnk) 126 | hypInitial = (A * log((exp(Lnk) * startDelay) + 1)) / exp(Lnk) 127 | 128 | return((hypFinal - hypInitial) / ((endDelay - startDelay) * A)) 129 | } 130 | 131 | #' dd_mbauc_log10_mazur 132 | #' 133 | #' @param A maximum value of good 134 | #' @param Lnk log transformed rate parameter 135 | #' @param startDelay start delay 136 | #' @param endDelay end delay 137 | #' 138 | #' @author Shawn Gilroy 139 | dd_mbauc_log10_mazur <- function(A, Lnk, startDelay, endDelay) { 140 | 141 | maximumArea = (log10(endDelay) - log10(startDelay)) * A 142 | 143 | area = stats::integrate(dd_integrand_mazur_log10, 144 | lower = log10(startDelay), 145 | upper = log10(endDelay), 146 | lnK = Lnk)$value/maximumArea 147 | 148 | return(area) 149 | } 150 | 151 | #' Hyperbolic Value Function 152 | #' 153 | #' @param x observation at point n (X) 154 | #' @param lnk fitted parameter 155 | #' 156 | #' @return projected, subjective value 157 | #' @author Shawn Gilroy 158 | #' @export 159 | dd_discount_func_mazur <- function(x, lnk) 160 | { 161 | func <- (1 + exp(lnk)*x)^(-1) 162 | eval(func) 163 | } 164 | 165 | #' Hyperbolic Gradient Helper for Nonlinear Fitting 166 | #' 167 | #' @param x observation at point n (X) 168 | #' @param lnk fitted parameter 169 | #' 170 | #' @return projected, subjective value 171 | #' @author Shawn Gilroy 172 | dd_discount_grad_mazur <- function(x, lnk) 173 | { 174 | func <- expression((1 + exp(lnk)*x)^(-1)) 175 | c(eval(stats::D(func, "lnk"))) 176 | } 177 | 178 | #' Hyperbolic Integrand helper (log10) 179 | #' 180 | #' This integrand helper is a projection of the integrand with delays represented in the log base 10 scale 181 | #' 182 | #' @param x observation at point n (X) 183 | #' @param lnK fitted parameter 184 | #' 185 | #' @return Numerical Integration Projection 186 | #' @author Shawn Gilroy 187 | dd_integrand_mazur_log10 <- function(x, lnK) { (1 + exp(lnK)*(10^x))^(-1) } 188 | -------------------------------------------------------------------------------- /R/dd_fit_noise.R: -------------------------------------------------------------------------------- 1 | 2 | #' dd_fit_noise 3 | #' 4 | #' This fits an intercept only model to the data. Its trash, but its a testable alternative that inferring usefulness from an R2 value 5 | #' 6 | #' @param fittingObject core dd fitting object 7 | #' @param id id tag 8 | #' 9 | #' @author Shawn Gilroy 10 | dd_fit_noise <- function(fittingObject, id) { 11 | 12 | modelResults = list( 13 | Model = "noise", 14 | Intercept = NA, 15 | RMSE = NA, 16 | BIC = NA, 17 | AIC = NA, 18 | ED50 = NA, 19 | MBAUC = NA, 20 | Log10MBAUC = NA 21 | ) 22 | 23 | modelFitNoise <- NULL 24 | 25 | currentData = fittingObject$data[ 26 | which(fittingObject$data[, 27 | as.character(fittingObject$settings['Individual'])] == id),] 28 | 29 | currentData$ddX = currentData[,as.character(fittingObject$settings['Delays'])] 30 | currentData$ddY = currentData[,as.character(fittingObject$settings['Values'])] 31 | currentData$ddY = currentData$ddY / as.numeric(fittingObject[[ "maxValue" ]]) 32 | 33 | try(modelFitNoise <- stats::lm(ddY ~ 1, currentData), silent = TRUE) 34 | 35 | if (!is.null(modelFitNoise)) { 36 | modelResults[[ "Intercept" ]] = modelFitNoise$coefficients[["(Intercept)"]] 37 | modelResults[[ "RMSE" ]] = summary(modelFitNoise)[["sigma"]] 38 | modelResults[[ "ED50" ]] = NA 39 | modelResults[[ "MBAUC" ]] = modelFitNoise$coefficients[["(Intercept)"]] / as.numeric(fittingObject[[ "maxValue" ]]) 40 | modelResults[[ "Log10MBAUC" ]] = modelFitNoise$coefficients[["(Intercept)"]] / as.numeric(fittingObject[[ "maxValue" ]]) 41 | modelResults[[ "BIC" ]] = ifelse(summary(modelFitNoise)[["sigma"]] == 0, 42 | Inf, 43 | stats::BIC(modelFitNoise)) 44 | modelResults[[ "AIC" ]] = ifelse(summary(modelFitNoise)[["sigma"]] == 0, 45 | Inf, 46 | stats::AIC(modelFitNoise)) 47 | } 48 | 49 | fittingObject$results[[as.character(id)]][["noise"]] = modelResults 50 | 51 | fittingObject 52 | } 53 | -------------------------------------------------------------------------------- /R/dd_fit_rachlin.R: -------------------------------------------------------------------------------- 1 | 2 | #' dd_fit_rachlin 3 | #' 4 | #' This fits a hyperbolic model to the data. 5 | #' 6 | #' @param fittingObject core dd fitting object 7 | #' @param id id tag 8 | #' 9 | #' @author Shawn Gilroy 10 | #' @importFrom minpack.lm nls.lm nls.lm.control 11 | dd_fit_rachlin <- function(fittingObject, id) { 12 | 13 | modelResults = list( 14 | Model = "rachlin", 15 | Lnk = NA, 16 | S = NA, 17 | RMSE = NA, 18 | BIC = NA, 19 | AIC = NA, 20 | ED50 = NA, 21 | MBAUC = NA, 22 | Log10MBAUC = NA 23 | ) 24 | 25 | currentData = fittingObject$data[ 26 | which(fittingObject$data[, 27 | as.character(fittingObject$settings['Individual'])] == id),] 28 | 29 | currentData$ddX = currentData[,as.character(fittingObject$settings['Delays'])] 30 | currentData$ddY = currentData[,as.character(fittingObject$settings['Values'])] 31 | currentData$ddY = currentData$ddY / as.numeric(fittingObject[[ "maxValue" ]]) 32 | 33 | startParams = dd_start_rachlin(currentData) 34 | 35 | modelFitRachlin <- NULL 36 | 37 | try(modelFitRachlin <- nls.lm(par = startParams, 38 | fn = residualFunction, 39 | jac = jacobianMatrix, 40 | valueFunction = dd_discount_func_rachlin, 41 | jacobianFunction = dd_discount_grad_rachlin, 42 | x = currentData$ddX, 43 | value = currentData$ddY, 44 | control = nls.lm.control(maxiter = 1000)), 45 | silent = TRUE) 46 | 47 | if (!is.null(modelFitRachlin)) { 48 | 49 | modelResults[[ "Lnk" ]] = modelFitRachlin$par[["lnk"]] 50 | modelResults[[ "S" ]] = modelFitRachlin$par[["s"]] 51 | modelResults[[ "RMSE" ]] = sqrt(modelFitRachlin$deviance/length(modelFitRachlin$fvec)) 52 | modelResults[[ "BIC" ]] = stats::BIC(logLik.nls.lm(modelFitRachlin)) 53 | modelResults[[ "AIC" ]] = stats::AIC(logLik.nls.lm(modelFitRachlin)) 54 | modelResults[[ "ED50" ]] = dd_ed50_rachlin( 55 | Lnk = modelFitRachlin$par[["lnk"]], 56 | s = modelFitRachlin$par[["s"]] 57 | ) 58 | modelResults[[ "MBAUC" ]] = dd_mbauc_rachlin( 59 | A = 1, 60 | Lnk = modelFitRachlin$par[["lnk"]], 61 | s = modelFitRachlin$par[["s"]], 62 | startDelay = min(currentData$ddX), 63 | endDelay = max(currentData$ddX) 64 | ) 65 | modelResults[[ "Log10MBAUC" ]] = dd_mbauc_log10_rachlin( 66 | A = 1, 67 | Lnk = modelFitRachlin$par[["lnk"]], 68 | s = modelFitRachlin$par[["s"]], 69 | startDelay = min(currentData$ddX), 70 | endDelay = max(currentData$ddX) 71 | ) 72 | modelResults[[ "Status" ]] = paste("Code:", modelFitRachlin$info, 73 | "- Message:", modelFitRachlin$message, 74 | sep = " ") 75 | } 76 | 77 | fittingObject$results[[as.character(id)]][["rachlin"]] = modelResults 78 | 79 | fittingObject 80 | } 81 | 82 | #' dd_start_rachlin 83 | #' 84 | #' Extract starting parameters 85 | #' 86 | #' @param currentData current data set 87 | #' 88 | #' @author Shawn Gilroy 89 | dd_start_rachlin <- function(currentData) { 90 | 91 | startlnK <- seq(-12, 12, 1) 92 | starts <- seq(.01, 10, .01) 93 | 94 | lengthLnK <- length(startlnK) 95 | lengthX = nrow(currentData) 96 | lengthS <- length(starts) 97 | 98 | SSlnK <- rep(startlnK, lengthS) 99 | SSs <- sort(rep(starts, lengthLnK)) 100 | 101 | sumSquares <- rep(NA, lengthS * lengthLnK) 102 | 103 | SY <- rep(currentData$ddY, lengthS * lengthLnK) 104 | 105 | SlnK <- rep(sort(rep(startlnK,lengthX)), lengthS) 106 | Ss <- sort(rep(starts, lengthX * lengthLnK)) 107 | 108 | projection <- (1 + exp(SlnK) * (currentData$ddX^Ss))^(-1) 109 | sqResidual <- (SY - projection)^2 110 | 111 | for (j in 1:(lengthS*lengthLnK)) sumSquares[j] <- sum(sqResidual[(j - 1) * lengthX + 1:lengthX]) 112 | 113 | presort <- data.frame(SSlnK, SSs, sumSquares) 114 | sorted <- presort[order(presort[,"sumSquares"]),] 115 | ini.par <- c(lnk = sorted$SSlnK[1], 116 | s = sorted$SSs[1]) 117 | 118 | ini.par 119 | } 120 | 121 | #' dd_ed50_rachlin 122 | #' 123 | #' @param Lnk parameter 124 | #' @param s parameter 125 | #' 126 | #' @author Shawn Gilroy 127 | dd_ed50_rachlin <- function(Lnk, s) { 128 | return(log( (1/(exp(Lnk)))^(1/s))) 129 | } 130 | 131 | #' dd_mbauc_rachlin 132 | #' 133 | #' @param A maximum value 134 | #' @param Lnk parameter value 135 | #' @param s parameter value 136 | #' @param startDelay time point 137 | #' @param endDelay time point 138 | #' 139 | #' @author Shawn Gilroy 140 | #' @export 141 | dd_mbauc_rachlin <- function(A, Lnk, s, startDelay, endDelay) { 142 | rachFinal <- A * endDelay * gauss_2F1((1.0), (1.0/s), (1 + (1.0/s)), (-exp(Lnk) * (endDelay )^s)) 143 | rachInitial <- A * startDelay * gauss_2F1((1.0), (1.0/s), (1 + (1.0/s)), (-exp(Lnk) * (startDelay )^s)) 144 | 145 | return((rachFinal - rachInitial) / ((endDelay - startDelay) * A)) 146 | } 147 | 148 | #' dd_mbauc_log10_rachlin 149 | #' 150 | #' @param A maximum value 151 | #' @param Lnk parameter value 152 | #' @param s parameter value 153 | #' @param startDelay time point 154 | #' @param endDelay time point 155 | #' 156 | #' @author Shawn Gilroy 157 | dd_mbauc_log10_rachlin <- function(A, Lnk, s, startDelay, endDelay) { 158 | 159 | maxX = log10(endDelay) 160 | minX = log10(startDelay) 161 | maximumArea = (maxX - minX) * A 162 | 163 | area = stats::integrate(dd_integrand_rachlin_log10, 164 | lower = minX, 165 | upper = maxX, 166 | lnK = Lnk, 167 | s = s)$value/maximumArea 168 | 169 | return(area) 170 | } 171 | 172 | #' Rachlin Value Function 173 | #' 174 | #' @param x observation at point n (X) 175 | #' @param lnk fitted parameter 176 | #' @param s fitted parameter 177 | #' 178 | #' @return projected, subjective value 179 | #' @author Shawn Gilroy 180 | #' @export 181 | dd_discount_func_rachlin <- function(x, lnk, s) 182 | { 183 | func <- (1 + exp(lnk)*(x^s))^(-1) 184 | eval(func) 185 | } 186 | 187 | #' Rachlin Gradient Helper for Nonlinear Fitting 188 | #' 189 | #' @param x observation at point n (X) 190 | #' @param lnk fitted parameter 191 | #' @param s fitted parameter 192 | #' 193 | #' @return projected, subjective value 194 | #' @author Shawn Gilroy 195 | dd_discount_grad_rachlin <- function(x, lnk, s) 196 | { 197 | func <- expression((1 + exp(lnk)*x)^(-s)) 198 | c(eval(stats::deriv(func, "lnk")), 199 | eval(stats::deriv(func, "s"))) 200 | } 201 | 202 | #' Rachlin Integrand helper (log10) 203 | #' 204 | #' This integrand helper is a projection of the integrand with delays represented in the log base 10 scale 205 | #' 206 | #' @param x observation at point n (X) 207 | #' @param lnK fitted parameter 208 | #' @param s fitted parameter 209 | #' 210 | #' @return Numerical Integration Projection 211 | #' @author Shawn Gilroy 212 | dd_integrand_rachlin_log10 <- function(x, lnK, s) { (1 + exp(lnK)*((10^x)^s))^(-1) } 213 | -------------------------------------------------------------------------------- /R/dd_message_debug.R: -------------------------------------------------------------------------------- 1 | #' message_debug 2 | #' 3 | #' Extension of message method, instead yolked to a flag defining level of verbosity. 4 | #' 5 | #' @param fittingObject core fitting object 6 | #' @param msg (char) message 7 | #' 8 | #' @author Shawn Gilroy 9 | message_debug <- function(fittingObject, msg) { 10 | if (fittingObject[[ "verbose" ]] == TRUE) message(msg) 11 | } 12 | -------------------------------------------------------------------------------- /R/dd_plot.R: -------------------------------------------------------------------------------- 1 | #' plot.discountingtools 2 | #' 3 | #' This method overrides the base plot function to provide various plots relevant to the user. 4 | #' 5 | #' @param fittingObject core fitting object 6 | #' @param which (char) type of plot to show, based on fits 7 | #' @param position0 (char) position of legend 8 | #' @param ylab0 (char) y axis label 9 | #' @param xlab0 (char) x axis label 10 | #' @param logAxis (char) axis designation 11 | #' @param yMin (num) y axis lower limit 12 | #' @param id (num) participant number to focus 13 | #' @param plotit (logical) bool of whether or not to print visual or output plotting frame 14 | #' 15 | #' @author Shawn Gilroy 16 | #' @export plot.discountingtools 17 | #' @export 18 | plot.discountingtools <- function(fittingObject, which = "ind", position0 = "bottomleft", ylab0 = "Subjective Value", xlab0 = "Delay", logAxis = "x", yMin = 0.01, id = NULL, plotit = TRUE) { 19 | 20 | if (plotit) { 21 | if (which == "ind" & is.null(id)) plot_individual_rainbow(fittingObject, position0, ylab0, xlab0, logAxis, yMin, plotit) 22 | if (which == "ind" & !is.null(id)) plot_individual_detailed(fittingObject, position0, ylab0, xlab0, logAxis, yMin, id, plotit) 23 | if (which == "group") plot_group_rainbow(fittingObject, position0, ylab0, xlab0, logAxis, yMin, plotit) 24 | if (which == "model") plot_model_characterization(fittingObject, position0, ylab0, xlab0, plotit) 25 | 26 | if (which == "ED50") plot_cross_rainbow(fittingObject, metric = "ProbableModel.LnED50", plotit) 27 | if (which == "MBAUC") plot_cross_rainbow(fittingObject, metric = "ProbableModel.MBAUC", plotit) 28 | if (which == "Log10MBAUC") plot_cross_rainbow(fittingObject, metric = "ProbableModel.Log10MBAUC", plotit) 29 | } else { 30 | if (which == "ind" & is.null(id)) out = plot_individual_rainbow(fittingObject, position0, ylab0, xlab0, logAxis, yMin, plotit) 31 | if (which == "ind" & !is.null(id)) out = plot_individual_detailed(fittingObject, position0, ylab0, xlab0, logAxis, yMin, id, plotit) 32 | if (which == "group") out = plot_group_rainbow(fittingObject, position0, ylab0, xlab0, logAxis, yMin, plotit) 33 | if (which == "model") out = plot_model_characterization(fittingObject, position0, ylab0, xlab0, plotit) 34 | 35 | if (which == "ED50") out = plot_cross_rainbow(fittingObject, metric = "LnED50", plotit) 36 | if (which == "MBAUC") out = plot_cross_rainbow(fittingObject, metric = "MBAUC", plotit) 37 | if (which == "Log10MBAUC") out = plot_cross_rainbow(fittingObject, metric = "Log10MBAUC", plotit) 38 | 39 | return(out) 40 | } 41 | } 42 | -------------------------------------------------------------------------------- /R/dd_plot_cross_model.R: -------------------------------------------------------------------------------- 1 | #' plot_cross_rainbow 2 | #' 3 | #' @param fittingObject core fitting object 4 | #' @param metric (char) the cross model metric to be displayed 5 | #' @param plotit (logical) bool of whether or not to print visual or output plotting frame 6 | #' 7 | #' @author Shawn Gilroy 8 | #' @importFrom grDevices rainbow 9 | #' @importFrom stats as.formula 10 | #' @importFrom lattice panel.histogram panel.superpose histogram 11 | plot_cross_rainbow <- function(fittingObject, metric, plotit) { 12 | 13 | if (!("Group" %in% names(fittingObject$settings))) { 14 | vecGroups = "sample" 15 | 16 | vecColors = rainbow(length(vecGroups), alpha = 1) 17 | 18 | resultFrame = summary(fittingObject) 19 | 20 | if (plotit) { 21 | print(histogram(as.formula(paste("~", metric)), 22 | data = resultFrame, 23 | type = "p")) 24 | } 25 | } else { 26 | vecGroups = unique(fittingObject$data[,as.character(fittingObject$settings['Group'])]) 27 | 28 | vecColors = rainbow(length(vecGroups), alpha = 1) 29 | 30 | resultFrame = summary(fittingObject) 31 | 32 | if (plotit) { 33 | print(histogram(as.formula(paste("~", metric)), 34 | data = resultFrame, 35 | type = "p", 36 | groups = Group, 37 | panel = function(...) 38 | panel.superpose(..., 39 | panel.groups = panel.histogram, 40 | col = vecColors, 41 | alpha = 0.5), 42 | auto.key = list(columns = length(vecColors), 43 | rectangles = FALSE, 44 | col = vecColors))) 45 | } 46 | } 47 | 48 | if (!plotit) resultFrame 49 | } 50 | -------------------------------------------------------------------------------- /R/dd_plot_group.R: -------------------------------------------------------------------------------- 1 | #' plot_group_rainbow 2 | #' 3 | #' Convenience method for illustrating individual fits when characterized by some a priori grouping. 4 | #' 5 | #' @param fittingObject core fitting object 6 | #' @param position0 (char) position of legend 7 | #' @param ylab0 (char) y axis label 8 | #' @param xlab0 (char) x axis label 9 | #' @param logAxis (char) axis designation 10 | #' @param yMin (num) y axis lower limit 11 | #' @param plotit (logical) bool of whether or not to print visual or output plotting frame 12 | #' 13 | #' @author Shawn Gilroy 14 | #' @importFrom grDevices rainbow 15 | #' @importFrom graphics lines legend 16 | plot_group_rainbow <- function(fittingObject, position0, ylab0, xlab0, logAxis, yMin, plotit) { 17 | 18 | if (is.null(fittingObject$settings[["Group"]])) stop('No Group aesthetic specified') 19 | 20 | results = summary(fittingObject) 21 | 22 | if (!("ProbableModel" %in% names(results)) & length(fittingObject$models) > 1) { 23 | stop('Cannot plot individual fits without selecting a single model or using model selection') 24 | } 25 | 26 | if (plotit) { 27 | preDraw = TRUE 28 | yLimits = c(0, fittingObject$maxValue) 29 | 30 | vecGroups = unique(fittingObject$data[,as.character(fittingObject$settings['Group'])]) 31 | vecColors = rainbow(length(vecGroups), alpha = 1) 32 | 33 | for (id in names(fittingObject$results)) { 34 | ogData = fittingObject$data[ 35 | which(fittingObject$data[,as.character(fittingObject$settings['Individual'])] == id),] 36 | 37 | model = fittingObject$models[1] 38 | 39 | if (is.null(fittingObject$rotation)) { 40 | model = names(fittingObject$results[[id]]) 41 | } else { 42 | model = fittingObject$rotation[[id]]$ProbableModel 43 | } 44 | 45 | result = fittingObject$results[[id]][[model]] 46 | 47 | xs = seq(min(ogData[,as.character(fittingObject$settings['Delays'])]), 48 | max(ogData[,as.character(fittingObject$settings['Delays'])]), length.out = 2000) 49 | 50 | if (model == "noise") yhat = rep(result$Intercept, length(xs)) 51 | 52 | if (model == "bleichrodt") yhat = dd_discount_func_bleichrodt_crdi(xs, result$Lnk, result$S, result$Beta) 53 | if (model == "ebertprelec") yhat = dd_discount_func_ebertprelec(xs, result$Lnk, result$S) 54 | if (model == "exponential") yhat = dd_discount_func_exponential(xs, result$Lnk) 55 | if (model == "greenmyerson") yhat = dd_discount_func_greenmyerson(xs, result$Lnk, result$S) 56 | if (model == "laibson") yhat = dd_discount_func_laibson(xs, result$Beta, result$Delta) 57 | if (model == "mazur") yhat = dd_discount_func_mazur(xs, result$Lnk) 58 | if (model == "rachlin") yhat = dd_discount_func_rachlin(xs, result$Lnk, result$S) 59 | if (model == "rodriguezlogue") yhat = dd_discount_func_rodriguezlogue(xs, result$Lnk, result$Beta) 60 | 61 | col = vecColors[match(ogData[1, as.character(fittingObject$settings['Group'])], vecGroups)] 62 | 63 | if (grepl("y", logAxis) == TRUE) { 64 | yhat = yhat[yhat >= 0] 65 | yLimits = c(yMin, fittingObject$maxValue) 66 | } 67 | 68 | if (preDraw) { 69 | plot(xs, yhat * fittingObject$maxValue, 70 | type = "l", 71 | ylim = yLimits, 72 | log = logAxis, 73 | main = "Summary Fits", 74 | col = col, 75 | ylab = ylab0, 76 | xlab = xlab0) 77 | 78 | preDraw = FALSE 79 | } else { 80 | lines(xs, yhat * fittingObject$maxValue, 81 | col = col) 82 | } 83 | } 84 | 85 | legend(position0, 86 | legend = vecGroups, 87 | col = vecColors, 88 | lty = 1) 89 | } else { 90 | outputframe = NULL 91 | 92 | for (id in names(fittingObject$results)) { 93 | 94 | ogData = fittingObject$data[ 95 | which(fittingObject$data[,as.character(fittingObject$settings['Individual'])] == id),] 96 | 97 | model = fittingObject$models[1] 98 | 99 | if (is.null(fittingObject$rotation)) { 100 | model = names(fittingObject$results[[id]]) 101 | } else { 102 | model = fittingObject$rotation[[id]]$ProbableModel 103 | } 104 | 105 | result = fittingObject$results[[id]][[model]] 106 | 107 | xs = seq(min(ogData[,as.character(fittingObject$settings['Delays'])]), 108 | max(ogData[,as.character(fittingObject$settings['Delays'])]), length.out = 2000) 109 | 110 | if (model == "noise") yhat = rep(result$Intercept, length(xs)) 111 | 112 | if (model == "bleichrodt") yhat = dd_discount_func_bleichrodt_crdi(xs, result$Lnk, result$S, result$Beta) 113 | if (model == "ebertprelec") yhat = dd_discount_func_ebertprelec(xs, result$Lnk, result$S) 114 | if (model == "exponential") yhat = dd_discount_func_exponential(xs, result$Lnk) 115 | if (model == "greenmyerson") yhat = dd_discount_func_greenmyerson(xs, result$Lnk, result$S) 116 | if (model == "laibson") yhat = dd_discount_func_laibson(xs, result$Beta, result$Delta) 117 | if (model == "mazur") yhat = dd_discount_func_mazur(xs, result$Lnk) 118 | if (model == "rachlin") yhat = dd_discount_func_rachlin(xs, result$Lnk, result$S) 119 | if (model == "rodriguezlogue") yhat = dd_discount_func_rodriguezlogue(xs, result$Lnk, result$Beta) 120 | 121 | tempFrame = data.frame( 122 | ID = rep(id, length(xs)), 123 | Group = rep(ogData[1, as.character(fittingObject$settings['Group'])], length(xs)), 124 | X = xs, 125 | Y = yhat * fittingObject$maxValue, 126 | Model = rep(model, length(xs)) 127 | ) 128 | 129 | if (is.null(outputframe)) { 130 | outputframe = tempFrame 131 | } else { 132 | outputframe = rbind(outputframe, 133 | tempFrame) 134 | } 135 | } 136 | } 137 | 138 | if (!plotit) outputframe 139 | } 140 | -------------------------------------------------------------------------------- /R/dd_plot_ind.R: -------------------------------------------------------------------------------- 1 | #' plot_individual_rainbow 2 | #' 3 | #' This specific implementation shows cross-model fits, with series characterized by different models illustrated with different colors. A legend is also provided for convenience of interpretation. 4 | #' 5 | #' @param fittingObject core fitting object 6 | #' @param position0 (char) position of legend 7 | #' @param ylab0 (char) y axis label 8 | #' @param xlab0 (char) x axis label 9 | #' @param logAxis (char) axis designation 10 | #' @param yMin (num) y axis lower limit 11 | #' @param plotit (logical) bool of whether or not to print visual or output plotting frame 12 | #' 13 | #' @author Shawn Gilroy 14 | #' @importFrom grDevices rainbow 15 | #' @importFrom graphics lines legend 16 | plot_individual_rainbow <- function(fittingObject, position0, ylab0, xlab0, logAxis, yMin, plotit) { 17 | 18 | if (plotit) { 19 | preDraw = TRUE 20 | yLimits = c(0, fittingObject$maxValue) 21 | 22 | vecModels = fittingObject$models 23 | vecColors = rainbow(length(vecModels), alpha = 1) 24 | 25 | preBuiltLegend = FALSE 26 | legendBuildModel = NA 27 | legendBuildColor = NA 28 | 29 | for (id in names(fittingObject$results)) { 30 | 31 | ogData = fittingObject$data[ 32 | fittingObject$data[[as.character(fittingObject$settings['Individual'])]] == id, 33 | ] 34 | 35 | # Hack: Check if even multiple models 36 | 37 | if (is.null(fittingObject$rotation)) { 38 | model = names(fittingObject$results[[id]]) 39 | } else { 40 | model = fittingObject$rotation[[id]]$ProbableModel 41 | } 42 | 43 | result = fittingObject$results[[id]][[model]] 44 | 45 | xs = seq(min(ogData[,as.character(fittingObject$settings['Delays'])]), 46 | max(ogData[,as.character(fittingObject$settings['Delays'])]), length.out = 2000) 47 | 48 | if (model == "noise") yhat = rep(result$Intercept, length(xs)) 49 | if (model == "bleichrodt") yhat = dd_discount_func_bleichrodt_crdi(xs, result$Lnk, result$S, result$Beta) 50 | if (model == "ebertprelec") yhat = dd_discount_func_ebertprelec(xs, result$Lnk, result$S) 51 | if (model == "exponential") yhat = dd_discount_func_exponential(xs, result$Lnk) 52 | if (model == "greenmyerson") yhat = dd_discount_func_greenmyerson(xs, result$Lnk, result$S) 53 | if (model == "laibson") yhat = dd_discount_func_laibson(xs, result$Beta, result$Delta) 54 | if (model == "mazur") yhat = dd_discount_func_mazur(xs, result$Lnk) 55 | if (model == "rachlin") yhat = dd_discount_func_rachlin(xs, result$Lnk, result$S) 56 | if (model == "rodriguezlogue") yhat = dd_discount_func_rodriguezlogue(xs, result$Lnk, result$Beta) 57 | 58 | if (length(vecColors) == 1) { 59 | col = vecColors 60 | } else { 61 | col = vecColors[match(model, vecModels)] 62 | } 63 | 64 | modelP = gsub("ebertprelec", "ebert prelec", model) 65 | modelP = gsub("greenmyerson", "green myerson", modelP) 66 | modelP = gsub("rodriguezlogue", "rodriguez logue", modelP) 67 | 68 | modelC = tools::toTitleCase(modelP) 69 | 70 | if (!(modelC %in% legendBuildModel)) { 71 | if (!preBuiltLegend) { 72 | legendBuildModel = c(modelC) 73 | legendBuildColor = c(col) 74 | 75 | preBuiltLegend = TRUE 76 | } else { 77 | legendBuildModel = c(legendBuildModel, modelC) 78 | legendBuildColor = c(legendBuildColor, col) 79 | } 80 | } 81 | 82 | if (grepl("y", logAxis) == TRUE) { 83 | yhat = yhat[yhat >= 0] 84 | yLimits = c(yMin, fittingObject$maxValue) 85 | } 86 | 87 | if (preDraw) { 88 | plot(xs, yhat * fittingObject$maxValue, 89 | type = "l", 90 | ylim = yLimits, 91 | log = logAxis, 92 | main = "Summary Fits", 93 | col = col, 94 | ylab = ylab0, 95 | xlab = xlab0) 96 | 97 | preDraw = FALSE 98 | } else { 99 | lines(xs, yhat * fittingObject$maxValue, 100 | col = col) 101 | } 102 | } 103 | 104 | legend(position0, 105 | legend = legendBuildModel, 106 | col = legendBuildColor, 107 | lty = 1, 108 | bty = "n") 109 | 110 | } else { 111 | outputframe = NULL 112 | 113 | for (id in names(fittingObject$results)) { 114 | 115 | ogData = fittingObject$data[ 116 | fittingObject$data[[as.character(fittingObject$settings['Individual'])]] == id, 117 | ] 118 | 119 | # Hack: Check if even multiple models 120 | 121 | if (is.null(fittingObject$rotation)) { 122 | model = names(fittingObject$results[[id]]) 123 | } else { 124 | model = fittingObject$rotation[[id]]$ProbableModel 125 | } 126 | 127 | result = fittingObject$results[[id]][[model]] 128 | 129 | xs = seq(min(ogData[,as.character(fittingObject$settings['Delays'])]), 130 | max(ogData[,as.character(fittingObject$settings['Delays'])]), length.out = 2000) 131 | 132 | if (model == "noise") yhat = rep(result$Intercept, length(xs)) 133 | if (model == "bleichrodt") yhat = dd_discount_func_bleichrodt_crdi(xs, result$Lnk, result$S, result$Beta) 134 | if (model == "ebertprelec") yhat = dd_discount_func_ebertprelec(xs, result$Lnk, result$S) 135 | if (model == "exponential") yhat = dd_discount_func_exponential(xs, result$Lnk) 136 | if (model == "greenmyerson") yhat = dd_discount_func_greenmyerson(xs, result$Lnk, result$S) 137 | if (model == "laibson") yhat = dd_discount_func_laibson(xs, result$Beta, result$Delta) 138 | if (model == "mazur") yhat = dd_discount_func_mazur(xs, result$Lnk) 139 | if (model == "rachlin") yhat = dd_discount_func_rachlin(xs, result$Lnk, result$S) 140 | if (model == "rodriguezlogue") yhat = dd_discount_func_rodriguezlogue(xs, result$Lnk, result$Beta) 141 | 142 | modelP = gsub("ebertprelec", "ebert prelec", model) 143 | modelP = gsub("greenmyerson", "green myerson", modelP) 144 | modelP = gsub("rodriguezlogue", "rodriguez logue", modelP) 145 | 146 | modelC = tools::toTitleCase(modelP) 147 | 148 | if (grepl("y", logAxis) == TRUE) { 149 | yhat = yhat[yhat >= 0] 150 | yLimits = c(yMin, fittingObject$maxValue) 151 | } 152 | 153 | tempFrame = data.frame( 154 | ID = rep(id, length(xs)), 155 | X = xs, 156 | Y = yhat * fittingObject$maxValue, 157 | Model = rep(modelC, length(xs)) 158 | ) 159 | 160 | if (is.null(outputframe)) { 161 | outputframe = tempFrame 162 | } else { 163 | outputframe = rbind(outputframe, 164 | tempFrame) 165 | } 166 | } 167 | } 168 | 169 | if (!plotit) outputframe 170 | } 171 | -------------------------------------------------------------------------------- /R/dd_plot_ind_detailed.R: -------------------------------------------------------------------------------- 1 | #' plot_individual_detailed 2 | #' 3 | #' This implementation of plot singles out a particular responder, providing the fits to the observed data as well as the probability that the "probable" model characterizes the data 4 | #' 5 | #' @param fittingObject core fitting object 6 | #' @param position0 (char) position of legend 7 | #' @param ylab0 (char) y axis label 8 | #' @param xlab0 (char) x axis label 9 | #' @param logAxis (char) axis designation 10 | #' @param yMin (num) y axis lower limit 11 | #' @param id (num) participant id 12 | #' @param plotit (logical) bool of whether or not to print visual or output plotting frame 13 | #' 14 | #' @author Shawn Gilroy 15 | #' @importFrom grDevices rainbow 16 | #' @importFrom graphics lines legend 17 | plot_individual_detailed <- function(fittingObject, position0, ylab0, xlab0, logAxis, yMin, id, plotit) { 18 | if (!(id %in% names(fittingObject$results))) stop('id not found in results') 19 | 20 | if (plotit) { 21 | if (grepl("y", logAxis) == TRUE) { 22 | yLimits = c(yMin, fittingObject$maxValue) 23 | } else { 24 | yLimits = c(0, fittingObject$maxValue) 25 | } 26 | 27 | vecModels = fittingObject$models 28 | vecColors = rainbow(length(vecModels), alpha = 1) 29 | 30 | preBuiltLegend = FALSE 31 | legendBuildModel = NA 32 | legendBuildColor = NA 33 | 34 | ogData = subset(fittingObject$data, ids == id) 35 | 36 | plot(ogData[,as.character(fittingObject$settings['Delays'])], 37 | ogData[,as.character(fittingObject$settings['Values'])], 38 | type = "p", 39 | ylim = yLimits, 40 | log = logAxis, 41 | main = "Summary Fits", 42 | col = "black", 43 | pch = 19, 44 | ylab = ylab0, 45 | xlab = xlab0) 46 | 47 | for (model in names(fittingObject$results[[id]])) { 48 | result = fittingObject$results[[id]][[model]] 49 | 50 | xs = seq(min(ogData[,as.character(fittingObject$settings['Delays'])]), 51 | max(ogData[,as.character(fittingObject$settings['Delays'])]), length.out = 2000) 52 | 53 | if (model == "noise") yhat = rep(result$Intercept, length(xs)) 54 | 55 | if (model == "bleichrodt") yhat = dd_discount_func_bleichrodt_crdi(xs, result$Lnk, result$S, result$Beta) 56 | if (model == "ebertprelec") yhat = dd_discount_func_ebertprelec(xs, result$Lnk, result$S) 57 | if (model == "exponential") yhat = dd_discount_func_exponential(xs, result$Lnk) 58 | if (model == "greenmyerson") yhat = dd_discount_func_greenmyerson(xs, result$Lnk, result$S) 59 | if (model == "laibson") yhat = dd_discount_func_laibson(xs, result$Beta, result$Delta) 60 | if (model == "mazur") yhat = dd_discount_func_mazur(xs, result$Lnk) 61 | if (model == "rachlin") yhat = dd_discount_func_rachlin(xs, result$Lnk, result$S) 62 | if (model == "rodriguezlogue") yhat = dd_discount_func_rodriguezlogue(xs, result$Lnk, result$Beta) 63 | 64 | if (length(vecColors) == 1) { 65 | col = vecColors 66 | } else { 67 | col = vecColors[match(model, vecModels)] 68 | } 69 | 70 | if (!(model %in% legendBuildModel)) { 71 | probString = "" 72 | 73 | modelP = gsub("ebertprelec", "ebert prelec", model) 74 | modelP = gsub("greenmyerson", "green myerson", modelP) 75 | modelP = gsub("rodriguezlogue", "rodriguez logue", modelP) 76 | 77 | modelC = tools::toTitleCase(modelP) 78 | modelC = gsub(" ", "~", modelC) 79 | 80 | if (grepl(model, fittingObject$rotation[[id]]$ProbableModel) == TRUE) { 81 | probString = paste0("~(", 82 | as.character(round(fittingObject$rotation[[id]]$ProbableModel.Prob, 3)), 83 | ")") 84 | 85 | modelP = parse(text = paste0("bold(",modelC, probString,")")) 86 | } else { 87 | modelP = parse(text = paste0(modelC, probString)) 88 | } 89 | 90 | if (!preBuiltLegend) { 91 | legendBuildModel = c(modelP) 92 | legendBuildColor = c(col) 93 | 94 | preBuiltLegend = TRUE 95 | } else { 96 | legendBuildModel = c(legendBuildModel, modelP) 97 | legendBuildColor = c(legendBuildColor, col) 98 | } 99 | } 100 | 101 | if (grepl("y", logAxis) == TRUE) { 102 | yhat = yhat[yhat >= 0] 103 | } 104 | 105 | lines(xs, yhat * fittingObject$maxValue, 106 | col = col) 107 | } 108 | 109 | legend(position0, 110 | legend = legendBuildModel, 111 | col = legendBuildColor, 112 | lty = 1, 113 | bty = "n") 114 | } else { 115 | outputframe = NULL 116 | legendBuildModel = NA 117 | 118 | ogData = subset(fittingObject$data, ids == id) 119 | 120 | for (model in names(fittingObject$results[[id]])) { 121 | result = fittingObject$results[[id]][[model]] 122 | 123 | xs = seq(min(ogData[,as.character(fittingObject$settings['Delays'])]), 124 | max(ogData[,as.character(fittingObject$settings['Delays'])]), length.out = 2000) 125 | 126 | if (model == "noise") yhat = rep(result$Intercept, length(xs)) 127 | 128 | if (model == "bleichrodt") yhat = dd_discount_func_bleichrodt_crdi(xs, result$Lnk, result$S, result$Beta) 129 | if (model == "ebertprelec") yhat = dd_discount_func_ebertprelec(xs, result$Lnk, result$S) 130 | if (model == "exponential") yhat = dd_discount_func_exponential(xs, result$Lnk) 131 | if (model == "greenmyerson") yhat = dd_discount_func_greenmyerson(xs, result$Lnk, result$S) 132 | if (model == "laibson") yhat = dd_discount_func_laibson(xs, result$Beta, result$Delta) 133 | if (model == "mazur") yhat = dd_discount_func_mazur(xs, result$Lnk) 134 | if (model == "rachlin") yhat = dd_discount_func_rachlin(xs, result$Lnk, result$S) 135 | if (model == "rodriguezlogue") yhat = dd_discount_func_rodriguezlogue(xs, result$Lnk, result$Beta) 136 | 137 | if (!(model %in% legendBuildModel)) { 138 | probString = "" 139 | 140 | modelP = gsub("ebertprelec", "ebert prelec", model) 141 | modelP = gsub("greenmyerson", "green myerson", modelP) 142 | modelP = gsub("rodriguezlogue", "rodriguez logue", modelP) 143 | 144 | modelC = tools::toTitleCase(modelP) 145 | modelC = gsub(" ", "~", modelC) 146 | 147 | if (grepl(model, fittingObject$rotation[[id]]$ProbableModel) == TRUE) { 148 | probString = paste0("~(", 149 | as.character(round(fittingObject$rotation[[id]]$ProbableModel.Prob, 3)), 150 | ")") 151 | 152 | modelP = parse(text = paste0("bold(",modelC, probString,")")) 153 | } else { 154 | modelP = parse(text = paste0(modelC, probString)) 155 | } 156 | } 157 | 158 | tempFrame = data.frame( 159 | ID = rep(id, length(xs)), 160 | X = xs, 161 | Y = yhat * fittingObject$maxValue, 162 | Model = rep(modelC, length(xs)) 163 | ) 164 | 165 | if (is.null(outputframe)) { 166 | outputframe = tempFrame 167 | } else { 168 | outputframe = rbind(outputframe, 169 | tempFrame) 170 | } 171 | } 172 | } 173 | 174 | if (!plotit) outputframe 175 | } 176 | -------------------------------------------------------------------------------- /R/dd_plot_model.R: -------------------------------------------------------------------------------- 1 | #' plot_model_characterization 2 | #' 3 | #' @param fittingObject core fitting object 4 | #' @param position0 (char) position of legend 5 | #' @param ylab0 (char) y axis label 6 | #' @param xlab0 (char) x axis label 7 | #' @param plotit (logical) bool of whether or not to print visual or output plotting frame 8 | #' 9 | #' @author Shawn Gilroy 10 | #' @importFrom lattice barchart 11 | plot_model_characterization <- function(fittingObject, position0, ylab0, xlab0, plotit = TRUE) { 12 | 13 | if (!("Group" %in% names(fittingObject$settings))) { 14 | 15 | resultFrame = summary(fittingObject) 16 | 17 | prePlot = table(resultFrame$ProbableModel) 18 | prePlotDf = data.frame( 19 | Counts = as.numeric(prePlot), 20 | Model = attr(prePlot, "dimnames")[[1]] 21 | ) 22 | 23 | prePlotDfFinal = prePlotDf 24 | 25 | if (plotit) { 26 | return(barchart(Counts ~ Model, 27 | data = prePlotDfFinal, 28 | main = "Model Characterization", 29 | scales = list(x = list(rot = 45)))) 30 | 31 | } 32 | } else { 33 | resultFrame = summary(fittingObject) 34 | 35 | prePlotDfFinal = NULL 36 | 37 | for (grp in unique(resultFrame$Group)) { 38 | subsetFrame = subset(resultFrame, Group == grp) 39 | 40 | prePlot = table(subsetFrame$ProbableModel) 41 | 42 | prePlotDf = data.frame( 43 | Counts = as.numeric(prePlot), 44 | Model = attr(prePlot, "dimnames")[[1]], 45 | Group = rep(grp, length(as.numeric(prePlot))) 46 | ) 47 | 48 | if (is.null(prePlotDfFinal)) { 49 | prePlotDfFinal = prePlotDf 50 | } else { 51 | prePlotDfFinal = rbind(prePlotDfFinal, 52 | prePlotDf) 53 | } 54 | } 55 | 56 | if (plotit) { 57 | return(barchart(Counts ~ Model | Group, 58 | data = prePlotDfFinal, 59 | groups = Group, 60 | main = "Model Characterization", 61 | stack = TRUE, 62 | scales = list(x = list(rot = 45)))) 63 | } 64 | } 65 | 66 | if (!plotit) prePlotDfFinal 67 | } 68 | -------------------------------------------------------------------------------- /R/dd_probable_model.R: -------------------------------------------------------------------------------- 1 | #' dd_probable_model 2 | #' 3 | #' This method is used to perform approximate Bayesian model selection using extracted Bayes Factors from calculated BIC values. 4 | #' 5 | #' @param fittingObject core dd fitting object 6 | #' @param id id tag 7 | #' 8 | #' @author Shawn Gilroy 9 | dd_probable_model <- function(fittingObject, id) { 10 | 11 | modelComparison = list( 12 | BFs = list(), 13 | BFSum = 0.0, 14 | Probs = list(), 15 | ProbableModel = NA, 16 | ProbableModelProb = NA 17 | ) 18 | 19 | currentResults = fittingObject$results[[as.character(id)]] 20 | 21 | # Perfect fit for noise model, hacky workaround 22 | if (is.infinite(currentResults$noise$BIC)) { 23 | for (model in as.character(fittingObject$models)) { 24 | modelComparison$BFs[[ model ]] = NULL 25 | modelComparison$BFSum = NULL 26 | } 27 | 28 | for (model in as.character(fittingObject$models)) 29 | modelComparison$Probs[[ model ]] = 0 30 | 31 | modelComparison$ProbableModel = "noise" 32 | modelComparison$ProbableModelProb = 1 33 | 34 | } else { 35 | for (model in as.character(fittingObject$models)) { 36 | modelComparison$BFs[[ model ]] = exp(-.5*(currentResults[[model]]$BIC - currentResults$noise$BIC)) 37 | modelComparison$BFSum = modelComparison$BFSum + modelComparison$BFs[[ model ]] 38 | } 39 | 40 | for (model in as.character(fittingObject$models)) 41 | modelComparison$Probs[[ model ]] = modelComparison$BFs[[ model ]] / modelComparison$BFSum 42 | } 43 | 44 | sortedProbs = sort(unlist(modelComparison[["Probs"]]), decreasing = TRUE) 45 | 46 | mostProbModel <- names(sortedProbs)[1] 47 | 48 | fittingObject$rotation[[as.character(id)]] = list( 49 | ProbableModel = mostProbModel, 50 | ProbableModel.BF = modelComparison$BFs[[mostProbModel]], 51 | ProbableModel.Prob = modelComparison$Probs[[mostProbModel]] 52 | ) 53 | 54 | for (metric in fittingObject[["metrics"]]) { 55 | if (metric == "lned50") fittingObject$ed50[[as.character(id)]] = currentResults[[mostProbModel]]$ED50 56 | if (metric == "mbauc") fittingObject$mbauc[[as.character(id)]] = currentResults[[mostProbModel]]$MBAUC 57 | if (metric == "logmbauc") fittingObject$mbauclog10[[as.character(id)]] = currentResults[[mostProbModel]]$Log10MBAUC 58 | } 59 | 60 | fittingObject 61 | } 62 | -------------------------------------------------------------------------------- /R/dd_screen_jb.R: -------------------------------------------------------------------------------- 1 | #' Perform Johnson & Bickel Screen 2 | #' 3 | #' This function applies the Johnson & Bickel screening criteria to included data series. The result of this procedure is a TRUE/FALSE response to one of two screening criteria. 4 | #' 5 | #' @param fittingObject core fitting object 6 | #' 7 | #' @return A data frame of model screenings 8 | #' @author Shawn Gilroy 9 | #' @export 10 | johnsonBickelScreen <- function(fittingObject) { 11 | 12 | # TODO: needs full testing 13 | 14 | listOfIds = unique(fittingObject$data[[as.character(fittingObject$settings['Individual'])]]) 15 | 16 | for (id in listOfIds) { 17 | message_debug(fittingObject, paste("JB Screen: ", id)) 18 | 19 | currentData = fittingObject$data[ 20 | which(fittingObject$data[, 21 | as.character(fittingObject$settings['Individual'])] == id),] 22 | 23 | fittingObject$data[ 24 | which(fittingObject$data[, 25 | as.character(fittingObject$settings['Individual'])] == id), "JB1"] = TRUE 26 | 27 | fittingObject$data[ 28 | which(fittingObject$data[, 29 | as.character(fittingObject$settings['Individual'])] == id), "JB2"] = TRUE 30 | 31 | currentData$ddX = currentData[,as.character(fittingObject$settings['Delays'])] 32 | currentData$ddY = currentData[,as.character(fittingObject$settings['Values'])] 33 | currentData$ddY = currentData$ddY / as.numeric(fittingObject[[ "maxValue" ]]) 34 | 35 | currentData = currentData[order(currentData$ddX), ] 36 | 37 | for (index in 2:length(currentData$ddX)) { 38 | prev = currentData[index - 1, "ddY"] 39 | curr = currentData[index, "ddY"] 40 | 41 | if ((curr - prev) > as.numeric(fittingObject[[ "JB1Flag" ]])) { 42 | message_debug(fittingObject, paste("JB Screen: ", id, "[Fail JB1]")) 43 | 44 | fittingObject$data[ 45 | which(fittingObject$data[, 46 | as.character(fittingObject$settings['Individual'])] == id), "JB1"] = FALSE 47 | } 48 | } 49 | 50 | prev <- currentData[1, "ddY"] 51 | curr <- currentData[length(currentData$ddX), "ddY"] 52 | 53 | if ((prev - curr) < as.numeric(fittingObject[[ "JB2Flag" ]])) { 54 | message_debug(fittingObject, paste("JB Screen: ", id, "[Fail JB2]")) 55 | 56 | fittingObject$data[ 57 | which(fittingObject$data[, 58 | as.character(fittingObject$settings['Individual'])] == id), "JB2"] = FALSE 59 | } 60 | } 61 | 62 | fittingObject 63 | } 64 | -------------------------------------------------------------------------------- /R/dd_utils.R: -------------------------------------------------------------------------------- 1 | #' Generalized residual call 2 | #' 3 | #' General, shared method for coordinating nls.lm fitting calls. Routes a supplied "valueFunction" with observed data and supplied parameters. 4 | #' 5 | #' @param params model parameters 6 | #' @param x observation at point n (X) 7 | #' @param value observation at point n (Y) 8 | #' @param valueFunction function to get projected value 9 | #' @param jacobianFunction function to create jacobian 10 | #' 11 | #' @return residual value of referenced function 12 | #' @author Shawn Gilroy 13 | residualFunction <- function(params, x, value, valueFunction, jacobianFunction) 14 | { 15 | value - do.call("valueFunction", c(list(x = x), as.list(params))) 16 | } 17 | 18 | #' Generalized Jacobian call 19 | #' 20 | #' General, shared method for constructing the Jacobian matrix. Routes a supplied "jacobianFunction" with pre-computed derivatives to construct matrix with observed data and supplied parameters. 21 | #' 22 | #' @param params model parameters 23 | #' @param x observation at point n (X) 24 | #' @param value observation at point n (Y) 25 | #' @param valueFunction function to get projected value 26 | #' @param jacobianFunction function to create jacobian 27 | #' 28 | #' @return difference value for jacobian 29 | #' @author Shawn Gilroy 30 | jacobianMatrix <- function(params, x, value, valueFunction, jacobianFunction) 31 | { 32 | -do.call("jacobianFunction", c(list(x = x), as.list(params))) 33 | } 34 | 35 | 36 | 37 | #' minpack.lm logLik hack 38 | #' 39 | #' This function constructs a class, derived from an nls.lm object, similar to that of the logLik function in nls. This allows for native calls of the AIC and BIC functions from stats, using nls.lm fit objects. 40 | #' 41 | #' @param fit nls.lm fitted model 42 | #' @param REML determine whether or not to use ML (FALSE by default) 43 | #' @param ... inherit other args as necessary 44 | #' 45 | #' @author Katharine Mullen 46 | #' @return provide a logLik class for AIC/BIC 47 | logLik.nls.lm <- function(fit, REML = FALSE, ...) 48 | { 49 | logLikelihood <- -length(fit$fvec) * (log(2 * pi) + 1 - log(length(fit$fvec)) + log(sum(fit$fvec^2)))/2 50 | 51 | attr(logLikelihood, "df") <- 1L + length(stats::coef(fit)) 52 | attr(logLikelihood, "nobs") <- attr(logLikelihood, "nall") <- length(fit$fvec) 53 | 54 | class(logLikelihood) <- "logLik" 55 | 56 | logLikelihood 57 | } 58 | 59 | #' Workaround for varying bx for hypergeometric series 60 | #' 61 | #' Credit: Stéphane Laurent 62 | #' Source: https://stats.stackexchange.com/questions/33451/computation-of-hypergeometric-function-in-r 63 | #' Licensed CC-BY-SA 3.0, as Per SA Guidelines 64 | #' 65 | #' @param a param 66 | #' @param b param 67 | #' @param c param 68 | #' @param x param 69 | #' 70 | #' @author Stéphane Laurent 71 | #' @importFrom gsl hyperg_2F1 72 | gauss_2F1 <- function(a, b, c, x){ 73 | if (x >= 0 & x < 1) { 74 | hyperg_2F1(a, b, c, x) 75 | } else { 76 | hyperg_2F1(c - a, b, c, 1 - 1 / (1 - x)) / (1 - x)^b 77 | } 78 | } 79 | -------------------------------------------------------------------------------- /codecov.yml: -------------------------------------------------------------------------------- 1 | comment: false 2 | 3 | coverage: 4 | status: 5 | project: 6 | default: 7 | target: auto 8 | threshold: 1% 9 | informational: true 10 | patch: 11 | default: 12 | target: auto 13 | threshold: 1% 14 | informational: true 15 | -------------------------------------------------------------------------------- /demo/.gitignore: -------------------------------------------------------------------------------- 1 | testDebug.R 2 | -------------------------------------------------------------------------------- /demo/00Index: -------------------------------------------------------------------------------- 1 | test_grouped_fits R code for testing fx 2 | test_single_fits_ed50 R code for testing fx 3 | test_single_fits_grouped_ed50 R code for testing fx 4 | test_single_fits_grouped_mbauc_log10 R code for testing fx 5 | test_single_fits_grouped_mbauc R code for testing fx 6 | test_single_fits_grouped R code for testing fx 7 | test_single_fits_mbauc_log10 R code for testing fx 8 | test_single_fits_mbauc R code for testing fx 9 | test_single_fits_recovery R code for testing fx 10 | test_single_fits_selection R code for testing fx 11 | testPlotting R code for testing fx 12 | testScreen R code for testing fx 13 | -------------------------------------------------------------------------------- /demo/test_grouped_fits.R: -------------------------------------------------------------------------------- 1 | # Example: Simulated group fits and parameter recovery 2 | 3 | # Note: Will take a minute to run 4 | 5 | rm(list = ls()) 6 | 7 | library(tidyverse) 8 | library(discountingtools) 9 | 10 | set.seed(65535) 11 | 12 | n_per_group <- 50 13 | 14 | data_frame = data.frame( 15 | ids = seq_len(n_per_group), 16 | ks = NA, 17 | grp = "Group A" 18 | ) 19 | 20 | data_frame$ks = rnorm(length(data_frame$ids), 0.35, 0.125) 21 | data_frame$ks = log(data_frame$ks) 22 | 23 | delays = c(1, 30, 180, 540, 1080, 2160, 4320, 8640) 24 | 25 | data_frame$auc = dd_mbauc_mazur(1, data_frame$ks, min(delays), max(delays)) 26 | 27 | for (row in 1:nrow(data_frame)) { 28 | ys = dd_discount_func_mazur(delays, data_frame[row, "ks"]) + rnorm(length(delays), 29 | 0, 30 | 0.05) 31 | 32 | data_frame[row, as.character(delays)] = ys 33 | } 34 | 35 | data_frame2 = data.frame( 36 | ids = 50 + seq_len(n_per_group), 37 | ks = NA, 38 | grp = "Group B" 39 | ) 40 | 41 | data_frame2$ks = rnorm(length(data_frame2$ids), 0.075, 0.035) 42 | data_frame2$ks = log(data_frame2$ks) 43 | 44 | data_frame2$auc = dd_mbauc_mazur(1, data_frame2$ks, min(delays), max(delays)) 45 | 46 | for (row in 1:nrow(data_frame2)) { 47 | ys = dd_discount_func_mazur(delays, data_frame2[row, "ks"]) + rnorm(length(delays), 48 | 0, 49 | 0.025) 50 | 51 | data_frame2[row, as.character(delays)] = ys 52 | } 53 | 54 | data_frame = rbind(data_frame, 55 | data_frame2) 56 | 57 | data_frame_long = data_frame %>% 58 | gather(Delay, Value, -ids, -ks, -grp, -auc) %>% 59 | mutate(Delay = as.numeric(Delay)) %>% 60 | mutate(Value = ifelse(Value < 0, 0, Value)) %>% 61 | mutate(Value = ifelse(Value > 1, 0, Value)) 62 | 63 | results = fit_dd_curves( 64 | data = data_frame_long, 65 | settings = list(Delays = Delay, 66 | Values = Value, 67 | Group = grp, 68 | Individual = ids), 69 | maxValue = 1, 70 | strategy = 'group', 71 | plan = c('mazur', 'rachlin'), 72 | verbose = FALSE) |> 73 | dd_analyze(modelSelection = TRUE) 74 | 75 | data_frame_results <- summary(results) 76 | 77 | png(filename = "../man/figures/grouped_fits.png", 78 | width = 8, 79 | height = 4, 80 | res = 600, 81 | units = "in") 82 | 83 | par(mfrow = c(1, 1)) 84 | 85 | plot(results, 86 | logAxis = "x", 87 | which = 'group', 88 | position = "topright") 89 | 90 | dev.off() 91 | -------------------------------------------------------------------------------- /demo/test_single_fits_ed50.R: -------------------------------------------------------------------------------- 1 | # Example: Simulated individual fits and parameter recovery 2 | 3 | rm(list = ls()) 4 | 5 | set.seed(65535) 6 | 7 | library(tidyverse) 8 | library(discountingtools) 9 | 10 | dataFrame = data.frame( 11 | ids = 1:100, 12 | ks = NA 13 | ) 14 | 15 | dataFrame$ks = rnorm(length(dataFrame$ids), 0.07, 0.03) 16 | dataFrame$ks = log(dataFrame$ks) 17 | 18 | delays = c(1, 30, 180, 540, 1080, 2160, 4320, 8640) 19 | 20 | for (row in seq_len(nrow(dataFrame))) { 21 | ys = dd_discount_func_mazur(delays, dataFrame[row, "ks"]) + rnorm(length(delays), 22 | 0, 23 | 0.025) 24 | 25 | dataFrame[row, as.character(delays)] = ys 26 | } 27 | 28 | dataFrame.long = dataFrame %>% 29 | gather(Delay, Value, -ids, -ks) %>% 30 | mutate(Delay = as.numeric(Delay)) %>% 31 | mutate(Value = ifelse(Value < 0, 0, Value)) %>% 32 | mutate(Value = ifelse(Value > 1, 0, Value)) 33 | 34 | results = fit_dd_curves( 35 | data = dataFrame.long, 36 | settings = list(Delays = Delay, 37 | Values = Value, 38 | Individual = ids), 39 | maxValue = 1, 40 | plan = c('mazur', 'exponential', 'rachlin', 'laibson'), 41 | verbose = TRUE) |> 42 | dd_analyze(modelSelection = TRUE) 43 | 44 | png(filename = "../man/figures/single_fits_ed50.png", width = 8, height = 6, res = 300, units = "in") 45 | 46 | plot(results, which = "ED50") 47 | 48 | dev.off() 49 | -------------------------------------------------------------------------------- /demo/test_single_fits_grouped.R: -------------------------------------------------------------------------------- 1 | # Example: Simulated group fits and parameter recovery 2 | 3 | # Note: Will take a minute to run 4 | 5 | rm(list = ls()) 6 | 7 | library(tidyverse) 8 | library(discountingtools) 9 | 10 | set.seed(65535) 11 | 12 | n_per_group <- 50 13 | 14 | data_frame = data.frame( 15 | ids = seq_len(n_per_group), 16 | ks = NA, 17 | grp = "Group A" 18 | ) 19 | 20 | data_frame$ks = rnorm(length(data_frame$ids), 0.35, 0.125) 21 | data_frame$ks = log(data_frame$ks) 22 | 23 | delays = c(1, 30, 180, 540, 1080, 2160, 4320, 8640) 24 | 25 | data_frame$auc = dd_mbauc_mazur(1, data_frame$ks, min(delays), max(delays)) 26 | 27 | for (row in 1:nrow(data_frame)) { 28 | ys = dd_discount_func_mazur(delays, data_frame[row, "ks"]) + rnorm(length(delays), 29 | 0, 30 | 0.05) 31 | 32 | data_frame[row, as.character(delays)] = ys 33 | } 34 | 35 | data_frame2 = data.frame( 36 | ids = 50 + seq_len(n_per_group), 37 | ks = NA, 38 | grp = "Group B" 39 | ) 40 | 41 | data_frame2$ks = rnorm(length(data_frame2$ids), 0.075, 0.035) 42 | data_frame2$ks = log(data_frame2$ks) 43 | 44 | data_frame2$auc = dd_mbauc_mazur(1, data_frame2$ks, min(delays), max(delays)) 45 | 46 | for (row in 1:nrow(data_frame2)) { 47 | ys = dd_discount_func_mazur(delays, data_frame2[row, "ks"]) + rnorm(length(delays), 48 | 0, 49 | 0.025) 50 | 51 | data_frame2[row, as.character(delays)] = ys 52 | } 53 | 54 | data_frame = rbind(data_frame, 55 | data_frame2) 56 | 57 | data_frame_long = data_frame %>% 58 | gather(Delay, Value, -ids, -ks, -grp, -auc) %>% 59 | mutate(Delay = as.numeric(Delay)) %>% 60 | mutate(Value = ifelse(Value < 0, 0, Value)) %>% 61 | mutate(Value = ifelse(Value > 1, 0, Value)) 62 | 63 | results = fit_dd_curves(data = data_frame_long, 64 | settings = list(Delays = Delay, 65 | Values = Value, 66 | Individual = ids, 67 | Group = grp), 68 | plan = c("mazur", "exponential"), 69 | maxValue = 1, 70 | verbose = TRUE) |> 71 | dd_analyze(modelSelection = TRUE) 72 | 73 | data_frame_results = summary(results) 74 | 75 | png(filename = "../man/figures/single_fits_grouped.png", 76 | width = 8, 77 | height = 4, 78 | res = 600, 79 | units = "in") 80 | 81 | par(mfrow = c(1, 2)) 82 | 83 | plot(results, logAxis = "x", position = "topright", which = "group") 84 | 85 | vecColors <- rainbow(2, alpha = 1) 86 | 87 | plot(data_frame_results[data_frame_results$Group == 'Group A','ProbableModel.MBAUC'], 88 | data_frame[data_frame$grp == "Group A", 'auc'], 89 | main = "Fitted vs. Simulated", 90 | ylab = "Fitted", 91 | xlab = "Simulated", 92 | col = vecColors[1], 93 | ylim = c(0, 0.05), 94 | xlim = c(0, 0.05)) 95 | 96 | points(data_frame_results[data_frame_results$Group == 'Group B','ProbableModel.MBAUC'], 97 | data_frame[data_frame$grp == "Group B", 'auc'], 98 | main = "Fitted vs. Simulated", 99 | ylab = "Fitted AUC", 100 | xlab = "Simulated AUC", 101 | col = vecColors[2]) 102 | 103 | lines(c(0, 0.05), 104 | c(0, 0.05)) 105 | 106 | dev.off() 107 | -------------------------------------------------------------------------------- /demo/test_single_fits_grouped_ed50.R: -------------------------------------------------------------------------------- 1 | # Example: Simulated group fits and parameter recovery 2 | 3 | # Note: Will take a minute to run 4 | 5 | rm(list = ls()) 6 | 7 | library(tidyverse) 8 | library(discountingtools) 9 | 10 | set.seed(65535) 11 | 12 | n_per_group <- 50 13 | 14 | data_frame = data.frame( 15 | ids = seq_len(n_per_group), 16 | ks = NA, 17 | grp = "Group A" 18 | ) 19 | 20 | data_frame$ks = rnorm(length(data_frame$ids), 0.35, 0.125) 21 | data_frame$ks = log(data_frame$ks) 22 | 23 | delays = c(1, 30, 180, 540, 1080, 2160, 4320, 8640) 24 | 25 | data_frame$auc = dd_mbauc_mazur(1, data_frame$ks, min(delays), max(delays)) 26 | 27 | for (row in 1:nrow(data_frame)) { 28 | ys = dd_discount_func_mazur(delays, data_frame[row, "ks"]) + rnorm(length(delays), 29 | 0, 30 | 0.05) 31 | 32 | data_frame[row, as.character(delays)] = ys 33 | } 34 | 35 | data_frame2 = data.frame( 36 | ids = 50 + seq_len(n_per_group), 37 | ks = NA, 38 | grp = "Group B" 39 | ) 40 | 41 | data_frame2$ks = rnorm(length(data_frame2$ids), 0.075, 0.035) 42 | data_frame2$ks = log(data_frame2$ks) 43 | 44 | data_frame2$auc = dd_mbauc_mazur(1, data_frame2$ks, min(delays), max(delays)) 45 | 46 | for (row in 1:nrow(data_frame2)) { 47 | ys = dd_discount_func_mazur(delays, data_frame2[row, "ks"]) + rnorm(length(delays), 48 | 0, 49 | 0.025) 50 | 51 | data_frame2[row, as.character(delays)] = ys 52 | } 53 | 54 | data_frame = rbind(data_frame, 55 | data_frame2) 56 | 57 | data_frame_long = data_frame %>% 58 | gather(Delay, Value, -ids, -ks, -grp, -auc) %>% 59 | mutate(Delay = as.numeric(Delay)) %>% 60 | mutate(Value = ifelse(Value < 0, 0, Value)) %>% 61 | mutate(Value = ifelse(Value > 1, 0, Value)) 62 | 63 | results = fit_dd_curves(data = data_frame_long, 64 | settings = list(Delays = Delay, 65 | Values = Value, 66 | Individual = ids, 67 | Group = grp), 68 | plan = c("mazur", "exponential"), 69 | maxValue = 1, 70 | verbose = TRUE) |> 71 | dd_analyze(modelSelection = TRUE) 72 | 73 | data_frame_results = summary(results) 74 | 75 | png(filename = "../man/figures/single_fits_grouped_ed50.png", 76 | width = 8, 77 | height = 6, 78 | res = 600, 79 | units = "in") 80 | 81 | plot(results, logAxis = "x", position = "topright", which = "ED50") 82 | 83 | dev.off() 84 | -------------------------------------------------------------------------------- /demo/test_single_fits_grouped_mbauc.R: -------------------------------------------------------------------------------- 1 | # Example: Simulated group fits and parameter recovery 2 | 3 | # Note: Will take a minute to run 4 | 5 | rm(list = ls()) 6 | 7 | library(tidyverse) 8 | library(discountingtools) 9 | 10 | set.seed(65535) 11 | 12 | n_per_group <- 50 13 | 14 | data_frame = data.frame( 15 | ids = seq_len(n_per_group), 16 | ks = NA, 17 | grp = "Group A" 18 | ) 19 | 20 | data_frame$ks = rnorm(length(data_frame$ids), 0.35, 0.125) 21 | data_frame$ks = log(data_frame$ks) 22 | 23 | delays = c(1, 30, 180, 540, 1080, 2160, 4320, 8640) 24 | 25 | data_frame$auc = dd_mbauc_mazur(1, data_frame$ks, min(delays), max(delays)) 26 | 27 | for (row in 1:nrow(data_frame)) { 28 | ys = dd_discount_func_mazur(delays, data_frame[row, "ks"]) + rnorm(length(delays), 29 | 0, 30 | 0.05) 31 | 32 | data_frame[row, as.character(delays)] = ys 33 | } 34 | 35 | data_frame2 = data.frame( 36 | ids = 50 + seq_len(n_per_group), 37 | ks = NA, 38 | grp = "Group B" 39 | ) 40 | 41 | data_frame2$ks = rnorm(length(data_frame2$ids), 0.075, 0.035) 42 | data_frame2$ks = log(data_frame2$ks) 43 | 44 | data_frame2$auc = dd_mbauc_mazur(1, data_frame2$ks, min(delays), max(delays)) 45 | 46 | for (row in 1:nrow(data_frame2)) { 47 | ys = dd_discount_func_mazur(delays, data_frame2[row, "ks"]) + rnorm(length(delays), 48 | 0, 49 | 0.025) 50 | 51 | data_frame2[row, as.character(delays)] = ys 52 | } 53 | 54 | data_frame = rbind(data_frame, 55 | data_frame2) 56 | 57 | data_frame_long = data_frame %>% 58 | gather(Delay, Value, -ids, -ks, -grp, -auc) %>% 59 | mutate(Delay = as.numeric(Delay)) %>% 60 | mutate(Value = ifelse(Value < 0, 0, Value)) %>% 61 | mutate(Value = ifelse(Value > 1, 0, Value)) 62 | 63 | results = fit_dd_curves(data = data_frame_long, 64 | settings = list(Delays = Delay, 65 | Values = Value, 66 | Individual = ids, 67 | Group = grp), 68 | plan = c("mazur", "exponential"), 69 | maxValue = 1, 70 | verbose = TRUE) |> 71 | dd_analyze(modelSelection = TRUE) 72 | 73 | data_frame_results = summary(results) 74 | 75 | png(filename = "../man/figures/single_fits_grouped_mbauc.png", 76 | width = 8, 77 | height = 6, 78 | res = 600, 79 | units = "in") 80 | 81 | plot(results, logAxis = "x", position = "topright", which = "MBAUC") 82 | 83 | dev.off() 84 | -------------------------------------------------------------------------------- /demo/test_single_fits_grouped_mbauc_log10.R: -------------------------------------------------------------------------------- 1 | # Example: Simulated group fits and parameter recovery 2 | 3 | # Note: Will take a minute to run 4 | 5 | rm(list = ls()) 6 | 7 | library(tidyverse) 8 | library(discountingtools) 9 | 10 | set.seed(65535) 11 | 12 | n_per_group <- 50 13 | 14 | data_frame = data.frame( 15 | ids = seq_len(n_per_group), 16 | ks = NA, 17 | grp = "Group A" 18 | ) 19 | 20 | data_frame$ks = rnorm(length(data_frame$ids), 0.35, 0.125) 21 | data_frame$ks = log(data_frame$ks) 22 | 23 | delays = c(1, 30, 180, 540, 1080, 2160, 4320, 8640) 24 | 25 | data_frame$auc = dd_mbauc_mazur(1, data_frame$ks, min(delays), max(delays)) 26 | 27 | for (row in 1:nrow(data_frame)) { 28 | ys = dd_discount_func_mazur(delays, data_frame[row, "ks"]) + rnorm(length(delays), 29 | 0, 30 | 0.05) 31 | 32 | data_frame[row, as.character(delays)] = ys 33 | } 34 | 35 | data_frame2 = data.frame( 36 | ids = 50 + seq_len(n_per_group), 37 | ks = NA, 38 | grp = "Group B" 39 | ) 40 | 41 | data_frame2$ks = rnorm(length(data_frame2$ids), 0.075, 0.035) 42 | data_frame2$ks = log(data_frame2$ks) 43 | 44 | data_frame2$auc = dd_mbauc_mazur(1, data_frame2$ks, min(delays), max(delays)) 45 | 46 | for (row in 1:nrow(data_frame2)) { 47 | ys = dd_discount_func_mazur(delays, data_frame2[row, "ks"]) + rnorm(length(delays), 48 | 0, 49 | 0.025) 50 | 51 | data_frame2[row, as.character(delays)] = ys 52 | } 53 | 54 | data_frame = rbind(data_frame, 55 | data_frame2) 56 | 57 | data_frame_long = data_frame %>% 58 | gather(Delay, Value, -ids, -ks, -grp, -auc) %>% 59 | mutate(Delay = as.numeric(Delay)) %>% 60 | mutate(Value = ifelse(Value < 0, 0, Value)) %>% 61 | mutate(Value = ifelse(Value > 1, 0, Value)) 62 | 63 | results = fit_dd_curves(data = data_frame_long, 64 | settings = list(Delays = Delay, 65 | Values = Value, 66 | Individual = ids, 67 | Group = grp), 68 | plan = c("mazur", "exponential"), 69 | maxValue = 1, 70 | verbose = TRUE) |> 71 | dd_analyze(modelSelection = TRUE) 72 | 73 | data_frame_results = summary(results) 74 | 75 | png(filename = "../man/figures/single_fits_grouped_mbauc_log10.png", 76 | width = 8, 77 | height = 6, 78 | res = 600, 79 | units = "in") 80 | 81 | plot(results, logAxis = "x", position = "topright", which = "Log10MBAUC") 82 | 83 | dev.off() 84 | -------------------------------------------------------------------------------- /demo/test_single_fits_mbauc.R: -------------------------------------------------------------------------------- 1 | # Example: Simulated individual fits and parameter recovery 2 | 3 | rm(list = ls()) 4 | 5 | set.seed(65535) 6 | 7 | library(tidyverse) 8 | library(discountingtools) 9 | 10 | dataFrame = data.frame( 11 | ids = 1:100, 12 | ks = NA 13 | ) 14 | 15 | dataFrame$ks = rnorm(length(dataFrame$ids), 0.07, 0.03) 16 | dataFrame$ks = log(dataFrame$ks) 17 | 18 | delays = c(1, 30, 180, 540, 1080, 2160, 4320, 8640) 19 | 20 | for (row in seq_len(nrow(dataFrame))) { 21 | ys = dd_discount_func_mazur(delays, dataFrame[row, "ks"]) + rnorm(length(delays), 22 | 0, 23 | 0.025) 24 | 25 | dataFrame[row, as.character(delays)] = ys 26 | } 27 | 28 | dataFrame.long = dataFrame %>% 29 | gather(Delay, Value, -ids, -ks) %>% 30 | mutate(Delay = as.numeric(Delay)) %>% 31 | mutate(Value = ifelse(Value < 0, 0, Value)) %>% 32 | mutate(Value = ifelse(Value > 1, 0, Value)) 33 | 34 | results = fit_dd_curves( 35 | data = dataFrame.long, 36 | settings = list(Delays = Delay, 37 | Values = Value, 38 | Individual = ids), 39 | maxValue = 1, 40 | plan = c('mazur', 'exponential', 'rachlin', 'laibson'), 41 | verbose = TRUE) |> 42 | dd_analyze(modelSelection = TRUE) 43 | 44 | png(filename = "../man/figures/single_fits_mbauc.png", width = 8, height = 6, res = 300, units = "in") 45 | 46 | plot(results, which = "MBAUC") 47 | 48 | dev.off() 49 | -------------------------------------------------------------------------------- /demo/test_single_fits_mbauc_log10.R: -------------------------------------------------------------------------------- 1 | # Example: Simulated individual fits and parameter recovery 2 | 3 | rm(list = ls()) 4 | 5 | set.seed(65535) 6 | 7 | library(tidyverse) 8 | library(discountingtools) 9 | 10 | dataFrame = data.frame( 11 | ids = 1:100, 12 | ks = NA 13 | ) 14 | 15 | dataFrame$ks = rnorm(length(dataFrame$ids), 0.07, 0.03) 16 | dataFrame$ks = log(dataFrame$ks) 17 | 18 | delays = c(1, 30, 180, 540, 1080, 2160, 4320, 8640) 19 | 20 | for (row in seq_len(nrow(dataFrame))) { 21 | ys = dd_discount_func_mazur(delays, dataFrame[row, "ks"]) + rnorm(length(delays), 22 | 0, 23 | 0.025) 24 | 25 | dataFrame[row, as.character(delays)] = ys 26 | } 27 | 28 | dataFrame.long = dataFrame %>% 29 | gather(Delay, Value, -ids, -ks) %>% 30 | mutate(Delay = as.numeric(Delay)) %>% 31 | mutate(Value = ifelse(Value < 0, 0, Value)) %>% 32 | mutate(Value = ifelse(Value > 1, 0, Value)) 33 | 34 | results = fit_dd_curves( 35 | data = dataFrame.long, 36 | settings = list(Delays = Delay, 37 | Values = Value, 38 | Individual = ids), 39 | maxValue = 1, 40 | plan = c('mazur', 'exponential', 'rachlin', 'laibson'), 41 | verbose = TRUE) |> 42 | dd_analyze(modelSelection = TRUE) 43 | 44 | png(filename = "../man/figures/single_fits_mbauc_log10.png", width = 8, height = 6, res = 300, units = "in") 45 | 46 | plot(results, which = "Log10MBAUC") 47 | 48 | dev.off() 49 | -------------------------------------------------------------------------------- /demo/test_single_fits_recovery.R: -------------------------------------------------------------------------------- 1 | # Example: Simulated individual fits and parameter recovery 2 | 3 | rm(list = ls()) 4 | 5 | set.seed(65535) 6 | 7 | library(tidyverse) 8 | library(discountingtools) 9 | 10 | dataFrame = data.frame( 11 | ids = 1:100, 12 | ks = NA 13 | ) 14 | 15 | dataFrame$ks = rnorm(length(dataFrame$ids), 0.07, 0.03) 16 | dataFrame$ks = log(dataFrame$ks) 17 | 18 | delays = c(1, 30, 180, 540, 1080, 2160, 4320, 8640) 19 | 20 | for (row in seq_len(nrow(dataFrame))) { 21 | ys = dd_discount_func_mazur(delays, dataFrame[row, "ks"]) + rnorm(length(delays), 22 | 0, 23 | 0.025) 24 | 25 | dataFrame[row, as.character(delays)] = ys 26 | } 27 | 28 | dataFrame.long = dataFrame %>% 29 | gather(Delay, Value, -ids, -ks) %>% 30 | mutate(Delay = as.numeric(Delay)) %>% 31 | mutate(Value = ifelse(Value < 0, 0, Value)) %>% 32 | mutate(Value = ifelse(Value > 1, 0, Value)) 33 | 34 | results = fit_dd_curves( 35 | data = dataFrame.long, 36 | settings = list(Delays = Delay, 37 | Values = Value, 38 | Individual = ids), 39 | maxValue = 1, 40 | plan = c('mazur'), 41 | verbose = TRUE) |> 42 | dd_analyze(modelSelection = FALSE) 43 | 44 | data_frame_results <- summary(results) 45 | 46 | png(filename = "../man/figures/single_fits_recovery.png", 47 | width = 8, 48 | height = 4, 49 | res = 600, 50 | units = "in") 51 | 52 | par(mfrow = c(1, 2)) 53 | 54 | plot(results, 55 | logAxis = "x", 56 | position = "topright") 57 | 58 | plot(data_frame_results$Mazur.Lnk, 59 | dataFrame$ks, 60 | main = "Fitted vs. Simulated", 61 | ylab = "Fitted", 62 | xlab = "Simulated", 63 | ylim = c(-4.5, -1), 64 | xlim = c(-4.5, -1)) 65 | 66 | lines(x = c(-4.5, -1), 67 | y = c(-4.5, -1)) 68 | 69 | dev.off() 70 | -------------------------------------------------------------------------------- /demo/test_single_fits_selection.R: -------------------------------------------------------------------------------- 1 | # Example: Simulated individual fits and parameter recovery 2 | 3 | rm(list = ls()) 4 | 5 | set.seed(65535) 6 | 7 | library(tidyverse) 8 | library(discountingtools) 9 | 10 | dataFrame = data.frame( 11 | ids = 1:100, 12 | ks = NA 13 | ) 14 | 15 | dataFrame$ks = rnorm(length(dataFrame$ids), 0.07, 0.03) 16 | dataFrame$ks = log(dataFrame$ks) 17 | 18 | delays = c(1, 30, 180, 540, 1080, 2160, 4320, 8640) 19 | 20 | for (row in seq_len(nrow(dataFrame))) { 21 | ys = dd_discount_func_mazur(delays, dataFrame[row, "ks"]) + rnorm(length(delays), 22 | 0, 23 | 0.025) 24 | 25 | dataFrame[row, as.character(delays)] = ys 26 | } 27 | 28 | dataFrame.long = dataFrame %>% 29 | gather(Delay, Value, -ids, -ks) %>% 30 | mutate(Delay = as.numeric(Delay)) %>% 31 | mutate(Value = ifelse(Value < 0, 0, Value)) %>% 32 | mutate(Value = ifelse(Value > 1, 0, Value)) 33 | 34 | results = fit_dd_curves( 35 | data = dataFrame.long, 36 | settings = list(Delays = Delay, 37 | Values = Value, 38 | Individual = ids), 39 | maxValue = 1, 40 | plan = c('mazur', 'exponential', 'rachlin'), 41 | verbose = TRUE) |> 42 | dd_analyze(modelSelection = TRUE) 43 | 44 | data_frame_results <- summary(results) 45 | 46 | png(filename = "../man/figures/single_fits_selection.png", 47 | width = 6, 48 | height = 4, 49 | res = 600, 50 | units = "in") 51 | 52 | par(mfrow = c(1, 1)) 53 | 54 | plot(results, 55 | logAxis = "x", 56 | position = "topright") 57 | 58 | dev.off() 59 | -------------------------------------------------------------------------------- /discountingtools.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: No 4 | SaveWorkspace: No 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageUseDevtools: Yes 20 | PackageInstallArgs: --no-multiarch --with-keep.source 21 | PackageRoxygenize: rd,collate,namespace,vignette 22 | -------------------------------------------------------------------------------- /man/dd_analyze.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_call_dd_analyze.R 3 | \name{dd_analyze} 4 | \alias{dd_analyze} 5 | \title{dd_analyze} 6 | \usage{ 7 | dd_analyze(fittingObject, modelSelection = FALSE) 8 | } 9 | \arguments{ 10 | \item{fittingObject}{core dd fitting object} 11 | 12 | \item{modelSelection}{(bool) this flag determines whether or not a model selection procedure will be applied in the results frame.} 13 | } 14 | \description{ 15 | This call is the workhorse of the program. Based on the settings applied, this method applies all relevant methods and calculations to the supplied data. 16 | } 17 | \author{ 18 | Shawn Gilroy 19 | } 20 | -------------------------------------------------------------------------------- /man/dd_discount_func_bleichrodt_crdi.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_bleichrodt.R 3 | \name{dd_discount_func_bleichrodt_crdi} 4 | \alias{dd_discount_func_bleichrodt_crdi} 5 | \title{Bleichrodt et al. Constant Relative Decreasing Impatience (CRDI) Value Function} 6 | \usage{ 7 | dd_discount_func_bleichrodt_crdi(x, lnk, s, beta) 8 | } 9 | \arguments{ 10 | \item{x}{observation at point n (X)} 11 | 12 | \item{lnk}{fitted parameter} 13 | 14 | \item{s}{fitted parameter} 15 | 16 | \item{beta}{fitted parameter} 17 | } 18 | \value{ 19 | projected, subjective value 20 | } 21 | \description{ 22 | Bleichrodt et al. Constant Relative Decreasing Impatience (CRDI) Value Function 23 | } 24 | \author{ 25 | Shawn Gilroy 26 | } 27 | -------------------------------------------------------------------------------- /man/dd_discount_func_ebertprelec.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_ebertprelec.R 3 | \name{dd_discount_func_ebertprelec} 4 | \alias{dd_discount_func_ebertprelec} 5 | \title{Ebert & Prelec Value Function} 6 | \usage{ 7 | dd_discount_func_ebertprelec(x, lnk, s) 8 | } 9 | \arguments{ 10 | \item{x}{observation at point n (X)} 11 | 12 | \item{lnk}{fitted parameter} 13 | 14 | \item{s}{fitted parameter} 15 | } 16 | \value{ 17 | projected, subjective value 18 | } 19 | \description{ 20 | Ebert & Prelec Value Function 21 | } 22 | \author{ 23 | Shawn Gilroy 24 | } 25 | -------------------------------------------------------------------------------- /man/dd_discount_func_exponential.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_exponential.R 3 | \name{dd_discount_func_exponential} 4 | \alias{dd_discount_func_exponential} 5 | \title{Exponential discounting function} 6 | \usage{ 7 | dd_discount_func_exponential(x, lnk) 8 | } 9 | \arguments{ 10 | \item{x}{observation at point n (X)} 11 | 12 | \item{lnk}{fitted parameter} 13 | } 14 | \value{ 15 | projected, subjective value 16 | } 17 | \description{ 18 | Exponential discounting function 19 | } 20 | \author{ 21 | Shawn Gilroy 22 | } 23 | -------------------------------------------------------------------------------- /man/dd_discount_func_greenmyerson.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_greenmyerson.R 3 | \name{dd_discount_func_greenmyerson} 4 | \alias{dd_discount_func_greenmyerson} 5 | \title{Green & Myerson Value Function} 6 | \usage{ 7 | dd_discount_func_greenmyerson(x, lnk, s) 8 | } 9 | \arguments{ 10 | \item{x}{observation at point n (X)} 11 | 12 | \item{lnk}{fitted parameter} 13 | 14 | \item{s}{fitted parameter} 15 | } 16 | \value{ 17 | projected, subjective value 18 | } 19 | \description{ 20 | Green & Myerson Value Function 21 | } 22 | \author{ 23 | Shawn Gilroy 24 | } 25 | -------------------------------------------------------------------------------- /man/dd_discount_func_laibson.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_laibson.R 3 | \name{dd_discount_func_laibson} 4 | \alias{dd_discount_func_laibson} 5 | \title{Beta Delta Value Function} 6 | \usage{ 7 | dd_discount_func_laibson(x, beta, delta) 8 | } 9 | \arguments{ 10 | \item{x}{observation at point n (X)} 11 | 12 | \item{beta}{fitted parameter} 13 | 14 | \item{delta}{fitted parameter} 15 | } 16 | \description{ 17 | Beta Delta Value Function 18 | } 19 | \author{ 20 | Shawn Gilroy 21 | } 22 | -------------------------------------------------------------------------------- /man/dd_discount_func_mazur.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_mazur.R 3 | \name{dd_discount_func_mazur} 4 | \alias{dd_discount_func_mazur} 5 | \title{Hyperbolic Value Function} 6 | \usage{ 7 | dd_discount_func_mazur(x, lnk) 8 | } 9 | \arguments{ 10 | \item{x}{observation at point n (X)} 11 | 12 | \item{lnk}{fitted parameter} 13 | } 14 | \value{ 15 | projected, subjective value 16 | } 17 | \description{ 18 | Hyperbolic Value Function 19 | } 20 | \author{ 21 | Shawn Gilroy 22 | } 23 | -------------------------------------------------------------------------------- /man/dd_discount_func_rachlin.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_rachlin.R 3 | \name{dd_discount_func_rachlin} 4 | \alias{dd_discount_func_rachlin} 5 | \title{Rachlin Value Function} 6 | \usage{ 7 | dd_discount_func_rachlin(x, lnk, s) 8 | } 9 | \arguments{ 10 | \item{x}{observation at point n (X)} 11 | 12 | \item{lnk}{fitted parameter} 13 | 14 | \item{s}{fitted parameter} 15 | } 16 | \value{ 17 | projected, subjective value 18 | } 19 | \description{ 20 | Rachlin Value Function 21 | } 22 | \author{ 23 | Shawn Gilroy 24 | } 25 | -------------------------------------------------------------------------------- /man/dd_discount_func_rodriguezlogue.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_rodriguezlogue.R 3 | \name{dd_discount_func_rodriguezlogue} 4 | \alias{dd_discount_func_rodriguezlogue} 5 | \title{Rodriguez & Logue Value Function} 6 | \usage{ 7 | dd_discount_func_rodriguezlogue(x, lnk, beta) 8 | } 9 | \arguments{ 10 | \item{x}{observation at point n (X)} 11 | 12 | \item{lnk}{fitted parameter} 13 | 14 | \item{beta}{fitted parameter} 15 | } 16 | \value{ 17 | projected, subjective value 18 | } 19 | \description{ 20 | Rodriguez & Logue Value Function 21 | } 22 | \author{ 23 | Shawn Gilroy 24 | } 25 | -------------------------------------------------------------------------------- /man/dd_discount_grad_bleichrodt_crdi.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_bleichrodt.R 3 | \name{dd_discount_grad_bleichrodt_crdi} 4 | \alias{dd_discount_grad_bleichrodt_crdi} 5 | \title{Bleichrodt et al. Constant Relative Decreasing Impatience (CRDI) Helper for Nonlinear Fitting} 6 | \usage{ 7 | dd_discount_grad_bleichrodt_crdi(x, lnk, s, beta) 8 | } 9 | \arguments{ 10 | \item{x}{observation at point n (X)} 11 | 12 | \item{lnk}{fitted parameter} 13 | 14 | \item{s}{fitted parameter} 15 | 16 | \item{beta}{fitted parameter} 17 | } 18 | \value{ 19 | projected, subjective value 20 | } 21 | \description{ 22 | Bleichrodt et al. Constant Relative Decreasing Impatience (CRDI) Helper for Nonlinear Fitting 23 | } 24 | \author{ 25 | Shawn Gilroy 26 | } 27 | -------------------------------------------------------------------------------- /man/dd_discount_grad_exponential.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_exponential.R 3 | \name{dd_discount_grad_exponential} 4 | \alias{dd_discount_grad_exponential} 5 | \title{Exponential Gradient Helper for Nonlinear Fitting} 6 | \usage{ 7 | dd_discount_grad_exponential(x, lnk) 8 | } 9 | \arguments{ 10 | \item{x}{observation at point n (X)} 11 | 12 | \item{lnk}{fitted parameter} 13 | } 14 | \value{ 15 | projected, subjective value 16 | } 17 | \description{ 18 | Exponential Gradient Helper for Nonlinear Fitting 19 | } 20 | \author{ 21 | Shawn Gilroy 22 | } 23 | -------------------------------------------------------------------------------- /man/dd_discount_grad_greenmyerson.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_greenmyerson.R 3 | \name{dd_discount_grad_greenmyerson} 4 | \alias{dd_discount_grad_greenmyerson} 5 | \title{Green & Myerson Gradient Helper for Nonlinear Fitting} 6 | \usage{ 7 | dd_discount_grad_greenmyerson(x, lnk, s) 8 | } 9 | \arguments{ 10 | \item{x}{observation at point n (X)} 11 | 12 | \item{lnk}{fitted parameter} 13 | 14 | \item{s}{fitted parameter} 15 | } 16 | \value{ 17 | projected, subjective value 18 | } 19 | \description{ 20 | Green & Myerson Gradient Helper for Nonlinear Fitting 21 | } 22 | \author{ 23 | Shawn Gilroy 24 | } 25 | -------------------------------------------------------------------------------- /man/dd_discount_grad_laibson.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_laibson.R 3 | \name{dd_discount_grad_laibson} 4 | \alias{dd_discount_grad_laibson} 5 | \title{Beta Delta Gradient Helper for Nonlinear Fitting} 6 | \usage{ 7 | dd_discount_grad_laibson(x, beta, delta) 8 | } 9 | \arguments{ 10 | \item{x}{observation at point n (X)} 11 | 12 | \item{beta}{fitted parameter} 13 | 14 | \item{delta}{fitted parameter} 15 | } 16 | \value{ 17 | projected, subjective value 18 | } 19 | \description{ 20 | Beta Delta Gradient Helper for Nonlinear Fitting 21 | } 22 | \author{ 23 | Shawn Gilroy 24 | } 25 | -------------------------------------------------------------------------------- /man/dd_discount_grad_mazur.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_mazur.R 3 | \name{dd_discount_grad_mazur} 4 | \alias{dd_discount_grad_mazur} 5 | \title{Hyperbolic Gradient Helper for Nonlinear Fitting} 6 | \usage{ 7 | dd_discount_grad_mazur(x, lnk) 8 | } 9 | \arguments{ 10 | \item{x}{observation at point n (X)} 11 | 12 | \item{lnk}{fitted parameter} 13 | } 14 | \value{ 15 | projected, subjective value 16 | } 17 | \description{ 18 | Hyperbolic Gradient Helper for Nonlinear Fitting 19 | } 20 | \author{ 21 | Shawn Gilroy 22 | } 23 | -------------------------------------------------------------------------------- /man/dd_discount_grad_rachlin.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_rachlin.R 3 | \name{dd_discount_grad_rachlin} 4 | \alias{dd_discount_grad_rachlin} 5 | \title{Rachlin Gradient Helper for Nonlinear Fitting} 6 | \usage{ 7 | dd_discount_grad_rachlin(x, lnk, s) 8 | } 9 | \arguments{ 10 | \item{x}{observation at point n (X)} 11 | 12 | \item{lnk}{fitted parameter} 13 | 14 | \item{s}{fitted parameter} 15 | } 16 | \value{ 17 | projected, subjective value 18 | } 19 | \description{ 20 | Rachlin Gradient Helper for Nonlinear Fitting 21 | } 22 | \author{ 23 | Shawn Gilroy 24 | } 25 | -------------------------------------------------------------------------------- /man/dd_discount_grad_rodriguezlogue.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_rodriguezlogue.R 3 | \name{dd_discount_grad_rodriguezlogue} 4 | \alias{dd_discount_grad_rodriguezlogue} 5 | \title{Rodriguez & Logue Helper for Nonlinear Fitting} 6 | \usage{ 7 | dd_discount_grad_rodriguezlogue(x, lnk, beta) 8 | } 9 | \arguments{ 10 | \item{x}{observation at point n (X)} 11 | 12 | \item{lnk}{fitted parameter} 13 | 14 | \item{beta}{fitted parameter} 15 | } 16 | \value{ 17 | projected, subjective value 18 | } 19 | \description{ 20 | Rodriguez & Logue Helper for Nonlinear Fitting 21 | } 22 | \author{ 23 | Shawn Gilroy 24 | } 25 | -------------------------------------------------------------------------------- /man/dd_ed50_bleichrodt.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_bleichrodt.R 3 | \name{dd_ed50_bleichrodt} 4 | \alias{dd_ed50_bleichrodt} 5 | \title{dd_ed50_bleichrodt} 6 | \usage{ 7 | dd_ed50_bleichrodt(Lnk, s, b, currentData) 8 | } 9 | \arguments{ 10 | \item{Lnk}{parameter} 11 | 12 | \item{s}{parameter} 13 | 14 | \item{b}{parameter} 15 | 16 | \item{currentData}{currentData} 17 | } 18 | \description{ 19 | dd_ed50_bleichrodt 20 | } 21 | \author{ 22 | Shawn Gilroy 23 | } 24 | -------------------------------------------------------------------------------- /man/dd_ed50_ebertprelec.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_ebertprelec.R 3 | \name{dd_ed50_ebertprelec} 4 | \alias{dd_ed50_ebertprelec} 5 | \title{dd_ed50_ebertprelec} 6 | \usage{ 7 | dd_ed50_ebertprelec(Lnk, s, currentData) 8 | } 9 | \arguments{ 10 | \item{Lnk}{parameter} 11 | 12 | \item{s}{parameter} 13 | 14 | \item{currentData}{currentData} 15 | } 16 | \description{ 17 | dd_ed50_ebertprelec 18 | } 19 | \author{ 20 | Shawn Gilroy 21 | } 22 | -------------------------------------------------------------------------------- /man/dd_ed50_exponential.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_exponential.R 3 | \name{dd_ed50_exponential} 4 | \alias{dd_ed50_exponential} 5 | \title{dd_ed50_exponential} 6 | \usage{ 7 | dd_ed50_exponential(Lnk) 8 | } 9 | \arguments{ 10 | \item{Lnk}{log transformed rate parameter} 11 | } 12 | \description{ 13 | dd_ed50_exponential 14 | } 15 | \author{ 16 | Shawn Gilroy 17 | } 18 | -------------------------------------------------------------------------------- /man/dd_ed50_greenmyerson.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_greenmyerson.R 3 | \name{dd_ed50_greenmyerson} 4 | \alias{dd_ed50_greenmyerson} 5 | \title{dd_ed50_greenmyerson} 6 | \usage{ 7 | dd_ed50_greenmyerson(Lnk, s) 8 | } 9 | \arguments{ 10 | \item{Lnk}{parameter} 11 | 12 | \item{s}{parameter} 13 | } 14 | \description{ 15 | dd_ed50_greenmyerson 16 | } 17 | \author{ 18 | Shawn Gilroy 19 | } 20 | -------------------------------------------------------------------------------- /man/dd_ed50_laibson.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_laibson.R 3 | \name{dd_ed50_laibson} 4 | \alias{dd_ed50_laibson} 5 | \title{dd_ed50_laibson} 6 | \usage{ 7 | dd_ed50_laibson(b, d) 8 | } 9 | \arguments{ 10 | \item{b}{beta param} 11 | 12 | \item{d}{delta param} 13 | } 14 | \description{ 15 | dd_ed50_laibson 16 | } 17 | \author{ 18 | Shawn Gilroy 19 | } 20 | -------------------------------------------------------------------------------- /man/dd_ed50_mazur.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_mazur.R 3 | \name{dd_ed50_mazur} 4 | \alias{dd_ed50_mazur} 5 | \title{dd_ed50_mazur} 6 | \usage{ 7 | dd_ed50_mazur(Lnk) 8 | } 9 | \arguments{ 10 | \item{Lnk}{log transformed rate parameter} 11 | } 12 | \description{ 13 | dd_ed50_mazur 14 | } 15 | \author{ 16 | Shawn Gilroy 17 | } 18 | -------------------------------------------------------------------------------- /man/dd_ed50_rachlin.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_rachlin.R 3 | \name{dd_ed50_rachlin} 4 | \alias{dd_ed50_rachlin} 5 | \title{dd_ed50_rachlin} 6 | \usage{ 7 | dd_ed50_rachlin(Lnk, s) 8 | } 9 | \arguments{ 10 | \item{Lnk}{parameter} 11 | 12 | \item{s}{parameter} 13 | } 14 | \description{ 15 | dd_ed50_rachlin 16 | } 17 | \author{ 18 | Shawn Gilroy 19 | } 20 | -------------------------------------------------------------------------------- /man/dd_ed50_rodriguezlogue.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_rodriguezlogue.R 3 | \name{dd_ed50_rodriguezlogue} 4 | \alias{dd_ed50_rodriguezlogue} 5 | \title{dd_ed50_rodriguezlogue} 6 | \usage{ 7 | dd_ed50_rodriguezlogue(Lnk, b, currentData) 8 | } 9 | \arguments{ 10 | \item{Lnk}{parameter} 11 | 12 | \item{b}{parameter} 13 | 14 | \item{currentData}{current data} 15 | } 16 | \description{ 17 | dd_ed50_rodriguezlogue 18 | } 19 | \author{ 20 | Shawn Gilroy 21 | } 22 | -------------------------------------------------------------------------------- /man/dd_fit_bleichrodt.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_bleichrodt.R 3 | \name{dd_fit_bleichrodt} 4 | \alias{dd_fit_bleichrodt} 5 | \title{dd_fit_bleichrodt} 6 | \usage{ 7 | dd_fit_bleichrodt(fittingObject, id) 8 | } 9 | \arguments{ 10 | \item{fittingObject}{core dd fitting object} 11 | 12 | \item{id}{id tag} 13 | } 14 | \description{ 15 | This fits a hyperbolic model to the data. 16 | } 17 | \author{ 18 | Shawn Gilroy 19 | } 20 | -------------------------------------------------------------------------------- /man/dd_fit_ebertprelec.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_ebertprelec.R 3 | \name{dd_fit_ebertprelec} 4 | \alias{dd_fit_ebertprelec} 5 | \title{dd_fit_ebertprelec} 6 | \usage{ 7 | dd_fit_ebertprelec(fittingObject, id) 8 | } 9 | \arguments{ 10 | \item{fittingObject}{core dd fitting object} 11 | 12 | \item{id}{id tag} 13 | } 14 | \description{ 15 | This fits a hyperbolic model to the data. 16 | } 17 | \author{ 18 | Shawn Gilroy 19 | } 20 | -------------------------------------------------------------------------------- /man/dd_fit_exponential.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_exponential.R 3 | \name{dd_fit_exponential} 4 | \alias{dd_fit_exponential} 5 | \title{dd_fit_exponential} 6 | \usage{ 7 | dd_fit_exponential(fittingObject, id) 8 | } 9 | \arguments{ 10 | \item{fittingObject}{core dd fitting object} 11 | 12 | \item{id}{id tag} 13 | } 14 | \description{ 15 | This fits a hyperbolic model to the data. 16 | } 17 | \author{ 18 | Shawn Gilroy 19 | } 20 | -------------------------------------------------------------------------------- /man/dd_fit_greenmyerson.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_greenmyerson.R 3 | \name{dd_fit_greenmyerson} 4 | \alias{dd_fit_greenmyerson} 5 | \title{dd_fit_greenmyerson} 6 | \usage{ 7 | dd_fit_greenmyerson(fittingObject, id) 8 | } 9 | \arguments{ 10 | \item{fittingObject}{core dd fitting object} 11 | 12 | \item{id}{id tag} 13 | } 14 | \description{ 15 | This fits a hyperbolic model to the data. 16 | } 17 | \author{ 18 | Shawn Gilroy 19 | } 20 | -------------------------------------------------------------------------------- /man/dd_fit_laibson.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_laibson.R 3 | \name{dd_fit_laibson} 4 | \alias{dd_fit_laibson} 5 | \title{dd_fit_laibson} 6 | \usage{ 7 | dd_fit_laibson(fittingObject, id) 8 | } 9 | \arguments{ 10 | \item{fittingObject}{core dd fitting object} 11 | 12 | \item{id}{id tag} 13 | } 14 | \description{ 15 | This fits a hyperbolic model to the data. 16 | } 17 | \author{ 18 | Shawn Gilroy 19 | } 20 | -------------------------------------------------------------------------------- /man/dd_fit_mazur.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_mazur.R 3 | \name{dd_fit_mazur} 4 | \alias{dd_fit_mazur} 5 | \title{dd_fit_mazur} 6 | \usage{ 7 | dd_fit_mazur(fittingObject, id) 8 | } 9 | \arguments{ 10 | \item{fittingObject}{core dd fitting object} 11 | 12 | \item{id}{id tag} 13 | } 14 | \description{ 15 | This fits a hyperbolic model to the data. 16 | } 17 | \author{ 18 | Shawn Gilroy 19 | } 20 | -------------------------------------------------------------------------------- /man/dd_fit_noise.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_noise.R 3 | \name{dd_fit_noise} 4 | \alias{dd_fit_noise} 5 | \title{dd_fit_noise} 6 | \usage{ 7 | dd_fit_noise(fittingObject, id) 8 | } 9 | \arguments{ 10 | \item{fittingObject}{core dd fitting object} 11 | 12 | \item{id}{id tag} 13 | } 14 | \description{ 15 | This fits an intercept only model to the data. Its trash, but its a testable alternative that inferring usefulness from an R2 value 16 | } 17 | \author{ 18 | Shawn Gilroy 19 | } 20 | -------------------------------------------------------------------------------- /man/dd_fit_rachlin.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_rachlin.R 3 | \name{dd_fit_rachlin} 4 | \alias{dd_fit_rachlin} 5 | \title{dd_fit_rachlin} 6 | \usage{ 7 | dd_fit_rachlin(fittingObject, id) 8 | } 9 | \arguments{ 10 | \item{fittingObject}{core dd fitting object} 11 | 12 | \item{id}{id tag} 13 | } 14 | \description{ 15 | This fits a hyperbolic model to the data. 16 | } 17 | \author{ 18 | Shawn Gilroy 19 | } 20 | -------------------------------------------------------------------------------- /man/dd_fit_rodriguezlogue.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_rodriguezlogue.R 3 | \name{dd_fit_rodriguezlogue} 4 | \alias{dd_fit_rodriguezlogue} 5 | \title{dd_fit_rodriguezlogue} 6 | \usage{ 7 | dd_fit_rodriguezlogue(fittingObject, id) 8 | } 9 | \arguments{ 10 | \item{fittingObject}{core dd fitting object} 11 | 12 | \item{id}{id tag} 13 | } 14 | \description{ 15 | This fits a hyperbolic model to the data. 16 | } 17 | \author{ 18 | Shawn Gilroy 19 | } 20 | -------------------------------------------------------------------------------- /man/dd_grad_func_ebertprelec.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_ebertprelec.R 3 | \name{dd_grad_func_ebertprelec} 4 | \alias{dd_grad_func_ebertprelec} 5 | \title{Ebert & Prelec Helper for Nonlinear Fitting} 6 | \usage{ 7 | dd_grad_func_ebertprelec(x, lnk, s) 8 | } 9 | \arguments{ 10 | \item{x}{observation at point n (X)} 11 | 12 | \item{lnk}{fitted parameter} 13 | 14 | \item{s}{fitted parameter} 15 | } 16 | \value{ 17 | projected, subjective value 18 | } 19 | \description{ 20 | Ebert & Prelec Helper for Nonlinear Fitting 21 | } 22 | \author{ 23 | Shawn Gilroy 24 | } 25 | -------------------------------------------------------------------------------- /man/dd_integrand_exponential_log10.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_exponential.R 3 | \name{dd_integrand_exponential_log10} 4 | \alias{dd_integrand_exponential_log10} 5 | \title{Exponential Integrand helper (log10)} 6 | \usage{ 7 | dd_integrand_exponential_log10(x, lnK) 8 | } 9 | \arguments{ 10 | \item{x}{observation at point n (X)} 11 | 12 | \item{lnK}{fitted parameter} 13 | } 14 | \value{ 15 | Numerical Integration Projection 16 | } 17 | \description{ 18 | This integrand helper is a projection of the integrand with delays represented in the log base 10 scale 19 | } 20 | \author{ 21 | Shawn Gilroy 22 | } 23 | -------------------------------------------------------------------------------- /man/dd_integrand_laibson_log10.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_laibson.R 3 | \name{dd_integrand_laibson_log10} 4 | \alias{dd_integrand_laibson_log10} 5 | \title{Beta Delta Integrand helper (log10)} 6 | \usage{ 7 | dd_integrand_laibson_log10(x, beta, delta) 8 | } 9 | \arguments{ 10 | \item{x}{observation at point n (X)} 11 | 12 | \item{beta}{fitted parameter} 13 | 14 | \item{delta}{fitted parameter} 15 | } 16 | \value{ 17 | Numerical Integration Projection 18 | } 19 | \description{ 20 | This integrand helper is a projection of the integrand with delays represented in the log base 10 scale 21 | } 22 | \author{ 23 | Shawn Gilroy 24 | } 25 | -------------------------------------------------------------------------------- /man/dd_integrand_mazur_log10.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_mazur.R 3 | \name{dd_integrand_mazur_log10} 4 | \alias{dd_integrand_mazur_log10} 5 | \title{Hyperbolic Integrand helper (log10)} 6 | \usage{ 7 | dd_integrand_mazur_log10(x, lnK) 8 | } 9 | \arguments{ 10 | \item{x}{observation at point n (X)} 11 | 12 | \item{lnK}{fitted parameter} 13 | } 14 | \value{ 15 | Numerical Integration Projection 16 | } 17 | \description{ 18 | This integrand helper is a projection of the integrand with delays represented in the log base 10 scale 19 | } 20 | \author{ 21 | Shawn Gilroy 22 | } 23 | -------------------------------------------------------------------------------- /man/dd_integrand_myersongreen_log10.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_greenmyerson.R 3 | \name{dd_integrand_myersongreen_log10} 4 | \alias{dd_integrand_myersongreen_log10} 5 | \title{Green & Myerson Integrand helper (log10)} 6 | \usage{ 7 | dd_integrand_myersongreen_log10(x, lnK, s) 8 | } 9 | \arguments{ 10 | \item{x}{observation at point n (X)} 11 | 12 | \item{lnK}{fitted parameter} 13 | 14 | \item{s}{fitted parameter} 15 | } 16 | \value{ 17 | Numerical Integration Projection 18 | } 19 | \description{ 20 | This integrand helper is a projection of the integrand with delays represented in the log base 10 scale 21 | } 22 | \author{ 23 | Shawn Gilroy 24 | } 25 | -------------------------------------------------------------------------------- /man/dd_integrand_rachlin_log10.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_rachlin.R 3 | \name{dd_integrand_rachlin_log10} 4 | \alias{dd_integrand_rachlin_log10} 5 | \title{Rachlin Integrand helper (log10)} 6 | \usage{ 7 | dd_integrand_rachlin_log10(x, lnK, s) 8 | } 9 | \arguments{ 10 | \item{x}{observation at point n (X)} 11 | 12 | \item{lnK}{fitted parameter} 13 | 14 | \item{s}{fitted parameter} 15 | } 16 | \value{ 17 | Numerical Integration Projection 18 | } 19 | \description{ 20 | This integrand helper is a projection of the integrand with delays represented in the log base 10 scale 21 | } 22 | \author{ 23 | Shawn Gilroy 24 | } 25 | -------------------------------------------------------------------------------- /man/dd_integrand_rodriguezlogue.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_rodriguezlogue.R 3 | \name{dd_integrand_rodriguezlogue} 4 | \alias{dd_integrand_rodriguezlogue} 5 | \title{Rodriguez & Logue Integrand helper} 6 | \usage{ 7 | dd_integrand_rodriguezlogue(x, lnK, beta) 8 | } 9 | \arguments{ 10 | \item{x}{observation at point n (X)} 11 | 12 | \item{lnK}{fitted parameter} 13 | 14 | \item{beta}{fitted parameter} 15 | } 16 | \value{ 17 | Numerical Integration Projection 18 | } 19 | \description{ 20 | This integrand helper is a projection of the integrand with delays represented as normal 21 | } 22 | \author{ 23 | Shawn Gilroy 24 | } 25 | -------------------------------------------------------------------------------- /man/dd_integrand_rodriguezlogue_log10.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_rodriguezlogue.R 3 | \name{dd_integrand_rodriguezlogue_log10} 4 | \alias{dd_integrand_rodriguezlogue_log10} 5 | \title{Rodriguez & Logue Integrand helper} 6 | \usage{ 7 | dd_integrand_rodriguezlogue_log10(x, lnK, beta) 8 | } 9 | \arguments{ 10 | \item{x}{observation at point n (X)} 11 | 12 | \item{lnK}{fitted parameter} 13 | 14 | \item{beta}{fitted parameter} 15 | } 16 | \value{ 17 | Numerical Integration Projection 18 | } 19 | \description{ 20 | This integrand helper is a projection of the integrand (log10) with delays represented in the log base 10 scale 21 | } 22 | \author{ 23 | Shawn Gilroy 24 | } 25 | -------------------------------------------------------------------------------- /man/dd_mbauc_bleichrodt.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_bleichrodt.R 3 | \name{dd_mbauc_bleichrodt} 4 | \alias{dd_mbauc_bleichrodt} 5 | \title{dd_mbauc_bleichrodt} 6 | \usage{ 7 | dd_mbauc_bleichrodt(A, Lnk, s, b, startDelay, endDelay) 8 | } 9 | \arguments{ 10 | \item{A}{maximum value} 11 | 12 | \item{Lnk}{parameter value} 13 | 14 | \item{s}{parameter value} 15 | 16 | \item{b}{parameter value} 17 | 18 | \item{startDelay}{time point} 19 | 20 | \item{endDelay}{time point} 21 | } 22 | \description{ 23 | dd_mbauc_bleichrodt 24 | } 25 | \author{ 26 | Shawn Gilroy 27 | } 28 | -------------------------------------------------------------------------------- /man/dd_mbauc_ebertprelec.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_ebertprelec.R 3 | \name{dd_mbauc_ebertprelec} 4 | \alias{dd_mbauc_ebertprelec} 5 | \title{dd_mbauc_ebertprelec} 6 | \usage{ 7 | dd_mbauc_ebertprelec(A, Lnk, s, startDelay, endDelay) 8 | } 9 | \arguments{ 10 | \item{A}{maximum value} 11 | 12 | \item{Lnk}{parameter value} 13 | 14 | \item{s}{parameter value} 15 | 16 | \item{startDelay}{time point} 17 | 18 | \item{endDelay}{time point} 19 | } 20 | \description{ 21 | dd_mbauc_ebertprelec 22 | } 23 | \author{ 24 | Shawn Gilroy 25 | } 26 | -------------------------------------------------------------------------------- /man/dd_mbauc_exponential.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_exponential.R 3 | \name{dd_mbauc_exponential} 4 | \alias{dd_mbauc_exponential} 5 | \title{dd_mbauc_exponential} 6 | \usage{ 7 | dd_mbauc_exponential(A, Lnk, startDelay, endDelay) 8 | } 9 | \arguments{ 10 | \item{A}{maximum value of good} 11 | 12 | \item{Lnk}{log transformed rate parameter} 13 | 14 | \item{startDelay}{start delay} 15 | 16 | \item{endDelay}{end delay} 17 | } 18 | \description{ 19 | dd_mbauc_exponential 20 | } 21 | \author{ 22 | Shawn Gilroy 23 | } 24 | -------------------------------------------------------------------------------- /man/dd_mbauc_greenmyerson.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_greenmyerson.R 3 | \name{dd_mbauc_greenmyerson} 4 | \alias{dd_mbauc_greenmyerson} 5 | \title{dd_mbauc_rachlin} 6 | \usage{ 7 | dd_mbauc_greenmyerson(A, Lnk, s, startDelay, endDelay) 8 | } 9 | \arguments{ 10 | \item{A}{maximum value} 11 | 12 | \item{Lnk}{parameter value} 13 | 14 | \item{s}{parameter value} 15 | 16 | \item{startDelay}{time point} 17 | 18 | \item{endDelay}{time point} 19 | } 20 | \description{ 21 | dd_mbauc_rachlin 22 | } 23 | \author{ 24 | Shawn Gilroy 25 | } 26 | -------------------------------------------------------------------------------- /man/dd_mbauc_laibson.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_laibson.R 3 | \name{dd_mbauc_laibson} 4 | \alias{dd_mbauc_laibson} 5 | \title{dd_mbauc_laibson} 6 | \usage{ 7 | dd_mbauc_laibson(A, b, d, startDelay, endDelay) 8 | } 9 | \arguments{ 10 | \item{A}{maximum value} 11 | 12 | \item{b}{parameter value} 13 | 14 | \item{d}{parameter value} 15 | 16 | \item{startDelay}{time point} 17 | 18 | \item{endDelay}{time point} 19 | } 20 | \description{ 21 | dd_mbauc_laibson 22 | } 23 | \author{ 24 | Shawn Gilroy 25 | } 26 | -------------------------------------------------------------------------------- /man/dd_mbauc_log10_bleichrodt.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_bleichrodt.R 3 | \name{dd_mbauc_log10_bleichrodt} 4 | \alias{dd_mbauc_log10_bleichrodt} 5 | \title{dd_mbauc_log10_bleichrodt} 6 | \usage{ 7 | dd_mbauc_log10_bleichrodt(A, Lnk, s, b, startDelay, endDelay) 8 | } 9 | \arguments{ 10 | \item{A}{maximum value} 11 | 12 | \item{Lnk}{parameter value} 13 | 14 | \item{s}{parameter value} 15 | 16 | \item{b}{parameter value} 17 | 18 | \item{startDelay}{time point} 19 | 20 | \item{endDelay}{time point} 21 | } 22 | \description{ 23 | dd_mbauc_log10_bleichrodt 24 | } 25 | \author{ 26 | Shawn Gilroy 27 | } 28 | -------------------------------------------------------------------------------- /man/dd_mbauc_log10_ebertprelec.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_ebertprelec.R 3 | \name{dd_mbauc_log10_ebertprelec} 4 | \alias{dd_mbauc_log10_ebertprelec} 5 | \title{dd_mbauc_log10_ebertprelec} 6 | \usage{ 7 | dd_mbauc_log10_ebertprelec(A, Lnk, s, startDelay, endDelay) 8 | } 9 | \arguments{ 10 | \item{A}{maximum value} 11 | 12 | \item{Lnk}{parameter value} 13 | 14 | \item{s}{parameter value} 15 | 16 | \item{startDelay}{time point} 17 | 18 | \item{endDelay}{time point} 19 | } 20 | \description{ 21 | dd_mbauc_log10_ebertprelec 22 | } 23 | \author{ 24 | Shawn Gilroy 25 | } 26 | -------------------------------------------------------------------------------- /man/dd_mbauc_log10_exponential.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_exponential.R 3 | \name{dd_mbauc_log10_exponential} 4 | \alias{dd_mbauc_log10_exponential} 5 | \title{dd_mbauc_log10_exponential} 6 | \usage{ 7 | dd_mbauc_log10_exponential(A, Lnk, startDelay, endDelay) 8 | } 9 | \arguments{ 10 | \item{A}{maximum value of good} 11 | 12 | \item{Lnk}{log transformed rate parameter} 13 | 14 | \item{startDelay}{start delay} 15 | 16 | \item{endDelay}{end delay} 17 | } 18 | \description{ 19 | dd_mbauc_log10_exponential 20 | } 21 | \author{ 22 | Shawn Gilroy 23 | } 24 | -------------------------------------------------------------------------------- /man/dd_mbauc_log10_greenmyerson.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_greenmyerson.R 3 | \name{dd_mbauc_log10_greenmyerson} 4 | \alias{dd_mbauc_log10_greenmyerson} 5 | \title{dd_mbauc_log10_greenmyerson} 6 | \usage{ 7 | dd_mbauc_log10_greenmyerson(A, Lnk, s, startDelay, endDelay) 8 | } 9 | \arguments{ 10 | \item{A}{maximum value} 11 | 12 | \item{Lnk}{parameter value} 13 | 14 | \item{s}{parameter value} 15 | 16 | \item{startDelay}{time point} 17 | 18 | \item{endDelay}{time point} 19 | } 20 | \description{ 21 | dd_mbauc_log10_greenmyerson 22 | } 23 | \author{ 24 | Shawn Gilroy 25 | } 26 | -------------------------------------------------------------------------------- /man/dd_mbauc_log10_laibson.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_laibson.R 3 | \name{dd_mbauc_log10_laibson} 4 | \alias{dd_mbauc_log10_laibson} 5 | \title{dd_mbauc_log10_laibson} 6 | \usage{ 7 | dd_mbauc_log10_laibson(A, b, d, startDelay, endDelay) 8 | } 9 | \arguments{ 10 | \item{A}{maximum value} 11 | 12 | \item{b}{parameter value} 13 | 14 | \item{d}{parameter value} 15 | 16 | \item{startDelay}{time point} 17 | 18 | \item{endDelay}{time point} 19 | } 20 | \description{ 21 | dd_mbauc_log10_laibson 22 | } 23 | \author{ 24 | Shawn Gilroy 25 | } 26 | -------------------------------------------------------------------------------- /man/dd_mbauc_log10_mazur.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_mazur.R 3 | \name{dd_mbauc_log10_mazur} 4 | \alias{dd_mbauc_log10_mazur} 5 | \title{dd_mbauc_log10_mazur} 6 | \usage{ 7 | dd_mbauc_log10_mazur(A, Lnk, startDelay, endDelay) 8 | } 9 | \arguments{ 10 | \item{A}{maximum value of good} 11 | 12 | \item{Lnk}{log transformed rate parameter} 13 | 14 | \item{startDelay}{start delay} 15 | 16 | \item{endDelay}{end delay} 17 | } 18 | \description{ 19 | dd_mbauc_log10_mazur 20 | } 21 | \author{ 22 | Shawn Gilroy 23 | } 24 | -------------------------------------------------------------------------------- /man/dd_mbauc_log10_rachlin.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_rachlin.R 3 | \name{dd_mbauc_log10_rachlin} 4 | \alias{dd_mbauc_log10_rachlin} 5 | \title{dd_mbauc_log10_rachlin} 6 | \usage{ 7 | dd_mbauc_log10_rachlin(A, Lnk, s, startDelay, endDelay) 8 | } 9 | \arguments{ 10 | \item{A}{maximum value} 11 | 12 | \item{Lnk}{parameter value} 13 | 14 | \item{s}{parameter value} 15 | 16 | \item{startDelay}{time point} 17 | 18 | \item{endDelay}{time point} 19 | } 20 | \description{ 21 | dd_mbauc_log10_rachlin 22 | } 23 | \author{ 24 | Shawn Gilroy 25 | } 26 | -------------------------------------------------------------------------------- /man/dd_mbauc_log10_rodriguezlogue.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_rodriguezlogue.R 3 | \name{dd_mbauc_log10_rodriguezlogue} 4 | \alias{dd_mbauc_log10_rodriguezlogue} 5 | \title{dd_mbauc_log10_rodriguezlogue} 6 | \usage{ 7 | dd_mbauc_log10_rodriguezlogue(A, Lnk, b, startDelay, endDelay) 8 | } 9 | \arguments{ 10 | \item{A}{maximum value} 11 | 12 | \item{Lnk}{parameter value} 13 | 14 | \item{b}{parameter value} 15 | 16 | \item{startDelay}{time point} 17 | 18 | \item{endDelay}{time point} 19 | } 20 | \description{ 21 | dd_mbauc_log10_rodriguezlogue 22 | } 23 | \author{ 24 | Shawn Gilroy 25 | } 26 | -------------------------------------------------------------------------------- /man/dd_mbauc_mazur.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_mazur.R 3 | \name{dd_mbauc_mazur} 4 | \alias{dd_mbauc_mazur} 5 | \title{dd_mbauc_mazur} 6 | \usage{ 7 | dd_mbauc_mazur(A, Lnk, startDelay, endDelay) 8 | } 9 | \arguments{ 10 | \item{A}{maximum value} 11 | 12 | \item{Lnk}{logged parameter value} 13 | 14 | \item{startDelay}{time point} 15 | 16 | \item{endDelay}{time point} 17 | } 18 | \description{ 19 | dd_mbauc_mazur 20 | } 21 | \author{ 22 | Shawn Gilroy 23 | } 24 | -------------------------------------------------------------------------------- /man/dd_mbauc_rachlin.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_rachlin.R 3 | \name{dd_mbauc_rachlin} 4 | \alias{dd_mbauc_rachlin} 5 | \title{dd_mbauc_rachlin} 6 | \usage{ 7 | dd_mbauc_rachlin(A, Lnk, s, startDelay, endDelay) 8 | } 9 | \arguments{ 10 | \item{A}{maximum value} 11 | 12 | \item{Lnk}{parameter value} 13 | 14 | \item{s}{parameter value} 15 | 16 | \item{startDelay}{time point} 17 | 18 | \item{endDelay}{time point} 19 | } 20 | \description{ 21 | dd_mbauc_rachlin 22 | } 23 | \author{ 24 | Shawn Gilroy 25 | } 26 | -------------------------------------------------------------------------------- /man/dd_mbauc_rodriguezlogue.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_rodriguezlogue.R 3 | \name{dd_mbauc_rodriguezlogue} 4 | \alias{dd_mbauc_rodriguezlogue} 5 | \title{dd_mbauc_rodriguezlogue} 6 | \usage{ 7 | dd_mbauc_rodriguezlogue(A, Lnk, b, startDelay, endDelay) 8 | } 9 | \arguments{ 10 | \item{A}{maximum value} 11 | 12 | \item{Lnk}{parameter value} 13 | 14 | \item{b}{parameter value} 15 | 16 | \item{startDelay}{time point} 17 | 18 | \item{endDelay}{time point} 19 | } 20 | \description{ 21 | dd_mbauc_rodriguezlogue 22 | } 23 | \author{ 24 | Shawn Gilroy 25 | } 26 | -------------------------------------------------------------------------------- /man/dd_probable_model.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_probable_model.R 3 | \name{dd_probable_model} 4 | \alias{dd_probable_model} 5 | \title{dd_probable_model} 6 | \usage{ 7 | dd_probable_model(fittingObject, id) 8 | } 9 | \arguments{ 10 | \item{fittingObject}{core dd fitting object} 11 | 12 | \item{id}{id tag} 13 | } 14 | \description{ 15 | This method is used to perform approximate Bayesian model selection using extracted Bayes Factors from calculated BIC values. 16 | } 17 | \author{ 18 | Shawn Gilroy 19 | } 20 | -------------------------------------------------------------------------------- /man/dd_screen.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_call_screen_options.R 3 | \name{dd_screen} 4 | \alias{dd_screen} 5 | \title{dd_screen_options} 6 | \usage{ 7 | dd_screen( 8 | fittingObject, 9 | screen = TRUE, 10 | JB1Flag = 0.2, 11 | JB2Flag = 0.1, 12 | filterPassing = NULL 13 | ) 14 | } 15 | \arguments{ 16 | \item{fittingObject}{core fitting object} 17 | 18 | \item{screen}{(bool) set screen TRUE or FALSE (i.e. NULL)} 19 | 20 | \item{JB1Flag}{(num) bounce constant per authors (set at initial defaults)} 21 | 22 | \item{JB2Flag}{(num) extremity change constant per authors (set at initial defaults)} 23 | 24 | \item{filterPassing}{(char vector) which JB criteria to retain in dataset, e.g. c("JB1", "JB2")} 25 | } 26 | \description{ 27 | This call applies screening criteria to a data dataset. Specifically, it can be used to apply criteria (no filtering) or apply criteria and filter based on one or more criteria (e.g., JB1, JB2) 28 | } 29 | -------------------------------------------------------------------------------- /man/dd_start_bleichrodt.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_bleichrodt.R 3 | \name{dd_start_bleichrodt} 4 | \alias{dd_start_bleichrodt} 5 | \title{dd_start_bleichrodt} 6 | \usage{ 7 | dd_start_bleichrodt(currentData) 8 | } 9 | \arguments{ 10 | \item{currentData}{current data set} 11 | } 12 | \description{ 13 | Extract starting parameters 14 | } 15 | \author{ 16 | Shawn Gilroy 17 | } 18 | -------------------------------------------------------------------------------- /man/dd_start_ebertprelec.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_ebertprelec.R 3 | \name{dd_start_ebertprelec} 4 | \alias{dd_start_ebertprelec} 5 | \title{dd_start_ebertprelec} 6 | \usage{ 7 | dd_start_ebertprelec(currentData) 8 | } 9 | \arguments{ 10 | \item{currentData}{current data set} 11 | } 12 | \description{ 13 | Extract starting parameters 14 | } 15 | \author{ 16 | Shawn Gilroy 17 | } 18 | -------------------------------------------------------------------------------- /man/dd_start_exponential.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_exponential.R 3 | \name{dd_start_exponential} 4 | \alias{dd_start_exponential} 5 | \title{dd_start_exponential} 6 | \usage{ 7 | dd_start_exponential(currentData, increment = 1) 8 | } 9 | \arguments{ 10 | \item{currentData}{current data set} 11 | 12 | \item{increment}{step size for span} 13 | } 14 | \description{ 15 | Extract starting parameters 16 | } 17 | \author{ 18 | Shawn Gilroy 19 | } 20 | -------------------------------------------------------------------------------- /man/dd_start_greenmyerson.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_greenmyerson.R 3 | \name{dd_start_greenmyerson} 4 | \alias{dd_start_greenmyerson} 5 | \title{dd_start_laibson} 6 | \usage{ 7 | dd_start_greenmyerson(currentData) 8 | } 9 | \arguments{ 10 | \item{currentData}{current data set} 11 | } 12 | \description{ 13 | Extract starting parameters 14 | } 15 | \author{ 16 | Shawn Gilroy 17 | } 18 | -------------------------------------------------------------------------------- /man/dd_start_laibson.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_laibson.R 3 | \name{dd_start_laibson} 4 | \alias{dd_start_laibson} 5 | \title{dd_start_laibson} 6 | \usage{ 7 | dd_start_laibson(currentData) 8 | } 9 | \arguments{ 10 | \item{currentData}{current data set} 11 | } 12 | \description{ 13 | Extract starting parameters 14 | } 15 | \author{ 16 | Shawn Gilroy 17 | } 18 | -------------------------------------------------------------------------------- /man/dd_start_mazur.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_mazur.R 3 | \name{dd_start_mazur} 4 | \alias{dd_start_mazur} 5 | \title{dd_start_mazur} 6 | \usage{ 7 | dd_start_mazur(currentData) 8 | } 9 | \arguments{ 10 | \item{currentData}{current data set} 11 | } 12 | \description{ 13 | Extract starting parameters 14 | } 15 | \author{ 16 | Shawn Gilroy 17 | } 18 | -------------------------------------------------------------------------------- /man/dd_start_rachlin.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_rachlin.R 3 | \name{dd_start_rachlin} 4 | \alias{dd_start_rachlin} 5 | \title{dd_start_rachlin} 6 | \usage{ 7 | dd_start_rachlin(currentData) 8 | } 9 | \arguments{ 10 | \item{currentData}{current data set} 11 | } 12 | \description{ 13 | Extract starting parameters 14 | } 15 | \author{ 16 | Shawn Gilroy 17 | } 18 | -------------------------------------------------------------------------------- /man/dd_start_rodriguezlogue.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_rodriguezlogue.R 3 | \name{dd_start_rodriguezlogue} 4 | \alias{dd_start_rodriguezlogue} 5 | \title{dd_start_rodriguezlogue} 6 | \usage{ 7 | dd_start_rodriguezlogue(currentData) 8 | } 9 | \arguments{ 10 | \item{currentData}{current data set} 11 | } 12 | \description{ 13 | Extract starting parameters 14 | } 15 | \author{ 16 | Shawn Gilroy 17 | } 18 | -------------------------------------------------------------------------------- /man/figures/grouped_fits.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/miyamot0/discountingtools/712ca3313a9eee44abb03c56c936d2141f90ce27/man/figures/grouped_fits.png -------------------------------------------------------------------------------- /man/figures/single_fits_ed50.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/miyamot0/discountingtools/712ca3313a9eee44abb03c56c936d2141f90ce27/man/figures/single_fits_ed50.png -------------------------------------------------------------------------------- /man/figures/single_fits_grouped.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/miyamot0/discountingtools/712ca3313a9eee44abb03c56c936d2141f90ce27/man/figures/single_fits_grouped.png -------------------------------------------------------------------------------- /man/figures/single_fits_grouped_ed50.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/miyamot0/discountingtools/712ca3313a9eee44abb03c56c936d2141f90ce27/man/figures/single_fits_grouped_ed50.png -------------------------------------------------------------------------------- /man/figures/single_fits_grouped_mbauc.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/miyamot0/discountingtools/712ca3313a9eee44abb03c56c936d2141f90ce27/man/figures/single_fits_grouped_mbauc.png -------------------------------------------------------------------------------- /man/figures/single_fits_grouped_mbauc_log10.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/miyamot0/discountingtools/712ca3313a9eee44abb03c56c936d2141f90ce27/man/figures/single_fits_grouped_mbauc_log10.png -------------------------------------------------------------------------------- /man/figures/single_fits_mbauc.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/miyamot0/discountingtools/712ca3313a9eee44abb03c56c936d2141f90ce27/man/figures/single_fits_mbauc.png -------------------------------------------------------------------------------- /man/figures/single_fits_mbauc_log10.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/miyamot0/discountingtools/712ca3313a9eee44abb03c56c936d2141f90ce27/man/figures/single_fits_mbauc_log10.png -------------------------------------------------------------------------------- /man/figures/single_fits_recovery.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/miyamot0/discountingtools/712ca3313a9eee44abb03c56c936d2141f90ce27/man/figures/single_fits_recovery.png -------------------------------------------------------------------------------- /man/figures/single_fits_selection.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/miyamot0/discountingtools/712ca3313a9eee44abb03c56c936d2141f90ce27/man/figures/single_fits_selection.png -------------------------------------------------------------------------------- /man/fit_dd_curves.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_call_fit_dd_curves.R 3 | \name{fit_dd_curves} 4 | \alias{fit_dd_curves} 5 | \title{fit_dd_curves} 6 | \usage{ 7 | fit_dd_curves( 8 | data, 9 | settings, 10 | maxValue = NULL, 11 | strategy = "ind", 12 | verbose = FALSE, 13 | plan = NULL, 14 | metrics = c("lned50", "mbauc", "logmbauc") 15 | ) 16 | } 17 | \arguments{ 18 | \item{data}{(dataframe) assigned data} 19 | 20 | \item{settings}{(named list) mappings} 21 | 22 | \item{maxValue}{(num) A parameter} 23 | 24 | \item{strategy}{(char) fit to individual ids (default) or group} 25 | 26 | \item{verbose}{(bool) output level (default FALSE)} 27 | 28 | \item{plan}{(char vector) This vector contains a list of possible model candidates.} 29 | 30 | \item{metrics}{(char vector) This vector contains a list of possible cross-model metrics.} 31 | } 32 | \description{ 33 | This is the entry point for users. It constructs a core fitting object that is passed through the program, with branching options based on those specified by the user. 34 | } 35 | \author{ 36 | Shawn Gilroy 37 | } 38 | -------------------------------------------------------------------------------- /man/gauss_2F1.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_utils.R 3 | \name{gauss_2F1} 4 | \alias{gauss_2F1} 5 | \title{Workaround for varying bx for hypergeometric series} 6 | \usage{ 7 | gauss_2F1(a, b, c, x) 8 | } 9 | \arguments{ 10 | \item{a}{param} 11 | 12 | \item{b}{param} 13 | 14 | \item{c}{param} 15 | 16 | \item{x}{param} 17 | } 18 | \description{ 19 | Credit: Stéphane Laurent 20 | Source: https://stats.stackexchange.com/questions/33451/computation-of-hypergeometric-function-in-r 21 | Licensed CC-BY-SA 3.0, as Per SA Guidelines 22 | } 23 | \author{ 24 | Stéphane Laurent 25 | } 26 | -------------------------------------------------------------------------------- /man/integrand_bleichrodt_crdi.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_bleichrodt.R 3 | \name{integrand_bleichrodt_crdi} 4 | \alias{integrand_bleichrodt_crdi} 5 | \title{Bleichrodt et al. Constant Relative Decreasing Impatience (CRDI) Integrand helper} 6 | \usage{ 7 | integrand_bleichrodt_crdi(x, lnK, s, beta) 8 | } 9 | \arguments{ 10 | \item{x}{observation at point n (X)} 11 | 12 | \item{lnK}{fitted parameter} 13 | 14 | \item{s}{fitted parameter} 15 | 16 | \item{beta}{fitted parameter} 17 | } 18 | \value{ 19 | Numerical Integration Projection 20 | } 21 | \description{ 22 | This integrand helper is a projection of the integrand with delays represented as normal 23 | } 24 | \author{ 25 | Shawn Gilroy 26 | } 27 | -------------------------------------------------------------------------------- /man/integrand_bleichrodt_crdi_log10.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_bleichrodt.R 3 | \name{integrand_bleichrodt_crdi_log10} 4 | \alias{integrand_bleichrodt_crdi_log10} 5 | \title{Bleichrodt et al. Constant Relative Decreasing Impatience (CRDI) Integrand helper (log10)} 6 | \usage{ 7 | integrand_bleichrodt_crdi_log10(x, lnK, s, beta) 8 | } 9 | \arguments{ 10 | \item{x}{observation at point n (X)} 11 | 12 | \item{lnK}{fitted parameter} 13 | 14 | \item{s}{fitted parameter} 15 | 16 | \item{beta}{fitted parameter} 17 | } 18 | \value{ 19 | Numerical Integration Projection 20 | } 21 | \description{ 22 | This integrand helper is a projection of the integrand with delays represented in the log base 10 scale 23 | } 24 | \author{ 25 | Shawn Gilroy 26 | } 27 | -------------------------------------------------------------------------------- /man/integrand_ebertprelec.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_ebertprelec.R 3 | \name{integrand_ebertprelec} 4 | \alias{integrand_ebertprelec} 5 | \title{Ebert & Prelec's Integrand helper} 6 | \usage{ 7 | integrand_ebertprelec(x, lnK, s) 8 | } 9 | \arguments{ 10 | \item{x}{observation at point n (X)} 11 | 12 | \item{lnK}{fitted parameter} 13 | 14 | \item{s}{fitted parameter} 15 | } 16 | \value{ 17 | Numerical Integration Projection 18 | } 19 | \description{ 20 | This integrand helper is a projection of the integrand with delays represented as normal 21 | } 22 | \author{ 23 | Shawn Gilroy 24 | } 25 | -------------------------------------------------------------------------------- /man/integrand_ebertprelec_log10.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_fit_ebertprelec.R 3 | \name{integrand_ebertprelec_log10} 4 | \alias{integrand_ebertprelec_log10} 5 | \title{Ebert & Prelec's ep Integrand helper (log10)} 6 | \usage{ 7 | integrand_ebertprelec_log10(x, lnK, s) 8 | } 9 | \arguments{ 10 | \item{x}{observation at point n (X)} 11 | 12 | \item{lnK}{fitted parameter} 13 | 14 | \item{s}{fitted parameter} 15 | } 16 | \value{ 17 | Numerical Integration Projection 18 | } 19 | \description{ 20 | This integrand helper is a projection of the integrand with delays represented in the log base 10 scale 21 | } 22 | \author{ 23 | Shawn Gilroy 24 | } 25 | -------------------------------------------------------------------------------- /man/jacobianMatrix.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_utils.R 3 | \name{jacobianMatrix} 4 | \alias{jacobianMatrix} 5 | \title{Generalized Jacobian call} 6 | \usage{ 7 | jacobianMatrix(params, x, value, valueFunction, jacobianFunction) 8 | } 9 | \arguments{ 10 | \item{params}{model parameters} 11 | 12 | \item{x}{observation at point n (X)} 13 | 14 | \item{value}{observation at point n (Y)} 15 | 16 | \item{valueFunction}{function to get projected value} 17 | 18 | \item{jacobianFunction}{function to create jacobian} 19 | } 20 | \value{ 21 | difference value for jacobian 22 | } 23 | \description{ 24 | General, shared method for constructing the Jacobian matrix. Routes a supplied "jacobianFunction" with pre-computed derivatives to construct matrix with observed data and supplied parameters. 25 | } 26 | \author{ 27 | Shawn Gilroy 28 | } 29 | -------------------------------------------------------------------------------- /man/johnsonBickelScreen.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_screen_jb.R 3 | \name{johnsonBickelScreen} 4 | \alias{johnsonBickelScreen} 5 | \title{Perform Johnson & Bickel Screen} 6 | \usage{ 7 | johnsonBickelScreen(fittingObject) 8 | } 9 | \arguments{ 10 | \item{fittingObject}{core fitting object} 11 | } 12 | \value{ 13 | A data frame of model screenings 14 | } 15 | \description{ 16 | This function applies the Johnson & Bickel screening criteria to included data series. The result of this procedure is a TRUE/FALSE response to one of two screening criteria. 17 | } 18 | \author{ 19 | Shawn Gilroy 20 | } 21 | -------------------------------------------------------------------------------- /man/logLik.nls.lm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_utils.R 3 | \name{logLik.nls.lm} 4 | \alias{logLik.nls.lm} 5 | \title{minpack.lm logLik hack} 6 | \usage{ 7 | \method{logLik}{nls.lm}(fit, REML = FALSE, ...) 8 | } 9 | \arguments{ 10 | \item{fit}{nls.lm fitted model} 11 | 12 | \item{REML}{determine whether or not to use ML (FALSE by default)} 13 | 14 | \item{...}{inherit other args as necessary} 15 | } 16 | \value{ 17 | provide a logLik class for AIC/BIC 18 | } 19 | \description{ 20 | This function constructs a class, derived from an nls.lm object, similar to that of the logLik function in nls. This allows for native calls of the AIC and BIC functions from stats, using nls.lm fit objects. 21 | } 22 | \author{ 23 | Katharine Mullen 24 | } 25 | -------------------------------------------------------------------------------- /man/message_debug.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_message_debug.R 3 | \name{message_debug} 4 | \alias{message_debug} 5 | \title{message_debug} 6 | \usage{ 7 | message_debug(fittingObject, msg) 8 | } 9 | \arguments{ 10 | \item{fittingObject}{core fitting object} 11 | 12 | \item{msg}{(char) message} 13 | } 14 | \description{ 15 | Extension of message method, instead yolked to a flag defining level of verbosity. 16 | } 17 | \author{ 18 | Shawn Gilroy 19 | } 20 | -------------------------------------------------------------------------------- /man/plot.discountingtools.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_plot.R 3 | \name{plot.discountingtools} 4 | \alias{plot.discountingtools} 5 | \title{plot.discountingtools} 6 | \usage{ 7 | \method{plot}{discountingtools}( 8 | fittingObject, 9 | which = "ind", 10 | position0 = "bottomleft", 11 | ylab0 = "Subjective Value", 12 | xlab0 = "Delay", 13 | logAxis = "x", 14 | yMin = 0.01, 15 | id = NULL, 16 | plotit = TRUE 17 | ) 18 | } 19 | \arguments{ 20 | \item{fittingObject}{core fitting object} 21 | 22 | \item{which}{(char) type of plot to show, based on fits} 23 | 24 | \item{position0}{(char) position of legend} 25 | 26 | \item{ylab0}{(char) y axis label} 27 | 28 | \item{xlab0}{(char) x axis label} 29 | 30 | \item{logAxis}{(char) axis designation} 31 | 32 | \item{yMin}{(num) y axis lower limit} 33 | 34 | \item{id}{(num) participant number to focus} 35 | 36 | \item{plotit}{(logical) bool of whether or not to print visual or output plotting frame} 37 | } 38 | \description{ 39 | This method overrides the base plot function to provide various plots relevant to the user. 40 | } 41 | \author{ 42 | Shawn Gilroy 43 | } 44 | -------------------------------------------------------------------------------- /man/plot_cross_rainbow.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_plot_cross_model.R 3 | \name{plot_cross_rainbow} 4 | \alias{plot_cross_rainbow} 5 | \title{plot_cross_rainbow} 6 | \usage{ 7 | plot_cross_rainbow(fittingObject, metric, plotit) 8 | } 9 | \arguments{ 10 | \item{fittingObject}{core fitting object} 11 | 12 | \item{metric}{(char) the cross model metric to be displayed} 13 | 14 | \item{plotit}{(logical) bool of whether or not to print visual or output plotting frame} 15 | } 16 | \description{ 17 | plot_cross_rainbow 18 | } 19 | \author{ 20 | Shawn Gilroy 21 | } 22 | -------------------------------------------------------------------------------- /man/plot_group_rainbow.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_plot_group.R 3 | \name{plot_group_rainbow} 4 | \alias{plot_group_rainbow} 5 | \title{plot_group_rainbow} 6 | \usage{ 7 | plot_group_rainbow( 8 | fittingObject, 9 | position0, 10 | ylab0, 11 | xlab0, 12 | logAxis, 13 | yMin, 14 | plotit 15 | ) 16 | } 17 | \arguments{ 18 | \item{fittingObject}{core fitting object} 19 | 20 | \item{position0}{(char) position of legend} 21 | 22 | \item{ylab0}{(char) y axis label} 23 | 24 | \item{xlab0}{(char) x axis label} 25 | 26 | \item{logAxis}{(char) axis designation} 27 | 28 | \item{yMin}{(num) y axis lower limit} 29 | 30 | \item{plotit}{(logical) bool of whether or not to print visual or output plotting frame} 31 | } 32 | \description{ 33 | Convenience method for illustrating individual fits when characterized by some a priori grouping. 34 | } 35 | \author{ 36 | Shawn Gilroy 37 | } 38 | -------------------------------------------------------------------------------- /man/plot_individual_detailed.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_plot_ind_detailed.R 3 | \name{plot_individual_detailed} 4 | \alias{plot_individual_detailed} 5 | \title{plot_individual_detailed} 6 | \usage{ 7 | plot_individual_detailed( 8 | fittingObject, 9 | position0, 10 | ylab0, 11 | xlab0, 12 | logAxis, 13 | yMin, 14 | id, 15 | plotit 16 | ) 17 | } 18 | \arguments{ 19 | \item{fittingObject}{core fitting object} 20 | 21 | \item{position0}{(char) position of legend} 22 | 23 | \item{ylab0}{(char) y axis label} 24 | 25 | \item{xlab0}{(char) x axis label} 26 | 27 | \item{logAxis}{(char) axis designation} 28 | 29 | \item{yMin}{(num) y axis lower limit} 30 | 31 | \item{id}{(num) participant id} 32 | 33 | \item{plotit}{(logical) bool of whether or not to print visual or output plotting frame} 34 | } 35 | \description{ 36 | This implementation of plot singles out a particular responder, providing the fits to the observed data as well as the probability that the "probable" model characterizes the data 37 | } 38 | \author{ 39 | Shawn Gilroy 40 | } 41 | -------------------------------------------------------------------------------- /man/plot_individual_rainbow.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_plot_ind.R 3 | \name{plot_individual_rainbow} 4 | \alias{plot_individual_rainbow} 5 | \title{plot_individual_rainbow} 6 | \usage{ 7 | plot_individual_rainbow( 8 | fittingObject, 9 | position0, 10 | ylab0, 11 | xlab0, 12 | logAxis, 13 | yMin, 14 | plotit 15 | ) 16 | } 17 | \arguments{ 18 | \item{fittingObject}{core fitting object} 19 | 20 | \item{position0}{(char) position of legend} 21 | 22 | \item{ylab0}{(char) y axis label} 23 | 24 | \item{xlab0}{(char) x axis label} 25 | 26 | \item{logAxis}{(char) axis designation} 27 | 28 | \item{yMin}{(num) y axis lower limit} 29 | 30 | \item{plotit}{(logical) bool of whether or not to print visual or output plotting frame} 31 | } 32 | \description{ 33 | This specific implementation shows cross-model fits, with series characterized by different models illustrated with different colors. A legend is also provided for convenience of interpretation. 34 | } 35 | \author{ 36 | Shawn Gilroy 37 | } 38 | -------------------------------------------------------------------------------- /man/plot_model_characterization.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_plot_model.R 3 | \name{plot_model_characterization} 4 | \alias{plot_model_characterization} 5 | \title{plot_model_characterization} 6 | \usage{ 7 | plot_model_characterization( 8 | fittingObject, 9 | position0, 10 | ylab0, 11 | xlab0, 12 | plotit = TRUE 13 | ) 14 | } 15 | \arguments{ 16 | \item{fittingObject}{core fitting object} 17 | 18 | \item{position0}{(char) position of legend} 19 | 20 | \item{ylab0}{(char) y axis label} 21 | 22 | \item{xlab0}{(char) x axis label} 23 | 24 | \item{plotit}{(logical) bool of whether or not to print visual or output plotting frame} 25 | } 26 | \description{ 27 | plot_model_characterization 28 | } 29 | \author{ 30 | Shawn Gilroy 31 | } 32 | -------------------------------------------------------------------------------- /man/residualFunction.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_utils.R 3 | \name{residualFunction} 4 | \alias{residualFunction} 5 | \title{Generalized residual call} 6 | \usage{ 7 | residualFunction(params, x, value, valueFunction, jacobianFunction) 8 | } 9 | \arguments{ 10 | \item{params}{model parameters} 11 | 12 | \item{x}{observation at point n (X)} 13 | 14 | \item{value}{observation at point n (Y)} 15 | 16 | \item{valueFunction}{function to get projected value} 17 | 18 | \item{jacobianFunction}{function to create jacobian} 19 | } 20 | \value{ 21 | residual value of referenced function 22 | } 23 | \description{ 24 | General, shared method for coordinating nls.lm fitting calls. Routes a supplied "valueFunction" with observed data and supplied parameters. 25 | } 26 | \author{ 27 | Shawn Gilroy 28 | } 29 | -------------------------------------------------------------------------------- /man/summary.discountingtools.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dd_summary.R 3 | \name{summary.discountingtools} 4 | \alias{summary.discountingtools} 5 | \title{summary.discountingtools} 6 | \usage{ 7 | \method{summary}{discountingtools}(fittingObject, detailed = FALSE) 8 | } 9 | \arguments{ 10 | \item{fittingObject}{core fitting object} 11 | 12 | \item{detailed}{enable additional model metrics (default FALSE)} 13 | } 14 | \description{ 15 | Override summary output. Rather than display the core fitting object, a data frame block of results is provided to the user for easy interpretation and further analysis 16 | } 17 | \author{ 18 | Shawn Gilroy 19 | } 20 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(discountingtools) 3 | 4 | test_check("discountingtools") 5 | -------------------------------------------------------------------------------- /tests/testthat/Rplots.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/miyamot0/discountingtools/712ca3313a9eee44abb03c56c936d2141f90ce27/tests/testthat/Rplots.pdf -------------------------------------------------------------------------------- /tests/testthat/test-call_dd_fit_curves.R: -------------------------------------------------------------------------------- 1 | rm(list = ls()) 2 | 3 | library(discountingtools) 4 | 5 | og_k <- -0.7549554 6 | og_ln_ed50 <- 0.8379741 7 | og_mb_auc <- 0.002105094 8 | og_mb_auc_log <- 0.1320793 9 | 10 | data_frame = data.frame( 11 | ids = 1, 12 | ks = og_k, 13 | delay = c(1, 30, 180, 540, 1080, 2160, 4320, 8640) 14 | ) 15 | 16 | data_frame[, 'value'] <- dd_discount_func_mazur( 17 | data_frame$delay, 18 | data_frame$ks) + 19 | c(0.0109249702, 20 | 0.0305477299, 21 | -0.0118369887, 22 | 0.0052715790, 23 | -0.0454706108, 24 | 0.0068767728, 25 | 0.0008717358, 26 | -0.0044386829) 27 | 28 | ## TODO: need good tests here 29 | 30 | describe("dd_fit_curves", { 31 | it("Should pass", { 32 | testthat::expect_no_error( 33 | fit_dd_curves( 34 | data = data_frame, 35 | settings = list(Delays = delay, 36 | Values = value, 37 | Individual = ids), 38 | maxValue = 1, 39 | plan = c('mazur'), 40 | verbose = TRUE) |> 41 | dd_screen() |> 42 | dd_analyze(modelSelection = FALSE) 43 | ) 44 | }) 45 | 46 | it("Should pass - with model selection", { 47 | testthat::expect_no_error( 48 | fit_dd_curves( 49 | data = data_frame, 50 | settings = list(Delays = delay, 51 | Values = value, 52 | Individual = ids), 53 | maxValue = 1, 54 | plan = c('mazur'), 55 | verbose = TRUE) |> 56 | dd_screen() |> 57 | dd_analyze(modelSelection = TRUE) 58 | ) 59 | }) 60 | 61 | it("Should pass - with filtering for JB1", { 62 | testthat::expect_no_error( 63 | fit_dd_curves( 64 | data = data_frame, 65 | settings = list(Delays = delay, 66 | Values = value, 67 | Individual = ids), 68 | maxValue = 1, 69 | plan = c('mazur'), 70 | verbose = TRUE) |> 71 | dd_screen(filterPassing = c("JB1")) |> 72 | dd_analyze(modelSelection = TRUE) 73 | ) 74 | }) 75 | 76 | it("Should pass - with filtering for JB2", { 77 | testthat::expect_no_error( 78 | fit_dd_curves( 79 | data = data_frame, 80 | settings = list(Delays = delay, 81 | Values = value, 82 | Individual = ids), 83 | maxValue = 1, 84 | plan = c('mazur'), 85 | verbose = TRUE) |> 86 | dd_screen(filterPassing = c("JB2")) |> 87 | dd_analyze(modelSelection = TRUE) 88 | ) 89 | }) 90 | 91 | it("Should fail: Bad screening arg", { 92 | testthat::expect_error( 93 | fit_dd_curves( 94 | data = data_frame, 95 | settings = list(Delays = delay, 96 | Values = value, 97 | Individual = ids), 98 | maxValue = 1, 99 | plan = c('mazur'), 100 | verbose = TRUE) |> 101 | dd_screen(filterPassing = c("JB3")) |> 102 | dd_analyze(modelSelection = TRUE), 103 | 'Only `JB1` or `JB2` screening supported' 104 | ) 105 | }) 106 | 107 | it("Should fail: Bad screen var", { 108 | testthat::expect_error( 109 | fit_dd_curves( 110 | data = data_frame, 111 | settings = list(Delays = delay, 112 | Values = value, 113 | Individual = ids), 114 | maxValue = 1, 115 | plan = c('mazur'), 116 | verbose = TRUE) |> 117 | dd_screen(screen = c("JB1")) |> 118 | dd_analyze(modelSelection = TRUE), 119 | 'screen must be a boolean' 120 | ) 121 | }) 122 | 123 | it("Should fail: Bad JB1Flag var", { 124 | testthat::expect_error( 125 | fit_dd_curves( 126 | data = data_frame, 127 | settings = list(Delays = delay, 128 | Values = value, 129 | Individual = ids), 130 | maxValue = 1, 131 | plan = c('mazur'), 132 | verbose = TRUE) |> 133 | dd_screen(JB1Flag = c("0.1")) |> 134 | dd_analyze(modelSelection = TRUE), 135 | 'JB1Flag must be numeric' 136 | ) 137 | }) 138 | 139 | it("Should fail: Bad JB2Flag var", { 140 | testthat::expect_error( 141 | fit_dd_curves( 142 | data = data_frame, 143 | settings = list(Delays = delay, 144 | Values = value, 145 | Individual = ids), 146 | maxValue = 1, 147 | plan = c('mazur'), 148 | verbose = TRUE) |> 149 | dd_screen(JB2Flag = c("0.1")) |> 150 | dd_analyze(modelSelection = TRUE), 151 | 'JB2Flag must be numeric' 152 | ) 153 | }) 154 | 155 | it("Should fail: Missing Delays", { 156 | testthat::expect_error( 157 | fit_dd_curves( 158 | data = data_frame, 159 | settings = list(Values = value, 160 | Individual = ids), 161 | maxValue = 1, 162 | plan = c('mazur')) |> 163 | dd_analyze(modelSelection = FALSE), 164 | "No Delays aesthetic specified" 165 | ) 166 | }) 167 | 168 | it("Should fail: Missing Values", { 169 | testthat::expect_error( 170 | fit_dd_curves( 171 | data = data_frame, 172 | settings = list(Delays = delay, 173 | Individual = ids), 174 | maxValue = 1, 175 | plan = c('mazur')) |> 176 | dd_analyze(modelSelection = FALSE), 177 | "No Values aesthetic specified" 178 | ) 179 | }) 180 | 181 | it("Should fail: Missing Individuals", { 182 | testthat::expect_error( 183 | fit_dd_curves( 184 | data = data_frame, 185 | settings = list(Delays = delay, 186 | Values = value), 187 | maxValue = 1, 188 | plan = c('mazur')) |> 189 | dd_analyze(modelSelection = FALSE), 190 | "No Individual aesthetic specified" 191 | ) 192 | }) 193 | 194 | it("Should fail: No models", { 195 | testthat::expect_error( 196 | fit_dd_curves( 197 | data = data_frame, 198 | settings = list(Delays = delay, 199 | Values = value, 200 | Individual = ids), 201 | maxValue = 1) |> 202 | dd_analyze(modelSelection = FALSE), 203 | "No models specified" 204 | ) 205 | }) 206 | 207 | it("Should fail: No max value specified", { 208 | testthat::expect_error( 209 | fit_dd_curves( 210 | data = data_frame, 211 | settings = list(Delays = delay, 212 | Values = value, 213 | Individual = ids), 214 | plan = c('mazur')) |> 215 | dd_analyze(modelSelection = FALSE), 216 | "No maximum value specified" 217 | ) 218 | }) 219 | 220 | it("Should fail: bad strategy specified", { 221 | testthat::expect_error( 222 | fit_dd_curves( 223 | data = data_frame, 224 | settings = list(Delays = delay, 225 | Values = value, 226 | Individual = ids), 227 | plan = c('mazur'), 228 | maxValue = 1, 229 | strategy = "individualized") |> 230 | dd_analyze(modelSelection = FALSE), 231 | "Only `ind` or `group` strategies supported" 232 | ) 233 | }) 234 | 235 | }) 236 | 237 | -------------------------------------------------------------------------------- /tests/testthat/test-ind-bleichrodt.R: -------------------------------------------------------------------------------- 1 | rm(list = ls()) 2 | 3 | library(discountingtools) 4 | 5 | og_k <- -2 6 | og_s <- 0.9 7 | og_b <- 1 8 | og_ln_ed50 <- 1.905696 9 | og_mb_auc <- 0.00121091 10 | og_mb_auc_log <- 0.2002947 11 | 12 | data_frame = data.frame( 13 | ids = 1, 14 | ks = og_k, 15 | ss = og_s, 16 | bs = og_b, 17 | delay = c(1, 30, 180, 540, 1080, 2160, 4320, 8640) 18 | ) 19 | 20 | data_frame[, 'value'] <- dd_discount_func_bleichrodt_crdi( 21 | data_frame$delay, 22 | data_frame$ks, 23 | data_frame$ss, 24 | data_frame$bs) + 25 | c(0.0109249702, 26 | 0.0305477299, 27 | -0.0118369887, 28 | 0.0052715790, 29 | -0.0454706108, 30 | 0.0068767728, 31 | 0.0008717358, 32 | -0.0044386829) 33 | 34 | describe("dd_fit: Bleichrodt CRDI Model", { 35 | 36 | cached_results = fit_dd_curves( 37 | data = data_frame, 38 | settings = list(Delays = delay, 39 | Values = value, 40 | Individual = ids), 41 | maxValue = 1, 42 | plan = c('bleichrodt')) |> 43 | dd_analyze(modelSelection = FALSE) |> 44 | summary() 45 | 46 | it("Should not fail with simple data", { 47 | expect_no_error( 48 | fit_dd_curves( 49 | data = data_frame, 50 | settings = list(Delays = delay, 51 | Values = value, 52 | Individual = ids), 53 | maxValue = 1, 54 | plan = c('bleichrodt')) |> 55 | dd_analyze(modelSelection = FALSE) 56 | ) 57 | }) 58 | 59 | it("Should be close to simulated parameter (15%)", { 60 | testthat::expect_equal( 61 | cached_results[1, 'Bleichrodt.Lnk'], 62 | og_k, 63 | tolerance = 0.15 64 | ) 65 | }) 66 | 67 | it("Should be close to simulated parameter (15%)", { 68 | testthat::expect_equal( 69 | cached_results[1, 'Bleichrodt.S'], 70 | og_s, 71 | tolerance = 0.15 72 | ) 73 | }) 74 | 75 | it("Should be close to simulated parameter (15%)", { 76 | testthat::expect_equal( 77 | cached_results[1, 'Bleichrodt.Beta'], 78 | og_b, 79 | tolerance = 0.15 80 | ) 81 | }) 82 | 83 | it("Should be close to expected LnED50", { 84 | testthat::expect_equal( 85 | cached_results[1, 'Bleichrodt.LnED50'], 86 | og_ln_ed50, 87 | tolerance = 0.1 88 | ) 89 | }) 90 | 91 | it("Should be close to expected MBAUC", { 92 | testthat::expect_equal( 93 | cached_results[1, 'Bleichrodt.MBAUC'], 94 | og_mb_auc, 95 | tolerance = 0.1 96 | ) 97 | }) 98 | 99 | it("Should be close to expected Log10 MBAUC", { 100 | testthat::expect_equal( 101 | cached_results[1, 'Bleichrodt.Log10MBAUC'], 102 | og_mb_auc_log, 103 | tolerance = 0.1 104 | ) 105 | }) 106 | }) 107 | 108 | -------------------------------------------------------------------------------- /tests/testthat/test-ind-ebertprelec.R: -------------------------------------------------------------------------------- 1 | rm(list = ls()) 2 | 3 | library(discountingtools) 4 | 5 | og_k <- -2 6 | og_s <- 0.9 7 | og_ln_ed50 <- 1.77213 8 | og_mb_auc <- 0.001022831 9 | og_mb_auc_log <- 0.1871914 10 | 11 | data_frame = data.frame( 12 | ids = 1, 13 | ks = og_k, 14 | ss = og_s, 15 | delay = c(1, 30, 180, 540, 1080, 2160, 4320, 8640) 16 | ) 17 | 18 | data_frame[, 'value'] <- dd_discount_func_ebertprelec( 19 | data_frame$delay, 20 | data_frame$ks, 21 | data_frame$ss) + 22 | c(0.0109249702, 23 | 0.0305477299, 24 | -0.0118369887, 25 | 0.0052715790, 26 | -0.0454706108, 27 | 0.0068767728, 28 | 0.0008717358, 29 | -0.0044386829) 30 | 31 | describe("dd_fit: Ebert and Prelec Model", { 32 | 33 | cached_results = fit_dd_curves( 34 | data = data_frame, 35 | settings = list(Delays = delay, 36 | Values = value, 37 | Individual = ids), 38 | maxValue = 1, 39 | plan = c('ebertprelec')) |> 40 | dd_analyze(modelSelection = FALSE) |> 41 | summary() 42 | 43 | it("Should not fail with simple data", { 44 | expect_no_error( 45 | fit_dd_curves( 46 | data = data_frame, 47 | settings = list(Delays = delay, 48 | Values = value, 49 | Individual = ids), 50 | maxValue = 1, 51 | plan = c('ebertprelec')) |> 52 | dd_analyze(modelSelection = FALSE) 53 | ) 54 | }) 55 | 56 | it("Should be close to simulated parameter (15%)", { 57 | testthat::expect_equal( 58 | cached_results[1, 'EbertPrelec.Lnk'], 59 | og_k, 60 | tolerance = 0.15 61 | ) 62 | }) 63 | 64 | it("Should be close to simulated parameter (15%)", { 65 | testthat::expect_equal( 66 | cached_results[1, 'EbertPrelec.S'], 67 | og_s, 68 | tolerance = 0.15 69 | ) 70 | }) 71 | 72 | it("Should be close to expected LnED50", { 73 | testthat::expect_equal( 74 | cached_results[1, 'EbertPrelec.LnED50'], 75 | og_ln_ed50, 76 | tolerance = 0.1 77 | ) 78 | }) 79 | 80 | it("Should be close to expected MBAUC", { 81 | testthat::expect_equal( 82 | cached_results[1, 'EbertPrelec.MBAUC'], 83 | og_mb_auc, 84 | tolerance = 0.1 85 | ) 86 | }) 87 | 88 | it("Should be close to expected Log10 MBAUC", { 89 | testthat::expect_equal( 90 | cached_results[1, 'EbertPrelec.Log10MBAUC'], 91 | og_mb_auc_log, 92 | tolerance = 0.1 93 | ) 94 | }) 95 | }) 96 | 97 | -------------------------------------------------------------------------------- /tests/testthat/test-ind-exponential.R: -------------------------------------------------------------------------------- 1 | rm(list = ls()) 2 | 3 | library(discountingtools) 4 | 5 | og_k <- -0.7925272 6 | og_ln_ed50 <- 0.4260143 7 | og_mb_auc <- 0.0001626005 8 | og_mb_auc_log <- 0.06856932 9 | 10 | data_frame = data.frame( 11 | ids = 1, 12 | ks = og_k, 13 | delay = c(1, 30, 180, 540, 1080, 2160, 4320, 8640) 14 | ) 15 | 16 | data_frame[, 'value'] <- dd_discount_func_exponential( 17 | data_frame$delay, 18 | data_frame$ks) + 19 | c(0.0109249702, 20 | 0.0305477299, 21 | -0.0118369887, 22 | 0.0052715790, 23 | -0.0454706108, 24 | 0.0068767728, 25 | 0.0008717358, 26 | -0.0044386829) 27 | 28 | describe("dd_fit: Exponential Model", { 29 | 30 | cached_results = fit_dd_curves( 31 | data = data_frame, 32 | settings = list(Delays = delay, 33 | Values = value, 34 | Individual = ids), 35 | maxValue = 1, 36 | plan = c('exponential')) |> 37 | dd_analyze(modelSelection = FALSE) |> 38 | summary() 39 | 40 | it("Should not fail with simple data", { 41 | expect_no_error( 42 | fit_dd_curves( 43 | data = data_frame, 44 | settings = list(Delays = delay, 45 | Values = value, 46 | Individual = ids), 47 | maxValue = 1, 48 | plan = c('exponential')) |> 49 | dd_analyze(modelSelection = FALSE) 50 | ) 51 | }) 52 | 53 | it("Should be close to simulated parameter (15%)", { 54 | testthat::expect_equal( 55 | cached_results[1, 'Exponential.Lnk'], 56 | og_k, 57 | tolerance = 0.15 58 | ) 59 | }) 60 | 61 | it("Should be close to expected LnED50", { 62 | testthat::expect_equal( 63 | cached_results[1, 'Exponential.LnED50'], 64 | og_ln_ed50, 65 | tolerance = 0.1 66 | ) 67 | }) 68 | 69 | it("Should be close to expected MBAUC", { 70 | testthat::expect_equal( 71 | cached_results[1, 'Exponential.MBAUC'], 72 | og_mb_auc, 73 | tolerance = 0.05 74 | ) 75 | }) 76 | 77 | it("Should be close to expected Log10 MBAUC", { 78 | testthat::expect_equal( 79 | cached_results[1, 'Exponential.Log10MBAUC'], 80 | og_mb_auc_log, 81 | tolerance = 0.05 82 | ) 83 | }) 84 | }) 85 | 86 | -------------------------------------------------------------------------------- /tests/testthat/test-ind-greenmyerson.R: -------------------------------------------------------------------------------- 1 | rm(list = ls()) 2 | 3 | library(discountingtools) 4 | 5 | og_k <- -1.0000000 6 | og_s <- 1 7 | og_ln_ed50 <- 1.101757 8 | og_mb_auc <- 0.003310236 9 | og_mb_auc_log <- 0.1559683 10 | 11 | data_frame = data.frame( 12 | ids = 1, 13 | ks = og_k, 14 | ss = og_s, 15 | delay = c(1, 30, 180, 540, 1080, 2160, 4320, 8640) 16 | ) 17 | 18 | data_frame[, 'value'] <- dd_discount_func_greenmyerson( 19 | data_frame$delay, 20 | data_frame$ks, 21 | data_frame$ss) + 22 | c(0.0109249702, 23 | 0.0305477299, 24 | -0.0118369887, 25 | 0.0052715790, 26 | -0.0454706108, 27 | 0.0068767728, 28 | 0.0008717358, 29 | -0.0044386829) 30 | 31 | describe("dd_fit: Green and Myerson Model", { 32 | 33 | cached_results = fit_dd_curves( 34 | data = data_frame, 35 | settings = list(Delays = delay, 36 | Values = value, 37 | Individual = ids), 38 | maxValue = 1, 39 | plan = c('greenmyerson')) |> 40 | dd_analyze(modelSelection = FALSE) |> 41 | summary() 42 | 43 | it("Should not fail with simple data", { 44 | expect_no_error( 45 | fit_dd_curves( 46 | data = data_frame, 47 | settings = list(Delays = delay, 48 | Values = value, 49 | Individual = ids), 50 | maxValue = 1, 51 | plan = c('greenmyerson')) |> 52 | dd_analyze(modelSelection = FALSE) 53 | ) 54 | }) 55 | 56 | it("Should be close to simulated parameter (15%)", { 57 | testthat::expect_equal( 58 | cached_results[1, 'GreenMyerson.Lnk'], 59 | og_k, 60 | tolerance = 0.15 61 | ) 62 | }) 63 | 64 | it("Should be close to simulated parameter (15%)", { 65 | testthat::expect_equal( 66 | cached_results[1, 'GreenMyerson.S'], 67 | og_s, 68 | tolerance = 0.15 69 | ) 70 | }) 71 | 72 | it("Should be close to expected LnED50", { 73 | testthat::expect_equal( 74 | cached_results[1, 'GreenMyerson.LnED50'], 75 | og_ln_ed50, 76 | tolerance = 0.1 77 | ) 78 | }) 79 | 80 | it("Should be close to expected MBAUC", { 81 | testthat::expect_equal( 82 | cached_results[1, 'GreenMyerson.MBAUC'], 83 | og_mb_auc, 84 | tolerance = 0.1 85 | ) 86 | }) 87 | 88 | it("Should be close to expected Log10 MBAUC", { 89 | testthat::expect_equal( 90 | cached_results[1, 'GreenMyerson.Log10MBAUC'], 91 | og_mb_auc_log, 92 | tolerance = 0.1 93 | ) 94 | }) 95 | }) 96 | 97 | -------------------------------------------------------------------------------- /tests/testthat/test-ind-laibson.R: -------------------------------------------------------------------------------- 1 | rm(list = ls()) 2 | 3 | library(discountingtools) 4 | 5 | og_d <- 0.7373318 6 | og_b <- 1 7 | og_ln_ed50 <- 0.8711429 8 | og_mb_auc <- 0.0003574047 9 | og_mb_auc_log <- 0.1026852 10 | 11 | data_frame = data.frame( 12 | ids = 1, 13 | ds = og_d, 14 | bs = og_b, 15 | delay = c(1, 30, 180, 540, 1080, 2160, 4320, 8640) 16 | ) 17 | 18 | data_frame[, 'value'] <- dd_discount_func_laibson( 19 | data_frame$delay, 20 | data_frame$bs, 21 | data_frame$ds) + 22 | c(0.0109249702, 23 | 0.0305477299, 24 | -0.0118369887, 25 | 0.0052715790, 26 | -0.0454706108, 27 | 0.0068767728, 28 | 0.0008717358, 29 | -0.0044386829) 30 | 31 | describe("dd_fit: Laibson Model", { 32 | 33 | cached_results = fit_dd_curves( 34 | data = data_frame, 35 | settings = list(Delays = delay, 36 | Values = value, 37 | Individual = ids), 38 | maxValue = 1, 39 | plan = c('laibson')) |> 40 | dd_analyze(modelSelection = FALSE) |> 41 | summary() 42 | 43 | it("Should not fail with simple data", { 44 | expect_no_error( 45 | fit_dd_curves( 46 | data = data_frame, 47 | settings = list(Delays = delay, 48 | Values = value, 49 | Individual = ids), 50 | maxValue = 1, 51 | plan = c('laibson')) |> 52 | dd_analyze(modelSelection = FALSE) 53 | ) 54 | }) 55 | 56 | it("Should be close to simulated parameter (15%)", { 57 | testthat::expect_equal( 58 | cached_results[1, 'Laibson.Delta'], 59 | og_d, 60 | tolerance = 0.15 61 | ) 62 | }) 63 | 64 | it("Should be close to simulated parameter (15%)", { 65 | testthat::expect_equal( 66 | cached_results[1, 'Laibson.Beta'], 67 | og_b, 68 | tolerance = 0.15 69 | ) 70 | }) 71 | 72 | it("Should be close to expected LnED50", { 73 | testthat::expect_equal( 74 | cached_results[1, 'Laibson.LnED50'], 75 | og_ln_ed50, 76 | tolerance = 0.1 77 | ) 78 | }) 79 | 80 | it("Should be close to expected MBAUC", { 81 | testthat::expect_equal( 82 | cached_results[1, 'Laibson.MBAUC'], 83 | og_mb_auc, 84 | tolerance = 0.05 85 | ) 86 | }) 87 | 88 | it("Should be close to expected Log10 MBAUC", { 89 | testthat::expect_equal( 90 | cached_results[1, 'Laibson.Log10MBAUC'], 91 | og_mb_auc_log, 92 | tolerance = 0.05 93 | ) 94 | }) 95 | }) 96 | 97 | -------------------------------------------------------------------------------- /tests/testthat/test-ind-mazur-screen.R: -------------------------------------------------------------------------------- 1 | rm(list = ls()) 2 | 3 | library(discountingtools) 4 | 5 | og_k <- 1 6 | og_ln_ed50 <- 0.8379741 7 | og_mb_auc <- 0.002105094 8 | og_mb_auc_log <- 0.1320793 9 | 10 | data_frame = data.frame( 11 | ids = 1, 12 | ks = og_k, 13 | delay = c(1, 30, 180, 540, 1080, 2160, 4320, 8640) 14 | ) 15 | 16 | data_frame[, 'value'] <- dd_discount_func_mazur( 17 | data_frame$delay, 18 | data_frame$ks) + 19 | c(0.0109249702, 20 | 0.0305477299, 21 | -0.0118369887, 22 | 0.0052715790, 23 | -0.0454706108, 24 | 0.0068767728, 25 | 0.0008717358, 26 | -0.0044386829) 27 | 28 | describe("dd_screen: Mazur Model", { 29 | it("Should not fail with data going in different direction", { 30 | expect_no_error( 31 | fit_dd_curves( 32 | data = data_frame, 33 | settings = list(Delays = delay, 34 | Values = value, 35 | Individual = ids), 36 | maxValue = 1, 37 | plan = c('mazur')) |> 38 | dd_screen() |> 39 | dd_analyze(modelSelection = FALSE) |> 40 | summary() 41 | ) 42 | }) 43 | }) 44 | 45 | -------------------------------------------------------------------------------- /tests/testthat/test-ind-mazur.R: -------------------------------------------------------------------------------- 1 | rm(list = ls()) 2 | 3 | library(discountingtools) 4 | 5 | og_k <- -0.7549554 6 | og_ln_ed50 <- 0.8379741 7 | og_mb_auc <- 0.002105094 8 | og_mb_auc_log <- 0.1320793 9 | 10 | data_frame = data.frame( 11 | ids = 1, 12 | ks = og_k, 13 | delay = c(1, 30, 180, 540, 1080, 2160, 4320, 8640) 14 | ) 15 | 16 | data_frame[, 'value'] <- dd_discount_func_mazur( 17 | data_frame$delay, 18 | data_frame$ks) + 19 | c(0.0109249702, 20 | 0.0305477299, 21 | -0.0118369887, 22 | 0.0052715790, 23 | -0.0454706108, 24 | 0.0068767728, 25 | 0.0008717358, 26 | -0.0044386829) 27 | 28 | describe("dd_fit: Mazur Model", { 29 | 30 | cached_results = fit_dd_curves( 31 | data = data_frame, 32 | settings = list(Delays = delay, 33 | Values = value, 34 | Individual = ids), 35 | maxValue = 1, 36 | plan = c('mazur')) |> 37 | dd_analyze(modelSelection = FALSE) |> 38 | summary() 39 | 40 | it("Should not fail with simple data", { 41 | expect_no_error( 42 | fit_dd_curves( 43 | data = data_frame, 44 | settings = list(Delays = delay, 45 | Values = value, 46 | Individual = ids), 47 | maxValue = 1, 48 | plan = c('mazur')) |> 49 | dd_analyze(modelSelection = FALSE) 50 | ) 51 | }) 52 | 53 | it("Should be close to simulated parameter (15%)", { 54 | testthat::expect_equal( 55 | cached_results[1, 'Mazur.Lnk'], 56 | og_k, 57 | tolerance = 0.15 58 | ) 59 | }) 60 | 61 | it("Should be close to expected LnED50", { 62 | testthat::expect_equal( 63 | cached_results[1, 'Mazur.LnED50'], 64 | og_ln_ed50, 65 | tolerance = 0.05 66 | ) 67 | }) 68 | 69 | it("Should be close to expected MBAUC", { 70 | testthat::expect_equal( 71 | cached_results[1, 'Mazur.MBAUC'], 72 | og_mb_auc, 73 | tolerance = 0.05 74 | ) 75 | }) 76 | 77 | it("Should be close to expected Log10 MBAUC", { 78 | testthat::expect_equal( 79 | cached_results[1, 'Mazur.Log10MBAUC'], 80 | og_mb_auc_log, 81 | tolerance = 0.05 82 | ) 83 | }) 84 | }) 85 | 86 | -------------------------------------------------------------------------------- /tests/testthat/test-ind-rachlin.R: -------------------------------------------------------------------------------- 1 | rm(list = ls()) 2 | 3 | library(discountingtools) 4 | 5 | og_k <- -2 6 | og_s <- 0.9 7 | og_ln_ed50 <- 2.272727 8 | og_mb_auc <- 0.01139605 9 | og_mb_auc_log <- 0.2663329 10 | 11 | data_frame = data.frame( 12 | ids = 1, 13 | ks = og_k, 14 | ss = og_s, 15 | delay = c(1, 30, 180, 540, 1080, 2160, 4320, 8640) 16 | ) 17 | 18 | data_frame[, 'value'] <- dd_discount_func_rachlin( 19 | data_frame$delay, 20 | data_frame$ks, 21 | data_frame$ss) + 22 | c(0.0109249702, 23 | 0.0305477299, 24 | -0.0118369887, 25 | 0.0052715790, 26 | -0.0454706108, 27 | 0.0068767728, 28 | 0.0008717358, 29 | -0.0044386829) 30 | 31 | describe("dd_fit: Rachlin Model", { 32 | 33 | cached_results = fit_dd_curves( 34 | data = data_frame, 35 | settings = list(Delays = delay, 36 | Values = value, 37 | Individual = ids), 38 | maxValue = 1, 39 | plan = c('rachlin')) |> 40 | dd_analyze(modelSelection = FALSE) |> 41 | summary() 42 | 43 | it("Should not fail with simple data", { 44 | expect_no_error( 45 | fit_dd_curves( 46 | data = data_frame, 47 | settings = list(Delays = delay, 48 | Values = value, 49 | Individual = ids), 50 | maxValue = 1, 51 | plan = c('rachlin')) |> 52 | dd_analyze(modelSelection = FALSE) 53 | ) 54 | }) 55 | 56 | it("Should be close to simulated parameter (15%)", { 57 | testthat::expect_equal( 58 | cached_results[1, 'Rachlin.Lnk'], 59 | og_k, 60 | tolerance = 0.15 61 | ) 62 | }) 63 | 64 | it("Should be close to simulated parameter (15%)", { 65 | testthat::expect_equal( 66 | cached_results[1, 'Rachlin.S'], 67 | og_s, 68 | tolerance = 0.15 69 | ) 70 | }) 71 | 72 | it("Should be close to expected LnED50", { 73 | testthat::expect_equal( 74 | cached_results[1, 'Rachlin.LnED50'], 75 | og_ln_ed50, 76 | tolerance = 0.1 77 | ) 78 | }) 79 | 80 | it("Should be close to expected MBAUC", { 81 | testthat::expect_equal( 82 | cached_results[1, 'Rachlin.MBAUC'], 83 | og_mb_auc, 84 | tolerance = 0.1 85 | ) 86 | }) 87 | 88 | it("Should be close to expected Log10 MBAUC", { 89 | testthat::expect_equal( 90 | cached_results[1, 'Rachlin.Log10MBAUC'], 91 | og_mb_auc_log, 92 | tolerance = 0.1 93 | ) 94 | }) 95 | }) 96 | 97 | -------------------------------------------------------------------------------- /tests/testthat/test-ind-rodriguezlogue.R: -------------------------------------------------------------------------------- 1 | rm(list = ls()) 2 | 3 | library(discountingtools) 4 | 5 | og_k <- 0.2038359 6 | og_b <- -0.01289119 7 | og_ln_ed50 <- 3.480851e-05 8 | og_mb_auc <- 0.0009689925 9 | og_mb_auc_log <- 0.07645845 10 | 11 | data_frame = data.frame( 12 | ids = 1, 13 | ks = og_k, 14 | bs = og_b, 15 | delay = c(1, 30, 180, 540, 1080, 2160, 4320, 8640) 16 | ) 17 | 18 | data_frame[, 'value'] <- dd_discount_func_rodriguezlogue( 19 | data_frame$delay, 20 | data_frame$ks, 21 | data_frame$bs) + 22 | c(0.0109249702, 23 | 0.0305477299, 24 | -0.0118369887, 25 | 0.0052715790, 26 | -0.0454706108, 27 | 0.0068767728, 28 | 0.0008717358, 29 | -0.0044386829) 30 | 31 | describe("dd_fit: Rodriguez and Logue Model", { 32 | 33 | cached_results = fit_dd_curves( 34 | data = data_frame, 35 | settings = list(Delays = delay, 36 | Values = value, 37 | Individual = ids), 38 | maxValue = 1, 39 | plan = c('rodriguezlogue')) |> 40 | dd_analyze(modelSelection = FALSE) |> 41 | summary() 42 | 43 | it("Should not fail with simple data", { 44 | expect_no_error( 45 | fit_dd_curves( 46 | data = data_frame, 47 | settings = list(Delays = delay, 48 | Values = value, 49 | Individual = ids), 50 | maxValue = 1, 51 | plan = c('rodriguezlogue')) |> 52 | dd_analyze(modelSelection = FALSE) 53 | ) 54 | }) 55 | 56 | # TODO: clean up simulation for these 57 | 58 | # it("Should be close to simulated parameter (15%)", { 59 | # testthat::expect_equal( 60 | # cached_results[1, 'RodriguezLogue.Lnk'], 61 | # og_k, 62 | # tolerance = 0.15 63 | # ) 64 | # }) 65 | # 66 | # it("Should be close to simulated parameter (15%)", { 67 | # testthat::expect_equal( 68 | # cached_results[1, 'RodriguezLogue.Beta'], 69 | # og_b, 70 | # tolerance = 0.15 71 | # ) 72 | # }) 73 | 74 | it("Should be close to expected LnED50", { 75 | testthat::expect_equal( 76 | cached_results[1, 'RodriguezLogue.LnED50'], 77 | og_ln_ed50, 78 | tolerance = 0.1 79 | ) 80 | }) 81 | 82 | it("Should be close to expected MBAUC", { 83 | testthat::expect_equal( 84 | cached_results[1, 'RodriguezLogue.MBAUC'], 85 | og_mb_auc, 86 | tolerance = 0.1 87 | ) 88 | }) 89 | 90 | it("Should be close to expected Log10 MBAUC", { 91 | testthat::expect_equal( 92 | cached_results[1, 'RodriguezLogue.Log10MBAUC'], 93 | og_mb_auc_log, 94 | tolerance = 0.1 95 | ) 96 | }) 97 | }) 98 | 99 | -------------------------------------------------------------------------------- /tests/testthat/test-model_selection.R: -------------------------------------------------------------------------------- 1 | rm(list = ls()) 2 | 3 | library(discountingtools) 4 | 5 | og_k <- -0.7925272 6 | og_ln_ed50 <- 0.7890187 7 | og_mb_auc <- 0.000617341 8 | og_mb_auc_log <- 0.1198922 9 | 10 | data_frame = data.frame( 11 | ids = 1, 12 | ks = og_k, 13 | delay = c(1, 30, 180, 540, 1080, 2160, 4320, 8640) 14 | ) 15 | 16 | data_frame[, 'value'] <- dd_discount_func_exponential( 17 | data_frame$delay, 18 | data_frame$ks) + 19 | c(0.0109249702, 20 | 0.0305477299, 21 | -0.0118369887, 22 | 0.0052715790, 23 | -0.0454706108, 24 | 0.0068767728, 25 | 0.0008717358, 26 | -0.0044386829) 27 | 28 | describe("dd_fit: Model Selection Rotation", { 29 | 30 | cached_results = fit_dd_curves( 31 | data = data_frame, 32 | settings = list(Delays = delay, 33 | Values = value, 34 | Individual = ids), 35 | maxValue = 1, 36 | plan = c('mazur', 'exponential', 'noise', 'laibson', 'greenmyerson', 'rachlin', 'ebertprelec', 'bleichrodt', 'rodriguezlogue')) |> 37 | dd_analyze(modelSelection = TRUE) |> 38 | summary() 39 | 40 | it("Should not fail with simple data", { 41 | expect_no_error( 42 | fit_dd_curves( 43 | data = data_frame, 44 | settings = list(Delays = delay, 45 | Values = value, 46 | Individual = ids), 47 | plan = c('mazur', 'exponential', 'noise', 'laibson', 'greenmyerson', 'rachlin', 'ebertprelec', 'bleichrodt', 'rodriguezlogue'), 48 | maxValue = 1) |> 49 | dd_analyze(modelSelection = TRUE) 50 | ) 51 | }) 52 | 53 | it("Should find EP to be best model", { 54 | testthat::expect_equal( 55 | cached_results[1, 'ProbableModel'], 56 | 'ebertprelec' 57 | ) 58 | }) 59 | 60 | it("Should be close to expected LnED50", { 61 | testthat::expect_equal( 62 | cached_results[1, 'ProbableModel.LnED50'], 63 | og_ln_ed50, 64 | tolerance = 0.1 65 | ) 66 | }) 67 | 68 | it("Should be close to expected MBAUC", { 69 | testthat::expect_equal( 70 | cached_results[1, 'ProbableModel.MBAUC'], 71 | og_mb_auc, 72 | tolerance = 0.05 73 | ) 74 | }) 75 | 76 | it("Should be close to expected Log10 MBAUC", { 77 | testthat::expect_equal( 78 | cached_results[1, 'ProbableModel.Log10MBAUC'], 79 | og_mb_auc_log, 80 | tolerance = 0.05 81 | ) 82 | }) 83 | }) 84 | 85 | -------------------------------------------------------------------------------- /tests/testthat/test-plot-group.R: -------------------------------------------------------------------------------- 1 | 2 | describe("dd_plot: Various Individuals", { 3 | suppressPackageStartupMessages(library(tidyr)) 4 | suppressPackageStartupMessages(library(dplyr)) 5 | library(discountingtools) 6 | 7 | n_per_group <- 5 8 | 9 | data_frame = data.frame( 10 | ids = seq_len(n_per_group), 11 | ks = NA, 12 | grp = "Group A" 13 | ) 14 | 15 | data_frame$ks = rnorm(length(data_frame$ids), 0.35, 0.125) 16 | data_frame$ks = log(data_frame$ks) 17 | 18 | delays = c(1, 30, 180, 540, 1080, 2160, 4320, 8640) 19 | 20 | data_frame$auc = dd_mbauc_mazur(1, data_frame$ks, min(delays), max(delays)) 21 | 22 | for (row in 1:nrow(data_frame)) { 23 | ys = dd_discount_func_mazur(delays, data_frame[row, "ks"]) + rnorm(length(delays), 24 | 0, 25 | 0.05) 26 | 27 | data_frame[row, as.character(delays)] = ys 28 | } 29 | 30 | data_frame2 = data.frame( 31 | ids = 50 + seq_len(n_per_group), 32 | ks = NA, 33 | grp = "Group B" 34 | ) 35 | 36 | data_frame2$ks = rnorm(length(data_frame2$ids), 0.075, 0.035) 37 | data_frame2$ks = log(data_frame2$ks) 38 | 39 | data_frame2$auc = dd_mbauc_mazur(1, data_frame2$ks, min(delays), max(delays)) 40 | 41 | for (row in 1:nrow(data_frame2)) { 42 | ys = dd_discount_func_mazur(delays, data_frame2[row, "ks"]) + rnorm(length(delays), 43 | 0, 44 | 0.025) 45 | 46 | data_frame2[row, as.character(delays)] = ys 47 | } 48 | 49 | data_frame = rbind(data_frame, 50 | data_frame2) 51 | 52 | data_frame_long = data_frame %>% 53 | gather(Delay, Value, -ids, -ks, -grp, -auc) %>% 54 | mutate(Delay = as.numeric(Delay)) %>% 55 | mutate(Value = ifelse(Value < 0, 0, Value)) %>% 56 | mutate(Value = ifelse(Value > 1, 0, Value)) 57 | 58 | results = fit_dd_curves(data = data_frame_long, 59 | settings = list(Delays = Delay, 60 | Values = Value, 61 | Individual = ids, 62 | Group = grp), 63 | plan = c("mazur", "exponential", "laibson", "greenmyerson", "rachlin", "ebertprelec", "bleichrodt", "rodriguezlogue"), 64 | maxValue = 1, 65 | verbose = FALSE) |> 66 | dd_analyze(modelSelection = TRUE) 67 | 68 | it("Plots individually in groups: Predictions", { 69 | expect_no_error( 70 | plot(results, logAxis = "x", position = "topright", which = "group") 71 | ) 72 | }) 73 | 74 | it("Plots individually in groups: Predictions [plotit = false]", { 75 | expect_no_error( 76 | plot(results, 77 | which = "group", 78 | plotit = FALSE) 79 | ) 80 | }) 81 | 82 | it("Plots individually in groups: Single Predictions", { 83 | expect_no_error( 84 | plot(results, logAxis = "x", position = "topright", 85 | which = "group", id = "1") 86 | ) 87 | }) 88 | 89 | it("Should fail: no single model to focus", { 90 | testthat::expect_error( 91 | fit_dd_curves(data = data_frame_long, 92 | settings = list(Delays = Delay, 93 | Values = Value, 94 | Individual = ids, 95 | Group = grp), 96 | plan = c("mazur", "exponential"), 97 | maxValue = 1, 98 | verbose = FALSE) |> 99 | dd_analyze(modelSelection = FALSE) |> 100 | plot(logAxis = "x", 101 | position = "topright", 102 | which = "group", 103 | id = "1"), 104 | 'Cannot plot individual fits without selecting a single model or using model selection' 105 | ) 106 | }) 107 | 108 | it("Should fail: no Group specified", { 109 | testthat::expect_error( 110 | fit_dd_curves(data = data_frame_long, 111 | settings = list(Delays = Delay, 112 | Values = Value, 113 | Individual = ids), 114 | plan = c("mazur"), 115 | maxValue = 1, 116 | verbose = FALSE) |> 117 | dd_analyze(modelSelection = TRUE) |> 118 | plot(logAxis = "x", 119 | position = "topright", 120 | which = "group", 121 | id = "1"), 122 | 'No Group aesthetic specified' 123 | ) 124 | }) 125 | 126 | it("Plots individually in groups: Single Predictions [plotit = false]", { 127 | expect_no_error( 128 | plot(results, 129 | which = "group", 130 | id = "1", 131 | plotit = FALSE) 132 | ) 133 | }) 134 | 135 | it("Plots individually in groups: models", { 136 | expect_no_error( 137 | plot(results, logAxis = "x", position = "topright", which = "model") 138 | ) 139 | }) 140 | 141 | it("Plots individually in groups: models [plotit = false]", { 142 | expect_no_error( 143 | plot(results, 144 | which = "model", 145 | plotit = FALSE) 146 | ) 147 | }) 148 | 149 | it("Plots individually: ED50", { 150 | expect_no_error( 151 | plot(results, logAxis = "x", position = "topright", which = "ED50") 152 | ) 153 | }) 154 | 155 | it("Plots individually: ED50 [plotit = false]", { 156 | expect_no_error( 157 | plot(results, 158 | which = "ED50", 159 | plotit = FALSE) 160 | ) 161 | }) 162 | 163 | it("Plots individually: MBAUC", { 164 | expect_no_error( 165 | plot(results, logAxis = "x", position = "topright", which = "MBAUC") 166 | ) 167 | }) 168 | 169 | it("Plots individually: MBAUC [plotit = false]", { 170 | expect_no_error( 171 | plot(results, 172 | which = "MBAUC", 173 | plotit = FALSE) 174 | ) 175 | }) 176 | 177 | it("Plots individually: MBAUC Log10 Scaled", { 178 | expect_no_error( 179 | plot(results, logAxis = "x", position = "topright", which = "Log10MBAUC") 180 | ) 181 | }) 182 | 183 | it("Plots individually: MBAUC Log10 Scaled [plotit = false]", { 184 | expect_no_error( 185 | plot(results, 186 | which = "Log10MBAUC", 187 | plotit = FALSE) 188 | ) 189 | }) 190 | }) 191 | 192 | -------------------------------------------------------------------------------- /tests/testthat/test-plot-ind.R: -------------------------------------------------------------------------------- 1 | 2 | describe("dd_plot: Various Individuals", { 3 | suppressPackageStartupMessages(library(tidyr)) 4 | suppressPackageStartupMessages(library(dplyr)) 5 | library(discountingtools) 6 | 7 | dataFrame = data.frame( 8 | ids = 1:10, 9 | ks = NA 10 | ) 11 | 12 | dataFrame$ks = rnorm(length(dataFrame$ids), 0.15, 0.03) 13 | dataFrame$ks = log(dataFrame$ks) 14 | 15 | delays = c(1, 30, 180, 540, 1080, 2160, 4320, 8640) 16 | 17 | for (row in seq_len(nrow(dataFrame))) { 18 | ys = dd_discount_func_mazur(delays, dataFrame[row, "ks"]) + rnorm(length(delays), 19 | 0, 20 | 0.025) 21 | 22 | dataFrame[row, as.character(delays)] = ys 23 | } 24 | 25 | data_frame = dataFrame %>% 26 | tidyr::gather(Delay, Value, -ids, -ks) %>% 27 | dplyr::mutate(Delay = as.numeric(Delay)) %>% 28 | dplyr::mutate(Value = ifelse(Value < 0, 0, Value)) %>% 29 | dplyr::mutate(Value = ifelse(Value > 1, 0, Value)) %>% 30 | as.data.frame() 31 | 32 | results = fit_dd_curves( 33 | data = data_frame, 34 | settings = list(Delays = Delay, 35 | Values = Value, 36 | Individual = ids), 37 | maxValue = 1, 38 | plan = c("mazur", "exponential", "laibson", "greenmyerson", "rachlin", "ebertprelec", "bleichrodt", "rodriguezlogue")) |> 39 | dd_analyze(modelSelection = TRUE) 40 | 41 | it("Plots individually: Predictions", { 42 | expect_no_error( 43 | plot(results, 44 | logAxis = "x", 45 | position = "topright") 46 | ) 47 | }) 48 | 49 | it("Plots individually: Predictions [plotit = F]", { 50 | expect_no_error( 51 | plot(results, plotit = FALSE) 52 | ) 53 | }) 54 | 55 | it("Plots individually: Single predictions", { 56 | expect_no_error( 57 | plot(results, 58 | logAxis = "x", 59 | id = "1", 60 | position = "topright") 61 | ) 62 | }) 63 | 64 | it("Plots individually: Single predictions [plotit = F]", { 65 | expect_no_error( 66 | plot(results, 67 | id = 1, 68 | plotit = FALSE) 69 | ) 70 | }) 71 | 72 | it("Plots individually: ED50", { 73 | expect_no_error( 74 | plot(results, which = "ED50") 75 | ) 76 | }) 77 | 78 | it("Plots individually: ED50 [plotit = F]", { 79 | expect_no_error( 80 | plot(results, 81 | plotit = FALSE, 82 | which = "ED50") 83 | ) 84 | }) 85 | 86 | it("Plots individually: MBAUC", { 87 | expect_no_error( 88 | plot(results, which = "MBAUC") 89 | ) 90 | }) 91 | 92 | it("Plots individually: MBAUC [plotit = F]", { 93 | expect_no_error( 94 | plot(results, 95 | plotit = FALSE, 96 | which = "MBAUC") 97 | ) 98 | }) 99 | 100 | it("Plots individually: MBAUC Log10 Scaled", { 101 | expect_no_error( 102 | plot(results, which = "Log10MBAUC") 103 | ) 104 | }) 105 | 106 | it("Plots individually: MBAUC Log10 Scaled [plotit = F]", { 107 | expect_no_error( 108 | plot(results, 109 | plotit = FALSE, 110 | which = "Log10MBAUC") 111 | ) 112 | }) 113 | 114 | it("Plots individually: Model", { 115 | expect_no_error( 116 | plot(results, which = "model") 117 | ) 118 | }) 119 | 120 | it("Plots individually: Model [plotit = F]", { 121 | expect_no_error( 122 | plot(results, 123 | plotit = FALSE, 124 | which = "model") 125 | ) 126 | }) 127 | }) 128 | 129 | -------------------------------------------------------------------------------- /vignettes/.gitignore: -------------------------------------------------------------------------------- 1 | discountingtools_cache 2 | --------------------------------------------------------------------------------