Support for panelr::asym() (#969)

* Support for `panelr::asym()` Fixes #607 * fix formula * fixes * update readme * Update get_varcov.R
easystats · Nov 18, 2024 · d1e6e85 · d1e6e85
1 parent 305a5e0
commit d1e6e85
Show file tree

Hide file tree

Showing 16 changed files with 363 additions and 121 deletions.
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.99.0.14
+Version: 0.99.0.15
 Authors@R:
     c(person(given = "Daniel",
              family = "Lüdecke",

diff --git a/NAMESPACE b/NAMESPACE
@@ -89,6 +89,7 @@ S3method(find_formula,SemiParBIV)
 S3method(find_formula,afex_aov)
 S3method(find_formula,anova)
 S3method(find_formula,aovlist)
+S3method(find_formula,asym)
 S3method(find_formula,averaging)
 S3method(find_formula,bamlss)
 S3method(find_formula,betamfx)
@@ -199,6 +200,7 @@ S3method(find_parameters,aareg)
 S3method(find_parameters,afex_aov)
 S3method(find_parameters,anova.rms)
 S3method(find_parameters,aovlist)
+S3method(find_parameters,asym)
 S3method(find_parameters,averaging)
 S3method(find_parameters,bamlss)
 S3method(find_parameters,bayesQR)
@@ -620,6 +622,7 @@ S3method(get_parameters,aareg)
 S3method(get_parameters,afex_aov)
 S3method(get_parameters,aov)
 S3method(get_parameters,aovlist)
+S3method(get_parameters,asym)
 S3method(get_parameters,averaging)
 S3method(get_parameters,bamlss)
 S3method(get_parameters,bayesQR)
@@ -824,6 +827,7 @@ S3method(get_statistic,SemiParBIV)
 S3method(get_statistic,aareg)
 S3method(get_statistic,afex_aov)
 S3method(get_statistic,anova.rms)
+S3method(get_statistic,asym)
 S3method(get_statistic,averaging)
 S3method(get_statistic,bayesx)
 S3method(get_statistic,betamfx)
@@ -972,6 +976,7 @@ S3method(get_varcov,MixMod)
 S3method(get_varcov,Rchoice)
 S3method(get_varcov,afex_aov)
 S3method(get_varcov,aov)
+S3method(get_varcov,asym)
 S3method(get_varcov,averaging)
 S3method(get_varcov,betamfx)
 S3method(get_varcov,betaor)
@@ -1081,6 +1086,7 @@ S3method(link_function,RM)
 S3method(link_function,Rchoice)
 S3method(link_function,afex_aov)
 S3method(link_function,aovlist)
+S3method(link_function,asym)
 S3method(link_function,averaging)
 S3method(link_function,bamlss)
 S3method(link_function,bayesx)
@@ -1208,6 +1214,7 @@ S3method(link_inverse,RM)
 S3method(link_inverse,Rchoice)
 S3method(link_inverse,afex_aov)
 S3method(link_inverse,aovlist)
+S3method(link_inverse,asym)
 S3method(link_inverse,averaging)
 S3method(link_inverse,bamlss)
 S3method(link_inverse,bayesx)
@@ -1342,6 +1349,7 @@ S3method(model_info,aareg)
 S3method(model_info,afex_aov)
 S3method(model_info,anova)
 S3method(model_info,aovlist)
+S3method(model_info,asym)
 S3method(model_info,averaging)
 S3method(model_info,bamlss)
 S3method(model_info,bayesQR)

diff --git a/NEWS.md b/NEWS.md
@@ -43,6 +43,8 @@
 
 * Added support for `coxph.panel` models.
 
+* Added support for models of class `asym` (package *panelr*).
+
 * Overhaul of documentation for the package-functions.
 
 ## Bug fix

diff --git a/R/find_formula.R b/R/find_formula.R
@@ -107,6 +107,33 @@ find_formula.default <- function(x, verbose = TRUE, ...) {
 }
 
 
+#' @export
+find_formula.asym <- function(x, verbose = TRUE, ...) {
+  modified_f <- safe_deparse(stats::formula(x))
+  # limitation: we can't preserve "*" and ":"
+  modified_f <- gsub("*", "+", modified_f, fixed = TRUE)
+  modified_f <- gsub(":", "+", modified_f, fixed = TRUE)
+  # explanation:
+  # - gsub("\\+\\s*minus__[^\\+]+", "", input_string):
+  #   This regular expression matches and removes any term that starts with
+  #   + minus__ followed by any characters that are not a +.
+  # - gsub("\\s*\\+\\s*$", "", output_string):
+  #   This removes any trailing plus sign and whitespace that might be left
+  #   at the end of the string.
+  output_string <- gsub("\\+\\s*minus__[^\\+]+", "", modified_f)
+  output_string <- gsub("\\s*(\\+|\\*)\\s*$", "", output_string) # Remove trailing plus sign if any
+  # explanation:
+  # - gsub("lag_([a-zA-Z]+)_", "lag(\\1)", input_string):
+  #   This regular expression matches the pattern "lag_", followed by one or
+  #   more letters (captured in a group), followed by "_". It replaces this
+  #   pattern with "lag(", the captured group, and ")".
+  output_string <- gsub("lag_([a-zA-Z]+)_", "lag(\\1)", output_string)
+  output_string <- gsub("plus__", "", output_string, fixed = TRUE)
+  f <- .safe(list(conditional = stats::as.formula(output_string)))
+  .find_formula_return(f, verbose = verbose)
+}
+
+
 #' @export
 find_formula.list <- function(x, verbose = TRUE, ...) {
   if (object_has_names(x, "gam")) {

diff --git a/R/find_parameters_other.R b/R/find_parameters_other.R
@@ -256,3 +256,21 @@ find_parameters.coxph <- function(x, flatten = FALSE, ...) {
     out
   }
 }
+
+
+#' @export
+find_parameters.asym <- function(x, flatten = FALSE, ...) {
+  cf <- stats::coef(x)
+
+  params <- names(cf)
+  params <- gsub("^plus__", "+", params)
+  params <- gsub("^minus__", "-", params)
+
+  out <- list(conditional = params)
+
+  if (flatten) {
+    unique(unlist(out, use.names = FALSE))
+  } else {
+    out
+  }
+}
diff --git a/R/find_statistic.R b/R/find_statistic.R
@@ -91,6 +91,7 @@ find_statistic.default <- function(x, ...) {
   # t-value objects ----------------------------------------------------------
 
   t.mods <- c(
+    "asym",
     "bayesx", "BBreg", "BBmm", "bcplm", "biglm", "bfsl", "blmerMod",
     "cch", "censReg", "complmrob", "cpglm", "cpglmm", "crq", "crqs",
     "drc",

diff --git a/R/get_parameters_others.R b/R/get_parameters_others.R
@@ -433,3 +433,20 @@ get_parameters.coxph <- function(x, verbose = TRUE, ...) {
 
   text_remove_backticks(params)
 }
+
+
+#' @export
+get_parameters.asym <- function(x, verbose = TRUE, ...) {
+  cf <- stats::coef(x)
+  params <- data.frame(
+    Parameter = names(cf),
+    Estimate = unname(cf),
+    stringsAsFactors = FALSE,
+    row.names = NULL
+  )
+
+  params$Parameter <- gsub("^plus__", "+", params$Parameter)
+  params$Parameter <- gsub("^minus__", "-", params$Parameter)
+
+  text_remove_backticks(params)
+}
diff --git a/R/get_statistic.R b/R/get_statistic.R
@@ -194,6 +194,22 @@ get_statistic.merModList <- function(x, ...) {
 }
 
 
+#' @export
+get_statistic.asym <- function(x, ...) {
+  cftable <- summary(x)$coef_table
+  out <- data.frame(
+    Parameter = rownames(x$cftable),
+    Statistic = cftable[, "t val."],
+    stringsAsFactors = FALSE,
+    row.names = NULL
+  )
+
+  out <- text_remove_backticks(out)
+  attr(out, "statistic") <- find_statistic(x)
+  out
+}
+
+
 #' @export
 get_statistic.afex_aov <- function(x, ...) {
   out <- data.frame(

diff --git a/R/get_varcov.R b/R/get_varcov.R
@@ -134,6 +134,16 @@ get_varcov.fixest <- function(x,
 }
 
 
+#' @export
+get_varcov.asym <- function(x, ...) {
+  out <- get_varcov.default(x, ...)
+  colnames(out) <- gsub("^plus__", "+", colnames(out))
+  rownames(out) <- gsub("^plus__", "+", rownames(out))
+  colnames(out) <- gsub("^minus__", "-", colnames(out))
+  rownames(out) <- gsub("^minus__", "-", rownames(out))
+  out
+}
+
 
 # mlm ---------------------------------------------
 

diff --git a/R/is_model.R b/R/is_model.R
@@ -57,7 +57,7 @@ is_regression_model <- function(x) {
 
     # a --------------------
     "aareg", "afex_aov", "AKP", "ancova", "anova", "Anova.mlm",
-    "anova.rms", "aov", "aovlist", "Arima", "averaging",
+    "anova.rms", "aov", "aovlist", "Arima", "averaging", "asym",
 
     # b --------------------
     "bamlss", "bamlss.frame", "bayesGAM", "bayesmeta", "bayesx",
@@ -81,7 +81,7 @@ is_regression_model <- function(x) {
     "eglm", "elm", "emmGrid", "emm_list", "epi.2by2", "ergm",
 
     # f --------------------
-    "feglm", "feis", "felm", "fitdistr", "fixest", "flexmix",
+    "fdm", "feglm", "feis", "felm", "fitdistr", "fixest", "flexmix",
     "flexsurvreg", "flac", "flic",
 
     # g --------------------

diff --git a/R/is_model_supported.R b/R/is_model_supported.R
@@ -44,8 +44,8 @@ supported_models <- function() {
 .supported_models_list <- function() {
   c(
     # a ----------------------------
-    "aareg", "afex_aov", "aov", "aovlist", "AKP", "Anova.mlm", "anova.rms",
-    "Arima", "averaging",
+    "asym", "aareg", "afex_aov", "aov", "aovlist", "AKP", "Anova.mlm",
+    "anova.rms", "Arima", "averaging",
 
     # b ----------------------------
     "bamlss", "bamlss.frame", "bayesx", "bayesQR", "BBmm", "BBreg", "bcplm",
@@ -66,7 +66,8 @@ supported_models <- function() {
     "eglm", "elm", "epi.2by2", "ergm", "emmGrid",
 
     # f ----------------------------
-    "feis", "felm", "feglm", "fitdistr", "fixest", "flexsurvreg", "flac", "flic",
+    "fdm", "feis", "felm", "feglm", "fitdistr", "fixest", "flexsurvreg",
+    "flac", "flic",
 
     # g ----------------------------
     "gam", "Gam", "gamlss", "gamm", "gamm4", "garch", "gbm", "gee", "geeglm",

diff --git a/R/link_function.R b/R/link_function.R
@@ -78,6 +78,9 @@ link_function.lm <- function(x, ...) {
   .extract_generic_linkfun(x, "identity")
 }
 
+#' @export
+link_function.asym <- link_function.lm
+
 #' @export
 link_function.phylolm <- link_function.lm
 

diff --git a/R/link_inverse.R b/R/link_inverse.R
@@ -127,6 +127,9 @@ link_inverse.lm <- function(x, ...) {
   .extract_generic_linkinv(x, "identity")
 }
 
+#' @export
+link_inverse.asym <- link_inverse.lm
+
 #' @export
 link_inverse.phylolm <- link_inverse.lm
 

diff --git a/R/model_info.R b/R/model_info.R
@@ -145,6 +145,12 @@ model_info.anova <- function(x, verbose = TRUE, ...) {
 }
 
 
+#' @export
+model_info.asym <- function(x, verbose = TRUE, ...) {
+  .make_family(x, verbose = verbose, ...)
+}
+
+
 #' @export
 model_info.mclogit <- function(x, verbose = TRUE, ...) {
   .make_family(