P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2025-07-09 02:03:04 +02:00
Code Releases Activity

read.4D improvements

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2018-11-15 12:42:35 +01:00
parent 5cb8f3cf72
commit fab64e6728
10 changed files with 89 additions and 51 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
R/get_locale.R
View File

@ -47,7 +47,7 @@ get_locale <- function() {
} else if (grepl("^(Portuguese|Portugu.s|pt_|PT_)", lang, ignore.case = FALSE)) {
"pt"
} else {
# other language, set to English
# other language -> set to English
"en"
}
}

1
R/ggplot_rsi.R
View File

@ -49,6 +49,7 @@
#'
#' \code{ggplot_rsi} is a wrapper around all above functions that uses data as first input. This makes it possible to use this function after a pipe (\code{\%>\%}). See Examples.
#' @rdname ggplot_rsi
#' @importFrom utils installed.packages
#' @export
#' @examples
#' library(dplyr)

18
R/misc.R
View File

@ -26,24 +26,6 @@ addin_insert_like <- function() {
rstudioapi::insertText(" %like% ")
}
# No export, no Rd
#' @importFrom utils View
addin_open_antibiotics <- function() {
View(antibiotics)
}
# No export, no Rd
#' @importFrom utils View
addin_open_microorganisms <- function() {
View(microorganisms)
}
# No export, no Rd
#' @importFrom utils View
addin_open_septic_patients <- function() {
View(septic_patients)
}
# No export, no Rd
percent <- function(x, round = 1, force_zero = FALSE, ...) {
val <- base::round(x * 100, digits = round)

16
R/mo.R
View File

@ -181,7 +181,7 @@ exec_as.mo <- function(x, Becker = FALSE, Lancefield = FALSE, allow_uncertain =
x[is.null(x)] <- NA
# support tidyverse selection like: df %>% select(colA)
if (!is.vector(x)) {
if (!is.vector(x) & !is.null(dim(x))) {
x <- pull(x, 1)
}
}
@ -360,9 +360,15 @@ exec_as.mo <- function(x, Becker = FALSE, Lancefield = FALSE, allow_uncertain =
# next
}
if (x_backup[i] %in% AMR::microorganisms.umcg[, 1]) {
ref_certe <- AMR::microorganisms.umcg[AMR::microorganisms.umcg[, 1] == x_backup[i], 2]
ref_mo <- AMR::microorganisms.certe[AMR::microorganisms.certe[, 1] == ref_certe, 2]
x[i] <- microorganismsDT[mo == ref_mo, ..property][[1]][1L]
mo_umcg <- AMR::microorganisms.umcg[AMR::microorganisms.umcg[, 1] == x_backup[i], 2]
mo_found <- AMR::microorganisms.certe[AMR::microorganisms.certe[, 1] == mo_umcg, 2]
if (length(mo_found) == 0) {
# not found
x[i] <- NA_character_
failures <- c(failures, x_backup[i])
} else {
x[i] <- microorganismsDT[mo == mo_found, ..property][[1]][1L]
}
next
}
if (x_backup[i] %in% reference_df[, 1]) {
@ -575,7 +581,7 @@ exec_as.mo <- function(x, Becker = FALSE, Lancefield = FALSE, allow_uncertain =
failures <- failures[!failures %in% c(NA, NULL, NaN)]
if (length(failures) > 0) {
warning("These ", length(failures) , " values could not be coerced: ",
warning("These ", length(failures) , " values could not be coerced to a valid MO code: ",
paste('"', unique(failures), '"', sep = "", collapse = ', '),
".",
call. = FALSE)

46
R/read_4d.R → R/read.4d.R
View File

@ -18,11 +18,15 @@
#' Read data from 4D database
#'
#' This function is only useful for the MMB department of the UMCG. Use this function to \strong{import data by just defining the \code{file} parameter}. It will automatically transform birth dates and calculate patients age, translate the data set to English, transform the \code{mo} with \code{\link{as.mo}} and transform all antimicrobial columns with \code{\link{as.rsi}}.
#' This function is only useful for the MMB department of the UMCG. Use this function to \strong{import data by just defining the \code{file} parameter}. It will automatically transform birth dates and calculate patients age, translate the column names to English, transform the \code{mo} with \code{\link{as.mo}} and transform all antimicrobial columns with \code{\link{as.rsi}}.
#' @inheritParams utils::read.table
#' @param info a logical to indicate whether info about the import should be printed, defaults to \code{TRUE} in interactive sessions
#' @details Column names will be transformed, but the original column names are set as a "label" attribute and can be seen in e.g. RStudio Viewer.
#' @export
read_4D <- function(file,
read.4D <- function(file,
info = interactive(),
header = TRUE,
row.names = NULL,
sep = "\t",
quote = "\"'",
dec = ",",
@ -36,7 +40,11 @@ read_4D <- function(file,
fileEncoding = "UTF-8",
encoding = "UTF-8") {
if (info == TRUE) {
message("Importing data... ", appendLF = FALSE)
}
data_4D <- utils::read.table(file = file,
row.names = row.names,
header = header,
sep = sep,
quote = quote,
@ -57,7 +65,7 @@ read_4D <- function(file,
posixlt <- as.POSIXlt(date_regular)
# born after today will be born 100 years ago
# based on https://stackoverflow.com/a/3312971/4575331
posixlt[date_regular > Sys.Date()]$year <- posixlt[date_regular > Sys.Date()]$year - 100
posixlt[date_regular > Sys.Date() & !is.na(posixlt)]$year <- posixlt[date_regular > Sys.Date() & !is.na(posixlt)]$year - 100
as.Date(posixlt)
}
to_age_4D <- function(from, to) {
@ -71,6 +79,15 @@ read_4D <- function(file,
age - 1, age)
}
if (info == TRUE) {
message("OK\nTransforming column names... ", appendLF = FALSE)
}
if ("row.names" %in% colnames(data_4D) & all(is.na(data_4D[, ncol(data_4D)]))) {
# remove first column name "row.names" and remove last empty column
colnames(data_4D) <- c(colnames(data_4D)[2:ncol(data_4D)], "_skip_last")
data_4D <- data_4D[, -ncol(data_4D)]
}
colnames(data_4D) <- tolower(colnames(data_4D))
if (all(c("afnamedat", "gebdatum") %in% colnames(data_4D))) {
# add age
@ -91,6 +108,10 @@ read_4D <- function(file,
# order of columns
data_4D <- data_4D[, cols_wanted]
# backup original column names
colnames.bak <- toupper(colnames(data_4D))
colnames.bak[colnames.bak == "AGE"] <- NULL
# rename of columns
colnames(data_4D) <- gsub("patientnr", "patient_id", colnames(data_4D), fixed = TRUE)
colnames(data_4D) <- gsub("gebdatum", "date_birth", colnames(data_4D), fixed = TRUE)
@ -104,6 +125,9 @@ read_4D <- function(file,
colnames(data_4D) <- gsub("mat", "specimen_group", colnames(data_4D), fixed = TRUE)
colnames(data_4D) <- gsub("mocode", "mo", colnames(data_4D), fixed = TRUE)
if (info == TRUE) {
message("OK\nTransforming dates and age... ", appendLF = FALSE)
}
if ("date_birth" %in% colnames(data_4D)) {
data_4D$date_birth <- to_date_4D(data_4D$date_birth)
@ -117,6 +141,10 @@ read_4D <- function(file,
if ("gender" %in% colnames(data_4D)) {
data_4D$gender[data_4D$gender == "V"] <- "F"
}
if (info == TRUE) {
message("OK\nTransforming MO codes... ", appendLF = FALSE)
}
if ("mo" %in% colnames(data_4D)) {
data_4D$mo <- as.mo(data_4D$mo)
# column right of mo is:
@ -129,6 +157,18 @@ read_4D <- function(file,
}
}
# set original column names as label (can be seen in RStudio Viewer)
if (info == TRUE) {
message("OK\nSetting original column names as label... ", appendLF = FALSE)
}
for (i in 1:ncol(data_4D)) {
attr(data_4D[, i], "label") <- colnames.bak[i]
}
if (info == TRUE) {
message("OK")
}
data_4D
}