tests/testthat/test-fitdistdoublecens.R

In primarycensored: Primary Event Censored Distributions

# Skip tests if fitdistrplus is not installed
if (!requireNamespace("fitdistrplus", quietly = TRUE)) {
  skip("Package 'fitdistrplus' is required for these tests")
}

test_that("fitdistdoublecens works correctly", {
  # Set seed for reproducibility
  set.seed(123)

  # Define true distribution parameters
  n <- 1000
  shape <- 1.77
  rate <- 0.44

  # Generate samples
  samples <- rprimarycensored(
    n, rgamma,
    shape = shape, rate = rate,
    pwindow = 1, swindow = 1, D = 8
  )

  # Create data frame
  delay_data <- data.frame(
    left = samples
  )
  delay_data$right <- delay_data$left + 1

  # Fit the model using fitdistdoublecens
  fit <- fitdistdoublecens(
    delay_data,
    distr = "gamma",
    start = list(shape = 1, rate = 1),
    D = 8, pwindow = 1
  )

  # Check that the function returns a fitdist object
  expect_s3_class(fit, "fitdist")

  # Check that the estimated parameters are close to the true values
  expect_equal(unname(fit$estimate["shape"]), shape, tolerance = 0.2)
  expect_equal(unname(fit$estimate["rate"]), rate, tolerance = 0.2)

  # Check that the log-likelihood is not NA or -Inf
  expect_false(is.na(fit$loglik))
  expect_false(is.infinite(fit$loglik))

  # Check that the AIC and BIC are calculated
  expect_false(is.na(fit$aic))
  expect_false(is.na(fit$bic))
})

test_that("fitdistdoublecens handles errors correctly", {
  # Test with invalid input
  expect_error(
    fitdistdoublecens(
      data.frame(x = 1:10), # Missing 'left' and 'right' columns
      distr = "gamma"
    ),
    "censdata must contain 'left' and 'right' columns"
  )

  # Test with non-existent distribution
  expect_error(
    fitdistdoublecens(
      data.frame(left = 1:10, right = 2:11),
      distr = "nonexistent_dist"
    )
  )
})

test_that("fitdistdoublecens works with different distributions", {
  set.seed(123)
  n <- 1000

  # Test with normal distribution
  true_mean <- 5
  true_sd <- 2
  samples <- rprimarycensored(
    n, rnorm,
    mean = true_mean, sd = true_sd,
    pwindow = 2, swindow = 2, D = 10
  )

  delay_data <- data.frame(
    left = samples
  )
  delay_data$right <- delay_data$left + 2

  fit_norm <- fitdistdoublecens(
    delay_data,
    distr = "norm",
    start = list(mean = 0, sd = 1),
    D = 10, pwindow = 2
  )

  expect_s3_class(fit_norm, "fitdist")
  expect_equal(unname(fit_norm$estimate["mean"]), true_mean, tolerance = 0.2)
  expect_equal(unname(fit_norm$estimate["sd"]), true_sd, tolerance = 0.2)
})

test_that("fitdistdoublecens works with mixed secondary windows", {
  set.seed(456)
  n <- 1000

  # True parameters for gamma distribution
  true_shape <- 3
  true_rate <- 0.5

  # Generate samples with mixed secondary windows
  # Generate samples with mixed secondary windows
  generate_sample <- function(pwindow, swindow, obs_time) {
    rpcens(
      1, rgamma,
      shape = true_shape, rate = true_rate,
      pwindow = pwindow, swindow = swindow, D = obs_time
    )
  }

  pwindows <- rep(1, n)
  swindows <- sample(c(1, 2), n, replace = TRUE)
  obs_times <- rep(10, n)

  samples <- mapply(generate_sample, pwindows, swindows, obs_times)

  delay_data <- data.frame(
    left = samples
  )
  delay_data$right <- delay_data$left + swindows

  fit_gamma <- fitdistdoublecens(
    delay_data,
    distr = "gamma",
    start = list(shape = 2, rate = 1),
    D = 10, pwindow = 1
  )

  expect_s3_class(fit_gamma, "fitdist")
  expect_equal(unname(fit_gamma$estimate["shape"]), true_shape, tolerance = 0.3)
  expect_equal(unname(fit_gamma$estimate["rate"]), true_rate, tolerance = 0.2)
})

test_that(
  "fitdistdoublecens throws error when required packages are not installed",
  {
    # Create dummy data
    dummy_data <- data.frame(left = 1:5, right = 2:6)

    # Test for fitdistrplus
    with_mocked_bindings(
      {
        expect_error(
          fitdistdoublecens(dummy_data, "norm"),
          "Package 'fitdistrplus' is required but not installed for this",
          fixed = TRUE
        )
      },
      requireNamespace = function(pkg, ...) {
        if (pkg == "fitdistrplus") {
          return(FALSE)
        }
        TRUE
      },
      .package = "base"
    )

    # Test for withr
    with_mocked_bindings(
      {
        expect_error(
          fitdistdoublecens(dummy_data, "norm"),
          "Package 'withr' is required but not installed for this function.",
          fixed = TRUE
        )
      },
      requireNamespace = function(pkg, ...) {
        if (pkg == "withr") {
          return(FALSE)
        }
        TRUE
      },
      .package = "base"
    )

    # Test when both packages are missing
    with_mocked_bindings(
      {
        expect_error(
          fitdistdoublecens(dummy_data, "norm"),
          "Package 'fitdistrplus' is required but not installed",
          fixed = TRUE
        )
      },
      requireNamespace = function(...) FALSE,
      .package = "base"
    )
  }
)