tests/testthat/test-distribution.R

In fddm: Fast Implementation of the Diffusion Decision Model

context("Testing the distribution function for accuracy")

source(system.file("extdata", "Blurton_et_al_distribution.R",
                   package = "fddm", mustWork = TRUE))
# note that pdiffusion() from rtdists is not agreeing with the Blurton/fddm code



#---------------------- Evaluate densities ------------------------------------#
# Define parameter space
if (identical(Sys.getenv("NOT_CRAN"), "true")) { # not on CRAN
  RT <- c(0.001, 0.01, seq(0.1, 10, by = 0.1), seq(15, 30, by = 5))
  A <- c(0.25, seq(0.5, 5, by = 0.5))
  V <- c(-5, -2, 0, 2, 5)
  W <- c(0.2, 0.5, 0.8)
  SV <- c(0, 0.5, 1, 1.5)
} else { # on CRAN
  RT <- c(0.001, 0.1, 1, 10)
  A <- c(0.5, 1, 5)
  V <- c(-5, 0, 5)
  W <- c(0.2, 0.5, 0.8)
  SV <- c(0, 0.5, 1.5)
}
t0 <- 0
eps <- 1e-6 # this is the setting from rtdists

nRT <- length(RT)
nA <- length(A)
nV <- length(V)
nW <- length(W)
nSV <- length(SV)
N <- nRT * nA * nV * nW * nSV

rt <- rep(RT, each = nSV * nW * nV * nA, times = 1)
a  <- rep(A,  each = nSV * nW * nV, times = nRT)
v  <- rep(V,  each = nSV * nW, times = nRT * nA)
w  <- rep(W,  each = nSV, times = nRT * nA * nV)
sv <- rep(SV, each = 1, times = nRT * nA * nV * nW)




# fddm methods
Mills <- data.frame(
  res = pfddm(rt = rt, response = "lower", a = a, v = v, t0 = t0, w = w,
              sv = sv, err_tol = eps, log = FALSE, method = "Mills"),
  dif = numeric(N),
  log_res = pfddm(rt = rt, response = "lower", a = a, v = v, t0 = t0, w = w,
                  sv = sv, err_tol = eps, log = TRUE, method = "Mills")
)
suppressWarnings( # warnings can be produced for large a, sv
NCDF <- data.frame(
  res = pfddm(rt = rt, response = "lower", a = a, v = v, t0 = t0, w = w,
              sv = sv, err_tol = eps, log = FALSE, method = "NCDF"),
  dif = numeric(N),
  log_res = pfddm(rt = rt, response = "lower", a = a, v = v, t0 = t0, w = w,
                  sv = sv, err_tol = eps, log = TRUE, method = "NCDF")
)
)

# non-fddm methods
Blurton <- data.frame(
  res = G_0(t = rt - t0, a = a, nu = v, w = w, eta2 = sv*sv, sigma2 = 1,
            eps = eps),
  dif = numeric(N)
)
# if (require("rtdists")) {
#   rtdists <- data.frame(
#     res = pdiffusion(rt, "lower", a = a, v = v, t0 = t0, z = w*a, sv = sv,
#                      precision = 3),
#     dif = numeric(N)
#   )
# }



# Calculate differences (use fddm's Mills method as truth)
ans <- Mills[["res"]]
Mills[["dif"]] <- abs(Mills[["res"]] - ans)
NCDF[["dif"]] <- abs(NCDF[["res"]] - ans)
Blurton[["dif"]] <- abs(Blurton[["res"]] - ans)
# if (require("rtdists")) {
#   rtdists[["dif"]] <- abs(rtdists[["res"]] - ans)
# }





#---------------------- Testing -----------------------------------------------#
# Ensure -eps = 0 <= CDF <= 1 = 1 + eps
test_that("CDF in [0, 1]", {
  expect_true(all(Mills[["res"]] >= 0 & Mills[["res"]] <= 1))
  expect_true(all(NCDF[["res"]] >= 0 & NCDF[["res"]] <= 1))

  expect_true(all(Blurton[["res"]] >= -eps & Blurton[["res"]] <= 1 + eps))

  # if (require("rtdists")) {
  #   expect_true(all(rtdists[["res"]] >= -eps & rtdists[["res"]] <= 1 + eps))
  # }
})

# Test accuracy within 2*eps (allows for convergence from above and below)
test_that("Accuracy relative to established packages", {
  expect_true(all(Mills[["dif"]] <= 2*eps))
  expect_true(sum(NCDF[["dif"]] <= 2*eps) / nrow(NCDF) > 0.9999) # 3 disagree
  expect_true(all(NCDF[["dif"]] <= 5*eps)) # they're still quite close

  expect_true(all(Blurton[["dif"]] <= 2*eps))

  # if (require("rtdists")) {
  #   expect_true(all(rtdists[["dif"]] <= 2*eps))
  # }
})

# Test consistency in fddm log vs non-log
test_that("Log-Consistency", {
  expect_equal(Mills[Mills[["res"]] > eps*eps, "log_res"],
               log(Mills[Mills[["res"]] > eps*eps, "res"]))
  expect_equal(NCDF[NCDF[["res"]] > eps*eps, "log_res"],
               log(NCDF[NCDF[["res"]] > eps*eps, "res"]))
})