-
Notifications
You must be signed in to change notification settings - Fork 7
/
generate_results.R
155 lines (142 loc) · 5.4 KB
/
generate_results.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
155
#' Generate Results using Table and Column Metadata
#'
#' @param table_metadata dataframe containing table metadata (see
#' ?table_metadata for details)
#' @param column_metadata_file An excel file with the data for column_metadata.
#' The file is read in with `readxl::read_excel()`. Should not be used with
#' `column_metadata` argument. Results in a dataframe containing the column
#' metadata that is passed to tlgsetup (see `tlgsetup()` for details). If a
#' column_metadata dataframe is passed in too, this is ignored.
#' @param column_metadata A dataframe containing the column metadata. This will
#' be used in place of `column_metadata_file`.
#' @param env environment to find dataframe specified in the table metadata
#' (defaults to parent environment)
#' @param tbltype If used, this will be used to subset the `column_metadata` based
#' on the `tbltype` column.
#' @param add_count Passed to `bind_table()` should counts be added for
#' `tablebyvars`?
#'
#' @return dataframe of results
#' @export
generate_results <-
function(table_metadata,
column_metadata_file = NULL,
column_metadata = NULL,
env = parent.frame(),
tbltype = NULL,
add_count = FALSE) {
if (is.null(table_metadata)) {
stop("Argument table_metadata to function generate_results is required
but no value has been supplied",
call. = FALSE)
}
if (!("anbr" %in% names(table_metadata)))
table_metadata$anbr <- 1:nrow(table_metadata)
# check incoming metadata
arglist <- list()
args_to_chk <- names(formals())[names(formals()) != "..."]
purrr::walk(
args_to_chk,
.f = function(x) {
arglist[[x]] <<- eval(rlang::sym(x))
}
)
check_generate_results(arglist)
if (is.null(column_metadata) && !is.null(column_metadata_file)) {
column_metadata <- read_excel(column_metadata_file, sheet = 1) %>%
mutate_if(is.character, function(x) {
x %>% stringr::str_replace_all("\\\\U2190", "\U2190")
}) %>%
mutate_if(is.character, function(x) {
x %>% stringr::str_replace_all("\\\\U2192", "\U2192")
}) %>%
mutate_if(is.character, function(x) {
x %>% stringr::str_replace_all("\\\\U2264", "\U2264")
}) %>%
mutate_if(is.character, function(x) {
x %>% stringr::str_replace_all("\\\\U2265", "\U2265")
}) %>%
mutate_if(is.character, function(x) {
x %>% stringr::str_replace_all("\\\\U2260", "\U2260")
}) %>%
mutate_if(is.character, function(x) {
x %>% stringr::str_replace_all("\\\\U00b1", "\U00b1")
}) %>%
mutate_if(is.character, function(x) {
x %>% stringr::str_replace_all("\\\\U03b1", "\U03b1")
}) %>%
mutate_if(is.character, function(x) {
x %>% stringr::str_replace_all("\\\\U03b2", "\U03b2")
}) %>%
mutate_if(is.character, function(x) {
x %>% stringr::str_replace_all("\\\\U03bc", "\U03bc")
}) %>%
mutate_if(is.character, function(x) {
x %>% stringr::str_replace_all("\\\\U00ab", "\U00ab")
})
} else if (is.null(column_metadata_file) &&
is.null(column_metadata)) {
stop(
"Either column_metadata_file or column_metadata must be supplied
to generate_results"
)
}
chunks <- split(table_metadata, as.numeric(rownames(table_metadata)))
# pass each record to the funtion and return one set of results for each list
# element
result_list <- purrr::map(seq_len(length(chunks)), function(i) {
do_tidytlg(chunks[[i]],
column_metadata = column_metadata,
column_metadata_file = column_metadata_file,
tbltype = tbltype,
env = env)
})
tablebys <- unique(unlist(purrr::map(chunks, ~extract2(., "tablebyvar"))))
res <- bind_table(result_list,
tablebyvar = tablebys,
add_count = add_count,
colvar = "colnbr",
add_format = FALSE) %>%
add_format(tableby = tablebys)
attr(res, "column_metadata") <- column_metadata %>%
# Per JCEV-16: Any non breaking space(utf8 160) should be collapsed into space
# (utf8 32)
mutate(
tbltype = gsub("\u00A0", " ", tbltype)
) %>%
filter(tbltype == !!tbltype)
structure(
res,
class = c("tidytlg.metadata_table", class(res))
)
}
do_tidytlg <-
function(x,
column_metadata,
column_metadata_file,
tbltype,
env = parent.frame()) {
# The dfs are characters, so this takes them and turns them into the actual
# data.frames
x <- as.list(x)
x <- x[!purrr::map_lgl(x, is.na)]
if ("statlist" %in% names(x))
st <- if (class(x$statlist)[1] == "list") x$statlist[[1]] else x$statlist
x <- purrr::map(x[names(x) != "statlist"], unlist)
if (exists("st")) x$statlist <- st
x$df <- get(x$df, envir = env) %>%
tlgsetup(var = x$colvar,
column_metadata = column_metadata,
column_metadata_file = column_metadata_file,
tbltype = tbltype)
if (!is.null(x$denom_df) && exists(x$denom_df, envir = env))
x$denom_df <- get(x$denom_df, envir = env) %>%
tlgsetup(var = x$colvar,
column_metadata = column_metadata,
column_metadata_file = column_metadata_file,
tbltype = tbltype)
x$colvar <- "colnbr"
# If a value is a function argument, pass it into the function. Otherwise
# append it to the output table
do.call(x$func, x)
}