forked from juba/rmdformats
-
Notifications
You must be signed in to change notification settings - Fork 0
/
pilltabs.R
161 lines (145 loc) · 6.07 KB
/
pilltabs.R
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
#' Given a cross-table, outputs HTML code to display several views of with a tabbed interface
#'
#' Given a two dimensions contingency tables, this function outputs HTML code to display,
#' within a dynamic tabbed interface, the count, line row percentages, column percentages and
#' chi-squared residuals tables.
#'
#' @param tab a two dimensions table object
#' @param count wether or not to the display the count table
#' @param rows wether or not to the display the row percentages table
#' @param cols wether or not to the display the column percentages table
#' @param chisq wether or not to the display the table chi-squared test results
#' @param resid wether or not to the display the chi-squared residuals table
#' @param row.names wether or not to display the table row names
#' @details
#' The function is intended to be called inside an rmarkdown document.
#' @return
#' No value is returned.
#' @author Julien Barnier <julien.barnier@@ens-lyon.fr>
#' @examples
#'
#' data(airquality)
#' tab <- table(airquality$Month, airquality$Ozone > 25)
#' pilltabs(tab)
#'
#' @import knitr
#' @importFrom questionr cprop rprop chisq.residuals
#' @importFrom stats chisq.test
#' @export
pilltabs <- function(tab, count = TRUE, rows = TRUE, cols = TRUE, chisq = TRUE, resid = TRUE, row.names = TRUE) {
if (!requireNamespace("questionr", quietly = TRUE))
stop("the questionr package is needed for the pilltabs() function to work. Please install it.",
call. = FALSE)
res <- list()
if (count) res[["count"]] <- kable(tab, output = FALSE, row.names = row.names)
if (rows) res[["rows"]] <- kable(round(questionr::rprop(tab, n = TRUE),1), output = FALSE, row.names = row.names)
if (cols) res[["cols"]] <- kable(round(questionr::cprop(tab, n = TRUE),1), output = FALSE, row.names = row.names)
if (resid) res[["resid"]] <- kable(round(questionr::chisq.residuals(tab),2), output = FALSE, row.names = row.names)
if (chisq) {
test <- stats::chisq.test(tab)
res[["chisq"]] <- paste0('X-squared = ', round(test$statistic, 4),
', df = ', test$parameter,
', p = ', format.pval(test$p.value, digits = 4))
}
class(res) <- "pilltabs"
res
}
#' Printing function for pilltabs
#'
#' Not to be used directly
#'
#' @param x data to be printed, generated by \code{\link{pilltabs}}
#' @param ... arguments passed to other methods
#' @export
print.pilltabs <- function(x, ...) {
if (!is.null(x[["count"]])) {
cat("\n--- COUNT ---\n\n")
cat(x[["count"]], sep = "\n")
}
if (!is.null(x[["rows"]])) {
cat("\n--- ROWS % ---\n\n")
cat(x[["rows"]], sep = "\n")
}
if (!is.null(x[["cols"]])) {
cat("\n--- COLS % ---\n\n")
cat(x[["cols"]], sep = "\n")
}
if (!is.null(x[["resid"]])) {
cat("\n--- CHI2 RESIDUALS ---\n\n")
cat(x[["resid"]], sep = "\n")
}
if (!is.null(x[["chisq"]])) {
cat("\n\n",x[["chisq"]],"\n\n")
}
}
#' knitr printing function for pilltabs
#'
#' Not to be used directly
#'
#' @param res data to be printed, generated by \code{\link{pilltabs}}
#' @param ... arguments passed to other methods
#' @import knitr
#' @importFrom stats runif
#' @export
knit_print.pilltabs <- function(res, ...) {
result <- ""
if (knitr::opts_knit$get("rmarkdown.pandoc.to") == "html") {
## Generating unique div ids
id <- round(stats::runif(1) * 10e10)
result <- paste0(result, '<ul class="nav nav-pills nav-pilltabs">\n')
if (!is.null(res[["count"]]))
result <- paste0(result, '<li class="active"><a href="#dyntab-count', id,'" data-toggle="pill">Count</a></li>\n')
if (!is.null(res[["rows"]]))
result <- paste0(result, '<li><a href="#dyntab-rows', id,'" data-toggle="pill">Rows %</a></li>\n')
if (!is.null(res[["cols"]]))
result <- paste0(result, '<li><a href="#dyntab-columns', id,'" data-toggle="pill">Columns %</a></li>\n')
if (!is.null(res[["resid"]]))
result <- paste0(result, '<li><a href="#dyntab-residuals', id,'" data-toggle="pill">Residuals</a></li>\n')
result <- paste0(result, '</ul>\n')
result <- paste0(result, '<div class="tab-content">\n')
if (!is.null(res[["count"]]))
result <- paste0(result,
' <div class="tab-pane dyntab active" id="dyntab-count', id,'">\n\n\n',
paste(res[["count"]], collapse = "\n"),
'\n\n\n </div>\n')
if (!is.null(res[["rows"]]))
result <- paste0(result,
' <div class="tab-pane dyntab" id="dyntab-rows', id,'">\n\n\n',
paste(res[["rows"]], collapse = "\n"),
'\n\n\n </div>\n')
if (!is.null(res[["cols"]]))
result <- paste0(result,
' <div class="tab-pane dyntab" id="dyntab-columns', id,'">\n\n\n',
paste(res[["cols"]], collapse = "\n"),
'\n\n\n </div>\n', sep = "\n")
if (!is.null(res[["resid"]]))
result <- paste0(result,
' <div class="tab-pane dyntab-residuals" id="dyntab-residuals', id,'">\n\n\n',
paste(res[["resid"]], collapse = "\n"),
'\n\n\n </div>\n', sep = "\n")
result <- paste0(result,
'</div>', sep = "\n")
if (!is.null(res[["chisq"]])) {
result <- paste0(result,
'<p class="chisq-results">', res[["chisq"]],'</p>')
}
}
else {
if (!is.null(res[["count"]])) {
result <- paste0(result, "\n\nCount :\n\n", paste(res[["count"]], collapse = "\n"))
}
if (!is.null(res[["rows"]])) {
result <- paste0(result, "\n\nRows percentage :\n\n", paste(res[["rows"]], collapse = "\n"))
}
if (!is.null(res[["cols"]])) {
result <- paste0(result, "\n\nColumns percentage :\n\n", paste(res[["cols"]], collapse = "\n"))
}
if (!is.null(res[["resid"]])) {
result <- paste0(result, "\n\nChi-squared residuals :\n\n", paste(res[["resid"]], collapse = "\n"))
}
if (!is.null(res[["chisq"]])) {
result <- paste0(result, "\n\n", res[["chisq"]])
}
}
asis_output(result)
}