P281424
/
AMR
mirror of https://github.com/msberends/AMR.git
1
0
Fork 0
Code Releases Activity

fix clipboard on linux

This commit is contained in:
dr. M.S. (Matthijs) Berends 2018-04-02 11:11:21 +02:00
parent abcb4accbd
commit c182a9673d
12 changed files with 181 additions and 176 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -3,3 +3,4 @@
.RData .RData
.Ruserdata .Ruserdata
AMR.Rproj AMR.Rproj
tests/testthat/Rplots.pdf

10
.travis.yml
View File

@ -3,15 +3,9 @@
# Setting up R deps # Setting up R deps
language: r language: r
r: 3.2 r: 3.2
r_packages: r_packages: covr
- covr
- testthat
- dplyr
- rvest
- xml2
- reshape2
# system deps # system deps, install xclip for clipboard support
os: os:
- linux - linux
- osx - osx

2
DESCRIPTION
View File

@ -1,6 +1,6 @@
Package: AMR Package: AMR
Version: 0.1.2 Version: 0.1.2
Date: 2018-03-27 Date: 2018-04-02
Title: Antimicrobial Resistance Analysis Title: Antimicrobial Resistance Analysis
Authors@R: c( Authors@R: c(
person( person(

70
R/clipboard.R
View File

@ -29,27 +29,39 @@ clipboard_import <- function(sep = '\t',
file <- pipe("xclip -o", "r") file <- pipe("xclip -o", "r")
on.exit(close(file)) on.exit(close(file))
} }
import_tbl <- read.delim(file = file, import_tbl <- tryCatch(read.delim(file = file,
sep = sep, sep = sep,
header = header, header = header,
strip.white = TRUE, strip.white = TRUE,
dec = dec, dec = dec,
na.strings = na, na.strings = na,
fileEncoding = 'UTF-8', fileEncoding = 'UTF-8',
encoding = 'UTF-8', encoding = 'UTF-8',
stringsAsFactors = FALSE) stringsAsFactors = FALSE),
error = function(e) {
FALSE
})
if (import_tbl == FALSE) {
cat("No clipboard content found.")
if (Sys.info()['sysname'] %like% "Linux") {
cat(" These functions do not work without X11 installed.")
}
cat("\n")
return(invisible())
}
# use tibble, so column types will be translated correctly # use tibble, so column types will be translated correctly
import_tbl <- as_tibble(import_tbl) import_tbl <- as_tibble(import_tbl)
if (startrow > 1) { if (startrow > 1) {
# would else lose column headers # would else lose column headers
import_tbl <- import_tbl[startrow:nrow(import_tbl),] import_tbl <- import_tbl[startrow:nrow(import_tbl),]
} }
colnames(import_tbl) <- gsub('[.]+', '_', colnames(import_tbl)) colnames(import_tbl) <- gsub('[.]+', '_', colnames(import_tbl))
if (NCOL(import_tbl) == 1 & as_vector == TRUE) { if (NCOL(import_tbl) == 1 & as_vector == TRUE) {
import_tbl %>% pull(1) import_tbl %>% pull(1)
} else { } else {
@ -66,14 +78,14 @@ clipboard_export <- function(x,
na = "", na = "",
header = TRUE, header = TRUE,
info = TRUE) { info = TRUE) {
x <- deparse(substitute(x)) x <- deparse(substitute(x))
size <- x %>% size <- x %>%
get() %>% get() %>%
object.size() %>% object.size() %>%
formatC(format = 'd') %>% formatC(format = 'd') %>%
as.integer() as.integer()
x <- get(x) x <- get(x)
if (is_Windows() == TRUE) { if (is_Windows() == TRUE) {
@ -86,18 +98,22 @@ clipboard_export <- function(x,
on.exit(close(file)) on.exit(close(file))
} }
write.table(x = x, tryCatch(write.table(x = x,
file = file, file = file,
sep = sep, sep = sep,
na = na, na = na,
row.names = FALSE, row.names = FALSE,
col.names = header, col.names = header,
dec = dec, dec = dec,
quote = FALSE) quote = FALSE),
error = function(e) {
FALSE
})
if (info == TRUE) { if (info == TRUE) {
cat("Successfully exported to clipboard:", NROW(x), "obs. of", NCOL(x), "variables.\n") cat("Successfully exported to clipboard:", NROW(x), "obs. of", NCOL(x), "variables.\n")
} }
} }
is_Windows <- function() { is_Windows <- function() {
@ -105,6 +121,10 @@ is_Windows <- function() {
} }
check_xclip <- function() { check_xclip <- function() {
if (!isTRUE(file.exists(Sys.which("xclip")[1L]))) { if (!isTRUE(file.exists(Sys.which("xclip")[1L]))) {
if (Sys.info()['sysname'] %like% "Linux") {
stop("Please install Linux package xclip first.") stop("Please install Linux package xclip first.")
} else {
stop("Please install package xclip first (use `brew install xclip on macOS`).")
}
} }
} }

38
R/data.R
View File

@ -42,7 +42,7 @@
#' @seealso \code{\link{microorganisms}} #' @seealso \code{\link{microorganisms}}
# last two columns created with: # last two columns created with:
# antibiotics %>% # antibiotics %>%
# mutate(useful_gramnegative = # mutate(useful_gramnegative =
# if_else( # if_else(
# atc_group1 %like% '(fusidic|glycopeptide|macrolide|lincosamide|daptomycin|linezolid)' | # atc_group1 %like% '(fusidic|glycopeptide|macrolide|lincosamide|daptomycin|linezolid)' |
# atc_group2 %like% '(fusidic|glycopeptide|macrolide|lincosamide|daptomycin|linezolid)' | # atc_group2 %like% '(fusidic|glycopeptide|macrolide|lincosamide|daptomycin|linezolid)' |
@ -116,39 +116,39 @@
#' # ----------- # #' # ----------- #
#' # PREPARATION # #' # PREPARATION #
#' # ----------- # #' # ----------- #
#' #'
#' # Save this example dataset to an object, so we can edit it: #' # Save this example dataset to an object, so we can edit it:
#' my_data <- septic_patients #' my_data <- septic_patients
#' #'
#' # load the dplyr package to make data science A LOT easier #' # load the dplyr package to make data science A LOT easier
#' library(dplyr) #' library(dplyr)
#' #'
#' # Add first isolates to our dataset: #' # Add first isolates to our dataset:
#' my_data <- my_data %>% #' my_data <- my_data %>%
#' mutate(first_isolates = first_isolate(my_data, date, patient_id, bactid)) #' mutate(first_isolates = first_isolate(my_data, "date", "patient_id", "bactid"))
#' #'
#' # -------- # #' # -------- #
#' # ANALYSIS # #' # ANALYSIS #
#' # -------- # #' # -------- #
#' #'
#' # 1. Get the amoxicillin resistance percentages #' # 1. Get the amoxicillin resistance percentages
#' # of E. coli, divided by hospital: #' # of E. coli, divided by hospital:
#' #'
#' my_data %>% #' my_data %>%
#' filter(bactid == "ESCCOL", #' filter(bactid == "ESCCOL",
#' first_isolates == TRUE) %>% #' first_isolates == TRUE) %>%
#' group_by(hospital_id) %>% #' group_by(hospital_id) %>%
#' summarise(n = n(), #' summarise(n = n(),
#' amoxicillin_resistance = rsi(amox)) #' amoxicillin_resistance = rsi(amox))
#' #'
#' #'
#' # 2. Get the amoxicillin/clavulanic acid resistance #' # 2. Get the amoxicillin/clavulanic acid resistance
#' # percentages of E. coli, trend over the years: #' # percentages of E. coli, trend over the years:
#' #'
#' my_data %>% #' my_data %>%
#' filter(bactid == guess_bactid("E. coli"), #' filter(bactid == guess_bactid("E. coli"),
#' first_isolates == TRUE) %>% #' first_isolates == TRUE) %>%
#' group_by(year = format(date, "%Y")) %>% #' group_by(year = format(date, "%Y")) %>%
#' summarise(n = n(), #' summarise(n = n(),
#' amoxclav_resistance = rsi(amcl, minimum = 20)) #' amoxclav_resistance = rsi(amcl, minimum = 20))
"septic_patients" "septic_patients"

180
R/first_isolates.R
View File

@ -18,14 +18,14 @@
#' Determine first (weighted) isolates #' Determine first (weighted) isolates
#' #'
#' Determine first (weighted) isolates of all microorganisms of every patient per episode and (if needed) per specimen type. #' Determine first (weighted) isolates of all microorganisms of every patient per episode and (if needed) per specimen type.
#' @param tbl a \code{data.frame} containing isolates. #' @param tbl a \code{data.frame} containing isolates.
#' @param col_date column name of the result date (or date that is was received on the lab), supports tidyverse-like quotation #' @param col_date column name of the result date (or date that is was received on the lab)
#' @param col_patient_id column name of the unique IDs of the patients, supports tidyverse-like quotation #' @param col_patient_id column name of the unique IDs of the patients
#' @param col_bactid column name of the unique IDs of the microorganisms (should occur in the \code{\link{microorganisms}} dataset), supports tidyverse-like quotation #' @param col_bactid column name of the unique IDs of the microorganisms (should occur in the \code{\link{microorganisms}} dataset)
#' @param col_testcode column name of the test codes. Use \code{col_testcode = NA} to \strong{not} exclude certain test codes (like test codes for screening). In that case \code{testcodes_exclude} will be ignored. Supports tidyverse-like quotation. #' @param col_testcode column name of the test codes. Use \code{col_testcode = NA} to \strong{not} exclude certain test codes (like test codes for screening). In that case \code{testcodes_exclude} will be ignored. Supports tidyverse-like quotation.
#' @param col_specimen column name of the specimen type or group, supports tidyverse-like quotation #' @param col_specimen column name of the specimen type or group
#' @param col_icu column name of the logicals (\code{TRUE}/\code{FALSE}) whether a ward or department is an Intensive Care Unit (ICU), supports tidyverse-like quotation #' @param col_icu column name of the logicals (\code{TRUE}/\code{FALSE}) whether a ward or department is an Intensive Care Unit (ICU)
#' @param col_keyantibiotics column name of the key antibiotics to determine first \emph{weighted} isolates, see \code{\link{key_antibiotics}}. Supports tidyverse-like quotation. #' @param col_keyantibiotics column name of the key antibiotics to determine first \emph{weighted} isolates, see \code{\link{key_antibiotics}}. Supports tidyverse-like quotation.
#' @param episode_days episode in days after which a genus/species combination will be determined as 'first isolate' again #' @param episode_days episode in days after which a genus/species combination will be determined as 'first isolate' again
#' @param testcodes_exclude character vector with test codes that should be excluded (case-insensitive) #' @param testcodes_exclude character vector with test codes that should be excluded (case-insensitive)
@ -36,8 +36,8 @@
#' @param ignore_I logical to determine whether antibiotic interpretations with \code{"I"} will be ignored when \code{type = "keyantibiotics"}, see Details #' @param ignore_I logical to determine whether antibiotic interpretations with \code{"I"} will be ignored when \code{type = "keyantibiotics"}, see Details
#' @param points_threshold points until the comparison of key antibiotics will lead to inclusion of an isolate when \code{type = "points"}, see Details #' @param points_threshold points until the comparison of key antibiotics will lead to inclusion of an isolate when \code{type = "points"}, see Details
#' @param info print progress #' @param info print progress
#' @param col_genus (deprecated, use \code{col_bactid} instead) column name of the genus of the microorganisms, supports tidyverse-like quotation #' @param col_genus (deprecated, use \code{col_bactid} instead) column name of the genus of the microorganisms
#' @param col_species (deprecated, use \code{col_bactid} instead) column name of the species of the microorganisms, supports tidyverse-like quotation #' @param col_species (deprecated, use \code{col_bactid} instead) column name of the species of the microorganisms
#' @details \strong{WHY THIS IS SO IMPORTANT} \cr #' @details \strong{WHY THIS IS SO IMPORTANT} \cr
#' To conduct an analysis of antimicrobial resistance, you should only include the first isolate of every patient per episode \href{https://www.ncbi.nlm.nih.gov/pubmed/17304462}{[1]}. If you would not do this, you could easily get an overestimate or underestimate of the resistance of an antibiotic. Imagine that a patient was admitted with an MRSA and that it was found in 5 different blood cultures the following week. The resistance percentage of oxacillin of all \emph{S. aureus} isolates would be overestimated, because you included this MRSA more than once. It would be \href{https://en.wikipedia.org/wiki/Selection_bias}{selection bias}. #' To conduct an analysis of antimicrobial resistance, you should only include the first isolate of every patient per episode \href{https://www.ncbi.nlm.nih.gov/pubmed/17304462}{[1]}. If you would not do this, you could easily get an overestimate or underestimate of the resistance of an antibiotic. Imagine that a patient was admitted with an MRSA and that it was found in 5 different blood cultures the following week. The resistance percentage of oxacillin of all \emph{S. aureus} isolates would be overestimated, because you included this MRSA more than once. It would be \href{https://en.wikipedia.org/wiki/Selection_bias}{selection bias}.
#' #'
@ -54,15 +54,13 @@
#' # septic_patients is a dataset available in the AMR package #' # septic_patients is a dataset available in the AMR package
#' ?septic_patients #' ?septic_patients
#' my_patients <- septic_patients #' my_patients <- septic_patients
#' #'
#' library(dplyr) #' library(dplyr)
#' my_patients$first_isolate <- my_patients %>% #' my_patients$first_isolate <- my_patients %>%
#' left_join_microorganisms() %>% #' first_isolate(col_date = "date",
#' first_isolate(col_date = date, #' col_patient_id = "patient_id",
#' col_patient_id = patient_id, #' col_bactid = "bactid")
#' col_genus = genus, #'
#' col_species = species)
#'
#' \dontrun{ #' \dontrun{
#' #'
#' # set key antibiotics to a new variable #' # set key antibiotics to a new variable
@ -121,31 +119,25 @@ first_isolate <- function(tbl,
info = TRUE, info = TRUE,
col_genus = NA, col_genus = NA,
col_species = NA) { col_species = NA) {
# support tidyverse-like quotation # bactid OR genus+species must be available
# col_date <- quasiquotate(deparse(substitute(col_date)), col_date) if (is.na(col_bactid) & (is.na(col_genus) | is.na(col_species))) {
# col_patient_id <- quasiquotate(deparse(substitute(col_patient_id)), col_patient_id) stop('`col_bactid or both `col_genus` and `col_species` must be available.')
# col_bactid <- quasiquotate(deparse(substitute(col_bactid)), col_bactid) }
# col_genus <- quasiquotate(deparse(substitute(col_genus)), col_genus)
# col_species <- quasiquotate(deparse(substitute(col_species)), col_species)
# col_testcode <- quasiquotate(deparse(substitute(col_testcode)), col_testcode)
# col_specimen <- quasiquotate(deparse(substitute(col_specimen)), col_specimen)
# col_icu <- quasiquotate(deparse(substitute(col_icu)), col_icu)
# col_keyantibiotics <- quasiquotate(deparse(substitute(col_keyantibiotics)), col_keyantibiotics)
# check if columns exist # check if columns exist
check_columns_existance <- function(column, tblname = tbl) { check_columns_existance <- function(column, tblname = tbl) {
if (NROW(tblname) <= 1 | NCOL(tblname) <= 1) { if (NROW(tblname) <= 1 | NCOL(tblname) <= 1) {
stop('Please check tbl for existance.') stop('Please check tbl for existance.')
} }
if (!is.na(column)) { if (!is.na(column)) {
if (!(column %in% colnames(tblname))) { if (!(column %in% colnames(tblname))) {
stop('Column ', column, ' not found.') stop('Column `', column, '` not found.')
} }
} }
} }
check_columns_existance(col_date) check_columns_existance(col_date)
check_columns_existance(col_patient_id) check_columns_existance(col_patient_id)
check_columns_existance(col_bactid) check_columns_existance(col_bactid)
@ -154,13 +146,13 @@ first_isolate <- function(tbl,
check_columns_existance(col_testcode) check_columns_existance(col_testcode)
check_columns_existance(col_icu) check_columns_existance(col_icu)
check_columns_existance(col_keyantibiotics) check_columns_existance(col_keyantibiotics)
if (!is.na(col_bactid)) { if (!is.na(col_bactid)) {
tbl <- tbl %>% left_join_microorganisms() tbl <- tbl %>% left_join_microorganisms(by = col_bactid)
col_genus <- "genus" col_genus <- "genus"
col_species <- "species" col_species <- "species"
} }
if (is.na(col_testcode)) { if (is.na(col_testcode)) {
testcodes_exclude <- NA testcodes_exclude <- NA
} }
@ -168,18 +160,18 @@ first_isolate <- function(tbl,
if (!is.na(testcodes_exclude[1]) & testcodes_exclude[1] != '' & info == TRUE) { if (!is.na(testcodes_exclude[1]) & testcodes_exclude[1] != '' & info == TRUE) {
cat('Isolates from these test codes will be ignored:\n', toString(testcodes_exclude), '\n') cat('Isolates from these test codes will be ignored:\n', toString(testcodes_exclude), '\n')
} }
if (is.na(col_icu)) { if (is.na(col_icu)) {
icu_exclude <- FALSE icu_exclude <- FALSE
} else { } else {
tbl <- tbl %>% tbl <- tbl %>%
mutate(col_icu = tbl %>% pull(col_icu) %>% as.logical()) mutate(col_icu = tbl %>% pull(col_icu) %>% as.logical())
} }
if (is.na(col_specimen)) { if (is.na(col_specimen)) {
filter_specimen <- '' filter_specimen <- ''
} }
specgroup.notice <- '' specgroup.notice <- ''
weighted.notice <- '' weighted.notice <- ''
# filter on specimen group and keyantibiotics when they are filled in # filter on specimen group and keyantibiotics when they are filled in
@ -196,11 +188,11 @@ first_isolate <- function(tbl,
} else { } else {
tbl <- tbl %>% mutate(key_ab = tbl %>% pull(col_keyantibiotics)) tbl <- tbl %>% mutate(key_ab = tbl %>% pull(col_keyantibiotics))
} }
if (is.na(testcodes_exclude[1])) { if (is.na(testcodes_exclude[1])) {
testcodes_exclude <- '' testcodes_exclude <- ''
} }
# create new dataframe with original row index and right sorting # create new dataframe with original row index and right sorting
tbl <- tbl %>% tbl <- tbl %>%
mutate(first_isolate_row_index = 1:nrow(tbl), mutate(first_isolate_row_index = 1:nrow(tbl),
@ -211,9 +203,9 @@ first_isolate <- function(tbl,
genus = tbl %>% pull(col_genus)) %>% genus = tbl %>% pull(col_genus)) %>%
mutate(species = if_else(is.na(species), '', species), mutate(species = if_else(is.na(species), '', species),
genus = if_else(is.na(genus), '', genus)) genus = if_else(is.na(genus), '', genus))
if (filter_specimen == '') { if (filter_specimen == '') {
if (icu_exclude == FALSE) { if (icu_exclude == FALSE) {
if (info == TRUE) { if (info == TRUE) {
cat('Isolates from ICU will *NOT* be ignored.\n') cat('Isolates from ICU will *NOT* be ignored.\n')
@ -235,7 +227,7 @@ first_isolate <- function(tbl,
col_genus, col_genus,
col_species, col_species,
col_date)) col_date))
suppressWarnings( suppressWarnings(
row.start <- which(tbl %>% pull(col_icu) == FALSE) %>% min(na.rm = TRUE) row.start <- which(tbl %>% pull(col_icu) == FALSE) %>% min(na.rm = TRUE)
) )
@ -243,7 +235,7 @@ first_isolate <- function(tbl,
row.end <- which(tbl %>% pull(col_icu) == FALSE) %>% max(na.rm = TRUE) row.end <- which(tbl %>% pull(col_icu) == FALSE) %>% max(na.rm = TRUE)
) )
} }
} else { } else {
# sort on specimen and only analyse these row to save time # sort on specimen and only analyse these row to save time
if (icu_exclude == FALSE) { if (icu_exclude == FALSE) {
@ -282,9 +274,9 @@ first_isolate <- function(tbl,
& tbl %>% pull(col_icu) == FALSE) %>% max(na.rm = TRUE) & tbl %>% pull(col_icu) == FALSE) %>% max(na.rm = TRUE)
) )
} }
} }
if (abs(row.start) == Inf | abs(row.end) == Inf) { if (abs(row.start) == Inf | abs(row.end) == Inf) {
if (info == TRUE) { if (info == TRUE) {
cat('No isolates found.\n') cat('No isolates found.\n')
@ -297,14 +289,14 @@ first_isolate <- function(tbl,
} }
return(tbl %>% pull(real_first_isolate)) return(tbl %>% pull(real_first_isolate))
} }
scope.size <- tbl %>% scope.size <- tbl %>%
filter(row_number() %>% filter(row_number() %>%
between(row.start, between(row.start,
row.end), row.end),
genus != '') %>% genus != '') %>%
nrow() nrow()
# Analysis of first isolate ---- # Analysis of first isolate ----
all_first <- tbl %>% all_first <- tbl %>%
mutate(other_pat_or_mo = if_else(patient_id == lag(patient_id) mutate(other_pat_or_mo = if_else(patient_id == lag(patient_id)
@ -316,7 +308,7 @@ first_isolate <- function(tbl,
mutate(days_diff = if_else(other_pat_or_mo == FALSE, mutate(days_diff = if_else(other_pat_or_mo == FALSE,
(date_lab - lag(date_lab)) + lag(days_diff), (date_lab - lag(date_lab)) + lag(days_diff),
0)) 0))
if (col_keyantibiotics != '') { if (col_keyantibiotics != '') {
if (info == TRUE) { if (info == TRUE) {
if (type == 'keyantibiotics') { if (type == 'keyantibiotics') {
@ -365,7 +357,7 @@ first_isolate <- function(tbl,
TRUE, TRUE,
FALSE)) FALSE))
} }
# first one as TRUE # first one as TRUE
all_first[row.start, 'real_first_isolate'] <- TRUE all_first[row.start, 'real_first_isolate'] <- TRUE
# no tests that should be included, or ICU # no tests that should be included, or ICU
@ -375,15 +367,15 @@ first_isolate <- function(tbl,
if (icu_exclude == TRUE) { if (icu_exclude == TRUE) {
all_first[which(all_first[, col_icu] == TRUE), 'real_first_isolate'] <- FALSE all_first[which(all_first[, col_icu] == TRUE), 'real_first_isolate'] <- FALSE
} }
# NA's where genus is unavailable # NA's where genus is unavailable
all_first <- all_first %>% all_first <- all_first %>%
mutate(real_first_isolate = if_else(genus == '', NA, real_first_isolate)) mutate(real_first_isolate = if_else(genus == '', NA, real_first_isolate))
all_first <- all_first %>% all_first <- all_first %>%
arrange(first_isolate_row_index) %>% arrange(first_isolate_row_index) %>%
pull(real_first_isolate) pull(real_first_isolate)
if (info == TRUE) { if (info == TRUE) {
cat(paste0('\nFound ', cat(paste0('\nFound ',
all_first %>% sum(na.rm = TRUE), all_first %>% sum(na.rm = TRUE),
@ -393,13 +385,13 @@ first_isolate <- function(tbl,
(all_first %>% sum(na.rm = TRUE) / tbl %>% nrow()) %>% percent(), (all_first %>% sum(na.rm = TRUE) / tbl %>% nrow()) %>% percent(),
' of total)\n')) ' of total)\n'))
} }
if (output_logical == FALSE) { if (output_logical == FALSE) {
all_first <- all_first %>% as.integer() all_first <- all_first %>% as.integer()
} }
all_first all_first
} }
#' Key antibiotics based on bacteria ID #' Key antibiotics based on bacteria ID
@ -409,10 +401,10 @@ first_isolate <- function(tbl,
#' @param info print warnings #' @param info print warnings
#' @param amcl,amox,cfot,cfta,cftr,cfur,cipr,clar,clin,clox,doxy,gent,line,mero,peni,pita,rifa,teic,trsu,vanc column names of antibiotics, case-insensitive #' @param amcl,amox,cfot,cfta,cftr,cfur,cipr,clar,clin,clox,doxy,gent,line,mero,peni,pita,rifa,teic,trsu,vanc column names of antibiotics, case-insensitive
#' @export #' @export
#' @importFrom dplyr %>% mutate if_else #' @importFrom dplyr %>% mutate if_else
#' @return Character of length 1. #' @return Character of length 1.
#' @seealso \code{\link{mo_property}} \code{\link{antibiotics}} #' @seealso \code{\link{mo_property}} \code{\link{antibiotics}}
#' @examples #' @examples
#' \donttest{ #' \donttest{
#' #' # set key antibiotics to a new variable #' #' # set key antibiotics to a new variable
#' tbl$keyab <- key_antibiotics(tbl) #' tbl$keyab <- key_antibiotics(tbl)
@ -440,9 +432,9 @@ key_antibiotics <- function(tbl,
teic = 'teic', teic = 'teic',
trsu = 'trsu', trsu = 'trsu',
vanc = 'vanc') { vanc = 'vanc') {
keylist <- character(length = nrow(tbl)) keylist <- character(length = nrow(tbl))
# check columns # check columns
col.list <- c(amox, cfot, cfta, cftr, cfur, cipr, clar, col.list <- c(amox, cfot, cfta, cftr, cfur, cipr, clar,
clin, clox, doxy, gent, line, mero, peni, clin, clox, doxy, gent, line, mero, peni,
@ -486,12 +478,12 @@ key_antibiotics <- function(tbl,
teic <- col.list[17] teic <- col.list[17]
trsu <- col.list[18] trsu <- col.list[18]
vanc <- col.list[19] vanc <- col.list[19]
# join microorganisms # join microorganisms
tbl <- tbl %>% left_join_microorganisms(col_bactid) tbl <- tbl %>% left_join_microorganisms(col_bactid)
tbl$key_ab <- NA_character_ tbl$key_ab <- NA_character_
# Staphylococcus # Staphylococcus
list_ab <- c(clox, trsu, teic, vanc, doxy, line, clar, rifa) list_ab <- c(clox, trsu, teic, vanc, doxy, line, clar, rifa)
list_ab <- list_ab[list_ab %in% colnames(tbl)] list_ab <- list_ab[list_ab %in% colnames(tbl)]
@ -501,7 +493,7 @@ key_antibiotics <- function(tbl,
MARGIN = 1, MARGIN = 1,
FUN = function(x) paste(x, collapse = "")), FUN = function(x) paste(x, collapse = "")),
key_ab)) key_ab))
# Rest of Gram + # Rest of Gram +
list_ab <- c(peni, amox, teic, vanc, clin, line, clar, trsu) list_ab <- c(peni, amox, teic, vanc, clin, line, clar, trsu)
list_ab <- list_ab[list_ab %in% colnames(tbl)] list_ab <- list_ab[list_ab %in% colnames(tbl)]
@ -511,7 +503,7 @@ key_antibiotics <- function(tbl,
MARGIN = 1, MARGIN = 1,
FUN = function(x) paste(x, collapse = "")), FUN = function(x) paste(x, collapse = "")),
key_ab)) key_ab))
# Gram - # Gram -
list_ab <- c(amox, amcl, pita, cfur, cfot, cfta, cftr, mero, cipr, trsu, gent) list_ab <- c(amox, amcl, pita, cfur, cfot, cfta, cftr, mero, cipr, trsu, gent)
list_ab <- list_ab[list_ab %in% colnames(tbl)] list_ab <- list_ab[list_ab %in% colnames(tbl)]
@ -521,76 +513,76 @@ key_antibiotics <- function(tbl,
MARGIN = 1, MARGIN = 1,
FUN = function(x) paste(x, collapse = "")), FUN = function(x) paste(x, collapse = "")),
key_ab)) key_ab))
# format # format
tbl <- tbl %>% tbl <- tbl %>%
mutate(key_ab = gsub('(NA|NULL)', '-', key_ab) %>% toupper()) mutate(key_ab = gsub('(NA|NULL)', '-', key_ab) %>% toupper())
tbl$key_ab tbl$key_ab
} }
#' @importFrom dplyr progress_estimated %>% #' @importFrom dplyr progress_estimated %>%
#' @noRd #' @noRd
key_antibiotics_equal <- function(x, key_antibiotics_equal <- function(x,
y, y,
type = c("keyantibiotics", "points"), type = c("keyantibiotics", "points"),
ignore_I = TRUE, ignore_I = TRUE,
points_threshold = 2, points_threshold = 2,
info = FALSE) { info = FALSE) {
# x is active row, y is lag # x is active row, y is lag
type <- type[1] type <- type[1]
if (length(x) != length(y)) { if (length(x) != length(y)) {
stop('Length of `x` and `y` must be equal.') stop('Length of `x` and `y` must be equal.')
} }
result <- logical(length(x)) result <- logical(length(x))
if (info == TRUE) { if (info == TRUE) {
p <- dplyr::progress_estimated(length(x)) p <- dplyr::progress_estimated(length(x))
} }
for (i in 1:length(x)) { for (i in 1:length(x)) {
if (info == TRUE) { if (info == TRUE) {
p$tick()$print() p$tick()$print()
} }
if (is.na(x[i])) { if (is.na(x[i])) {
x[i] <- '' x[i] <- ''
} }
if (is.na(y[i])) { if (is.na(y[i])) {
y[i] <- '' y[i] <- ''
} }
if (nchar(x[i]) != nchar(y[i])) { if (nchar(x[i]) != nchar(y[i])) {
result[i] <- FALSE result[i] <- FALSE
} else if (x[i] == '' & y[i] == '') { } else if (x[i] == '' & y[i] == '') {
result[i] <- TRUE result[i] <- TRUE
} else { } else {
x2 <- strsplit(x[i], "")[[1]] x2 <- strsplit(x[i], "")[[1]]
y2 <- strsplit(y[i], "")[[1]] y2 <- strsplit(y[i], "")[[1]]
if (type == 'points') { if (type == 'points') {
# count points for every single character: # count points for every single character:
# - no change is 0 points # - no change is 0 points
# - I <-> S|R is 0.5 point # - I <-> S|R is 0.5 point
# - S|R <-> R|S is 1 point # - S|R <-> R|S is 1 point
# use the levels of as.rsi (S = 1, I = 2, R = 3) # use the levels of as.rsi (S = 1, I = 2, R = 3)
suppressWarnings(x2 <- x2 %>% as.rsi() %>% as.double()) suppressWarnings(x2 <- x2 %>% as.rsi() %>% as.double())
suppressWarnings(y2 <- y2 %>% as.rsi() %>% as.double()) suppressWarnings(y2 <- y2 %>% as.rsi() %>% as.double())
points <- (x2 - y2) %>% abs() %>% sum(na.rm = TRUE) points <- (x2 - y2) %>% abs() %>% sum(na.rm = TRUE)
result[i] <- ((points / 2) >= points_threshold) result[i] <- ((points / 2) >= points_threshold)
} else if (type == 'keyantibiotics') { } else if (type == 'keyantibiotics') {
# check if key antibiotics are exactly the same # check if key antibiotics are exactly the same
# also possible to ignore I, so only S <-> R and S <-> R are counted # also possible to ignore I, so only S <-> R and S <-> R are counted
@ -599,15 +591,15 @@ key_antibiotics_equal <- function(x,
} else { } else {
valid_chars <- c('S', 's', 'I', 'i', 'R', 'r') valid_chars <- c('S', 's', 'I', 'i', 'R', 'r')
} }
# remove invalid values (like "-", NA) on both locations # remove invalid values (like "-", NA) on both locations
x2[which(!x2 %in% valid_chars)] <- '?' x2[which(!x2 %in% valid_chars)] <- '?'
x2[which(!y2 %in% valid_chars)] <- '?' x2[which(!y2 %in% valid_chars)] <- '?'
y2[which(!x2 %in% valid_chars)] <- '?' y2[which(!x2 %in% valid_chars)] <- '?'
y2[which(!y2 %in% valid_chars)] <- '?' y2[which(!y2 %in% valid_chars)] <- '?'
result[i] <- all(x2 == y2) result[i] <- all(x2 == y2)
} else { } else {
stop('`', type, '` is not a valid value for type, must be "points" or "keyantibiotics". See ?first_isolate.') stop('`', type, '` is not a valid value for type, must be "points" or "keyantibiotics". See ?first_isolate.')
} }
@ -627,7 +619,7 @@ key_antibiotics_equal <- function(x,
#' @importFrom dplyr %>% filter slice pull #' @importFrom dplyr %>% filter slice pull
#' @return Character (vector). #' @return Character (vector).
#' @seealso \code{\link{microorganisms}} for the dataframe that is being used to determine ID's. #' @seealso \code{\link{microorganisms}} for the dataframe that is being used to determine ID's.
#' @examples #' @examples
#' # These examples all return "STAAUR", the ID of S. aureus: #' # These examples all return "STAAUR", the ID of S. aureus:
#' guess_bactid("stau") #' guess_bactid("stau")
#' guess_bactid("STAU") #' guess_bactid("STAU")
@ -646,7 +638,7 @@ guess_bactid <- function(x) {
# add start and stop # add start and stop
x_species <- paste(x, 'species') x_species <- paste(x, 'species')
x <- paste0('^', x, '$') x <- paste0('^', x, '$')
for (i in 1:length(x)) { for (i in 1:length(x)) {
if (tolower(x[i]) == '^e.*coli$') { if (tolower(x[i]) == '^e.*coli$') {
# avoid detection of Entamoeba coli in case of E. coli # avoid detection of Entamoeba coli in case of E. coli
@ -681,7 +673,7 @@ guess_bactid <- function(x) {
# let's try the ID's first # let's try the ID's first
found <- AMR::microorganisms %>% filter(bactid == x.bak[i]) found <- AMR::microorganisms %>% filter(bactid == x.bak[i])
if (nrow(found) == 0) { if (nrow(found) == 0) {
# now try exact match # now try exact match
found <- AMR::microorganisms %>% filter(fullname == x[i]) found <- AMR::microorganisms %>% filter(fullname == x[i])
@ -709,10 +701,10 @@ guess_bactid <- function(x) {
x.bak[i] %>% substr((x_length / 2) + 1, x_length) %>% trimws()) x.bak[i] %>% substr((x_length / 2) + 1, x_length) %>% trimws())
found <- AMR::microorganisms %>% filter(fullname %like% paste0('^', x[i])) found <- AMR::microorganisms %>% filter(fullname %like% paste0('^', x[i]))
} }
if (nrow(found) != 0) { if (nrow(found) != 0) {
x[i] <- found %>% x[i] <- found %>%
slice(1) %>% slice(1) %>%
pull(bactid) pull(bactid)
} else { } else {
x[i] <- "" x[i] <- ""

6
R/join.R
View File

@ -10,12 +10,12 @@
#' @param ... other parameters to pass on to \code{dplyr::\link[dplyr]{join}}. #' @param ... other parameters to pass on to \code{dplyr::\link[dplyr]{join}}.
#' @details As opposed to the \code{\link[dplyr]{join}} functions of \code{dplyr}, characters vectors are supported and at default existing columns will get a suffix \code{"2"} and the newly joined columns will not get a suffix. See \code{\link[dplyr]{join}} for more information. #' @details As opposed to the \code{\link[dplyr]{join}} functions of \code{dplyr}, characters vectors are supported and at default existing columns will get a suffix \code{"2"} and the newly joined columns will not get a suffix. See \code{\link[dplyr]{join}} for more information.
#' @export #' @export
#' @examples #' @examples
#' left_join_microorganisms("STAAUR") #' left_join_microorganisms("STAAUR")
#' #'
#' library(dplyr) #' library(dplyr)
#' septic_patients %>% left_join_microorganisms() #' septic_patients %>% left_join_microorganisms()
#' #'
#' df <- data.frame(date = seq(from = as.Date("2018-01-01"), #' df <- data.frame(date = seq(from = as.Date("2018-01-01"),
#' to = as.Date("2018-01-07"), #' to = as.Date("2018-01-07"),
#' by = 1), #' by = 1),

2
man/clipboard.Rd
View File

@ -41,7 +41,7 @@ clipboard_export(x, sep = "\\t", dec = ".", na = "", header = TRUE,
data.frame data.frame
} }
\description{ \description{
These are helper functions around \code{\link{read.table}} and \code{\link{write.table}} to import from and export to clipboard. The data will be read and written as tab-separated by default, which makes it possible to copy and paste from other software like Excel and SPSS without further transformation. These are helper functions around \code{\link{read.table}} and \code{\link{write.table}} to import from and export to clipboard, with support for Windows, Linux and macOS. The data will be read and written as tab-separated by default, which makes it possible to copy and paste from other software like Excel and SPSS without further transformation.
} }
\details{ \details{
For \code{clipboard_export}, the reserved clipboard size for exporting will be set automatically to 125\% of the object size of \code{x}. This way, it is possible to export data with thousands of rows as the only limit will be your systems RAM. For \code{clipboard_export}, the reserved clipboard size for exporting will be set automatically to 125\% of the object size of \code{x}. This way, it is possible to export data with thousands of rows as the only limit will be your systems RAM.

24
man/first_isolate.Rd
View File

@ -14,17 +14,17 @@ first_isolate(tbl, col_date, col_patient_id, col_bactid = NA,
\arguments{ \arguments{
\item{tbl}{a \code{data.frame} containing isolates.} \item{tbl}{a \code{data.frame} containing isolates.}
\item{col_date}{column name of the result date (or date that is was received on the lab), supports tidyverse-like quotation} \item{col_date}{column name of the result date (or date that is was received on the lab)}
\item{col_patient_id}{column name of the unique IDs of the patients, supports tidyverse-like quotation} \item{col_patient_id}{column name of the unique IDs of the patients}
\item{col_bactid}{column name of the unique IDs of the microorganisms (should occur in the \code{\link{microorganisms}} dataset), supports tidyverse-like quotation} \item{col_bactid}{column name of the unique IDs of the microorganisms (should occur in the \code{\link{microorganisms}} dataset)}
\item{col_testcode}{column name of the test codes. Use \code{col_testcode = NA} to \strong{not} exclude certain test codes (like test codes for screening). In that case \code{testcodes_exclude} will be ignored. Supports tidyverse-like quotation.} \item{col_testcode}{column name of the test codes. Use \code{col_testcode = NA} to \strong{not} exclude certain test codes (like test codes for screening). In that case \code{testcodes_exclude} will be ignored. Supports tidyverse-like quotation.}
\item{col_specimen}{column name of the specimen type or group, supports tidyverse-like quotation} \item{col_specimen}{column name of the specimen type or group}
\item{col_icu}{column name of the logicals (\code{TRUE}/\code{FALSE}) whether a ward or department is an Intensive Care Unit (ICU), supports tidyverse-like quotation} \item{col_icu}{column name of the logicals (\code{TRUE}/\code{FALSE}) whether a ward or department is an Intensive Care Unit (ICU)}
\item{col_keyantibiotics}{column name of the key antibiotics to determine first \emph{weighted} isolates, see \code{\link{key_antibiotics}}. Supports tidyverse-like quotation.} \item{col_keyantibiotics}{column name of the key antibiotics to determine first \emph{weighted} isolates, see \code{\link{key_antibiotics}}. Supports tidyverse-like quotation.}
@ -46,9 +46,9 @@ first_isolate(tbl, col_date, col_patient_id, col_bactid = NA,
\item{info}{print progress} \item{info}{print progress}
\item{col_genus}{(deprecated, use \code{col_bactid} instead) column name of the genus of the microorganisms, supports tidyverse-like quotation} \item{col_genus}{(deprecated, use \code{col_bactid} instead) column name of the genus of the microorganisms}
\item{col_species}{(deprecated, use \code{col_bactid} instead) column name of the species of the microorganisms, supports tidyverse-like quotation} \item{col_species}{(deprecated, use \code{col_bactid} instead) column name of the species of the microorganisms}
} }
\value{ \value{
A vector to add to table, see Examples. A vector to add to table, see Examples.
@ -73,12 +73,10 @@ my_patients <- septic_patients
library(dplyr) library(dplyr)
my_patients$first_isolate <- my_patients \%>\% my_patients$first_isolate <- my_patients \%>\%
left_join_microorganisms() \%>\% first_isolate(col_date = "date",
first_isolate(col_date = date, col_patient_id = "patient_id",
col_patient_id = patient_id, col_bactid = "bactid")
col_genus = genus,
col_species = species)
\dontrun{ \dontrun{
# set key antibiotics to a new variable # set key antibiotics to a new variable

22
man/septic_patients.Rd
View File

@ -38,31 +38,31 @@ my_data <- septic_patients
library(dplyr) library(dplyr)
# Add first isolates to our dataset: # Add first isolates to our dataset:
my_data <- my_data \%>\% my_data <- my_data \%>\%
mutate(first_isolates = first_isolate(my_data, date, patient_id, bactid)) mutate(first_isolates = first_isolate(my_data, "date", "patient_id", "bactid"))
# -------- # # -------- #
# ANALYSIS # # ANALYSIS #
# -------- # # -------- #
# 1. Get the amoxicillin resistance percentages # 1. Get the amoxicillin resistance percentages
# of E. coli, divided by hospital: # of E. coli, divided by hospital:
my_data \%>\% my_data \%>\%
filter(bactid == "ESCCOL", filter(bactid == "ESCCOL",
first_isolates == TRUE) \%>\% first_isolates == TRUE) \%>\%
group_by(hospital_id) \%>\% group_by(hospital_id) \%>\%
summarise(n = n(), summarise(n = n(),
amoxicillin_resistance = rsi(amox)) amoxicillin_resistance = rsi(amox))
# 2. Get the amoxicillin/clavulanic acid resistance # 2. Get the amoxicillin/clavulanic acid resistance
# percentages of E. coli, trend over the years: # percentages of E. coli, trend over the years:
my_data \%>\% my_data \%>\%
filter(bactid == guess_bactid("E. coli"), filter(bactid == guess_bactid("E. coli"),
first_isolates == TRUE) \%>\% first_isolates == TRUE) \%>\%
group_by(year = format(date, "\%Y")) \%>\% group_by(year = format(date, "\%Y")) \%>\%
summarise(n = n(), summarise(n = n(),
amoxclav_resistance = rsi(amcl, minimum = 20)) amoxclav_resistance = rsi(amcl, minimum = 20))
} }

BIN
tests/testthat/Rplots.pdf
View File

Binary file not shown.

2
tests/testthat/test-clipboard.R
View File

@ -1,9 +1,9 @@
context("clipboard.R") context("clipboard.R")
test_that("clipboard works", { test_that("clipboard works", {
skip_on_os(c("linux", "solaris"))
t1 <<- AMR::antibiotics # why is the <<- needed? Won't work without it... t1 <<- AMR::antibiotics # why is the <<- needed? Won't work without it...
clipboard_export(t1, info = FALSE) clipboard_export(t1, info = FALSE)
t2 <- clipboard_import() t2 <- clipboard_import()
skip_if(is.null(t1) | is.null(t2), message = "No clipboard content found: skipping.")
expect_equal(t1, t2) expect_equal(t1, t2)
}) })