#' model_info
#'
#' Extrahiert die Variablen namen die Labels und die Daten
#'
#'
#'
#' @name model_info
#'
#' @param x Fit Objekt
#' @return Liste mit c("class", "family", "y", "x", "labels", "N")
#' @export
#' @examples
#' model_info(mpg ~ cyl)
#' model_info(glm(vs ~ mpg, mtcars, family = binomial()))
#' model_info(lm(mpg ~ drat + wt + qsec, mtcars))
#' model_info(wilcox.test(mpg ~ vs, mtcars))
#' model_info(t.test(mpg ~ vs, mtcars))
#'
model_info <- function(x) {
# Alternative ist die Library insight
# mit zb der Funktion
# model_info(m4<-Hmisc::spearman2(mpg ~ factor(vs), mtcars))
# insight::model_info(m2)
# insight::find_response(m4)
# insight::find_predictors(m4)
# aber es gehen noch nicht so viel Modelle
UseMethod("model_info")
}
#' @rdname model_info
#' @export
model_info.default <- function(x) {
list(
class = class(x) ,
family = NULL ,
y = NULL ,
x = NULL ,
labels = NULL,
N = NULL
)
}
#' @rdname model_info
#' @export
model_info.data.frame <- function(x) {
list(
class = class(x) ,
family = NULL ,
y = NULL ,
x = NULL ,
labels = NULL,
N = nrow(x)
)
}
#' @rdname model_info
#' @export
Infomation <- function(x) {
if (!is.null(comment(x)))
Text(comment(x))
else
Text("Daten: N = ", nrow(x), ", Col = ", ncol(x))
invisible(x)
}
#' @rdname model_info
#' @export
model_info.formula <- function(x) {
fm <- Formula_Names(x)
list(
class = class(x) ,
family = NULL ,
y = fm$yname,
x = fm$xname,
labels = NULL,
N = NULL
)
}
#' @rdname model_info
#' @export
model_info.eff <- function(x) {
list(
#formula=fm,
class = class(x)[1],
family = x$family[1:2] ,
y = x$response,
x = names(x$variables) ,
# data = x$model,
labels = GetLabelOrName(x$data),
N = nrow(x$data)
)
}
#' @rdname model_info
#' @export
#' @examples
#' # model_info(Hmisc::spearman2(mpg ~ factor(vs), mtcars))
#'
model_info.htest <- function(x) {
if (names(x$statistic) == "t") {
list(
class = "t.test" ,
family = x$methode ,
y = strsplit(x$data.name, " by ")[[1]][1] ,
x = strsplit(x$data.name, " by ")[[1]][2] ,
labels = NULL,
N = NULL
)
} else {
list(
class = "wilcox.test" ,
family = x$methode ,
y = strsplit(x$data.name, " by ")[[1]][1] ,
x = strsplit(x$data.name, " by ")[[1]][2] ,
labels = NULL,
N = NULL
)
}
}
#' @rdname model_info
#' @export
model_info.lm <- function(x)
model_info_glm(x)
#' @rdname model_info
#' @export
model_info.glm <- function(x)
model_info_glm(x)
#' @rdname model_info
#' @export
model_info.anova <- function(x) {
fm <- formula(x)
y <- gsub("Response: ", "", attr(x, "heading")[2])
x <- rownames(x)
x <- x[-length(x)]
if (length(grep("\\:", x)) > 0)
x <- x[-grep("\\:", x)]
labels <- c(y, x)
names(labels) <- labels
list(
class = "anova",
family = c("anova", ""),
y = y,
x = x,
labels = labels,
N = NA
)
}
# helper lm glm
model_info_glm <- function(x) {
fm <- formula(x)
list(
class = class(x)[1],
family = unlist(family(x)[1:2]) ,
y = all.vars(formula(fm))[1],
x = all.vars(formula(fm))[-1],
labels = GetLabelOrName(x$model),
N = nrow(x$model)
)
}
#' @rdname model_info
#' @export
model_info.lmerModLmerTest <- function(x)
model_info_lmer(x)
#' @rdname model_info
#' @export
model_info.merModLmerTest <- function(x)
model_info_lmer(x)
#' @rdname model_info
#' @export
model_info.lmerTest <- function(x)
model_info_lmer(x)
#' @rdname model_info
#' @export
model_info.glmerMod <- function(x)
model_info_lmer(x)
#-- "merModLmerTest" "lmerTest" "glmerMod"
model_info_lmer <- function(x) {
fm <- formula(x)
list(
class = class(x)[1],
family = unlist(family(x)[1:2]) ,
y = all.vars(formula(fm))[1],
x = all.vars(formula(fm))[-1],
# data = x@frame,
labels = GetLabelOrName(x@frame),
N = nrow(x@frame)
)
}
#' @rdname model_info
#' @export
model_info.lme <- function(x) {
fm <- insight::model_info(x)
xn <- fm$model_terms$conditional
yn <- fm$model_terms$response
list(
class = class(x) ,
family = fm$family ,
y = yn,
x = xn,
labels = GetLabelOrName(insight::get_data(x)[-1]),
N = fm$n_obs
)
}
#' @rdname model_info
#' @export
#' @examples
#' # model_info(coin::wilcox_test(mpg ~ factor(vs), mtcars))
#'
model_info.ScalarIndependenceTest <- function(x) {
list(
class = "coin" ,
family = NULL ,
y = NULL ,
x = NULL ,
labels = NULL,
N = NULL
)
}
#' @rdname model_info
#' @export
#' @examples
#' # model_info(Hmisc::spearman2(mpg ~ factor(vs), mtcars))
#'
model_info.biVar <- function(x) {
list(
class = "biVar" ,
family = NULL ,
y = NULL ,
x = NULL ,
labels = NULL,
N = NULL
)
}
#' @rdname model_info
#' @export
model_info.survfit <- function(x)
model_info_surv(x)
#' @rdname model_info
#' @export
model_info.coxph <- function(x)
model_info_surv(x)
model_info_surv <- function(x) {
fm <- formula(x)
list(
class = class(x)[1],
family = NULL,
y = all.vars(formula(fm))[1],
x = all.vars(formula(fm))[-1],
labels = NULL,
N = x$n
)
}
#' @rdname model_info
#' @export
model_info.survdiff <- function(x) {
fm <- formula(x)
list(
class = class(x)[1],
family = NULL,
y = all.vars(formula(fm))[1],
x = all.vars(formula(fm))[-1],
labels = NULL,
N = sum(x$n)
)
}
#' @rdname model_info
#' @export
model_info.ICC <- function(x) {
### # geht irgendwie noch nicht
list(
class = class(x)[1] ,
family = NULL,
y = NULL,
x = NULL,
labels = NULL,
N = paste0("obs=", x$n.obs, ", judge=", x$n.judge)
)
}
#' @rdname model_info
#' @export
model_info.polr <- function(x) {
list(
class = class(x)[1],
family = x$method ,
y = names(x$model)[1],
x = names(x$model)[-1],
labels = GetLabelOrName(x$model),
N = x$n
)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.