Further increase test coverage

R/generics.R

@@ -341,11 +341,12 @@ coef.td_bclm <- function(object, df_par = TRUE, ...) {
               's' = unname(p['.B2']/p['.B1']))
     } else if (d == 'power') {
       cf <- c('k' = unname(p['.B2']/p['.B1']))
-    } else if (d == 'itch') {
-      cf <- object$coefficients
-    } else if (d == 'naive') {
-      cf <- object$coefficients
     }
+    # } else if (d == 'itch') {
+    #   cf <- object$coefficients
+    # } else if (d == 'naive') {
+    #   cf <- object$coefficients
+    # }
   } else {
     cf <- object$coefficients
   }

R/td_bclm.R

@@ -42,7 +42,7 @@ td_bclm <- function(data,
                    required_columns = c('val_imm', 'val_del', 'del', 'imm_chosen'))
   attention_checks(data, warn = T)
   invariance_checks(data, warn = T)
-  if (length(grep('\\.B', names(data))) > 1) {
+  if (length(grep('\\.B', names(data))) > 0) {
     stop('No columns can have a name that begins with ".B"')
   }
 

R/td_bcnm.R

@@ -261,17 +261,6 @@ get_prob_mod_frame <- function(...) {
   }
 }
 
-get_nll_fn <- function(data, prob_mod_frame) {
-  # Get negative log-likelihood function, given a set of data and a model
-  # "frame" with structural aspects specified but parameters unspecified
-
-  nll_fn <- function(par) {
-    p <- laplace_smooth(prob_mod_frame(data, par))
-    return(sum(-ll(p, data$imm_chosen)))
-  }
-  return(nll_fn)
-}
-
 # Robust stuff---may incorporate later
 # huber <- function(t, c) {
 #   idx <- t > c

R/td_ddm.R

