Skip to content

Commit 11bdfdb

Browse files
strengejackestrengejacke
committed
informative message
1 parent 6909196 commit 11bdfdb

File tree

3 files changed

+73
-49
lines changed

3 files changed

+73
-49
lines changed

‎DESCRIPTION

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,7 @@
11
Type: Package
22
Package: insight
33
Title: Easy Access to Model Information for Various Model Objects
4-
Version: 0.19.8.1
4+
Version: 0.19.8.2
55
Authors@R:
66
c(person(given = "Daniel",
77
family = "Lüdecke",

‎R/get_varcov.R

Lines changed: 65 additions & 48 deletions
Original file line numberDiff line numberDiff line change
@@ -94,7 +94,7 @@ get_varcov.default <- function(x,
9494
vcov <- .check_vcov_args(x, vcov = vcov, verbose = verbose, ...)
9595

9696
if (is.null(vcov)) {
97-
vc <- suppressWarnings(stats::vcov(x))
97+
vc <- .safe_vcov(x)
9898
} else {
9999
vc <- .get_varcov_sandwich(x,
100100
vcov_fun = vcov,
@@ -127,9 +127,9 @@ get_varcov.fixest <- function(x,
127127
# fixest supplies its own mechanism. Vincent thinks it might not be wise to
128128
# try `sandwich`, because there may be inconsistencies.
129129
check_if_installed("fixest")
130-
args <- c(list(x, vcov = vcov), vcov_args)
130+
my_args <- c(list(x, vcov = vcov), vcov_args)
131131
FUN <- stats::vcov
132-
do.call("FUN", args)
132+
do.call("FUN", my_args)
133133
}
134134

135135

@@ -223,19 +223,17 @@ get_varcov.DirichletRegModel <- function(x,
223223
.check_get_varcov_dots(x, ...)
224224
component <- match.arg(component)
225225
if (x$parametrization == "common") {
226-
vc <- stats::vcov(x)
226+
vc <- .safe_vcov(x)
227+
} else if (component == "conditional") {
228+
vc <- .safe_vcov(x)
229+
keep <- grepl("^(?!\\(phi\\))", rownames(vc), perl = TRUE)
230+
vc <- vc[keep, keep, drop = FALSE]
231+
} else if (component == "precision") {
232+
vc <- .safe_vcov(x)
233+
keep <- startsWith(rownames(vc), "(phi)")
234+
vc <- vc[keep, keep, drop = FALSE]
227235
} else {
228-
if (component == "conditional") {
229-
vc <- stats::vcov(x)
230-
keep <- grepl("^(?!\\(phi\\))", rownames(vc), perl = TRUE)
231-
vc <- vc[keep, keep, drop = FALSE]
232-
} else if (component == "precision") {
233-
vc <- stats::vcov(x)
234-
keep <- startsWith(rownames(vc), "(phi)")
235-
vc <- vc[keep, keep, drop = FALSE]
236-
} else {
237-
vc <- stats::vcov(x)
238-
}
236+
vc <- .safe_vcov(x)
239237
}
240238
.process_vcov(vc, verbose, ...)
241239
}
@@ -253,19 +251,19 @@ get_varcov.clm2 <- function(x,
253251
n_location <- length(x$beta)
254252
n_scale <- length(x$zeta)
255253

256-
vc <- stats::vcov(x)
254+
vc <- .safe_vcov(x)
257255

258256
if (.is_negativ_matrix(vc, ...)) {
259257
vc <- .fix_negative_matrix(vc)
260258
}
261259

262-
range <- switch(component,
260+
col_range <- switch(component,
263261
all = 1:(n_scale + n_intercepts + n_location),
264262
conditional = 1:(n_intercepts + n_location),
265263
scale = (1 + n_intercepts + n_location):(n_scale + n_intercepts + n_location)
266264
)
267265

268-
vc <- vc[range, range, drop = FALSE]
266+
vc <- vc[col_range, col_range, drop = FALSE]
269267

270268
# fix possible missings due to rank deficient model matrix
271269
vc <- .fix_rank_deficiency(vc)
@@ -307,7 +305,7 @@ get_varcov.pgmm <- function(x,
307305
component <- match.arg(component)
308306

309307
if (is.null(vcov)) {
310-
vc <- suppressWarnings(stats::vcov(x))
308+
vc <- .safe_vcov(x)
311309
} else {
312310
vc <- .get_varcov_sandwich(x,
313311
vcov_fun = vcov,
@@ -353,7 +351,7 @@ get_varcov.mvord <- function(x,
353351
...) {
354352
.check_get_varcov_dots(x, ...)
355353
component <- match.arg(component)
356-
vc <- stats::vcov(x)
354+
vc <- .safe_vcov(x)
357355

358356
if (component != "all") {
359357
fp <- find_parameters(x)[[component]]
@@ -374,7 +372,7 @@ get_varcov.mjoint <- function(x,
374372
...) {
375373
.check_get_varcov_dots(x, ...)
376374
component <- match.arg(component)
377-
vc <- stats::vcov(x)
375+
vc <- .safe_vcov(x)
378376

379377
keep <- match(find_parameters(x, flatten = TRUE, component = component), rownames(vc))
380378
vc <- vc[keep, keep, drop = FALSE]
@@ -389,7 +387,7 @@ get_varcov.mhurdle <- function(x,
389387
...) {
390388
.check_get_varcov_dots(x, ...)
391389
component <- match.arg(component)
392-
vc <- stats::vcov(x)
390+
vc <- .safe_vcov(x)
393391

394392
# rownames(vc) <- gsub("^(h1|h2|h3)\\.(.*)", "\\2", rownames(vc))
395393
# colnames(vc) <- rownames(vc)
@@ -405,7 +403,7 @@ get_varcov.mhurdle <- function(x,
405403
get_varcov.truncreg <- function(x, component = c("conditional", "all"), verbose = TRUE, ...) {
406404
.check_get_varcov_dots(x, ...)
407405
component <- match.arg(component)
408-
vc <- stats::vcov(x)
406+
vc <- .safe_vcov(x)
409407

410408
if (component == "conditional") {
411409
vc <- vc[1:(nrow(vc) - 1), 1:(ncol(vc) - 1), drop = FALSE]
@@ -418,7 +416,7 @@ get_varcov.truncreg <- function(x, component = c("conditional", "all"), verbose
418416
get_varcov.gamlss <- function(x, component = c("conditional", "all"), verbose = TRUE, ...) {
419417
.check_get_varcov_dots(x, ...)
420418
component <- match.arg(component)
421-
vc <- suppressWarnings(stats::vcov(x))
419+
vc <- .safe_vcov(x)
422420

423421
if (component == "conditional") {
424422
cond_pars <- length(find_parameters(x)$conditional)
@@ -520,10 +518,10 @@ get_varcov.glmmTMB <- function(x,
520518
component <- match.arg(component)
521519

522520
vc <- switch(component,
523-
conditional = stats::vcov(x)[["cond"]],
521+
conditional = .safe_vcov(x)[["cond"]],
524522
zi = ,
525-
zero_inflated = stats::vcov(x)[["zi"]],
526-
dispersion = stats::vcov(x)[["disp"]],
523+
zero_inflated = .safe_vcov(x)[["zi"]],
524+
dispersion = .safe_vcov(x)[["disp"]],
527525
stats::vcov(x, full = TRUE)
528526
)
529527
.process_vcov(vc, verbose, ...)
@@ -592,7 +590,7 @@ get_varcov.brmsfit <- function(x, component = "conditional", verbose = TRUE, ...
592590
params <- find_parameters(x, effects = "fixed", component = component, flatten = TRUE)
593591
params <- gsub("^b_", "", params)
594592

595-
vc <- stats::vcov(x)[params, params, drop = FALSE]
593+
vc <- .safe_vcov(x)[params, params, drop = FALSE]
596594
.process_vcov(vc, verbose, ...)
597595
}
598596

@@ -659,15 +657,15 @@ get_varcov.flac <- get_varcov.flic
659657
get_varcov.merModList <- function(x, ...) {
660658
.check_get_varcov_dots(x, ...)
661659
format_warning("Can't access variance-covariance matrix for 'merModList' objects.")
662-
return(NULL)
660+
NULL
663661
}
664662

665663

666664
#' @export
667665
get_varcov.mediate <- function(x, ...) {
668666
.check_get_varcov_dots(x, ...)
669667
format_warning("Can't access variance-covariance matrix for 'mediate' objects.")
670-
return(NULL)
668+
NULL
671669
}
672670

673671

@@ -715,7 +713,7 @@ get_varcov.bife <- function(x, verbose = TRUE, ...) {
715713
.check_get_varcov_dots(x, ...)
716714
params <- find_parameters(x, flatten = TRUE)
717715
np <- length(params)
718-
vc <- stats::vcov(x)[1:np, 1:np, drop = FALSE]
716+
vc <- .safe_vcov(x)[1:np, 1:np, drop = FALSE]
719717

720718
dimnames(vc) <- list(params, params)
721719
.process_vcov(vc, verbose, ...)
@@ -725,7 +723,7 @@ get_varcov.bife <- function(x, verbose = TRUE, ...) {
725723
#' @export
726724
get_varcov.Rchoice <- function(x, verbose = TRUE, ...) {
727725
.check_get_varcov_dots(x, ...)
728-
vc <- stats::vcov(x)
726+
vc <- .safe_vcov(x)
729727
params <- find_parameters(x, flatten = TRUE)
730728
dimnames(vc) <- list(params, params)
731729
.process_vcov(vc, verbose, ...)
@@ -803,7 +801,7 @@ get_varcov.rqs <- get_varcov.crq
803801
get_varcov.flexsurvreg <- function(x, verbose = TRUE, ...) {
804802
.check_get_varcov_dots(x, ...)
805803
pars <- find_parameters(x, flatten = TRUE)
806-
vc <- as.matrix(stats::vcov(x))[pars, pars, drop = FALSE]
804+
vc <- as.matrix(.safe_vcov(x))[pars, pars, drop = FALSE]
807805
.process_vcov(vc, verbose, ...)
808806
}
809807

@@ -863,7 +861,7 @@ get_varcov.mixor <- function(x, effects = c("all", "fixed", "random"), verbose =
863861
.check_get_varcov_dots(x, ...)
864862
effects <- match.arg(effects)
865863
params <- find_parameters(x, effects = effects, flatten = TRUE)
866-
vc <- as.matrix(stats::vcov(x))[params, params, drop = FALSE]
864+
vc <- as.matrix(.safe_vcov(x))[params, params, drop = FALSE]
867865
.process_vcov(vc, verbose, ...)
868866
}
869867

@@ -973,7 +971,7 @@ get_varcov.vgam <- get_varcov.vglm
973971
get_varcov.tobit <- function(x, verbose = TRUE, ...) {
974972
.check_get_varcov_dots(x, ...)
975973
coef_names <- find_parameters(x, flatten = TRUE)
976-
vc <- stats::vcov(x)[coef_names, coef_names, drop = FALSE]
974+
vc <- .safe_vcov(x)[coef_names, coef_names, drop = FALSE]
977975
.process_vcov(vc, verbose, ...)
978976
}
979977

@@ -1031,6 +1029,27 @@ get_varcov.LORgee <- get_varcov.gee
10311029
# helper-functions -----------------------------------------------------
10321030

10331031

1032+
.safe_vcov <- function(x) {
1033+
vc <- tryCatch(
1034+
suppressWarnings(stats::vcov(x)),
1035+
error = function(e) e
1036+
)
1037+
if (inherits(vc, "error")) {
1038+
# check for dates or times, which can cause the error
1039+
my_data <- get_data(x, verbose = FALSE)
1040+
if (!is.null(my_data) && any(vapply(my_data, inherits, FUN.VALUE = logical(1), what = c("Date", "POSIXt", "difftime")))) { # nolint
1041+
msg <- "A reason might be that your model includes dates or times. Please convert them to numeric values before fitting the model." # nolint
1042+
} else {
1043+
msg <- NULL
1044+
}
1045+
format_error(paste(
1046+
"Can't extract variance-covariance matrix. `get_varcov()` returned following error:",
1047+
vc$message
1048+
), msg)
1049+
}
1050+
vc
1051+
}
1052+
10341053
.process_vcov <- function(vc, verbose = TRUE, ...) {
10351054
if (.is_negativ_matrix(vc, ...)) {
10361055
vc <- .fix_negative_matrix(vc)
@@ -1100,8 +1119,8 @@ get_varcov.LORgee <- get_varcov.gee
11001119

11011120
.get_weighted_varcov <- function(x, cov_unscaled) {
11021121
ssd <- .weighted_crossprod(stats::residuals(x), w = x$weights)
1103-
df <- sum(x$weights)
1104-
out <- structure(list(SSD = ssd, call = x$call, df = df), class = "SSD")
1122+
weight_df <- sum(x$weights)
1123+
out <- structure(list(SSD = ssd, call = x$call, df = weight_df), class = "SSD")
11051124
kronecker(stats::estVar(out), cov_unscaled, make.dimnames = TRUE)
11061125
}
11071126

@@ -1116,19 +1135,17 @@ get_varcov.LORgee <- get_varcov.gee
11161135
}
11171136

11181137
if (length(w) == 1 || (is.vector(w) && stats::sd(w) < sqrt(.Machine$double.eps))) {
1119-
return(w[1] * crossprod(x))
1138+
w[1] * crossprod(x)
1139+
} else if (is.vector(w)) {
1140+
if (length(w) != nrow(x)) {
1141+
format_error("`w` is the wrong length.")
1142+
}
1143+
crossprod(x, w * x)
11201144
} else {
1121-
if (is.vector(w)) {
1122-
if (length(w) != nrow(x)) {
1123-
format_error("`w` is the wrong length.")
1124-
}
1125-
return(crossprod(x, w * x))
1126-
} else {
1127-
if (nrow(w) != ncol(w) || nrow(w) != nrow(x)) {
1128-
format_error("`w` is the wrong dimension.")
1129-
}
1130-
return(crossprod(x, w %*% x))
1145+
if (nrow(w) != ncol(w) || nrow(w) != nrow(x)) {
1146+
format_error("`w` is the wrong dimension.")
11311147
}
1148+
crossprod(x, w %*% x)
11321149
}
11331150
}
11341151

‎tests/testthat/test-get_varcov.R

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -75,3 +75,10 @@ test_that("verbose and deprecated arguments", {
7575
expect_warning(get_varcov(mod, robust = TRUE), regexp = "deprecated")
7676
expect_warning(get_varcov(mod, robust = TRUE, verbose = FALSE), NA)
7777
})
78+
79+
80+
test_that("error: ill-defined model", {
81+
dd <- data.frame(y = as.difftime(0:5, units = "days"))
82+
m1 <- lm(y ~ 1, data = dd)
83+
expect_error(get_varcov(m1), regex = "Can't extract variance-covariance")
84+
})

0 commit comments

Comments
 (0)