1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
|
#' @examplesIf require("tinytable") && require("lme4") && require("glmmTMB")
#' \donttest{
#' data(iris)
#' data(Salamanders, package = "glmmTMB")
#' m1 <- lm(Sepal.Length ~ Species * Petal.Length, data = iris)
#' m2 <- lme4::lmer(
#' Sepal.Length ~ Petal.Length + Petal.Width + (1 | Species),
#' data = iris
#' )
#' m3 <- glmmTMB::glmmTMB(
#' count ~ spp + mined + (1 | site),
#' ziformula = ~mined,
#' family = poisson(),
#' data = Salamanders
#' )
#' out <- compare_parameters(m1, m2, m3, effects = "all", component = "all")
#' print_table(out)
#' }
#' @rdname display.parameters_model
#' @export
print_table <- function(x, digits = 2, p_digits = 3, theme = "default", ...) {
insight::check_if_installed(c("datawizard", "tinytable"))
if (!inherits(x, "compare_parameters")) {
insight::format_error("`print_table` can only be used with `compare_parameters` objects.")
}
# random parameters?
random_variances <- any(unlist(lapply(attributes(x)$all_attributes, function(i) {
i$ran_pars
})))
# remember attributes
ci_lvl <- attributes(x)$all_attributes[[1]]$ci
model_names <- attributes(x)$model_names
# check if we have mixed models with random variance parameters. in such
# cases, we don't need the group-column, but we rather merge it with the
# parameter column
if (isTRUE(random_variances)) {
# if (any(c("brmsfit", "stanreg", "stanmvreg") %in% m_class)) {
# # rename random effect parameters names for stan models
# x <- .format_stan_parameters(x)
# } else {
# x <- .format_ranef_parameters(x)
# }
x <- .format_ranef_parameters(x)
x$Group <- NULL
}
# check if we have only have fixed effects, and if so, remove column
if (!is.null(x$Effects) && all(x$Effects == "fixed")) {
x$Effects <- NULL
}
# check if we have only have conditional component, and if so, remove column
if (!is.null(x$Component) && all(x$Component == "conditional")) {
x$Component <- NULL
}
# check if we have models with extra components (e.g., zero-inflated models)
# if so, we need to create a group variable, so we can include subheaders in
# the table, and we want to re-arrange rows
if (!is.null(x$Component) || !is.null(x$Effects)) {
# create group variable, so we can include subheaders in table
x$groups <- paste0(x$Component, ".", x$Effects)
x <- datawizard::data_arrange(x, c("Effects", "Component"))
# remove further unused columns
x$Component <- NULL
x$Effects <- NULL
}
# we now iterate all model columns, remove non-used columns per model,
# and create the formated CI columns etc.
for (i in model_names) {
x[paste0("SE.", i)] <- NULL
x[paste0("df_error.", i)] <- NULL
x[paste0("z.", i)] <- NULL
x[paste0("t.", i)] <- NULL
ci_pos <- which(colnames(x) == paste0("CI.", i))
x[paste0("CI.", i)] <- NULL
# format estimate columns
estimate_col <- min(which(endsWith(colnames(x), paste0(".", i))))
x[[estimate_col]] <- insight::format_value(
x[[estimate_col]],
digits = digits,
zap_small = TRUE
)
# format CI columns
x$CI <- insight::format_ci(
x[[paste0("CI_low.", i)]],
x[[paste0("CI_high.", i)]],
digits = digits,
ci = NULL,
brackets = FALSE,
zap_small = TRUE
)
colnames(x)[colnames(x) == "CI"] <- paste0(sprintf("%g", 100 * ci_lvl), "% CI.", i)
x[paste0("CI_low.", i)] <- NULL
x[paste0("CI_high.", i)] <- NULL
# format p-values
x[[paste0("p.", i)]] <- insight::format_p(
x[[paste0("p.", i)]],
digits = p_digits,
name = NULL
)
# relocate CI columns to right position
x <- x[c(1:(ci_pos - 1), ncol(x), ci_pos:(ncol(x) - 1))]
}
# used for subgroup headers, if available
row_header_pos <- row_header_labels <- NULL
if (!is.null(x$groups)) {
# find start row of each subgroup
row_header_pos <- which(!duplicated(x$groups))
group_headers <- as.vector(x$groups[row_header_pos])
for (i in seq_along(group_headers)) {
gh <- .format_model_component_header(
x = NULL,
type = group_headers[i],
split_column = "",
is_zero_inflated = FALSE,
is_ordinal_model = FALSE,
is_multivariate = FALSE,
ran_pars = random_variances,
formatted_table = NULL
)
group_headers[i] <- gh$name
}
# create named list, required for tinytables
row_header_labels <- as.list(stats::setNames(row_header_pos, group_headers))
# since we have the group names in "row_header_labels" now , we can remove the column
x$groups <- NULL
# make sure that the row header positions are correct - each header
# must be shifted by the number of rows above
for (i in 2:length(row_header_pos)) {
row_header_pos[i] <- row_header_pos[i] + (i - 1)
}
}
# find out position of column groups
col_groups <- lapply(model_names, function(i) {
which(endsWith(colnames(x), paste0(".", i)))
})
names(col_groups) <- model_names
# fix column names
for (i in model_names) {
colnames(x) <- gsub(paste0("\\.", i, "$"), "", colnames(x))
}
# base table
out <- tinytable::tt(as.data.frame(x), caption = NULL, notes = NULL, ...)
# add subheaders, if any
if (is.null(row_header_labels)) {
out <- tinytable::group_tt(out, j = col_groups)
} else {
out <- tinytable::group_tt(out, i = row_header_labels, j = col_groups)
out <- tinytable::style_tt(out, i = row_header_pos, italic = TRUE)
}
# style table
out <- insight::apply_table_theme(out, x, theme = theme, sub_header_positions = row_header_pos)
# make sure HTML is default output
out@output <- "html"
out
}
|
