Predicted proportions below zero for model-averaged binomial GLM (#838)

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: insight
 Title: Easy Access to Model Information for Various Model Objects
-Version: 0.19.7.4
+Version: 0.19.7.5
 Authors@R: 
     c(person(given = "Daniel",
              family = "Lüdecke",
@@ -160,6 +160,7 @@ Suggests:
     mmrm,
     modelbased,
     multgee,
+    MuMIn,
     nestedLogit,
     nlme,
     nnet,

NAMESPACE

@@ -1024,6 +1024,7 @@ S3method(link_function,RM)
 S3method(link_function,Rchoice)
 S3method(link_function,afex_aov)
 S3method(link_function,aovlist)
+S3method(link_function,averaging)
 S3method(link_function,bamlss)
 S3method(link_function,bayesx)
 S3method(link_function,bcplm)
@@ -1144,6 +1145,7 @@ S3method(link_inverse,RM)
 S3method(link_inverse,Rchoice)
 S3method(link_inverse,afex_aov)
 S3method(link_inverse,aovlist)
+S3method(link_inverse,averaging)
 S3method(link_inverse,bamlss)
 S3method(link_inverse,bayesx)
 S3method(link_inverse,bcplm)

R/all_equal_models.R

@@ -25,11 +25,11 @@
 #' all_models_same_class(m1, m4, mtcars, m2, m3, verbose = TRUE)
 #' @export
 all_models_equal <- function(..., verbose = FALSE) {
-  objects <- list(...)
-  object_names <- match.call(expand.dots = FALSE)$`...`
+  model_objects <- list(...)
+  object_names <- match.call(expand.dots = FALSE)[["..."]]
 
-  all_supported <- vapply(objects, is_model_supported, FUN.VALUE = logical(1))
-  all_classes <- sapply(objects, class)
+  all_supported <- vapply(model_objects, is_model_supported, FUN.VALUE = logical(1))
+  all_classes <- sapply(model_objects, class)
 
   if (is.matrix(all_classes)) {
     all_classes <- as.vector(all_classes[1, ])

R/check_if_installed.R

@@ -129,8 +129,8 @@ check_if_installed <- function(package,
         return(invisible(is_installed))
       }
     } else {
-      message <- format_message(what_is_wrong, what_you_can_do)
-      if (stop) stop(message, call. = FALSE) else warning(message, call. = FALSE)
+      msg <- format_message(what_is_wrong, what_you_can_do)
+      if (stop) stop(msg, call. = FALSE) else warning(msg, call. = FALSE)
     }
   }
 

R/clean_names.R

@@ -172,7 +172,7 @@ clean_names.character <- function(x, include_names = FALSE, ...) {
           if (grepl("=|[[:digit:]]", x[i])) {
             new_x <- trim_ws(unlist(strsplit(x[i], ",", fixed = TRUE), use.names = FALSE))
             to_remove <- which(!grepl("\\D", new_x))
-            to_remove <- c(to_remove, which(grepl("=", new_x, fixed = TRUE)))
+            to_remove <- c(to_remove, grep("=", new_x, fixed = TRUE))
             if (length(to_remove) == 0) {
               x[i] <- toString(new_x)
             } else {

R/clean_parameters.R

@@ -392,10 +392,10 @@ clean_parameters.aovlist <- function(x, ...) {
 
 #' @export
 clean_parameters.afex_aov <- function(x, ...) {
-  if (!is.null(x$aov)) {
-    clean_parameters(x$aov, ...)
-  } else {
+  if (is.null(x$aov)) {
     clean_parameters(x$lm, ...)
+  } else {
+    clean_parameters(x$aov, ...)
   }
 }
 
@@ -552,9 +552,7 @@ clean_parameters.mlm <- function(x, ...) {
     # for backwards compatibility, we keep the old behaviour. But generally,
     # when we have the argument "version = 2", Stan models have the same
     # labelling as frequentist models
-    if (!identical(dots$version, 2)) {
-      r_grps <- gsub("^r_(.*)\\[(.*),(.*)\\]", "\\3: \\1", out$Cleaned_Parameter[rand_eff])
-    } else {
+    if (identical(dots$version, 2)) {
       out$Level <- ""
       r_levels <- gsub("^r_(.*)\\[(.*),(.*)\\]", "\\2", out$Cleaned_Parameter[rand_eff])
       r_grps <- gsub("^r_(.*)\\[(.*),(.*)\\]", "\\1", out$Cleaned_Parameter[rand_eff])
@@ -567,6 +565,8 @@ clean_parameters.mlm <- function(x, ...) {
       if (any(sd_cor)) {
         out$Group[sd_cor] <- gsub("SD/Cor: (.*)", "\\1", out$Group[sd_cor])
       }
+    } else {
+      r_grps <- gsub("^r_(.*)\\[(.*),(.*)\\]", "\\3: \\1", out$Cleaned_Parameter[rand_eff])
     }
     r_pars <- gsub("__zi", "", r_pars, fixed = TRUE)
     r_grps <- gsub("__zi", "", r_grps, fixed = TRUE)
@@ -589,11 +589,11 @@ clean_parameters.mlm <- function(x, ...) {
     out$Component[simplex] <- "simplex"
   }
 
-  smooth <- startsWith(out$Cleaned_Parameter, "sds_")
-  if (length(smooth)) {
+  smooth_parameters <- startsWith(out$Cleaned_Parameter, "sds_")
+  if (length(smooth_parameters)) {
     out$Cleaned_Parameter <- gsub("^sds_", "", out$Cleaned_Parameter)
-    out$Component[smooth] <- "smooth_sd"
-    out$Function[smooth] <- "smooth"
+    out$Component[smooth_parameters] <- "smooth_sd"
+    out$Function[smooth_parameters] <- "smooth"
   }
 
   # fix intercept names
@@ -604,7 +604,7 @@ clean_parameters.mlm <- function(x, ...) {
     out$Cleaned_Parameter[intercepts] <- "(Intercept)"
   }
 
-  interaction_terms <- which(grepl(".", out$Cleaned_Parameter, fixed = TRUE))
+  interaction_terms <- grep(".", out$Cleaned_Parameter, fixed = TRUE)
 
   if (length(interaction_terms)) {
     for (i in interaction_terms) {
@@ -662,11 +662,7 @@ clean_parameters.mlm <- function(x, ...) {
 
   if (any(rand_effects)) {
     r_pars <- gsub("b\\[(.*) (.*)\\]", "\\2", out$Cleaned_Parameter[rand_effects])
-    if (!identical(dots$version, 2)) {
-      re_grp_level <- gsub("b\\[(.*) (.*):(.*)\\]", "\\2", out$Cleaned_Parameter[rand_effects])
-      r_grps <- gsub("b\\[(.*) (.*)\\]", "\\1", out$Cleaned_Parameter[rand_effects])
-      out$Group[rand_effects] <- sprintf("%s: %s", r_grps, re_grp_level)
-    } else {
+    if (identical(dots$version, 2)) {
       out$Level <- ""
       r_levels <- gsub("b\\[(.*) (.*):(.*)\\]", "\\3", out$Cleaned_Parameter[rand_effects])
       r_grps <- gsub("b\\[(.*) (.*):(.*)\\]", "\\2", out$Cleaned_Parameter[rand_effects])
@@ -677,19 +673,23 @@ clean_parameters.mlm <- function(x, ...) {
       if (any(sd_cor)) {
         out$Group[sd_cor] <- gsub("SD/Cor: (.*)", "\\1", out$Group[sd_cor])
       }
+    } else {
+      re_grp_level <- gsub("b\\[(.*) (.*):(.*)\\]", "\\2", out$Cleaned_Parameter[rand_effects])
+      r_grps <- gsub("b\\[(.*) (.*)\\]", "\\1", out$Cleaned_Parameter[rand_effects])
+      out$Group[rand_effects] <- sprintf("%s: %s", r_grps, re_grp_level)
     }
 
     out$Cleaned_Parameter[rand_effects] <- r_pars
   }
 
   # clean remaining parameters
 
-  smooth <- startsWith(out$Cleaned_Parameter, "smooth_sd[")
+  smooth_parameters <- startsWith(out$Cleaned_Parameter, "smooth_sd[")
 
-  if (length(smooth)) {
+  if (length(smooth_parameters)) {
     out$Cleaned_Parameter <- gsub("^smooth_sd\\[(.*)\\]", "\\1", out$Cleaned_Parameter)
-    out$Component[smooth] <- "smooth_sd"
-    out$Function[smooth] <- "smooth"
+    out$Component[smooth_parameters] <- "smooth_sd"
+    out$Function[smooth_parameters] <- "smooth"
   }
 
   out
@@ -705,25 +705,23 @@ clean_parameters.mlm <- function(x, ...) {
   }
 
   out$Cleaned_Parameter <- tryCatch(
-    {
-      apply(pars, 1, function(i) {
-        if (i[1] == i[2]) {
-          i[2] <- ""
-        } else if (i[1] != i[2] && !grepl(":", i[1], fixed = TRUE)) {
-          i[1] <- paste0(i[1], " [", i[2], "]")
-          i[2] <- ""
-        } else if (grepl(":", i[1], fixed = TRUE)) {
-          f <- unlist(strsplit(i[1], ":", fixed = TRUE), use.names = FALSE)
-          l <- unlist(strsplit(i[2], ".&.", fixed = TRUE), use.names = FALSE)
-          m <- match(f, l)
-          matches <- m[!is.na(m)]
-          l[matches] <- ""
-          l[-matches] <- paste0("[", l[-matches], "]")
-          i[1] <- paste0(f, l, collapse = " * ")
-        }
-        as.vector(i[1])
-      })
-    },
+    apply(pars, 1, function(i) {
+      if (i[1] == i[2]) {
+        i[2] <- ""
+      } else if (i[1] != i[2] && !grepl(":", i[1], fixed = TRUE)) {
+        i[1] <- paste0(i[1], " [", i[2], "]")
+        i[2] <- ""
+      } else if (grepl(":", i[1], fixed = TRUE)) {
+        f <- unlist(strsplit(i[1], ":", fixed = TRUE), use.names = FALSE)
+        l <- unlist(strsplit(i[2], ".&.", fixed = TRUE), use.names = FALSE)
+        m <- match(f, l)
+        matches <- m[!is.na(m)]
+        l[matches] <- ""
+        l[-matches] <- paste0("[", l[-matches], "]")
+        i[1] <- paste0(f, l, collapse = " * ")
+      }
+      as.vector(i[1])
+    }),
     error = function(e) {
       out$Cleaned_Parameter
     }

R/link_function.R

@@ -314,8 +314,8 @@ link_function.psm <- link_function.tobit
 
 #' @export
 link_function.flexsurvreg <- function(x, ...) {
-  dist <- parse(text = safe_deparse(x$call))[[1]]$dist
-  .make_tobit_family(x, dist)$linkfun
+  distribution <- parse(text = safe_deparse(x$call))[[1]]$dist
+  .make_tobit_family(x, distribution)$linkfun
 }
 
 
@@ -416,6 +416,17 @@ link_function.mira <- function(x, ...) {
 }
 
 
+#' @export
+link_function.averaging <- function(x, ...) {
+  ml <- attributes(x)$modelList
+  if (is.null(ml)) {
+    format_warning("Can't retrieve data. Please use `fit = TRUE` in `model.avg()`.")
+    return(NULL)
+  }
+  link_function(ml[[1]])
+}
+
+
 #' @export
 link_function.robmixglm <- function(x, ...) {
   switch(tolower(x$family),

R/link_inverse.R

@@ -87,8 +87,8 @@ link_inverse.psm <- link_inverse.tobit
 
 #' @export
 link_inverse.flexsurvreg <- function(x, ...) {
-  dist <- parse(text = safe_deparse(x$call))[[1]]$dist
-  .make_tobit_family(x, dist)$linkinv
+  distribution <- parse(text = safe_deparse(x$call))[[1]]$dist
+  .make_tobit_family(x, distribution)$linkinv
 }
 
 
@@ -496,6 +496,17 @@ link_inverse.svyolr <- function(x, ...) {
 }
 
 
+#' @export
+link_inverse.averaging <- function(x, ...) {
+  ml <- attributes(x)$modelList
+  if (is.null(ml)) {
+    format_warning("Can't retrieve data. Please use `fit = TRUE` in `model.avg()`.")
+    return(NULL)
+  }
+  link_inverse(ml[[1]])
+}
+
+
 #' @export
 link_inverse.LORgee <- function(x, ...) {
   if (grepl(pattern = "logit", x = x$link, fixed = TRUE)) {
@@ -634,9 +645,7 @@ link_inverse.gamlss <- function(x, what = c("mu", "sigma", "nu", "tau"), ...) {
 link_inverse.bamlss <- function(x, ...) {
   flink <- stats::family(x)$links[1]
   tryCatch(
-    {
-      stats::make.link(flink)$linkinv
-    },
+    stats::make.link(flink)$linkinv,
     error = function(e) {
       print_colour("\nCould not find appropriate link-inverse-function.\n", "red")
     }

R/model_info.R

@@ -465,8 +465,8 @@ model_info.brmultinom <- model_info.speedglm
 
 #' @export
 model_info.flexsurvreg <- function(x, verbose = TRUE, ...) {
-  dist <- parse(text = safe_deparse(x$call))[[1]]$dist
-  faminfo <- .make_tobit_family(x, dist)
+  distribution <- parse(text = safe_deparse(x$call))[[1]]$dist
+  faminfo <- .make_tobit_family(x, distribution)
 
   .make_family(
     x = x,
@@ -622,11 +622,11 @@ model_info.comprisk <- model_info.coxph
 #' @export
 model_info.zeroinfl <- function(x, ...) {
   if (is.list(x$dist)) {
-    dist <- x$dist[[1]]
+    distribution <- x$dist[[1]]
   } else {
-    dist <- x$dist
+    distribution <- x$dist
   }
-  fitfam <- switch(dist,
+  fitfam <- switch(distribution,
     poisson = "poisson",
     negbin = "negative binomial",
     "poisson"
@@ -647,11 +647,11 @@ model_info.zerotrunc <- model_info.zeroinfl
 #' @export
 model_info.hurdle <- function(x, ...) {
   if (is.list(x$dist)) {
-    dist <- x$dist[[1]]
+    distribution <- x$dist[[1]]
   } else {
-    dist <- x$dist
+    distribution <- x$dist
   }
-  fitfam <- switch(dist,
+  fitfam <- switch(distribution,
     poisson = "poisson",
     negbin = "negative binomial",
     "poisson"
@@ -745,15 +745,15 @@ model_info.BGGM <- function(x, ...) {
     stats::binomial()
   )
 
-  family <- switch(x$type,
+  fam <- switch(x$type,
     continuous = "gaussian",
     binary = "binomial",
     "ordinal"
   )
 
   .make_family(
     x = x,
-    fitfam = family,
+    fitfam = fam,
     zero.inf = FALSE,
     logit.link = link$link == "logit",
     link.fun = link$link,
@@ -934,14 +934,14 @@ model_info.LORgee <- function(x, ...) {
   }
 
   if (x$link == "Cumulative logit") {
-    family <- "ordinal"
+    fam <- "ordinal"
   } else {
-    family <- "multinomial"
+    fam <- "multinomial"
   }
 
   .make_family(
     x = x,
-    fitfam = family,
+    fitfam = fam,
     logit.link = link == "logit",
     link.fun = link,
     ...