2018-02-21 11:52:31 +01:00
# ==================================================================== #
# TITLE #
2020-10-08 11:16:03 +02:00
# Antimicrobial Resistance (AMR) Analysis for R #
2018-02-21 11:52:31 +01:00
# #
2019-01-02 23:24:07 +01:00
# SOURCE #
2020-07-08 14:48:06 +02:00
# https://github.com/msberends/AMR #
2018-02-21 11:52:31 +01:00
# #
# LICENCE #
2020-12-27 00:30:28 +01:00
# (c) 2018-2021 Berends MS, Luz CF et al. #
2020-10-08 11:16:03 +02:00
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
2018-02-21 11:52:31 +01:00
# #
2019-01-02 23:24:07 +01:00
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
# GNU General Public License version 2.0 (GNU GPL-2), as published by #
# the Free Software Foundation. #
2020-01-05 17:22:09 +01:00
# We created this package for both routine data analysis and academic #
# research and it was publicly released in the hope that it will be #
# useful, but it comes WITHOUT ANY WARRANTY OR LIABILITY. #
2020-10-08 11:16:03 +02:00
# #
# Visit our website for the full manual and a complete tutorial about #
# how to conduct AMR analysis: https://msberends.github.io/AMR/ #
2018-02-21 11:52:31 +01:00
# ==================================================================== #
#' Determine first (weighted) isolates
#'
2020-11-23 21:50:27 +01:00
#' Determine first (weighted) isolates of all microorganisms of every patient per episode and (if needed) per specimen type. To determine patient episodes not necessarily based on microorganisms, use [is_new_episode()] that also supports grouping with the `dplyr` package.
2020-02-22 17:03:47 +01:00
#' @inheritSection lifecycle Stable lifecycle
2020-12-27 20:32:40 +01:00
#' @param x a [data.frame] containing isolates. Can be left blank when used inside `dplyr` verbs, such as [`filter()`][dplyr::filter()], [`mutate()`][dplyr::mutate()] and [`summarise()`][dplyr::summarise()].
2020-11-17 16:57:41 +01:00
#' @param col_date column name of the result date (or date that is was received on the lab), defaults to the first column with a date class
2018-12-10 15:14:29 +01:00
#' @param col_patient_id column name of the unique IDs of the patients, defaults to the first column that starts with 'patient' or 'patid' (case insensitive)
2019-11-28 22:32:17 +01:00
#' @param col_mo column name of the IDs of the microorganisms (see [as.mo()]), defaults to the first column of class [`mo`]. Values will be coerced using [as.mo()].
2020-12-17 16:22:25 +01:00
#' @param col_testcode column name of the test codes. Use `col_testcode = NULL` to **not** exclude certain test codes (such as test codes for screening). In that case `testcodes_exclude` will be ignored.
2018-04-02 11:11:21 +02:00
#' @param col_specimen column name of the specimen type or group
2019-11-28 22:32:17 +01:00
#' @param col_icu column name of the logicals (`TRUE`/`FALSE`) whether a ward or department is an Intensive Care Unit (ICU)
#' @param col_keyantibiotics column name of the key antibiotics to determine first *weighted* isolates, see [key_antibiotics()]. Defaults to the first column that starts with 'key' followed by 'ab' or 'antibiotics' (case insensitive). Use `col_keyantibiotics = FALSE` to prevent this.
2019-08-08 22:39:42 +02:00
#' @param episode_days episode in days after which a genus/species combination will be determined as 'first isolate' again. The default of 365 days is based on the guideline by CLSI, see Source.
2018-03-19 20:39:23 +01:00
#' @param testcodes_exclude character vector with test codes that should be excluded (case-insensitive)
2020-12-22 00:51:17 +01:00
#' @param icu_exclude logical whether ICU isolates should be excluded (rows with value `TRUE` in the column set with `col_icu`)
#' @param specimen_group value in the column set with `col_specimen` to filter on
2019-11-28 22:32:17 +01:00
#' @param type type to determine weighed isolates; can be `"keyantibiotics"` or `"points"`, see Details
#' @param ignore_I logical to determine whether antibiotic interpretations with `"I"` will be ignored when `type = "keyantibiotics"`, see Details
#' @param points_threshold points until the comparison of key antibiotics will lead to inclusion of an isolate when `type = "points"`, see Details
2018-02-21 11:52:31 +01:00
#' @param info print progress
2019-11-28 22:32:17 +01:00
#' @param include_unknown logical to determine whether 'unknown' microorganisms should be included too, i.e. microbial code `"UNKNOWN"`, which defaults to `FALSE`. For WHONET users, this means that all records with organism code `"con"` (*contamination*) will be excluded at default. Isolates with a microbial ID of `NA` will always be excluded as first isolate.
2020-12-22 00:51:17 +01:00
#' @param ... arguments passed on to [first_isolate()] when using [filter_first_isolate()], or arguments passed on to [key_antibiotics()] when using [filter_first_weighted_isolate()]
2020-12-07 16:06:42 +01:00
#' @details
2020-12-27 20:32:40 +01:00
#' These functions are context-aware when used inside `dplyr` verbs, such as `filter()`, `mutate()` and `summarise()`. This means that then the `x` argument can be left blank, please see *Examples*.
2020-12-07 16:06:42 +01:00
#'
#' The [first_isolate()] function is a wrapper around the [is_new_episode()] function, but more efficient for data sets containing microorganism codes or names.
2020-11-17 16:57:41 +01:00
#'
#' All isolates with a microbial ID of `NA` will be excluded as first isolate.
#'
#' ### Why this is so important
2020-11-28 22:15:44 +01:00
#' To conduct an analysis of antimicrobial resistance, you should only include the first isolate of every patient per episode [(Hindler *et al.* 2007)](https://pubmed.ncbi.nlm.nih.gov/17304462/). 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 *S. aureus* isolates would be overestimated, because you included this MRSA more than once. It would be [selection bias](https://en.wikipedia.org/wiki/Selection_bias).
2018-12-22 22:39:34 +01:00
#'
2020-11-17 16:57:41 +01:00
#' ### `filter_*()` shortcuts
2019-08-08 22:39:42 +02:00
#'
2020-11-17 16:57:41 +01:00
#' The functions [filter_first_isolate()] and [filter_first_weighted_isolate()] are helper functions to quickly filter on first isolates.
#'
#' The function [filter_first_isolate()] is essentially equal to either:
#'
2019-11-28 22:32:17 +01:00
#' ```
2020-09-29 23:35:46 +02:00
#' x[first_isolate(x, ...), ]
2020-11-28 22:15:44 +01:00
#'
2020-12-07 16:06:42 +01:00
#' x %>% filter(first_isolate(...))
2019-11-28 22:32:17 +01:00
#' ```
2020-11-17 16:57:41 +01:00
#'
2019-11-28 22:32:17 +01:00
#' The function [filter_first_weighted_isolate()] is essentially equal to:
2020-11-17 16:57:41 +01:00
#'
2019-11-28 22:32:17 +01:00
#' ```
2020-09-29 23:35:46 +02:00
#' x %>%
#' mutate(keyab = key_antibiotics(.)) %>%
#' mutate(only_weighted_firsts = first_isolate(x,
#' col_keyantibiotics = "keyab", ...)) %>%
#' filter(only_weighted_firsts == TRUE) %>%
#' select(-only_weighted_firsts, -keyab)
2019-11-28 22:32:17 +01:00
#' ```
2018-07-17 13:02:05 +02:00
#' @section Key antibiotics:
2019-11-28 22:32:17 +01:00
#' There are two ways to determine whether isolates can be included as first *weighted* isolates which will give generally the same results:
2018-03-13 11:57:30 +01:00
#'
2020-12-22 00:51:17 +01:00
#' 1. Using `type = "keyantibiotics"` and argument `ignore_I`
2019-11-28 22:32:17 +01:00
#'
#' Any difference from S to R (or vice versa) will (re)select an isolate as a first weighted isolate. With `ignore_I = FALSE`, also differences from I to S|R (or vice versa) will lead to this. This is a reliable method and 30-35 times faster than method 2. Read more about this in the [key_antibiotics()] function.
#'
2020-12-22 00:51:17 +01:00
#' 2. Using `type = "points"` and argument `points_threshold`
2019-11-28 22:32:17 +01:00
#'
#' A difference from I to S|R (or vice versa) means 0.5 points, a difference from S to R (or vice versa) means 1 point. When the sum of points exceeds `points_threshold`, which default to `2`, an isolate will be (re)selected as a first weighted isolate.
2018-12-22 22:39:34 +01:00
#' @rdname first_isolate
2019-11-28 22:32:17 +01:00
#' @seealso [key_antibiotics()]
2018-02-26 12:15:52 +01:00
#' @export
2019-11-28 22:32:17 +01:00
#' @return A [`logical`] vector
2020-05-16 13:05:47 +02:00
#' @source Methodology of this function is strictly based on:
2019-11-28 22:32:17 +01:00
#'
#' **M39 Analysis and Presentation of Cumulative Antimicrobial Susceptibility Test Data, 4th Edition**, 2014, *Clinical and Laboratory Standards Institute (CLSI)*. <https://clsi.org/standards/products/microbiology/documents/m39/>.
2019-01-02 23:24:07 +01:00
#' @inheritSection AMR Read more on our website!
2018-02-21 11:52:31 +01:00
#' @examples
2019-08-27 16:45:42 +02:00
#' # `example_isolates` is a dataset available in the AMR package.
#' # See ?example_isolates.
2019-08-14 14:57:06 +02:00
#'
2020-09-29 23:35:46 +02:00
#' # basic filtering on first isolates
#' example_isolates[first_isolate(example_isolates), ]
2020-04-15 11:30:28 +02:00
#'
2020-11-17 16:57:41 +01:00
#' # filtering based on isolates ----------------------------------------------
2020-09-29 23:35:46 +02:00
#' \donttest{
#' if (require("dplyr")) {
2020-11-17 16:57:41 +01:00
#' # filter on first isolates:
2020-09-29 23:35:46 +02:00
#' example_isolates %>%
#' mutate(first_isolate = first_isolate(.)) %>%
#' filter(first_isolate == TRUE)
#'
2020-11-17 16:57:41 +01:00
#' # short-hand versions:
2020-09-29 23:35:46 +02:00
#' example_isolates %>%
2020-12-07 16:06:42 +01:00
#' filter(first_isolate())
#' example_isolates %>%
2020-09-29 23:35:46 +02:00
#' filter_first_isolate()
#'
#' example_isolates %>%
#' filter_first_weighted_isolate()
2020-04-15 11:30:28 +02:00
#'
2020-11-17 16:57:41 +01:00
#' # now let's see if first isolates matter:
2020-09-29 23:35:46 +02:00
#' A <- example_isolates %>%
#' group_by(hospital_id) %>%
#' summarise(count = n_rsi(GEN), # gentamicin availability
#' resistance = resistance(GEN)) # gentamicin resistance
#'
#' B <- example_isolates %>%
#' filter_first_weighted_isolate() %>% # the 1st isolate filter
#' group_by(hospital_id) %>%
#' summarise(count = n_rsi(GEN), # gentamicin availability
#' resistance = resistance(GEN)) # gentamicin resistance
#'
#' # Have a look at A and B.
#' # B is more reliable because every isolate is counted only once.
#' # Gentamicin resistance in hospital D appears to be 3.7% higher than
#' # when you (erroneously) would have used all isolates for analysis.
#' }
2018-02-21 11:52:31 +01:00
#' }
2019-05-13 14:56:23 +02:00
first_isolate <- function ( x ,
2018-10-23 11:15:05 +02:00
col_date = NULL ,
col_patient_id = NULL ,
col_mo = NULL ,
col_testcode = NULL ,
col_specimen = NULL ,
col_icu = NULL ,
col_keyantibiotics = NULL ,
2018-02-21 11:52:31 +01:00
episode_days = 365 ,
2018-10-23 11:15:05 +02:00
testcodes_exclude = NULL ,
2018-02-21 11:52:31 +01:00
icu_exclude = FALSE ,
2018-12-22 22:39:34 +01:00
specimen_group = NULL ,
2018-03-19 20:39:23 +01:00
type = " keyantibiotics" ,
ignore_I = TRUE ,
2018-02-27 20:01:02 +01:00
points_threshold = 2 ,
2020-02-21 21:13:38 +01:00
info = interactive ( ) ,
2019-08-08 22:39:42 +02:00
include_unknown = FALSE ,
2018-12-22 22:39:34 +01:00
... ) {
2020-12-07 16:06:42 +01:00
if ( missing ( x ) ) {
x <- get_current_data ( arg_name = " x" , call = -2 )
}
2020-11-17 16:57:41 +01:00
meet_criteria ( x , allow_class = " data.frame" ) # also checks dimensions to be >0
2020-10-19 17:09:19 +02:00
meet_criteria ( col_date , allow_class = " character" , has_length = 1 , allow_NULL = TRUE , is_in = colnames ( x ) )
meet_criteria ( col_patient_id , allow_class = " character" , has_length = 1 , allow_NULL = TRUE , is_in = colnames ( x ) )
meet_criteria ( col_mo , allow_class = " character" , has_length = 1 , allow_NULL = TRUE , is_in = colnames ( x ) )
meet_criteria ( col_testcode , allow_class = " character" , has_length = 1 , allow_NULL = TRUE , is_in = colnames ( x ) )
2020-10-21 15:28:48 +02:00
if ( isFALSE ( col_specimen ) ) {
col_specimen <- NULL
}
2020-10-19 17:09:19 +02:00
meet_criteria ( col_specimen , allow_class = " character" , has_length = 1 , allow_NULL = TRUE , is_in = colnames ( x ) )
meet_criteria ( col_icu , allow_class = " character" , has_length = 1 , allow_NULL = TRUE , is_in = colnames ( x ) )
2020-10-21 15:28:48 +02:00
if ( isFALSE ( col_keyantibiotics ) ) {
col_keyantibiotics <- NULL
}
2020-10-19 17:09:19 +02:00
meet_criteria ( col_keyantibiotics , allow_class = " character" , has_length = 1 , allow_NULL = TRUE , is_in = colnames ( x ) )
meet_criteria ( episode_days , allow_class = c ( " numeric" , " integer" ) , has_length = 1 )
meet_criteria ( testcodes_exclude , allow_class = " character" , allow_NULL = TRUE )
meet_criteria ( icu_exclude , allow_class = " logical" , has_length = 1 )
meet_criteria ( specimen_group , allow_class = " character" , has_length = 1 , allow_NULL = TRUE )
meet_criteria ( type , allow_class = " character" , has_length = 1 )
meet_criteria ( ignore_I , allow_class = " logical" , has_length = 1 )
meet_criteria ( points_threshold , allow_class = c ( " numeric" , " integer" ) , has_length = 1 )
meet_criteria ( info , allow_class = " logical" , has_length = 1 )
meet_criteria ( include_unknown , allow_class = " logical" , has_length = 1 )
2019-10-11 17:21:02 +02:00
2018-12-22 22:39:34 +01:00
dots <- unlist ( list ( ... ) )
if ( length ( dots ) != 0 ) {
2020-12-22 00:51:17 +01:00
# backwards compatibility with old arguments
2020-09-18 16:05:53 +02:00
dots.names <- dots %pm>% names ( )
2019-10-11 17:21:02 +02:00
if ( " filter_specimen" %in% dots.names ) {
specimen_group <- dots [which ( dots.names == " filter_specimen" ) ]
2018-12-22 22:39:34 +01:00
}
2019-10-11 17:21:02 +02:00
if ( " tbl" %in% dots.names ) {
x <- dots [which ( dots.names == " tbl" ) ]
2019-05-13 14:56:23 +02:00
}
2018-10-23 11:15:05 +02:00
}
2019-10-11 17:21:02 +02:00
2020-05-16 13:05:47 +02:00
# remove data.table, grouping from tibbles, etc.
x <- as.data.frame ( x , stringsAsFactors = FALSE )
2020-11-17 16:57:41 +01:00
# try to find columns based on type
2018-10-23 11:15:05 +02:00
# -- mo
2019-01-15 12:45:24 +01:00
if ( is.null ( col_mo ) ) {
2019-05-23 16:58:59 +02:00
col_mo <- search_type_in_df ( x = x , type = " mo" )
2020-06-22 11:18:40 +02:00
stop_if ( is.null ( col_mo ) , " `col_mo` must be set" )
2020-09-14 19:41:48 +02:00
stop_ifnot ( col_mo %in% colnames ( x ) , " column '" , col_mo , " ' (`col_mo`) not found" )
2018-10-23 11:15:05 +02:00
}
2019-10-11 17:21:02 +02:00
2018-10-23 11:15:05 +02:00
# -- date
2018-12-10 15:14:29 +01:00
if ( is.null ( col_date ) ) {
2019-05-23 16:58:59 +02:00
col_date <- search_type_in_df ( x = x , type = " date" )
2020-06-22 11:18:40 +02:00
stop_if ( is.null ( col_date ) , " `col_date` must be set" )
2018-08-31 13:36:19 +02:00
}
2019-10-11 17:21:02 +02:00
2018-10-23 11:15:05 +02:00
# -- patient id
2019-01-15 12:45:24 +01:00
if ( is.null ( col_patient_id ) ) {
2019-10-11 17:21:02 +02:00
if ( all ( c ( " First name" , " Last name" , " Sex" ) %in% colnames ( x ) ) ) {
2019-01-29 20:20:09 +01:00
# WHONET support
2020-05-16 13:05:47 +02:00
x $ patient_id <- paste ( x $ `First name` , x $ `Last name` , x $ Sex )
2019-01-29 20:20:09 +01:00
col_patient_id <- " patient_id"
2020-12-03 16:59:04 +01:00
message_ ( " Using combined columns '" , font_bold ( " First name" ) , " ', '" , font_bold ( " Last name" ) , " ' and '" , font_bold ( " Sex" ) , " ' as input for `col_patient_id`" )
2019-01-29 20:20:09 +01:00
} else {
2019-05-23 16:58:59 +02:00
col_patient_id <- search_type_in_df ( x = x , type = " patient_id" )
2019-01-29 20:20:09 +01:00
}
2020-06-22 11:18:40 +02:00
stop_if ( is.null ( col_patient_id ) , " `col_patient_id` must be set" )
2018-12-10 15:14:29 +01:00
}
2019-10-11 17:21:02 +02:00
2018-12-10 15:14:29 +01:00
# -- key antibiotics
2019-01-15 12:45:24 +01:00
if ( is.null ( col_keyantibiotics ) ) {
2019-05-23 16:58:59 +02:00
col_keyantibiotics <- search_type_in_df ( x = x , type = " keyantibiotics" )
2018-12-10 15:14:29 +01:00
}
2020-10-21 15:28:48 +02:00
2019-01-29 00:06:50 +01:00
# -- specimen
2019-05-31 14:25:11 +02:00
if ( is.null ( col_specimen ) & ! is.null ( specimen_group ) ) {
2019-05-23 16:58:59 +02:00
col_specimen <- search_type_in_df ( x = x , type = " specimen" )
2019-01-29 00:06:50 +01:00
}
2019-10-11 17:21:02 +02:00
2018-03-19 20:39:23 +01:00
# check if columns exist
2019-05-13 14:56:23 +02:00
check_columns_existance <- function ( column , tblname = x ) {
2018-10-23 11:15:05 +02:00
if ( ! is.null ( column ) ) {
2020-06-22 11:18:40 +02:00
stop_ifnot ( column %in% colnames ( tblname ) ,
2020-12-22 00:51:17 +01:00
" Column '" , column , " ' not found." , call = FALSE )
2018-02-21 11:52:31 +01:00
}
}
2019-10-11 17:21:02 +02:00
2018-02-21 11:52:31 +01:00
check_columns_existance ( col_date )
2018-02-26 14:06:31 +01:00
check_columns_existance ( col_patient_id )
2018-08-31 13:36:19 +02:00
check_columns_existance ( col_mo )
2018-02-21 11:52:31 +01:00
check_columns_existance ( col_testcode )
check_columns_existance ( col_icu )
check_columns_existance ( col_keyantibiotics )
2019-10-11 17:21:02 +02:00
2020-07-22 10:24:23 +02:00
# convert dates to Date
dates <- as.Date ( x [ , col_date , drop = TRUE ] )
dates [is.na ( dates ) ] <- as.Date ( " 1970-01-01" )
x [ , col_date ] <- dates
2020-05-16 13:05:47 +02:00
# create original row index
x $ newvar_row_index <- seq_len ( nrow ( x ) )
2020-07-22 10:24:23 +02:00
x $ newvar_mo <- x [ , col_mo , drop = TRUE ]
2020-05-16 13:05:47 +02:00
x $ newvar_genus_species <- paste ( mo_genus ( x $ newvar_mo ) , mo_species ( x $ newvar_mo ) )
2020-07-22 10:24:23 +02:00
x $ newvar_date <- x [ , col_date , drop = TRUE ]
x $ newvar_patient_id <- x [ , col_patient_id , drop = TRUE ]
2019-08-08 22:39:42 +02:00
2018-10-23 11:15:05 +02:00
if ( is.null ( col_testcode ) ) {
testcodes_exclude <- NULL
2018-02-21 11:52:31 +01:00
}
2018-03-19 20:39:23 +01:00
# remove testcodes
2018-10-23 11:15:05 +02:00
if ( ! is.null ( testcodes_exclude ) & info == TRUE ) {
2020-10-27 15:56:51 +01:00
message_ ( " [Criterion] Exclude test codes: " , toString ( paste0 ( " '" , testcodes_exclude , " '" ) ) ,
add_fn = font_black ,
as_note = FALSE )
2018-02-21 11:52:31 +01:00
}
2019-10-11 17:21:02 +02:00
2018-10-23 11:15:05 +02:00
if ( is.null ( col_specimen ) ) {
2018-12-22 22:39:34 +01:00
specimen_group <- NULL
2018-03-19 20:39:23 +01:00
}
2019-10-11 17:21:02 +02:00
2018-03-19 20:39:23 +01:00
# filter on specimen group and keyantibiotics when they are filled in
2018-12-22 22:39:34 +01:00
if ( ! is.null ( specimen_group ) ) {
2019-05-13 14:56:23 +02:00
check_columns_existance ( col_specimen , x )
2018-02-21 11:52:31 +01:00
if ( info == TRUE ) {
2020-10-27 15:56:51 +01:00
message_ ( " [Criterion] Exclude other than specimen group '" , specimen_group , " '" ,
add_fn = font_black ,
as_note = FALSE )
2018-02-21 11:52:31 +01:00
}
}
2018-10-23 11:15:05 +02:00
if ( ! is.null ( col_keyantibiotics ) ) {
2020-05-16 13:05:47 +02:00
x $ newvar_key_ab <- x [ , col_keyantibiotics , drop = TRUE ]
2018-02-21 11:52:31 +01:00
}
2019-10-11 17:21:02 +02:00
2018-10-23 11:15:05 +02:00
if ( is.null ( testcodes_exclude ) ) {
2019-10-11 17:21:02 +02:00
testcodes_exclude <- " "
2018-02-21 11:52:31 +01:00
}
2019-10-11 17:21:02 +02:00
2019-08-08 22:39:42 +02:00
# arrange data to the right sorting
2018-12-22 22:39:34 +01:00
if ( is.null ( specimen_group ) ) {
2020-07-02 21:12:52 +02:00
x <- x [order ( x $ newvar_patient_id ,
x $ newvar_genus_species ,
x $ newvar_date ) , ]
rownames ( x ) <- NULL
row.start <- 1
row.end <- nrow ( x )
2018-02-21 11:52:31 +01:00
} else {
2020-05-16 13:05:47 +02:00
# filtering on specimen and only analyse these rows to save time
2020-09-18 16:05:53 +02:00
x <- x [order ( pm_pull ( x , col_specimen ) ,
2020-07-02 21:12:52 +02:00
x $ newvar_patient_id ,
x $ newvar_genus_species ,
x $ newvar_date ) , ]
rownames ( x ) <- NULL
suppressWarnings (
2020-09-18 16:05:53 +02:00
row.start <- which ( x %pm>% pm_pull ( col_specimen ) == specimen_group ) %pm>% min ( na.rm = TRUE )
2020-07-02 21:12:52 +02:00
)
suppressWarnings (
2020-09-18 16:05:53 +02:00
row.end <- which ( x %pm>% pm_pull ( col_specimen ) == specimen_group ) %pm>% max ( na.rm = TRUE )
2020-07-02 21:12:52 +02:00
)
2018-02-21 11:52:31 +01:00
}
2019-10-11 17:21:02 +02:00
2020-11-17 16:57:41 +01:00
# speed up - return immediately if obvious
2018-02-21 11:52:31 +01:00
if ( abs ( row.start ) == Inf | abs ( row.end ) == Inf ) {
if ( info == TRUE ) {
2020-11-17 16:57:41 +01:00
message_ ( " => Found " , font_bold ( " no isolates" ) ,
add_fn = font_black ,
as_note = FALSE )
2018-02-21 11:52:31 +01:00
}
2019-08-08 22:39:42 +02:00
return ( rep ( FALSE , nrow ( x ) ) )
2018-02-21 11:52:31 +01:00
}
2020-11-17 16:57:41 +01:00
if ( row.start == row.end ) {
if ( info == TRUE ) {
message_ ( " => Found " , font_bold ( " 1 isolate" ) , " , as the data only contained 1 row" ,
add_fn = font_black ,
as_note = FALSE )
}
return ( TRUE )
}
if ( length ( c ( row.start : row.end ) ) == pm_n_distinct ( x [c ( row.start : row.end ) , col_mo , drop = TRUE ] ) ) {
if ( info == TRUE ) {
message_ ( " => Found " , font_bold ( paste ( length ( c ( row.start : row.end ) ) , " isolates" ) ) ,
" , as all isolates were different microorganisms" ,
add_fn = font_black ,
as_note = FALSE )
}
return ( rep ( TRUE , length ( c ( row.start : row.end ) ) ) )
}
2019-08-08 22:39:42 +02:00
# did find some isolates - add new index numbers of rows
2020-05-16 13:05:47 +02:00
x $ newvar_row_index_sorted <- seq_len ( nrow ( x ) )
2020-07-02 21:12:52 +02:00
2020-06-26 12:31:27 +02:00
scope.size <- nrow ( x [which ( x $ newvar_row_index_sorted %in% c ( row.start + 1 : row.end ) &
! is.na ( x $ newvar_mo ) ) , , drop = FALSE ] )
2019-10-11 17:21:02 +02:00
2018-03-19 20:39:23 +01:00
# Analysis of first isolate ----
2020-09-18 16:05:53 +02:00
x $ other_pat_or_mo <- ifelse ( x $ newvar_patient_id == pm_lag ( x $ newvar_patient_id ) &
x $ newvar_genus_species == pm_lag ( x $ newvar_genus_species ) ,
2020-07-22 10:24:23 +02:00
FALSE ,
TRUE )
2020-05-16 13:05:47 +02:00
x $ episode_group <- paste ( x $ newvar_patient_id , x $ newvar_genus_species )
2020-07-02 21:12:52 +02:00
x $ more_than_episode_ago <- unlist ( lapply ( unique ( x $ episode_group ) ,
function ( g ,
df = x ,
days = episode_days ) {
2020-11-23 21:50:27 +01:00
is_new_episode ( x = df [which ( df $ episode_group == g ) , ] $ newvar_date ,
episode_days = days )
2020-07-02 21:12:52 +02:00
} ) )
2019-10-11 17:21:02 +02:00
weighted.notice <- " "
2018-10-23 11:15:05 +02:00
if ( ! is.null ( col_keyantibiotics ) ) {
2019-10-11 17:21:02 +02:00
weighted.notice <- " weighted "
2018-02-21 11:52:31 +01:00
if ( info == TRUE ) {
2019-10-11 17:21:02 +02:00
if ( type == " keyantibiotics" ) {
2020-10-27 15:56:51 +01:00
message_ ( " [Criterion] Base inclusion on key antibiotics, " ,
ifelse ( ignore_I == FALSE , " not " , " " ) ,
" ignoring I" ,
add_fn = font_black ,
as_note = FALSE )
2018-03-19 20:39:23 +01:00
}
2019-10-11 17:21:02 +02:00
if ( type == " points" ) {
2020-10-27 15:56:51 +01:00
message_ ( " [Criterion] Base inclusion on key antibiotics, using points threshold of "
, points_threshold ,
add_fn = font_black ,
as_note = FALSE )
2018-03-19 20:39:23 +01:00
}
2018-02-21 11:52:31 +01:00
}
2018-03-19 21:03:23 +01:00
type_param <- type
2019-08-08 22:39:42 +02:00
2020-05-16 13:05:47 +02:00
x $ other_key_ab <- ! key_antibiotics_equal ( y = x $ newvar_key_ab ,
2020-09-18 16:05:53 +02:00
z = pm_lag ( x $ newvar_key_ab ) ,
2020-07-02 21:12:52 +02:00
type = type_param ,
ignore_I = ignore_I ,
points_threshold = points_threshold ,
info = info )
2020-05-16 13:05:47 +02:00
# with key antibiotics
2020-09-18 16:05:53 +02:00
x $ newvar_first_isolate <- pm_if_else ( x $ newvar_row_index_sorted >= row.start &
2020-10-19 17:09:19 +02:00
x $ newvar_row_index_sorted <= row.end &
x $ newvar_genus_species != " " &
( x $ other_pat_or_mo | x $ more_than_episode_ago | x $ other_key_ab ) ,
TRUE ,
FALSE )
2019-08-08 22:39:42 +02:00
2018-02-21 11:52:31 +01:00
} else {
2018-12-31 01:48:53 +01:00
# no key antibiotics
2020-09-18 16:05:53 +02:00
x $ newvar_first_isolate <- pm_if_else ( x $ newvar_row_index_sorted >= row.start &
2020-10-19 17:09:19 +02:00
x $ newvar_row_index_sorted <= row.end &
x $ newvar_genus_species != " " &
( x $ other_pat_or_mo | x $ more_than_episode_ago ) ,
TRUE ,
FALSE )
2018-02-21 11:52:31 +01:00
}
2019-10-11 17:21:02 +02:00
2018-03-19 20:39:23 +01:00
# first one as TRUE
2020-05-16 13:05:47 +02:00
x [row.start , " newvar_first_isolate" ] <- TRUE
2018-03-19 20:39:23 +01:00
# no tests that should be included, or ICU
2018-10-23 11:15:05 +02:00
if ( ! is.null ( col_testcode ) ) {
2020-05-16 13:05:47 +02:00
x [which ( x [ , col_testcode ] %in% tolower ( testcodes_exclude ) ) , " newvar_first_isolate" ] <- FALSE
2018-02-21 11:52:31 +01:00
}
2020-05-16 13:05:47 +02:00
if ( ! is.null ( col_icu ) ) {
if ( icu_exclude == TRUE ) {
2020-10-27 15:56:51 +01:00
message_ ( " [Criterion] Exclude isolates from ICU." ,
add_fn = font_black ,
as_note = FALSE )
2020-05-16 13:05:47 +02:00
x [which ( as.logical ( x [ , col_icu , drop = TRUE ] ) ) , " newvar_first_isolate" ] <- FALSE
} else {
2020-10-27 15:56:51 +01:00
message_ ( " [Criterion] Include isolates from ICU." ,
add_fn = font_black ,
as_note = FALSE )
2020-05-16 13:05:47 +02:00
}
2018-02-21 11:52:31 +01:00
}
2019-08-08 22:39:42 +02:00
decimal.mark <- getOption ( " OutDec" )
big.mark <- ifelse ( decimal.mark != " ," , " ," , " ." )
# handle empty microorganisms
2020-05-16 13:05:47 +02:00
if ( any ( x $ newvar_mo == " UNKNOWN" , na.rm = TRUE ) & info == TRUE ) {
2020-10-27 15:56:51 +01:00
message_ ( ifelse ( include_unknown == TRUE , " Included " , " Excluded " ) ,
format ( sum ( x $ newvar_mo == " UNKNOWN" , na.rm = TRUE ) ,
decimal.mark = decimal.mark , big.mark = big.mark ) ,
2020-12-07 16:06:42 +01:00
" isolates with a microbial ID 'UNKNOWN' (column '" , font_bold ( col_mo ) , " ')" )
2019-08-08 22:39:42 +02:00
}
2020-05-16 13:05:47 +02:00
x [which ( x $ newvar_mo == " UNKNOWN" ) , " newvar_first_isolate" ] <- include_unknown
2019-08-08 22:39:42 +02:00
# exclude all NAs
2020-05-16 13:05:47 +02:00
if ( any ( is.na ( x $ newvar_mo ) ) & info == TRUE ) {
2020-10-27 15:56:51 +01:00
message_ ( " Excluded " , format ( sum ( is.na ( x $ newvar_mo ) , na.rm = TRUE ) ,
decimal.mark = decimal.mark , big.mark = big.mark ) ,
2020-12-07 16:06:42 +01:00
" isolates with a microbial ID 'NA' (column '" , font_bold ( col_mo ) , " ')" )
2019-08-08 22:39:42 +02:00
}
2020-05-16 13:05:47 +02:00
x [which ( is.na ( x $ newvar_mo ) ) , " newvar_first_isolate" ] <- FALSE
2019-08-08 22:39:42 +02:00
# arrange back according to original sorting again
2020-05-16 13:05:47 +02:00
x <- x [order ( x $ newvar_row_index ) , ]
rownames ( x ) <- NULL
2019-08-08 22:39:42 +02:00
2018-02-21 11:52:31 +01:00
if ( info == TRUE ) {
2020-09-03 12:31:48 +02:00
n_found <- sum ( x $ newvar_first_isolate , na.rm = TRUE )
2020-09-18 16:05:53 +02:00
p_found_total <- percentage ( n_found / nrow ( x [which ( ! is.na ( x $ newvar_mo ) ) , , drop = FALSE ] ) , digits = 1 )
p_found_scope <- percentage ( n_found / scope.size , digits = 1 )
if ( ! p_found_total %like% " [.]" ) {
p_found_total <- gsub ( " %" , " .0%" , p_found_total , fixed = TRUE )
}
if ( ! p_found_scope %like% " [.]" ) {
p_found_scope <- gsub ( " %" , " .0%" , p_found_scope , fixed = TRUE )
}
2018-12-22 22:39:34 +01:00
# mark up number of found
2020-09-03 12:31:48 +02:00
n_found <- format ( n_found , big.mark = big.mark , decimal.mark = decimal.mark )
2018-12-22 22:39:34 +01:00
if ( p_found_total != p_found_scope ) {
msg_txt <- paste0 ( " => Found " ,
2020-05-16 13:05:47 +02:00
font_bold ( paste0 ( n_found , " first " , weighted.notice , " isolates" ) ) ,
2020-06-26 12:31:27 +02:00
" (" , p_found_scope , " within scope and " , p_found_total , " of total where a microbial ID was available)" )
2018-12-22 22:39:34 +01:00
} else {
msg_txt <- paste0 ( " => Found " ,
2020-05-16 13:05:47 +02:00
font_bold ( paste0 ( n_found , " first " , weighted.notice , " isolates" ) ) ,
2020-06-26 12:31:27 +02:00
" (" , p_found_total , " of total where a microbial ID was available)" )
2018-12-22 22:39:34 +01:00
}
2020-10-27 15:56:51 +01:00
message_ ( msg_txt , add_fn = font_black , as_note = FALSE )
2018-02-21 11:52:31 +01:00
}
2019-10-11 17:21:02 +02:00
2020-05-16 13:05:47 +02:00
x $ newvar_first_isolate
2019-10-11 17:21:02 +02:00
2018-02-21 11:52:31 +01:00
}
2018-12-22 22:39:34 +01:00
#' @rdname first_isolate
#' @export
2019-05-13 14:56:23 +02:00
filter_first_isolate <- function ( x ,
2018-12-22 22:39:34 +01:00
col_date = NULL ,
col_patient_id = NULL ,
col_mo = NULL ,
... ) {
2020-10-19 17:09:19 +02:00
meet_criteria ( x , allow_class = " data.frame" )
meet_criteria ( col_date , allow_class = " character" , has_length = 1 , allow_NULL = TRUE , is_in = colnames ( x ) )
meet_criteria ( col_patient_id , allow_class = " character" , has_length = 1 , allow_NULL = TRUE , is_in = colnames ( x ) )
meet_criteria ( col_mo , allow_class = " character" , has_length = 1 , allow_NULL = TRUE , is_in = colnames ( x ) )
2020-05-18 10:30:53 +02:00
subset ( x , first_isolate ( x = x ,
2019-05-23 16:58:59 +02:00
col_date = col_date ,
col_patient_id = col_patient_id ,
col_mo = col_mo ,
... ) )
2018-12-22 22:39:34 +01:00
}
#' @rdname first_isolate
#' @export
2019-05-13 14:56:23 +02:00
filter_first_weighted_isolate <- function ( x ,
2018-12-22 22:39:34 +01:00
col_date = NULL ,
col_patient_id = NULL ,
col_mo = NULL ,
col_keyantibiotics = NULL ,
... ) {
2020-10-19 17:09:19 +02:00
meet_criteria ( x , allow_class = " data.frame" )
meet_criteria ( col_date , allow_class = " character" , has_length = 1 , allow_NULL = TRUE , is_in = colnames ( x ) )
meet_criteria ( col_patient_id , allow_class = " character" , has_length = 1 , allow_NULL = TRUE , is_in = colnames ( x ) )
meet_criteria ( col_mo , allow_class = " character" , has_length = 1 , allow_NULL = TRUE , is_in = colnames ( x ) )
meet_criteria ( col_keyantibiotics , allow_class = " character" , has_length = 1 , allow_NULL = TRUE , is_in = colnames ( x ) )
2020-05-18 10:30:53 +02:00
y <- x
if ( is.null ( col_keyantibiotics ) ) {
# first try to look for it
col_keyantibiotics <- search_type_in_df ( x = x , type = " keyantibiotics" )
# still NULL? Then create it since we are calling filter_first_WEIGHTED_isolate()
if ( is.null ( col_keyantibiotics ) ) {
y $ keyab <- suppressMessages ( key_antibiotics ( x ,
col_mo = col_mo ,
... ) )
col_keyantibiotics <- " keyab"
}
}
2020-07-02 21:12:52 +02:00
2020-05-18 10:30:53 +02:00
subset ( x , first_isolate ( x = y ,
col_date = col_date ,
2020-11-23 21:50:27 +01:00
col_patient_id = col_patient_id ) )
2020-11-17 16:57:41 +01:00
}