Support dcchoice

Fixes easystats/performance#637
easystats · Oct 6, 2023 · bfb28b1 · bfb28b1
1 parent e87e9e0
commit bfb28b1
Show file tree

Hide file tree

Showing 6 changed files with 39 additions and 1 deletion.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Type: Package
 Package: insight
 Title: Easy Access to Model Information for Various Model Objects
-Version: 0.19.5.12
+Version: 0.19.5.13
 Authors@R: 
     c(person(given = "Daniel",
              family = "Lüdecke",

diff --git a/NAMESPACE b/NAMESPACE
@@ -1049,6 +1049,7 @@ S3method(link_function,cph)
 S3method(link_function,crch)
 S3method(link_function,crq)
 S3method(link_function,crqs)
+S3method(link_function,dbchoice)
 S3method(link_function,default)
 S3method(link_function,feglm)
 S3method(link_function,feis)
@@ -1168,6 +1169,7 @@ S3method(link_inverse,cph)
 S3method(link_inverse,crch)
 S3method(link_inverse,crq)
 S3method(link_inverse,crqs)
+S3method(link_inverse,dbchoice)
 S3method(link_inverse,default)
 S3method(link_inverse,feglm)
 S3method(link_inverse,feis)
@@ -1299,6 +1301,7 @@ S3method(model_info,crch)
 S3method(model_info,crq)
 S3method(model_info,crqs)
 S3method(model_info,data.frame)
+S3method(model_info,dbchoice)
 S3method(model_info,default)
 S3method(model_info,deltaMethod)
 S3method(model_info,earth)
@@ -1439,6 +1442,7 @@ S3method(n_obs,cpglmm)
 S3method(n_obs,crq)
 S3method(n_obs,crqs)
 S3method(n_obs,crr)
+S3method(n_obs,dbchoice)
 S3method(n_obs,default)
 S3method(n_obs,eglm)
 S3method(n_obs,emm_list)

diff --git a/R/link_function.R b/R/link_function.R
@@ -389,6 +389,12 @@ link_function.model_fit <- link_function.logitmfx
 # Other models -----------------------------
 
 
+#' @export
+link_function.dbchoice <- function(x, ...) {
+  x$f.stage$family$linkfun
+}
+
+
 #' @export
 link_function.Rchoice <- function(x, ...) {
   stats::make.link(link = x$link)$linkfun

diff --git a/R/link_inverse.R b/R/link_inverse.R
@@ -386,6 +386,12 @@ link_inverse.negbinirr <- link_inverse.logitmfx
 
 # Other models ----------------------------
 
+#' @export
+link_inverse.dbchoice <- function(x, ...) {
+  x$f.stage$family$linkinv
+}
+
+
 #' @export
 link_inverse.Rchoice <- function(x, ...) {
   stats::make.link(link = x$link)$linkinv

diff --git a/R/model_info.R b/R/model_info.R
@@ -785,6 +785,20 @@ model_info.Rchoice <- function(x, ...) {
 }
 
 
+#' @export
+model_info.dbchoice <- function(x, ...) {
+  faminfo <- x$f.stage$family
+  .make_family(
+    x = x,
+    fitfam = faminfo$family,
+    logit.link = faminfo$link == "logit",
+    multi.var = FALSE,
+    link.fun = faminfo$link,
+    ...
+  )
+}
+
+
 #' @export
 model_info.ivprobit <- function(x, ...) {
   .make_family(

diff --git a/R/n_obs.R b/R/n_obs.R
@@ -100,11 +100,19 @@ n_obs.glm <- function(x, disaggregate = FALSE, ...) {
 #' @export
 n_obs.censReg <- n_obs.default
 
+
 #' @export
 n_obs.nestedLogit <- function(x, disaggregate = FALSE, ...) {
   lapply(x$models, n_obs)
 }
 
+
+#' @export
+n_obs.dbchoice <- function(x, ...) {
+  stats::nobs(x)
+}
+
+
 #' @rdname n_obs
 #' @export
 n_obs.svyolr <- function(x, weighted = FALSE, ...) {