Skip to content

Commit

Permalink
Merge branch 'main' into strengejacke/issue595
Browse files Browse the repository at this point in the history
  • Loading branch information
strengejacke authored Oct 29, 2023
2 parents 67d3319 + 50a0443 commit 4d4b776
Show file tree
Hide file tree
Showing 12 changed files with 246 additions and 144 deletions.
3 changes: 2 additions & 1 deletion DESCRIPTION
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
Type: Package
Package: performance
Title: Assessment of Regression Models Performance
Version: 0.10.7.1
Version: 0.10.7.2
Authors@R:
c(person(given = "Daniel",
family = "Lüdecke",
Expand Down Expand Up @@ -154,3 +154,4 @@ Config/Needs/website:
r-lib/pkgdown,
easystats/easystatstemplate
Config/rcmdcheck/ignore-inconsequential-notes: true
Remotes: easystats/insight
13 changes: 13 additions & 0 deletions NEWS.md
Original file line number Diff line number Diff line change
@@ -1,3 +1,16 @@
# performance 0.10.8

## Changes

* Changed behaviour of `check_predictions()` for models from binomial family,
to get comparable plots for different ways of outcome specification. Now,
if the outcome is a proportion, or defined as matrix of trials and successes,
the produced plots are the same (because the models should be the same, too).

## Bug fixes

* Fixed CRAN check errors.

# performance 0.10.7

## Breaking changes
Expand Down
12 changes: 11 additions & 1 deletion R/binned_residuals.R
Original file line number Diff line number Diff line change
Expand Up @@ -29,6 +29,7 @@
#' time-consuming. By default, `show_dots = NULL`. In this case `binned_residuals()`
#' tries to guess whether performance will be poor due to a very large model
#' and thus automatically shows or hides dots.
#' @param verbose Toggle warnings and messages.
#' @param ... Currently not used.
#'
#' @return A data frame representing the data that is mapped in the accompanying
Expand Down Expand Up @@ -83,11 +84,20 @@ binned_residuals <- function(model,
ci_type = c("exact", "gaussian", "boot"),
residuals = c("deviance", "pearson", "response"),
iterations = 1000,
verbose = TRUE,
...) {
# match arguments
ci_type <- match.arg(ci_type)
residuals <- match.arg(residuals)

# for non-bernoulli models, `"exact"` doesn't work
if (isFALSE(insight::model_info(model)$is_bernoulli)) {
ci_type <- "gaussian"
if (verbose) {
insight::format_alert("Using `ci_type = \"gaussian\"` because model is not bernoulli.")
}
}

fitted_values <- stats::fitted(model)
mf <- insight::get_data(model, verbose = FALSE)

Expand Down Expand Up @@ -186,7 +196,7 @@ binned_residuals <- function(model,
}
out <- out / n

quant <- stats::quantile(out, c((1 - ci) / 2, (1 + ci) / 2))
quant <- stats::quantile(out, c((1 - ci) / 2, (1 + ci) / 2), na.rm = TRUE)
c(CI_low = quant[1L], CI_high = quant[2L])
}

Expand Down
2 changes: 1 addition & 1 deletion R/check_model.R
Original file line number Diff line number Diff line change
Expand Up @@ -374,7 +374,7 @@ check_model.model_fit <- function(x,
dat$INFLUENTIAL <- .influential_obs(model, threshold = threshold)
dat$PP_CHECK <- .safe(check_predictions(model, ...))
if (isTRUE(model_info$is_binomial)) {
dat$BINNED_RESID <- binned_residuals(model, ...)
dat$BINNED_RESID <- binned_residuals(model, verbose = verbose, ...)
}
if (isTRUE(model_info$is_count)) {
dat$OVERDISPERSION <- .diag_overdispersion(model)
Expand Down
40 changes: 24 additions & 16 deletions R/check_predictions.R
Original file line number Diff line number Diff line change
Expand Up @@ -197,10 +197,10 @@ pp_check.lm <- function(object,
out <- .check_re_formula(out, object, iterations, re_formula, verbose, ...)

# save information about model
if (!is.null(model_info)) {
minfo <- model_info
} else {
if (is.null(model_info)) {
minfo <- insight::model_info(object)
} else {
minfo <- model_info
}

# glmmTMB returns column matrix for bernoulli
Expand All @@ -215,9 +215,10 @@ pp_check.lm <- function(object,
}

if (is.null(out)) {
insight::format_error(
sprintf("Could not simulate responses. Maybe there is no `simulate()` for objects of class `%s`?", class(object)[1])
)
insight::format_error(sprintf(
"Could not simulate responses. Maybe there is no `simulate()` for objects of class `%s`?",
class(object)[1]
))
}

# get response data, and response term, to check for transformations
Expand Down Expand Up @@ -263,7 +264,7 @@ pp_check.glm <- function(object,
out <- tryCatch(
{
matrix_sim <- stats::simulate(object, nsim = iterations, re.form = re_formula, ...)
as.data.frame(sapply(matrix_sim, function(i) i[, 1] / i[, 2], simplify = TRUE))
as.data.frame(sapply(matrix_sim, function(i) i[, 1] / rowSums(i, na.rm = TRUE), simplify = TRUE))
},
error = function(e) {
NULL
Expand All @@ -274,9 +275,10 @@ pp_check.glm <- function(object,
out <- .check_re_formula(out, object, iterations, re_formula, verbose, ...)

if (is.null(out)) {
insight::format_error(
sprintf("Could not simulate responses. Maybe there is no `simulate()` for objects of class `%s`?", class(object)[1])
)
insight::format_error(sprintf(
"Could not simulate responses. Maybe there is no `simulate()` for objects of class `%s`?",
class(object)[1]
))
}

# get response data, and response term
Expand All @@ -285,13 +287,13 @@ pp_check.glm <- function(object,
)
resp_string <- insight::find_terms(object)$response

out$y <- response[, 1] / response[, 2]
out$y <- response[, 1] / rowSums(response, na.rm = TRUE)

# safe information about model
if (!is.null(model_info)) {
minfo <- model_info
} else {
if (is.null(model_info)) {
minfo <- insight::model_info(object)
} else {
minfo <- model_info
}

attr(out, "check_range") <- check_range
Expand Down Expand Up @@ -363,14 +365,20 @@ print.performance_pp_check <- function(x, verbose = TRUE, ...) {
if (is.numeric(original)) {
if (min(replicated) > min(original)) {
insight::print_color(
insight::format_message("Warning: Minimum value of original data is not included in the replicated data.", "Model may not capture the variation of the data."),
insight::format_message(
"Warning: Minimum value of original data is not included in the replicated data.",
"Model may not capture the variation of the data."
),
"red"
)
}

if (max(replicated) < max(original)) {
insight::print_color(
insight::format_message("Warning: Maximum value of original data is not included in the replicated data.", "Model may not capture the variation of the data."),
insight::format_message(
"Warning: Maximum value of original data is not included in the replicated data.",
"Model may not capture the variation of the data."
),
"red"
)
}
Expand Down
2 changes: 2 additions & 0 deletions R/looic.R
Original file line number Diff line number Diff line change
Expand Up @@ -12,6 +12,7 @@
#' @return A list with four elements, the ELPD, LOOIC and their standard errors.
#'
#' @examplesIf require("rstanarm")
#' \donttest{
#' model <- suppressWarnings(rstanarm::stan_glm(
#' mpg ~ wt + cyl,
#' data = mtcars,
Expand All @@ -20,6 +21,7 @@
#' refresh = 0
#' ))
#' looic(model)
#' }
#' @export
looic <- function(model, verbose = TRUE) {
insight::check_if_installed("loo")
Expand Down
Loading

0 comments on commit 4d4b776

Please sign in to comment.