-
Notifications
You must be signed in to change notification settings - Fork 7
/
n_perc.R
155 lines (136 loc) · 4.65 KB
/
n_perc.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
#' @title Count and Percentage
#'
#' @description A function for calculating and formatting counts and
#' percentages.
#'
#' @details
#' Default behavior will return the count of successes and the percentage as "N
#' (pp%). If there are missing values in the input vector the omission of such
#' can be controlled by setting \code{na.rm = TRUE}. In this case, the number
#' of non-missing values will be reported by default. Omission of the
#' non-missing values can be controlled by setting \code{show_denom = "never"}.
#'
#' The function n_perc0 uses a set of default arguments which may be
#' advantageous for use in building tables.
#'
#' @param x a 0:1 or boolean vector
#' @param digits digits to the right of the decimal point to return in the
#' percentage estimate.
#' @param na_rm if true, omit NA values
#' @param show_denom defaults to "ifNA". Other options are "always" or "never".
#' @param show_symbol if TRUE (default) the percent symbol is shown, else it is suppressed.
#' @param markup latex or markdown
#' @param ... pass through
#'
#' @return a character vector of the formatted values
#'
#' @examples
#'
#' n_perc(c(0, 1,1, 1, 0, 0), show_denom = "always")
#' n_perc(c(0, 1,1, 1, 0, 0, NA), na_rm = TRUE)
#'
#' n_perc(mtcars$cyl == 6)
#'
#' set.seed(42)
#' x <- rbinom(4269, 1, 0.314)
#' n_perc(x)
#' n_perc(x, show_denom = "always")
#' n_perc(x, show_symbol = FALSE)
#'
#' # n_perc0 examples
#' n_perc0(c(0, 1,1, 1, 0, 0))
#' n_perc0(mtcars$cyl == 6)
#'
#' @rdname n_perc
#' @export
n_perc <- function(x,
digits = getOption("qwraps2_frmt_digits", 2),
na_rm = FALSE,
show_denom = "ifNA",
show_symbol = TRUE,
markup = getOption("qwraps2_markup", "latex"),
...
) {
cl <- as.list(match.call())
if (!("na_rm" %in% names(cl)) & ("na.rm" %in% names(cl))) {
na_rm <- cl$na.rm
warning(paste(cl[[1]], "uses the argument `na_rm`, not `na.rm`."))
}
stopifnot(inherits(na_rm, "logical"))
stopifnot(inherits(show_symbol, "logical"))
stopifnot(markup %in% c("latex", "markdown"))
stopifnot(show_denom %in% c("always", "never", "ifNA"))
stopifnot(inherits(x, "logical") | all(stats::na.omit(x) %in% c(0.0, 1.0)))
d <- sum(!is.na(x))
n <- sum(x, na.rm = na_rm)
p <- frmt(100 * n/d, digits)
if (show_denom == "never") {
rtn <- paste0(frmt(as.integer(n)), " (", p, "%)")
} else {
if (show_denom =="always" | any(is.na(x))) {
rtn <- paste0(frmt(as.integer(n)), "/", frmt(as.integer(d)), " (", p, "%)")
} else {
rtn <- paste0(frmt(as.integer(n)), " (", p, "%)")
}
}
if (!show_symbol) {
rtn <- gsub("%", "", rtn)
}
if (markup == "latex") {
rtn <- gsub("%", "\\\\%", rtn)
}
return(rtn)
}
#' @rdname n_perc
#' @export
perc_n <- function(x,
digits = getOption("qwraps2_frmt_digits", 2),
na_rm = FALSE,
show_denom = "ifNA",
show_symbol = FALSE,
markup = getOption("qwraps2_markup", "latex"),
...) {
cl <- as.list(match.call())
if (!("na_rm" %in% names(cl)) & ("na.rm" %in% names(cl))) {
na_rm <- cl$na.rm
warning(paste(cl[[1]], "uses the argument `na_rm`, not `na.rm`."))
}
stopifnot(inherits(na_rm, "logical"))
stopifnot(inherits(show_symbol, "logical"))
stopifnot(markup %in% c("latex", "markdown"))
stopifnot(show_denom %in% c("always", "never", "ifNA"))
stopifnot(inherits(x, "logical") | all(stats::na.omit(x) %in% c(0, 1)))
d <- sum(!is.na(x))
n <- sum(x, na.rm = na_rm)
p <- frmt(100 * n/d, digits)
if (show_denom =="always" | any(is.na(x))) {
rtn <- paste0(p, "% (n = ", frmt(as.integer(d)), " non-missing)")
} else {
rtn <- paste0(p, "% (n = ", frmt(as.integer(d)), ")")
}
if (markup == "latex") {
rtn <- gsub("%", "\\\\%", rtn)
}
return(rtn)
}
#' @rdname n_perc
#' @export
n_perc0 <- function(x,
digits = 0,
na_rm = FALSE,
show_denom = "never",
show_symbol = FALSE,
markup = getOption("qwraps2_markup", "latex"),
...) {
cl <- as.list(match.call())
if (!("na_rm" %in% names(cl)) & ("na.rm" %in% names(cl))) {
na_rm <- cl$na.rm
warning(paste(cl[[1]], "uses the argument `na_rm`, not `na.rm`."))
}
stopifnot(inherits(na_rm, "logical"))
stopifnot(inherits(show_symbol, "logical"))
stopifnot(markup %in% c("latex", "markdown"))
stopifnot(show_denom %in% c("always", "never", "ifNA"))
stopifnot(inherits(x, "logical") | all(stats::na.omit(x) %in% c(0, 1)))
n_perc(x, digits, na_rm, show_denom, show_symbol, markup)
}