@@ -58,7 +58,7 @@ td_ddm <- function(
 
   # Check that RTs are in seconds vs milliseconds
   if (median(data$rt) > 500) {
-    warning('Median RT is greater than 500, meaning RTs are likely in units of milliseconds (or smaller). They should be in units of seconds.')
+    stop('Median RT is greater than 500, meaning RTs are likely in units of milliseconds (or smaller). They should be in units of seconds.')
   }
 
   # Attention checks
@@ -204,12 +204,7 @@ get_linpred_func_ddm <- function(discount_function, drift_transform) {
 
   linpred_func <- function(data, par) {
     # Compute subjective value difference
-    tryCatch(
-      svd <- data$val_imm - data$val_del*discount_function$fn(data, par),
-      error = function(e) {
-        browser()
-      }
-    )
+    svd <- data$val_imm - data$val_del*discount_function$fn(data, par)
     # Compute drift rate
     drift <- svd*par['v']
     # Transform drift rate

R/utils.R

@@ -15,9 +15,9 @@ qgumbel <- function(p, location = 0, scale = 1) {
 }
 
 # Dirac CDF
-pdirac <- function(q, location = 0) {
-  ifelse(q < location, 0, 1)
-}
+# pdirac <- function(q, location = 0) {
+#   ifelse(q < location, 0, 1)
+# }
 
 # Log-likelihood
 ll <- function(p, x) {

tests/testthat/test-generics.R

@@ -0,0 +1,9 @@
+
+# This is quite short because most of the generics are tested along with the class they're defined for
+
+data("td_bc_single_ptpt")
+
+mod <- kirby_score(td_bc_single_ptpt)
+test_that('no residuals for kirby-scored data', {
+  expect_error(residuals(mod))
+})

tests/testthat/test-td_bclm.R

@@ -52,7 +52,9 @@ while (model_idx <= length(models)) {
 }
 
 test_that('errors', {
-  expect_error(td_bcnm(df, model = 'random'))
-  expect_error(td_bcnm())
-  expect_error(td_bcnm(df[, 1:2]))
+  expect_error(td_bclm(df, model = 'random'))
+  expect_error(td_bclm())
+  expect_error(td_bclm(df[, 1:2]))
+  df$`.B1` <- 1
+  expect_error(td_bclm(df, model = 'hyperbolic.1'))
 })

tests/testthat/test-td_bcnm.R

@@ -61,6 +61,7 @@ while (arg_combo_idx <= nrow(arg_combos)) {
     expect_length(residuals(mod, type = 'deviance'), n = nrow(df))
     expect_length(residuals(mod, type = 'pearson'), n = nrow(df))
     expect_length(residuals(mod, type = 'response'), n = nrow(df))
+    expect_type(deviance(mod), 'double')
   })
 
   pdf(NULL) # Don't actually produce plots
@@ -71,7 +72,9 @@ while (arg_combo_idx <= nrow(arg_combos)) {
     expect_no_error(plot(mod, type = 'endpoints', verbose = F))
     expect_output(plot(mod, type = 'endpoints', verbose = T))
     expect_no_error(plot(mod, type = 'endpoints', verbose = F, del = 100, val_del = 50))
+    expect_no_error(plot(mod, type = 'endpoints', verbose = F, del = unique(df$del)[1], val_del = 50))
     expect_no_error(plot(mod, type = 'link'))
+    expect_error(plot(mod, type = 'rt'))
   })
   dev.off()
 

tests/testthat/test-td_ddm.R

@@ -30,6 +30,7 @@ test_that('generics', {
   expect_type(logLik(mod), 'double')
   expect_type(logLik(mod, type = 'resp'), 'double')
   expect_named(coef(mod))
+  expect_type(deviance(mod), 'double')
   # Residuals are not applicable
   # expect_vector(residuals(mod, type = 'deviance'), size = nrow(df))
   # expect_vector(residuals(mod, type = 'pearson'), size = nrow(df))
@@ -84,4 +85,6 @@ test_that('errors', {
   expect_error(td_ddm(df, discount_function = 'random'))
   expect_error(td_ddm())
   expect_error(td_ddm(df[, 1:2]))
+  df$rt <- df$rt*1000 # in ms
+  expect_error(td_ddm(df, discount_function = 'hyperbolic'))
 })

tests/testthat/test-td_fn.R

@@ -4,20 +4,48 @@ test_that('normal functioning', {
                         fn = function(data, p) {p['x']},
                         par_starts = list(x = 0.5),
                         par_lims = list(x = c(0, 1))))
+  expect_no_error(td_fn(name = 'custom',
+                        fn = function(data, p) {p['x']},
+                        par_starts = list(x = 0.5)))
+  expect_no_error(td_fn(init = function(self, data) {
+    self$fn <- function(data, p) {p['x']}
+    self$par_starts <- list(x = 0.5)
+    self$par_lims <- list(x = c(0, 1))
+    return(self)
+  }))
 })
 
 test_that('errors', {
   expect_error(td_fn())
   expect_error(td_fn(predefined = 'random-discount-function'))
   expect_error(td_fn(fn = function(data, p) {p['x']}))
-  expect_error(td_fn(fn = function(data, p) {p['x']}))
+  expect_error(td_fn(fn = function(p) {p['x']}))
   expect_error(td_fn(name = 'custom',
                      fn = function(data, p) {p['x']},
-                     par_starts = c(x = 0.5),
-                     par_lims = c(x = 0)))
+                     par_starts = list(x = 0.5),
+                     par_lims = list(y = c(0, 1)))) #!
+  expect_error(td_fn(init = function(self) { #!
+    self$fn <- function(data, p) {p['x']}
+    self$par_starts <- list(x = 0.5)
+    self$par_lims <- list(x = c(0, 1))
+    return(self)
+  }))
   expect_error(td_fn(name = 'custom',
                      fn = function(data, p) {p['x']},
-                     par_starts = c(x = 0.5),
+                     par_starts = c(x = 0.5), #!
+                     par_lims = c(x = 0))) #!
+  expect_error(td_fn(name = 'custom',
+                     fn = function(data, p) {p['x']},
+                     par_starts = c(x = 0.5), #!
                      par_lims = list(c(0, 1))))
-  expect_error(td_fn())
+  expect_no_error(td_fn(name = 'custom',
+                        fn = function(data, p) {p['x']},
+                        par_starts = list(x = 0.5),
+                        par_lims = list(x = c(0, 1)),
+                        ED50 = 'random')) #!
+  expect_no_error(td_fn(name = 'custom',
+                        fn = function(data, p) {p['x']},
+                        par_starts = list(x = 0.5),
+                        par_lims = list(x = c(0, 1)),
+                        ED50 = 1)) #!
 })

tests/testthat/test-utils.R

@@ -60,4 +60,8 @@ test_that('wileyto scoring', {
 test_that('experimental indiff scoring function', {
   expect_no_error(most_consistent_indiffs(td_bc_single_ptpt))
   expect_no_error(delwise_consistencies(td_bc_single_ptpt))
+})
+
+test_that('kirby_consistency', {
+  expect_no_error(kirby_consistency(td_bc_single_ptpt, discount_function = 'hyperbolic'))
 })