test_that("new_pcens creates object with correct structure", { pdist <- pgamma dprimary <- dunif shape <- 2 rate <- 1 obj <- new_pcens( pdist, dprimary, list(), shape = shape, rate = rate ) expect_s3_class(obj, "pcens_pgamma_dunif") expect_identical(body(obj$pdist), body(pgamma)) expect_identical(formals(obj$pdist), formals(pgamma)) expect_identical(body(obj$dprimary), body(dunif)) expect_identical(formals(obj$dprimary), formals(dunif)) expect_identical(obj$args, list(shape = shape, rate = rate)) new_obj <- new_pcens( pgamma, dunif, list(), shape = shape, rate = rate ) expect_identical(obj, new_obj) }) test_that( "pcens_cdf methods dispatch correctly to existing analytical solutions", { pdist <- pgamma dprimary <- dunif obj_gamma <- new_pcens( pdist, dprimary, list(), shape = 2, rate = 1 ) pdist <- plnorm dprimary <- dunif obj_lnorm <- new_pcens( pdist, dprimary, list(), meanlog = 0, sdlog = 1 ) pdist <- pweibull dprimary <- dunif obj_weibull <- new_pcens( pdist, dprimary, list(), shape = 2, scale = 1 ) expect_s3_class(obj_gamma, "pcens_pgamma_dunif") expect_s3_class(obj_lnorm, "pcens_plnorm_dunif") expect_s3_class(obj_weibull, "pcens_pweibull_dunif") q_values <- c(5, 10) pwindow <- 2 expect_no_error( pcens_cdf(obj_gamma, q = q_values, pwindow = pwindow) ) expect_no_error( pcens_cdf(obj_lnorm, q = q_values, pwindow = pwindow) ) expect_no_error( pcens_cdf(obj_weibull, q = q_values, pwindow = pwindow) ) } ) test_that( "pcens_cdf errors as expected when the wrong distributional parameters are supplied", { pdist <- pgamma dprimary <- dunif obj_gamma <- new_pcens( pdist, dprimary, list(), rate = 1 ) expect_error( pcens_cdf(obj_gamma, q = 1, pwindow = 1), "shape parameter is required for Gamma distribution" ) obj_gamma_no_rate <- new_pcens( pdist, dprimary, list(), shape = 2 ) expect_error( pcens_cdf(obj_gamma_no_rate, q = 1, pwindow = 1), "scale or rate parameter is required for Gamma distribution" ) pdist <- plnorm obj_lnorm_no_meanlog <- new_pcens( pdist, dprimary, list(), sdlog = 1 ) expect_error( pcens_cdf(obj_lnorm_no_meanlog, q = 1, pwindow = 1), "meanlog parameter is required for Log-Normal distribution" ) obj_lnorm_no_sdlog <- new_pcens( pdist, dprimary, list(), meanlog = 0 ) expect_error( pcens_cdf(obj_lnorm_no_sdlog, q = 1, pwindow = 1), "sdlog parameter is required for Log-Normal distribution" ) pdist <- pweibull obj_weibull_no_shape <- new_pcens( pdist, dprimary, list(), scale = 1 ) expect_error( pcens_cdf(obj_weibull_no_shape, q = 1, pwindow = 1), "shape parameter is required for Weibull distribution" ) obj_weibull_no_scale <- new_pcens( pdist, dprimary, list(), shape = 2 ) expect_error( pcens_cdf(obj_weibull_no_scale, q = 1, pwindow = 1), "scale parameter is required for Weibull distribution" ) } ) test_that( "pcens_cdf.default computes the same values as pcens_cdf.pcens_pgamma_dunif", { pdist <- pgamma dprimary <- dunif shapes <- c(0.5, 1, 2, 5) rates <- c(0.1, 0.5, 1, 2) pwindows <- c(1, 2, 5, 10) for (shape in shapes) { for (rate in rates) { for (pwindow in pwindows) { obj <- new_pcens( pdist, dprimary, list(), shape = shape, rate = rate ) q_values <- seq(0, 30, by = 0.1) result_numeric <- pcens_cdf( obj, q = q_values, pwindow = pwindow, use_numeric = TRUE ) result_analytical <- pcens_cdf( obj, q = q_values, pwindow = pwindow, use_numeric = FALSE ) # Check properties of numeric result expect_type(result_numeric, "double") expect_length(result_numeric, length(q_values)) expect_true( all(diff(result_numeric) >= 0) ) # Ensure CDF is non-decreasing # Check that analytical and numeric results are the same expect_equal( result_numeric, result_analytical, tolerance = 1e-5, info = sprintf( "Mismatch for shape = %s, rate = %s, pwindow = %s", shape, rate, pwindow ) ) } } } } ) test_that( "pcens_cdf.default computes the same values as pcens_cdf.pcens_plnorm_dunif", { pdist <- plnorm dprimary <- dunif meanlogs <- c(-1, 0, 1, 2) sdlogs <- c(0.5, 1, 1.5) pwindows <- c(1, 2, 5, 8) for (meanlog in meanlogs) { for (sdlog in sdlogs) { for (pwindow in pwindows) { obj <- new_pcens( pdist, dprimary, list(), meanlog = meanlog, sdlog = sdlog ) q_values <- seq(0, 30, by = 0.1) result_numeric <- pcens_cdf( obj, q = q_values, pwindow = pwindow, use_numeric = TRUE ) result_analytical <- pcens_cdf( obj, q = q_values, pwindow = pwindow, use_numeric = FALSE ) # Check properties of numeric result expect_type(result_numeric, "double") expect_length(result_numeric, length(q_values)) expect_true( all(diff(result_numeric) >= 0) ) # Ensure CDF is non-decreasing # Check that analytical and numeric results are the same expect_equal( result_numeric, result_analytical, tolerance = 1e-5, info = sprintf( "Mismatch for meanlog = %s, sdlog = %s, pwindow = %s", meanlog, sdlog, pwindow ) ) } } } } ) test_that( "pcens_cdf.default computes the same values as pcens_cdf.pcens_pweibull_dunif", { pdist <- pweibull dprimary <- dunif shapes <- c(0.5, 1, 2) scales <- c(0.5, 1, 2) pwindows <- c(1, 2, 3, 4, 5) for (shape in shapes) { for (scale in scales) { for (pwindow in pwindows) { obj <- new_pcens( pdist, dprimary, list(), shape = shape, scale = scale ) q_values <- seq(0, 30, by = 0.1) result_numeric <- pcens_cdf( obj, q = q_values, pwindow = pwindow, use_numeric = TRUE ) result_analytical <- pcens_cdf( obj, q = q_values, pwindow = pwindow, use_numeric = FALSE ) # Check properties of numeric result expect_type(result_numeric, "double") expect_length(result_numeric, length(q_values)) expect_true( all(diff(result_numeric) >= 0) ) # Ensure CDF is non-decreasing # Check that analytical and numeric results are the same expect_equal( result_numeric, result_analytical, tolerance = 1e-5, info = sprintf( "Mismatch for shape = %s, scale = %s, pwindow = %s", shape, scale, pwindow ) ) } } } } ) test_that("new_pcens *_name deprecation is soft.", { pdist <- function(...) pgamma(...) dprimary <- function(...) dunif(...) shape <- 2 rate <- 1 neg_obj <- new_pcens( pdist, dprimary, list(), shape = shape, rate = rate ) expect_s3_class(neg_obj, "pcens_unknown_unknown") ref_obj <- new_pcens( add_name_attribute(pdist, "pgamma"), add_name_attribute(dprimary, "dunif"), list(), shape = shape, rate = rate ) lifecycle::expect_deprecated(obj <- new_pcens( # nolint pdist, add_name_attribute(dprimary, "dunif"), list(), pdist_name = "pgamma", shape = shape, rate = rate )) lifecycle::expect_deprecated(new_obj <- new_pcens( # nolint add_name_attribute(pdist, "pgamma"), dprimary, list(), dprimary_name = "dunif", shape = shape, rate = rate )) expect_identical(body(obj$pdist), body(ref_obj$pdist)) expect_identical(body(new_obj$pdist), body(ref_obj$pdist)) expect_identical(formals(obj$pdist), formals(ref_obj$pdist)) expect_identical(formals(new_obj$pdist), formals(ref_obj$pdist)) expect_identical(body(obj$dprimary), body(ref_obj$dprimary)) expect_identical(body(new_obj$dprimary), body(ref_obj$dprimary)) expect_identical(formals(obj$dprimary), formals(new_obj$dprimary)) expect_identical(formals(new_obj$dprimary), formals(ref_obj$dprimary)) }) test_that("new_pcens works with custom function with name attribute", { # Create custom functions with name attributes custom_pdist <- function(x, shape, rate) pgamma(x, shape, rate) custom_dprimary <- function(x, min = 0, max = 1) dunif(x, min, max) named_pdist <- add_name_attribute(custom_pdist, "pgamma") named_dprimary <- add_name_attribute(custom_dprimary, "dunif") # Create pcens object with custom named functions obj <- new_pcens( named_pdist, named_dprimary, list(), shape = 2, rate = 1 ) # Check class is set correctly using function names expect_s3_class(obj, "pcens_pgamma_dunif") # Check functions are preserved correctly expect_identical(body(obj$pdist), body(custom_pdist)) expect_identical(formals(obj$pdist), formals(custom_pdist)) expect_identical(body(obj$dprimary), body(custom_dprimary)) expect_identical(formals(obj$dprimary), formals(custom_dprimary)) # Check arguments are preserved expect_identical(obj$args, list(shape = 2, rate = 1)) })