Skip to content

Commit

Permalink
Bug fix for check_regression argument selection
Browse files Browse the repository at this point in the history
  • Loading branch information
chjackson committed Sep 19, 2023
1 parent bcc1062 commit 3c7166f
Show file tree
Hide file tree
Showing 6 changed files with 39 additions and 10 deletions.
10 changes: 10 additions & 0 deletions NEWS.md
Original file line number Diff line number Diff line change
@@ -0,0 +1,10 @@
# Version 1.0.1

* Bug fix for `evppi(...,check=TRUE)` with multiple WTPs

* `pars` no longer required for `evsi()` with regression methods


# Version 1.0

* Initial CRAN release
9 changes: 4 additions & 5 deletions R/check_regression.R
Original file line number Diff line number Diff line change
Expand Up @@ -22,7 +22,8 @@
##'
##' @param pars Parameter (or parameter group) whose EVPPI calculation is to be checked.
##' This should be in the \code{pars} component of the object returned by \code{\link{evppi}}.
##' Only relevant if \code{x} is the result of an \code{\link{evppi}} calculation.
##' Only relevant if \code{x} is the result of an \code{\link{evppi}} calculation. By default,
##' the first calculation shown in \code{x} is checked.
##'
##' @param n Sample size whose EVSI calculation is to be checked.
##' This should be in the \code{n} component of the object returned by \code{\link{evsi}}.
Expand Down Expand Up @@ -69,7 +70,7 @@ check_regression <- function(x, pars=NULL, n=NULL, comparison=1, outcome="costs"
if (inherits(x, "evppi")) {
if (is.null(pars)) pars <- x$pars[1]
if (!(pars %in% x$pars)) stop(sprintf("parameter `%s` not found", pars))
method <- attr(x, "methods")[match(pars, x$pars)]
method <- attr(x, "methods")[match(pars, unique(x$pars))]
}
else if (inherits(x, "evsi")){
if (is.null(n)) pars <- as.character(x$n[1])
Expand All @@ -89,6 +90,7 @@ check_regression <- function(x, pars=NULL, n=NULL, comparison=1, outcome="costs"
if (!(comparison %in% 1:ncomp)) stop(sprintf("`comparison` should be a positive integer <= %s", ncomp))
if (cea){
if (!(outcome %in% c("costs","effects"))) stop("`outcome` should be \"costs\" or \"effects\"")
outcome <- if (outcome=="costs") "c" else "e"
mod <- mods[[pars]][[outcome]][[comparison]]
} else {
mod <- mods[[pars]][[comparison]]
Expand All @@ -113,9 +115,6 @@ check_plot_default <- function(mod){
if (!is.numeric(res))
warning("residuals() does not work on regression model object, so can't produce diagnostic plots")
dat <- data.frame(fit = fit, res = res)
oldpar <- graphics::par(no.readonly=TRUE)
on.exit(par(oldpar))
graphics::par(mfrow=c(2,1))
bw <- 2 * IQR(dat$res) / length(dat$res)^(1/3)
p1 <- ggplot2::ggplot(dat, aes(x=res)) +
ggplot2::geom_histogram(binwidth=bw) +
Expand Down
2 changes: 1 addition & 1 deletion R/evppi.R
Original file line number Diff line number Diff line change
Expand Up @@ -281,7 +281,7 @@ evppi <- function(outputs,
res <- cbind(pars=rep(names(pars), each = nwtp), res)
if (check){
attr(res, "models") <- lapply(eres, function(x)attr(x, "models"))
names(attr(res, "models")) <- res$pars
names(attr(res, "models")) <- names(pars)
}
attr(res, "methods") <- methods
attr(res, "outputs") <- class(outputs)[1]
Expand Down
3 changes: 2 additions & 1 deletion man/check_regression.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

22 changes: 22 additions & 0 deletions tests/testthat/test_check_regression.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,22 @@
pi1 <- "p_side_effects_t1"
pi2 <- "p_side_effects_t2"

test_that("check_regression",{
evtest <- evppi(chemo_nb, chemo_pars, pars=pi1, check=TRUE)
et <- check_regression(evtest)
expect_equal(et$AIC, 165744, tol=1)
evtest <- evppi(chemo_nb, chemo_pars, pars=list(pi1, c(pi1, pi2)), check=TRUE)
et2 <- check_regression(evtest,par="p_side_effects_t1,p_side_effects_t2")
expect_true(et$AIC != et2$AIC)

evtest <- evppi(chemo_cea, chemo_pars, pars=c(pi1), check=TRUE)
etc <- check_regression(evtest, outcome="costs")
ete <- check_regression(evtest, outcome="effects")
expect_true(etc$AIC != ete$AIC)
evtest <- evppi(chemo_cea, chemo_pars, pars=list(pi1, c(pi1, pi2)), check=TRUE)
etb <- check_regression(evtest, outcome="costs")
expect_equal(etc$AIC, etb$AIC)
et <- check_regression(evtest, outcome="costs",
par="p_side_effects_t1,p_side_effects_t2")
expect_true(et$AIC != etb$AIC)
})
3 changes: 0 additions & 3 deletions tests/testthat/test_plots.R
Original file line number Diff line number Diff line change
Expand Up @@ -14,7 +14,4 @@ test_that("EVPPI plots work",{
evtest <- evppi(chemo_cea, chemo_pars, pars=as.list(names(chemo_pars)))
plot(evtest, top=6)
}, NA)
evtest <- evppi(chemo_nb, chemo_pars, pars=pi1, check=TRUE)
et <- check_regression(evtest)
expect_equal(et$AIC, 165744, tol=1)
})

0 comments on commit 3c7166f

Please sign in to comment.