-
Notifications
You must be signed in to change notification settings - Fork 12
/
read_secuTrial_raw.R
163 lines (143 loc) · 5.95 KB
/
read_secuTrial_raw.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
156
157
158
159
160
161
162
163
#'
#' This function loads a secuTrial export
#'
#' @description
#' This function will always load the full set of meta and data tables.
#' The export options are also loaded and written into export_options.
#'
#' @export read_secuTrial_raw
#' @importFrom stringr str_match str_length str_wrap
#' @importFrom dplyr all_equal
#' @importFrom magrittr %>%
#' @import readr
#' @importFrom grDevices rainbow
#' @importFrom graphics axis image layout legend lines par plot
#' @importFrom stats aggregate median na.omit reshape setNames
#' @importFrom utils read.table unzip
#' @name secuTrialdata
#' @rdname secuTrialdata
#' @param data_dir string The data_dir specifies the path to the secuTrial data export.
#' @param ... options passed to \code{read_export_table} (an internal function). Can be used for passing options to read.table
#' @return \code{secuTrialdata} object containing a list of
#' export options and data.frames with all the data loaded from
#' the secuTrial export.
#' The list will contain at least the metadata data.frames and
#' export_options list.
#'
#' @examples
#' # prepare path to example export
#' export_location <- system.file("extdata", "sT_exports", "BMD",
#' "s_export_CSV-xls_BMD_short_en_utf8.zip",
#' package = "secuTrialR")
#' # read all export data
#' sT_export <- read_secuTrial_raw(data_dir = export_location)
#'
read_secuTrial_raw <- function(data_dir, ...) {
# check for file existence
if (! file.exists(data_dir)) {
stop(paste0("There is no file '", data_dir, "'"))
}
# load export options
export_options <- read_export_options(data_dir = data_dir)
# check for language not english
if (export_options$lang_not_supported) {
stop("Your export language is not supported and can not be processed.")
}
# check if it is a rectangular export
if (export_options$is_rectangular) {
stop("Your export is rectangular. It can not be loaded with this function.")
}
# check for column names in export_options
# if column names is not selected then the tables in the export have no header
if (! export_options$column_names) {
stop(paste0("The specified secuTrial export does not include 'Column names'. ",
"Rerun your export in the ExportSearchTool with ",
"'Column names' activated."))
}
# warn if encoding = ISO-8859-1 or ISO-8859-15
if (grepl("ISO-8859-1", export_options$encoding)) {
warning("ISO-8859-1 encoding detected. Strings may not be interpreted correctly")
}
# init return list
return_list <- list(export_options = export_options)
# load meta tables
meta_names <- as.vector(unlist(export_options$meta_names))
# meta table names reference for exclusion from later loading
meta_files <- c()
for (name in meta_names) {
# file name
file <- names(which(export_options$data_names == name))
meta_files <- c(meta_files, file)
# skip loading if file does not exist
if (length(file) == 0) {
next
}
loaded_table <- read_export_table(data_dir = data_dir,
file_name = file,
export_options = export_options,
is_meta_table = TRUE,
...)
# update name
loaded_table <- setNames(list(loaded_table), name)
# make add_id and lab_id entry in export_options
if (name == export_options$meta_names$casenodes) {
col_names_casenode <- names(loaded_table[[names(loaded_table)]])
return_list$export_options$add_id <- any(col_names_casenode == "mnpaid")
return_list$export_options$lab_id <- any(col_names_casenode == "mnplabid")
}
return_list <- c(return_list, loaded_table)
}
# init load_list
load_list <- names(export_options$data_names)
# exclude meta tables since they have already been loaded
load_list <- load_list[! load_list %in% meta_files]
for (file in load_list) {
# get table name from export options
table_name <- export_options$data_names[file]
# load table
loaded_table <- read_export_table(data_dir = data_dir,
file_name = file,
# needs to be return_list$export_options
# because this is updated with add-id and lab-id
# export_options is not
export_options = return_list$export_options,
casenodes_table = return_list[[export_options$meta_names$casenodes]],
centre_table = return_list[[export_options$meta_names$centres]],
visitplan_table = return_list[[export_options$meta_names$visitplan]],
...)
# update name
loaded_table <- setNames(list(loaded_table), table_name[[1]])
return_list <- c(return_list, loaded_table)
}
class(return_list) <- "secuTrialdata"
return(return_list)
}
#' @rdname secuTrialdata
#' @param x secuTrialdata object as returned by \code{read_secuTrial_raw}
#' @param ... further parameters
#' @return data.frame with a row for each table in the export. For each table it
#' contains the name, number of rows and columns, an indicator for
#' whether the table is a metadata table and the files original name.
#' @export
#'
#' @examples
#' # Print method
#' print(sT_export)
#' # or
#' sT_export
print.secuTrialdata <- function(x, ...) {
cat("secuTrial data imported from:\n")
cat(str_wrap(x$export_options$data_dir, width = 80), "\n")
tab <- lapply(x$export_options$data_names, function(y) {
tmp <- x[[y]]
tmp
data.frame(table = y,
nrow = nrow(tmp),
ncol = ncol(tmp),
meta = y %in% x$export_options$meta_names)
})
tab <- do.call("rbind", tab)
tab$original_name <- rownames(tab)
rownames(tab) <- NULL
print(tab, row.names = FALSE)
}