2018-02-21 11:52:31 +01:00
# ==================================================================== #
# TITLE #
# Antimicrobial Resistance (AMR) Analysis #
# #
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-01-05 17:22:09 +01:00
# (c) 2018-2020 Berends MS, Luz CF et al. #
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-07-08 14:48:06 +02:00
# Visit our website for more info: https://msberends.github.io/AMR. #
2018-02-21 11:52:31 +01:00
# ==================================================================== #
#' Class 'mic'
#'
2019-11-28 22:32:17 +01:00
#' This transforms a vector to a new class [`mic`], which is an ordered [`factor`] with valid MIC values as levels. Invalid MIC values will be translated as `NA` with a warning.
2020-01-05 17:22:09 +01:00
#' @inheritSection lifecycle Stable lifecycle
2018-02-21 11:52:31 +01:00
#' @rdname as.mic
#' @param x vector
#' @param na.rm a logical indicating whether missing values should be removed
2019-11-28 22:32:17 +01:00
#' @details To interpret MIC values as RSI values, use [as.rsi()] on MIC values. It supports guidelines from EUCAST and CLSI.
#' @return Ordered [`factor`] with new class [`mic`]
2019-11-28 23:00:37 +01:00
#' @aliases mic
2018-02-21 11:52:31 +01:00
#' @export
2019-11-28 22:32:17 +01:00
#' @seealso [as.rsi()]
2019-01-02 23:24:07 +01:00
#' @inheritSection AMR Read more on our website!
2018-02-22 20:48:48 +01:00
#' @examples
#' mic_data <- as.mic(c(">=32", "1.0", "1", "1.00", 8, "<=0.128", "8", "16", "16"))
#' is.mic(mic_data)
2018-04-02 16:05:09 +02:00
#'
2018-06-19 10:05:38 +02:00
#' # this can also coerce combined MIC/RSI values:
2018-07-25 14:17:04 +02:00
#' as.mic("<=0.002; S") # will return <=0.002
2018-06-19 10:05:38 +02:00
#'
2019-05-10 16:44:59 +02:00
#' # interpret MIC values
#' as.rsi(x = as.mic(2),
#' mo = as.mo("S. pneumoniae"),
#' ab = "AMX",
#' guideline = "EUCAST")
#' as.rsi(x = as.mic(4),
#' mo = as.mo("S. pneumoniae"),
#' ab = "AMX",
#' guideline = "EUCAST")
#'
2018-02-22 20:48:48 +01:00
#' plot(mic_data)
2018-03-13 14:34:10 +01:00
#' barplot(mic_data)
2018-02-21 11:52:31 +01:00
as.mic <- function ( x , na.rm = FALSE ) {
if ( is.mic ( x ) ) {
x
} else {
x <- x %>% unlist ( )
if ( na.rm == TRUE ) {
x <- x [ ! is.na ( x ) ]
}
x.bak <- x
2020-07-13 09:17:24 +02:00
2018-06-19 10:05:38 +02:00
# comma to period
2019-10-11 17:21:02 +02:00
x <- gsub ( " ," , " ." , x , fixed = TRUE )
2020-02-20 13:19:23 +01:00
# transform Unicode for >= and <=
x <- gsub ( " \u2264" , " <=" , x , fixed = TRUE )
x <- gsub ( " \u2265" , " >=" , x , fixed = TRUE )
2018-06-19 10:05:38 +02:00
# remove space between operator and number ("<= 0.002" -> "<=0.002")
2019-10-11 17:21:02 +02:00
x <- gsub ( " (<|=|>) +" , " \\1" , x )
2019-10-08 22:21:33 +02:00
# transform => to >= and =< to <=
2019-10-11 17:21:02 +02:00
x <- gsub ( " =<" , " <=" , x , fixed = TRUE )
2020-02-20 13:19:23 +01:00
x <- gsub ( " =>" , " >=" , x , fixed = TRUE )
2020-07-30 12:37:01 +02:00
# dots without a leading zero must start with 0
x <- gsub ( " ([^0-9]|^)[.]" , " \\10." , x )
2020-04-29 14:33:44 +02:00
# values like "<=0.2560.512" should be 0.512
2019-10-11 17:21:02 +02:00
x <- gsub ( " .*[.].*[.]" , " 0." , x )
2018-02-21 11:52:31 +01:00
# remove ending .0
2019-10-11 17:21:02 +02:00
x <- gsub ( " [.]+0$" , " " , x )
2018-02-21 11:52:31 +01:00
# remove all after last digit
2019-10-11 17:21:02 +02:00
x <- gsub ( " [^0-9]+$" , " " , x )
2019-10-08 22:21:33 +02:00
# keep only one zero before dot
x <- gsub ( " 0+[.]" , " 0." , x )
# starting 00 is probably 0.0 if there's no dot yet
x [ ! x %like% " [.]" ] <- gsub ( " ^00" , " 0.0" , x [ ! x %like% " [.]" ] )
2018-02-21 11:52:31 +01:00
# remove last zeroes
2019-10-11 17:21:02 +02:00
x <- gsub ( " ([.].?)0+$" , " \\1" , x )
x <- gsub ( " (.*[.])0+$" , " \\10" , x )
2018-12-29 22:24:19 +01:00
# remove ending .0 again
2019-10-11 17:21:02 +02:00
x [x %like% " [.]" ] <- gsub ( " 0+$" , " " , x [x %like% " [.]" ] )
2020-04-29 14:33:44 +02:00
# never end with dot
x <- gsub ( " [.]$" , " " , x )
2018-06-19 10:05:38 +02:00
# force to be character
x <- as.character ( x )
2019-10-08 22:21:33 +02:00
# trim it
x <- trimws ( x )
2020-04-29 14:33:44 +02:00
2019-05-10 16:44:59 +02:00
## previously unempty values now empty - should return a warning later on
2018-08-24 11:08:20 +02:00
x [x.bak != " " & x == " " ] <- " invalid"
2020-07-13 09:17:24 +02:00
2019-05-10 16:44:59 +02:00
# these are allowed MIC values and will become factor levels
2019-11-03 22:24:42 +01:00
ops <- c ( " <" , " <=" , " " , " >=" , " >" )
lvls <- c ( c ( t ( sapply ( ops , function ( x ) paste0 ( x , " 0.00" , 1 : 9 ) ) ) ) ,
unique ( c ( t ( sapply ( ops , function ( x ) paste0 ( x , sort ( as.double ( paste0 ( " 0.0" ,
sort ( c ( 1 : 99 , 125 , 128 , 256 , 512 , 625 ) ) ) ) ) ) ) ) ) ) ,
unique ( c ( t ( sapply ( ops , function ( x ) paste0 ( x , sort ( as.double ( paste0 ( " 0." ,
c ( 1 : 99 , 125 , 128 , 256 , 512 ) ) ) ) ) ) ) ) ) ,
c ( t ( sapply ( ops , function ( x ) paste0 ( x , sort ( c ( 1 : 9 , 1.5 ) ) ) ) ) ) ,
c ( t ( sapply ( ops , function ( x ) paste0 ( x , c ( 10 : 98 ) [9 : 98 %% 2 == TRUE ] ) ) ) ) ,
c ( t ( sapply ( ops , function ( x ) paste0 ( x , sort ( c ( 2 ^ c ( 7 : 10 ) , 80 * c ( 2 : 12 ) ) ) ) ) ) ) )
2020-07-13 09:17:24 +02:00
2019-10-11 17:21:02 +02:00
na_before <- x [is.na ( x ) | x == " " ] %>% length ( )
2018-02-21 11:52:31 +01:00
x [ ! x %in% lvls ] <- NA
2019-10-11 17:21:02 +02:00
na_after <- x [is.na ( x ) | x == " " ] %>% length ( )
2020-07-13 09:17:24 +02:00
2018-02-21 11:52:31 +01:00
if ( na_before != na_after ) {
2019-10-11 17:21:02 +02:00
list_missing <- x.bak [is.na ( x ) & ! is.na ( x.bak ) & x.bak != " " ] %>%
2018-02-21 11:52:31 +01:00
unique ( ) %>%
sort ( )
2019-10-11 17:21:02 +02:00
list_missing <- paste0 ( ' "' , list_missing , ' "' , collapse = " , " )
warning ( na_after - na_before , " results truncated (" ,
2018-03-19 20:39:23 +01:00
round ( ( ( na_after - na_before ) / length ( x ) ) * 100 ) ,
2019-10-11 17:21:02 +02:00
" %) that were invalid MICs: " ,
2018-02-21 11:52:31 +01:00
list_missing , call. = FALSE )
}
2020-07-13 09:17:24 +02:00
2019-08-07 15:37:39 +02:00
structure ( .Data = factor ( x , levels = lvls , ordered = TRUE ) ,
2019-10-11 17:21:02 +02:00
class = c ( " mic" , " ordered" , " factor" ) )
2018-02-21 11:52:31 +01:00
}
}
2020-02-20 13:19:23 +01:00
all_valid_mics <- function ( x ) {
2020-06-26 10:21:22 +02:00
x_mic <- tryCatch ( suppressWarnings ( as.mic ( x [ ! is.na ( x ) ] ) ) ,
error = function ( e ) NA )
2020-02-20 13:19:23 +01:00
! any ( is.na ( x_mic ) ) & ! all ( is.na ( x ) )
}
2018-02-21 11:52:31 +01:00
#' @rdname as.mic
#' @export
is.mic <- function ( x ) {
2020-02-10 14:18:15 +01:00
inherits ( x , " mic" )
2018-02-21 11:52:31 +01:00
}
2020-05-28 16:48:55 +02:00
#' @method as.double mic
2018-02-21 11:52:31 +01:00
#' @export
#' @noRd
as.double.mic <- function ( x , ... ) {
2019-10-11 17:21:02 +02:00
as.double ( gsub ( " (<|=|>)+" , " " , as.character ( x ) ) )
2018-02-21 11:52:31 +01:00
}
2020-05-28 16:48:55 +02:00
#' @method as.integer mic
2018-02-21 11:52:31 +01:00
#' @export
#' @noRd
as.integer.mic <- function ( x , ... ) {
2019-10-11 17:21:02 +02:00
as.integer ( gsub ( " (<|=|>)+" , " " , as.character ( x ) ) )
2018-02-21 11:52:31 +01:00
}
2020-05-28 16:48:55 +02:00
#' @method as.numeric mic
2018-02-21 11:52:31 +01:00
#' @export
#' @noRd
as.numeric.mic <- function ( x , ... ) {
2019-10-11 17:21:02 +02:00
as.numeric ( gsub ( " (<|=|>)+" , " " , as.character ( x ) ) )
2018-02-21 11:52:31 +01:00
}
2020-05-28 16:48:55 +02:00
#' @method droplevels mic
2018-12-29 22:24:19 +01:00
#' @export
#' @noRd
2019-10-11 17:21:02 +02:00
droplevels.mic <- function ( x , exclude = ifelse ( anyNA ( levels ( x ) ) , NULL , NA ) , ... ) {
2018-12-29 22:24:19 +01:00
x <- droplevels.factor ( x , exclude = exclude , ... )
2019-10-11 17:21:02 +02:00
class ( x ) <- c ( " mic" , " ordered" , " factor" )
2018-12-29 22:24:19 +01:00
x
}
2020-05-28 16:48:55 +02:00
#' @method print mic
2018-02-21 11:52:31 +01:00
#' @export
#' @noRd
print.mic <- function ( x , ... ) {
2020-05-27 16:37:49 +02:00
cat ( " Class <mic>\n" )
2018-08-01 22:37:28 +02:00
print ( as.character ( x ) , quote = FALSE )
2018-02-21 11:52:31 +01:00
}
2020-05-28 16:48:55 +02:00
#' @method summary mic
2018-02-21 11:52:31 +01:00
#' @export
#' @noRd
summary.mic <- function ( object , ... ) {
x <- object
n_total <- x %>% length ( )
x <- x [ ! is.na ( x ) ]
n <- x %>% length ( )
2018-12-07 12:04:55 +01:00
c (
2019-10-11 17:21:02 +02:00
" Class" = " mic" ,
2018-12-07 12:04:55 +01:00
" <NA>" = n_total - n ,
" Min." = sort ( x ) [1 ] %>% as.character ( ) ,
" Max." = sort ( x ) [n ] %>% as.character ( )
)
2018-02-21 11:52:31 +01:00
}
2020-05-28 16:48:55 +02:00
#' @method plot mic
2018-02-21 11:52:31 +01:00
#' @export
2019-06-16 22:14:43 +02:00
#' @importFrom graphics barplot axis par
2018-02-21 11:52:31 +01:00
#' @noRd
2019-06-16 21:42:40 +02:00
plot.mic <- function ( x ,
2019-10-11 17:21:02 +02:00
main = paste ( " MIC values of" , deparse ( substitute ( x ) ) ) ,
ylab = " Frequency" ,
xlab = " MIC value" ,
2019-06-16 21:42:40 +02:00
axes = FALSE ,
... ) {
barplot ( table ( droplevels.factor ( x ) ) ,
ylab = ylab ,
xlab = xlab ,
axes = axes ,
main = main ,
... )
axis ( 2 , seq ( 0 , max ( table ( droplevels.factor ( x ) ) ) ) )
2018-03-13 14:34:10 +01:00
}
2020-05-28 16:48:55 +02:00
#' @method barplot mic
2018-03-13 14:34:10 +01:00
#' @export
2018-03-13 15:40:10 +01:00
#' @importFrom graphics barplot axis
2018-03-13 14:34:10 +01:00
#' @noRd
2019-06-16 21:42:40 +02:00
barplot.mic <- function ( height ,
2019-10-11 17:21:02 +02:00
main = paste ( " MIC values of" , deparse ( substitute ( height ) ) ) ,
ylab = " Frequency" ,
xlab = " MIC value" ,
2019-06-16 21:42:40 +02:00
axes = FALSE ,
... ) {
barplot ( table ( droplevels.factor ( height ) ) ,
ylab = ylab ,
xlab = xlab ,
axes = axes ,
main = main ,
2018-03-13 14:34:10 +01:00
... )
2019-06-16 21:42:40 +02:00
axis ( 2 , seq ( 0 , max ( table ( droplevels.factor ( height ) ) ) ) )
2018-02-21 11:52:31 +01:00
}
2019-08-07 15:37:39 +02:00
2020-05-28 16:48:55 +02:00
#' @method [ mic
2020-04-13 21:09:56 +02:00
#' @export
#' @noRd
" [.mic" <- function ( x , ... ) {
y <- NextMethod ( )
attributes ( y ) <- attributes ( x )
y
}
2020-05-28 16:48:55 +02:00
#' @method [[ mic
2020-04-13 21:09:56 +02:00
#' @export
#' @noRd
" [[.mic" <- function ( x , ... ) {
y <- NextMethod ( )
attributes ( y ) <- attributes ( x )
y
}
2020-05-28 16:48:55 +02:00
#' @method [<- mic
2020-04-13 21:09:56 +02:00
#' @export
#' @noRd
" [<-.mic" <- function ( i , j , ... , value ) {
value <- as.mic ( value )
y <- NextMethod ( )
attributes ( y ) <- attributes ( i )
y
}
2020-05-28 16:48:55 +02:00
#' @method [[<- mic
2020-04-13 21:09:56 +02:00
#' @export
#' @noRd
" [[<-.mic" <- function ( i , j , ... , value ) {
value <- as.mic ( value )
y <- NextMethod ( )
attributes ( y ) <- attributes ( i )
y
}
2020-05-28 16:48:55 +02:00
#' @method c mic
2020-04-13 21:09:56 +02:00
#' @export
#' @noRd
c.mic <- function ( x , ... ) {
y <- NextMethod ( )
2020-04-14 14:12:31 +02:00
attributes ( y ) <- attributes ( x )
2020-04-13 21:09:56 +02:00
y
}