From bde796c66e92965d030a0190e8c3f763451d8d9f Mon Sep 17 00:00:00 2001 From: Daniel Date: Sun, 17 Nov 2024 18:46:34 +0100 Subject: [PATCH] Support for `panelr::asym()` Fixes #607 --- DESCRIPTION | 2 +- NAMESPACE | 8 + NEWS.md | 2 + R/find_formula.R | 14 ++ R/find_parameters_other.R | 18 ++ R/find_statistic.R | 1 + R/get_parameters_others.R | 17 ++ R/get_statistic.R | 16 ++ R/get_varcov.R | 8 + R/is_model.R | 4 +- R/is_model_supported.R | 7 +- R/link_function.R | 3 + R/link_inverse.R | 3 + R/model_info.R | 6 + tests/testthat/test-panelr-asym.R | 274 ++++++++++++++++++++++++++++++ 15 files changed, 377 insertions(+), 6 deletions(-) create mode 100644 tests/testthat/test-panelr-asym.R diff --git a/DESCRIPTION b/DESCRIPTION index b43d75dc5..c96200b09 100644 --- 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 index dcaaa1ba4..79bc9c69d 100644 --- 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 index b3fcf972f..4a93c1eb6 100644 --- 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 index b615ff359..18d771738 100644 --- a/R/find_formula.R +++ b/R/find_formula.R @@ -107,6 +107,20 @@ find_formula.default <- function(x, verbose = TRUE, ...) { } +#' @export +find_formula.asym <- function(x, verbose = TRUE, ...) { + modified_f <- safe_deparse(stats::formula(x)) + while (grepl("minus__", modified_f)) { + modified_f <- gsub("(.*)minus__(\\S+)(.*)", "\\1\\3", modified_f) + modified_f <- gsub("+ ", "", modified_f, fixed = TRUE) + modified_f <- gsub("* ", "*", modified_f, fixed = TRUE) + } + # modified_f <- gsub("(.*)lag_(.*)_(.*)", "\\1lag(\\2)\\3", modified_f) + f <- .safe(list(conditional = stats::as.formula(modified_f))) + .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 index 7d6c7f283..438f790ea 100644 --- 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 index b5eabaa4f..e8914d26d 100644 --- 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 index 538b395df..5a33dac3e 100644 --- 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 index ae9e2e600..21ebaed12 100644 --- 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 index d2d54ad8b..031db6626 100644 --- a/R/get_varcov.R +++ b/R/get_varcov.R @@ -134,6 +134,14 @@ 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)) + out +} + # mlm --------------------------------------------- diff --git a/R/is_model.R b/R/is_model.R index 19ee5cd85..28467341a 100644 --- 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 index 74329c2ab..a7cd8fcba 100644 --- 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 index a696c6c98..ca06e49b7 100644 --- 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 index 44de28207..b6d3c3492 100644 --- 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 index b98ee6843..674cadcb9 100644 --- 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( diff --git a/tests/testthat/test-panelr-asym.R b/tests/testthat/test-panelr-asym.R new file mode 100644 index 000000000..a231221a4 --- /dev/null +++ b/tests/testthat/test-panelr-asym.R @@ -0,0 +1,274 @@ +skip_if_not_installed("panelr") + +data("teen_poverty", package = "panelr") +teen <- panelr::long_panel(teen_poverty, begin = 1, end = 5) +m1 <- panelr::asym(hours ~ lag(pov) + spouse, data = teen, use.wave = TRUE) + +test_that("model_info", { + expect_true(model_info(m1)$is_linear) +}) + +test_that("id_mixed", { + expect_true(is_mixed_model(m1)) + expect_true(is_mixed_model(m2)) +}) + +test_that("find_predictors", { + expect_identical( + find_predictors(m1), + list( + conditional = c("union", "wks"), + instruments = c("blk", "fem"), + interactions = c("blk", "union") + ) + ) + expect_identical( + find_predictors(m1, flatten = TRUE), + c("union", "wks", "blk", "fem") + ) + expect_null(find_predictors(m1, effects = "random")) + + expect_identical( + find_predictors(m2), + list( + conditional = c("union", "wks"), + instruments = c("blk", "t") + ) + ) + expect_identical(find_predictors(m2, effects = "random"), list(random = "id")) +}) + +test_that("find_random", { + expect_null(find_random(m1)) + expect_identical(find_random(m2), list(random = "id")) +}) + +test_that("get_random", { + expect_warning(expect_null(get_random(m1))) + expect_identical(get_random(m2)[[1]], model.frame(m2)$id) +}) + +test_that("find_response", { + expect_identical(find_response(m1), "lwage") +}) + +test_that("get_response", { + expect_identical(get_response(m1), model.frame(m1)$lwage) +}) + +test_that("get_predictors", { + expect_identical( + colnames(get_predictors(m1)), + c("lag(union)", "wks", "blk", "fem") + ) + expect_identical( + colnames(get_predictors(m2)), + c("lag(union)", "wks", "blk", "t") + ) +}) + +test_that("link_inverse", { + expect_equal(link_inverse(m1)(0.2), 0.2, tolerance = 1e-5) +}) + +test_that("clean_parameters", { + cp <- clean_parameters(m1) + expect_identical( + cp$Cleaned_Parameter, + c( + "union", "wks", "(Intercept)", "imean(lag(union))", "imean(wks)", + "blk", "fem", "union:blk" + ) + ) + expect_identical( + cp$Component, + c( + "conditional", "conditional", "instruments", "instruments", + "instruments", "instruments", "instruments", "interactions" + ) + ) +}) + +test_that("get_data", { + expect_identical(nrow(get_data(m1)), 3570L) + expect_identical( + colnames(get_data(m1)), + c( + "lwage", + "id", + "t", + "lag(union)", + "wks", + "blk", + "fem", + "imean(lag(union))", + "imean(wks)", + "imean(lag(union):blk)", + "lag(union):blk" + ) + ) + expect_identical( + colnames(get_data(m2)), + c( + "lwage", + "id", + "t", + "lag(union)", + "wks", + "blk", + "imean(lag(union))", + "imean(wks)" + ) + ) +}) + +test_that("find_formula", { + expect_length(find_formula(m1), 3) + expect_equal( + find_formula(m1), + list( + conditional = as.formula("lwage ~ lag(union) + wks"), + instruments = as.formula("~blk + fem"), + interactions = as.formula("~blk * lag(union)") + ), + ignore_attr = TRUE + ) + + expect_equal( + find_formula(m2), + list( + conditional = as.formula("lwage ~ lag(union) + wks"), + instruments = as.formula("~blk + t"), + random = as.formula("~t | id") + ), + ignore_attr = TRUE + ) +}) + +test_that("find_variables", { + expect_identical( + find_variables(m1), + list( + response = "lwage", + conditional = c("union", "wks"), + instruments = c("blk", "fem"), + interactions = c("blk", "union") + ) + ) + expect_identical( + find_variables(m1, flatten = TRUE), + c("lwage", "union", "wks", "blk", "fem") + ) + + expect_identical( + find_variables(m2), + list( + response = "lwage", + conditional = c("union", "wks"), + instruments = c("blk", "t"), + random = "id" + ) + ) + expect_identical( + find_variables(m2, flatten = TRUE), + c("lwage", "union", "wks", "blk", "t", "id") + ) +}) + +test_that("n_obs", { + expect_identical(n_obs(m1), 3570L) + expect_identical(n_obs(m2), 3570L) +}) + +test_that("linkfun", { + expect_false(is.null(link_function(m1))) +}) + +test_that("find_parameters", { + expect_identical( + find_parameters(m1), + list( + conditional = c("lag(union)", "wks"), + instruments = c("(Intercept)", "imean(lag(union))", "imean(wks)", "blk", "fem"), + random = "lag(union):blk" + ) + ) + + expect_identical(nrow(get_parameters(m1)), 8L) + + expect_identical( + find_parameters(m2), + list( + conditional = c("lag(union)", "wks"), + instruments = c("(Intercept)", "imean(lag(union))", "imean(wks)", "blk", "t") + ) + ) +}) + + +test_that("get_parameters", { + expect_equal( + get_parameters(m1), + data.frame( + Parameter = c( + "lag(union)", + "wks", + "(Intercept)", + "imean(lag(union))", + "imean(wks)", + "blk", + "fem", + "lag(union):blk" + ), + Estimate = c( + 0.0582474262882615, -0.00163678667081885, 6.59813245629044, + -0.0279959204722801, 0.00438047648390025, -0.229414915661438, + -0.441756913071962, -0.127319623945541 + ), + Component = c( + "within", "within", "between", "between", + "between", "between", "between", "interactions" + ), + stringsAsFactors = FALSE + ), + tolerance = 1e-4 + ) +}) + + +test_that("find_terms", { + expect_identical( + find_terms(m1), + list( + response = "lwage", + conditional = c("lag(union)", "wks"), + instruments = c("blk", "fem"), + interactions = c("blk", "lag(union)") + ) + ) + expect_identical( + find_terms(m2), + list( + response = "lwage", + conditional = c("lag(union)", "wks"), + instruments = c("blk", "t"), + random = c("t", "id") + ) + ) +}) + +test_that("is_multivariate", { + expect_false(is_multivariate(m1)) +}) + +test_that("find_statistic", { + expect_identical(find_statistic(m1), "t-statistic") + expect_identical(find_statistic(m2), "t-statistic") +}) + +test_that("get_variance", { + skip_on_cran() + v <- get_variance(m1) + expect_equal(v$var.intercept, c(id = 0.125306895731005), tolerance = 1e-4) + expect_equal(v$var.fixed, 0.0273792999320531, tolerance = 1e-4) +})