2018-06-08 12:06:54 +02:00
# ==================================================================== #
# TITLE #
# Antimicrobial Resistance (AMR) Analysis #
# #
2019-01-02 23:24:07 +01:00
# SOURCE #
# https://gitlab.com/msberends/AMR #
2018-06-08 12:06:54 +02:00
# #
# LICENCE #
2019-01-02 23:24:07 +01:00
# (c) 2019 Berends MS (m.s.berends@umcg.nl), Luz CF (c.f.luz@umcg.nl) #
2018-06-08 12:06:54 +02: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. #
# #
# This R package was created for academic research and was publicly #
# released in the hope that it will be useful, but it comes WITHOUT #
# ANY WARRANTY OR LIABILITY. #
# Visit our website for more info: https://msberends.gitab.io/AMR. #
2018-06-08 12:06:54 +02:00
# ==================================================================== #
2018-08-31 13:36:19 +02:00
#' Transform to microorganism ID
2018-06-08 12:06:54 +02:00
#'
2019-02-27 11:36:12 +01:00
#' Use this function to determine a valid microorganism ID (\code{mo}). Determination is done using Artificial Intelligence (AI) and the complete taxonomic kingdoms Archaea, Bacteria, Protozoa, Viruses and most microbial species from the kingdom Fungi (see Source), so the input can be almost anything: a full name (like \code{"Staphylococcus aureus"}), an abbreviated name (like \code{"S. aureus"}), an abbreviation known in the field (like \code{"MRSA"}), or just a genus. You could also \code{\link{select}} a genus and species column, zie Examples.
2018-09-04 11:33:30 +02:00
#' @param x a character vector or a \code{data.frame} with one or two columns
#' @param Becker a logical to indicate whether \emph{Staphylococci} should be categorised into Coagulase Negative \emph{Staphylococci} ("CoNS") and Coagulase Positive \emph{Staphylococci} ("CoPS") instead of their own species, according to Karsten Becker \emph{et al.} [1].
#'
#' This excludes \emph{Staphylococcus aureus} at default, use \code{Becker = "all"} to also categorise \emph{S. aureus} as "CoPS".
2018-09-24 23:33:29 +02:00
#' @param Lancefield a logical to indicate whether beta-haemolytic \emph{Streptococci} should be categorised into Lancefield groups instead of their own species, according to Rebecca C. Lancefield [2]. These \emph{Streptococci} will be categorised in their first group, e.g. \emph{Streptococcus dysgalactiae} will be group C, although officially it was also categorised into groups G and L.
2018-09-04 11:33:30 +02:00
#'
#' This excludes \emph{Enterococci} at default (who are in group D), use \code{Lancefield = "all"} to also categorise all \emph{Enterococci} as group D.
2018-12-07 12:04:55 +01:00
#' @param allow_uncertain a logical to indicate whether the input should be checked for less possible results, see Details
2019-01-21 15:53:01 +01:00
#' @param reference_df a \code{data.frame} to use for extra reference when translating \code{x} to a valid \code{mo}. See \code{\link{set_mo_source}} and \code{\link{get_mo_source}} to automate the usage of your own codes (e.g. used in your analysis or organisation).
2018-08-31 13:36:19 +02:00
#' @rdname as.mo
#' @aliases mo
#' @keywords mo Becker becker Lancefield lancefield guess
2018-09-24 23:33:29 +02:00
#' @details
2018-10-01 11:39:43 +02:00
#' A microbial ID from this package (class: \code{mo}) typically looks like these examples:\cr
2018-09-24 23:33:29 +02:00
#' \preformatted{
2018-12-07 12:04:55 +01:00
#' Code Full name
#' --------------- --------------------------------------
#' B_KLBSL Klebsiella
#' B_KLBSL_PNE Klebsiella pneumoniae
#' B_KLBSL_PNE_RHI Klebsiella pneumoniae rhinoscleromatis
2018-09-24 23:33:29 +02:00
#' | | | |
#' | | | |
#' | | | ----> subspecies, a 3-4 letter acronym
#' | | ----> species, a 3-4 letter acronym
#' | ----> genus, a 5-7 letter acronym, mostly without vowels
2019-02-18 02:33:37 +01:00
#' ----> taxonomic kingdom: A (Archaea), B (Bacteria), C (Chromista),
#' F (Fungi), P (Protozoa) or V (Viruses)
2018-09-24 23:33:29 +02:00
#' }
2018-08-01 08:03:31 +02:00
#'
2018-09-04 11:33:30 +02:00
#' Use the \code{\link{mo_property}} functions to get properties based on the returned code, see Examples.
2018-08-28 13:51:13 +02:00
#'
2018-10-31 12:10:49 +01:00
#' This function uses Artificial Intelligence (AI) to help getting fast and logical results. It tries to find matches in this order:
#' \itemize{
2019-02-08 16:06:54 +01:00
#' \item{Taxonomic kingdom: it first searches in Bacteria, then Fungi, then Protozoa}
2019-02-25 10:42:57 +01:00
#' \item{Human pathogenic prevalence: it first searches in more prevalent microorganisms, then less prevalent ones (see section \emph{Microbial prevalence of pathogens in humans})}
2018-11-24 20:25:09 +01:00
#' \item{Valid MO codes and full names: it first searches in already valid MO code and known genus/species combinations}
2018-10-31 12:10:49 +01:00
#' \item{Breakdown of input values: from here it starts to breakdown input values to find possible matches}
#' }
#'
2018-12-07 12:04:55 +01:00
#' A couple of effects because of these rules:
2018-07-23 14:14:03 +02:00
#' \itemize{
#' \item{\code{"E. coli"} will return the ID of \emph{Escherichia coli} and not \emph{Entamoeba coli}, although the latter would alphabetically come first}
2018-09-16 16:43:29 +02:00
#' \item{\code{"H. influenzae"} will return the ID of \emph{Haemophilus influenzae} and not \emph{Haematobacter influenzae} for the same reason}
#' \item{Something like \code{"stau"} or \code{"S aur"} will return the ID of \emph{Staphylococcus aureus} and not \emph{Staphylococcus auricularis}}
2018-07-23 14:14:03 +02:00
#' }
2018-10-01 11:39:43 +02:00
#' This means that looking up human pathogenic microorganisms takes less time than looking up human \strong{non}-pathogenic microorganisms.
2018-09-24 23:33:29 +02:00
#'
2019-02-08 16:06:54 +01:00
#' \strong{UNCERTAIN RESULTS} \cr
#' When using \code{allow_uncertain = TRUE} (which is the default setting), it will use additional rules if all previous AI rules failed to get valid results. These are:
#' \itemize{
#' \item{It tries to look for previously accepted (but now invalid) taxonomic names}
#' \item{It strips off values between brackets and the brackets itself, and re-evaluates the input with all previous rules}
#' \item{It strips off words from the end one by one and re-evaluates the input with all previous rules}
#' \item{It strips off words from the start one by one and re-evaluates the input with all previous rules}
2019-02-27 11:36:12 +01:00
#' \item{It tries to look for some manual changes which are not (yet) published to the Catalogue of Life (like \emph{Propionibacterium} being \emph{Cutibacterium})}
2019-02-08 16:06:54 +01:00
#' }
#'
#' Examples:
2018-12-07 12:04:55 +01:00
#' \itemize{
2019-02-18 02:33:37 +01:00
#' \item{\code{"Streptococcus group B (known as S. agalactiae)"}. The text between brackets will be removed and a warning will be thrown that the result \emph{Streptococcus group B} (\code{B_STRPT_GRB}) needs review.}
2018-12-07 12:04:55 +01:00
#' \item{\code{"S. aureus - please mind: MRSA"}. The last word will be stripped, after which the function will try to find a match. If it does not, the second last word will be stripped, etc. Again, a warning will be thrown that the result \emph{Staphylococcus aureus} (\code{B_STPHY_AUR}) needs review.}
2019-02-08 16:06:54 +01:00
#' \item{\code{"Fluoroquinolone-resistant Neisseria gonorrhoeae"}. The first word will be stripped, after which the function will try to find a match. A warning will be thrown that the result \emph{Neisseria gonorrhoeae} (\code{B_NESSR_GON}) needs review.}
2018-12-07 12:04:55 +01:00
#' }
#'
2019-02-08 16:06:54 +01:00
#' Use \code{mo_failures()} to get a vector with all values that could not be coerced to a valid value.
#'
2019-02-27 11:36:12 +01:00
#' Use \code{mo_uncertainties()} to get info about all values that were coerced to a valid value, but with uncertainty.
2019-02-08 16:06:54 +01:00
#'
#' Use \code{mo_renamed()} to get a vector with all values that could be coerced based on an old, previously accepted taxonomic name.
#'
2019-02-25 10:42:57 +01:00
#' @section Microbial prevalence of pathogens in humans:
#' The artificial intelligence takes into account microbial prevalence of pathogens in humans. It uses three groups and every (sub)species is in the group it matches first. These groups are:
#' \itemize{
#' \item{1 (most prevalent): class is Gammaproteobacteria \strong{or} genus is one of: \emph{Enterococcus}, \emph{Staphylococcus}, \emph{Streptococcus}.}
2019-02-25 15:52:32 +01:00
#' \item{2: phylum is one of: Proteobacteria, Firmicutes, Actinobacteria, Sarcomastigophora \strong{or} genus is one of: \emph{Aspergillus}, \emph{Bacteroides}, \emph{Candida}, \emph{Capnocytophaga}, \emph{Chryseobacterium}, \emph{Cryptococcus}, \emph{Elisabethkingia}, \emph{Flavobacterium}, \emph{Fusobacterium}, \emph{Giardia}, \emph{Leptotrichia}, \emph{Mycoplasma}, \emph{Prevotella}, \emph{Rhodotorula}, \emph{Treponema}, \emph{Trichophyton}, \emph{Ureaplasma}.}
2019-02-25 10:42:57 +01:00
#' \item{3 (least prevalent): all others.}
#' }
#'
#' Group 1 contains all common Gram negatives, like all Enterobacteriaceae and e.g. \emph{Pseudomonas} and \emph{Legionella}.
#'
#' Group 2 probably contains all microbial pathogens ever found in humans.
2019-02-20 00:04:48 +01:00
#' @inheritSection catalogue_of_life Catalogue of Life
2018-10-31 12:10:49 +01:00
# (source as a section, so it can be inherited by other man pages)
2018-09-24 23:33:29 +02:00
#' @section Source:
2018-09-04 11:33:30 +02:00
#' [1] Becker K \emph{et al.} \strong{Coagulase-Negative Staphylococci}. 2014. Clin Microbiol Rev. 27(4): 870– 926. \url{https://dx.doi.org/10.1128/CMR.00109-13}
#'
#' [2] Lancefield RC \strong{A serological differentiation of human and other groups of hemolytic streptococci}. 1933. J Exp Med. 57(4): 571– 95. \url{https://dx.doi.org/10.1084/jem.57.4.571}
2018-09-24 23:33:29 +02:00
#'
2019-02-27 11:36:12 +01:00
#' [3] Catalogue of Life: Annual Checklist (public online taxonomic database), \url{www.catalogueoflife.org} (check included annual version with \code{\link{catalogue_of_life_version}()}).
2018-06-08 12:06:54 +02:00
#' @export
2018-08-31 13:36:19 +02:00
#' @return Character (vector) with class \code{"mo"}. Unknown values will return \code{NA}.
2019-02-20 00:04:48 +01:00
#' @seealso \code{\link{microorganisms}} for the \code{data.frame} that is being used to determine ID's. \cr
2018-09-24 23:33:29 +02:00
#' The \code{\link{mo_property}} functions (like \code{\link{mo_genus}}, \code{\link{mo_gramstain}}) to get properties based on the returned code.
2019-01-02 23:24:07 +01:00
#' @inheritSection AMR Read more on our website!
2018-06-08 12:06:54 +02:00
#' @examples
2018-10-01 11:39:43 +02:00
#' # These examples all return "B_STPHY_AUR", the ID of S. aureus:
2018-08-31 13:36:19 +02:00
#' as.mo("stau")
#' as.mo("STAU")
#' as.mo("staaur")
#' as.mo("S. aureus")
#' as.mo("S aureus")
#' as.mo("Staphylococcus aureus")
2018-12-07 12:04:55 +01:00
#' as.mo("Staphylococcus aureus (MRSA)")
2018-08-31 13:36:19 +02:00
#' as.mo("MRSA") # Methicillin Resistant S. aureus
#' as.mo("VISA") # Vancomycin Intermediate S. aureus
#' as.mo("VRSA") # Vancomycin Resistant S. aureus
2018-06-08 12:06:54 +02:00
#'
2018-09-05 10:51:46 +02:00
#' as.mo("Streptococcus group A")
#' as.mo("GAS") # Group A Streptococci
#' as.mo("GBS") # Group B Streptococci
#'
2019-01-06 16:40:55 +01:00
#' as.mo("S. epidermidis") # will remain species: B_STPHY_EPI
#' as.mo("S. epidermidis", Becker = TRUE) # will not remain species: B_STPHY_CNS
2018-08-02 13:15:45 +02:00
#'
2019-02-18 02:33:37 +01:00
#' as.mo("S. pyogenes") # will remain species: B_STRPT_PYO
#' as.mo("S. pyogenes", Lancefield = TRUE) # will not remain species: B_STRPT_GRA
2018-08-02 13:15:45 +02:00
#'
2018-08-31 13:36:19 +02:00
#' # Use mo_* functions to get a specific property based on `mo`
2018-09-24 23:33:29 +02:00
#' Ecoli <- as.mo("E. coli") # returns `B_ESCHR_COL`
2018-08-28 13:51:13 +02:00
#' mo_genus(Ecoli) # returns "Escherichia"
2018-09-24 23:33:29 +02:00
#' mo_gramstain(Ecoli) # returns "Gram negative"
#' # but it uses as.mo internally too, so you could also just use:
#' mo_genus("E. coli") # returns "Escherichia"
#'
2018-08-28 13:51:13 +02:00
#'
2018-06-08 12:06:54 +02:00
#' \dontrun{
2018-08-31 13:36:19 +02:00
#' df$mo <- as.mo(df$microorganism_name)
2018-06-08 12:06:54 +02:00
#'
#' # the select function of tidyverse is also supported:
2018-07-23 14:14:03 +02:00
#' library(dplyr)
2018-08-31 13:36:19 +02:00
#' df$mo <- df %>%
2018-07-23 14:14:03 +02:00
#' select(microorganism_name) %>%
2018-11-24 20:25:09 +01:00
#' as.mo()
2018-06-08 12:06:54 +02:00
#'
#' # and can even contain 2 columns, which is convenient for genus/species combinations:
2018-08-31 13:36:19 +02:00
#' df$mo <- df %>%
2018-07-23 14:14:03 +02:00
#' select(genus, species) %>%
2018-11-24 20:25:09 +01:00
#' as.mo()
#' # although this works easier and does the same:
2018-07-23 14:14:03 +02:00
#' df <- df %>%
2018-11-24 20:25:09 +01:00
#' mutate(mo = as.mo(paste(genus, species)))
2018-06-08 12:06:54 +02:00
#' }
2019-01-21 15:53:01 +01:00
as.mo <- function ( x , Becker = FALSE , Lancefield = FALSE , allow_uncertain = TRUE , reference_df = get_mo_source ( ) ) {
2019-02-27 14:22:07 +01:00
if ( ! " AMR" %in% base :: .packages ( ) ) {
library ( " AMR" )
# check onLoad() in R/zzz.R: data tables are created there.
}
2019-02-26 12:33:26 +01:00
if ( all ( x %in% AMR :: microorganisms $ mo )
& isFALSE ( Becker )
& isFALSE ( Lancefield )
& is.null ( reference_df ) ) {
y <- x
2019-02-27 14:22:07 +01:00
} else if ( all ( tolower ( x ) %in% microorganismsDT $ fullname_lower )
& isFALSE ( Becker )
& isFALSE ( Lancefield )
& is.null ( reference_df ) ) {
# we need special treatment for very prevalent full names, they are likely! (case insensitive)
2019-02-25 16:07:21 +01:00
# e.g. as.mo("Staphylococcus aureus")
2019-02-27 14:22:07 +01:00
y <- microorganismsDT [prevalence == 1 ] [data.table ( fullname_lower = tolower ( x ) ) ,
on = " fullname_lower" ,
" mo" ] [ [1 ] ]
2019-02-25 16:07:21 +01:00
if ( any ( is.na ( y ) ) ) {
2019-02-27 14:22:07 +01:00
y [is.na ( y ) ] <- microorganismsDT [prevalence == 2 ] [data.table ( fullname_lower = tolower ( x [is.na ( y ) ] ) ) ,
on = " fullname_lower" ,
" mo" ] [ [1 ] ]
2019-02-25 16:07:21 +01:00
}
if ( any ( is.na ( y ) ) ) {
2019-02-27 14:22:07 +01:00
y [is.na ( y ) ] <- microorganismsDT [prevalence == 3 ] [data.table ( fullname_lower = tolower ( x [is.na ( y ) ] ) ) ,
on = " fullname_lower" ,
" mo" ] [ [1 ] ]
2019-02-25 16:07:21 +01:00
}
2019-02-27 14:22:07 +01:00
2019-02-26 12:33:26 +01:00
} else {
# will be checked for mo class in validation and uses exec_as.mo internally if necessary
y <- mo_validate ( x = x , property = " mo" ,
Becker = Becker , Lancefield = Lancefield ,
allow_uncertain = allow_uncertain , reference_df = reference_df )
2019-02-25 16:07:21 +01:00
}
2019-02-27 14:22:07 +01:00
2019-02-26 12:33:26 +01:00
structure ( .Data = y , class = " mo" )
2018-09-27 23:23:48 +02:00
}
#' @rdname as.mo
#' @export
is.mo <- function ( x ) {
2018-12-22 22:39:34 +01:00
identical ( class ( x ) , " mo" )
2018-09-27 23:23:48 +02:00
}
2019-02-27 14:22:07 +01:00
#' @importFrom dplyr %>% pull left_join n_distinct progress_estimated filter distinct
2018-10-31 12:10:49 +01:00
#' @importFrom data.table data.table as.data.table setkey
2019-02-23 16:02:31 +01:00
#' @importFrom crayon magenta red blue silver italic has_color
2018-12-06 14:36:39 +01:00
exec_as.mo <- function ( x , Becker = FALSE , Lancefield = FALSE ,
2019-01-21 15:53:01 +01:00
allow_uncertain = TRUE , reference_df = get_mo_source ( ) ,
2018-12-06 14:36:39 +01:00
property = " mo" , clear_options = TRUE ) {
2018-10-31 12:10:49 +01:00
2018-11-24 20:25:09 +01:00
if ( ! " AMR" %in% base :: .packages ( ) ) {
library ( " AMR" )
2019-02-18 02:33:37 +01:00
# check onLoad() in R/zzz.R: data tables are created there.
2018-11-24 20:25:09 +01:00
}
2018-10-31 12:10:49 +01:00
2018-12-06 14:36:39 +01:00
if ( clear_options == TRUE ) {
options ( mo_failures = NULL )
2019-02-08 16:06:54 +01:00
options ( mo_uncertainties = NULL )
2018-12-06 14:36:39 +01:00
options ( mo_renamed = NULL )
}
2018-06-08 12:06:54 +02:00
if ( NCOL ( x ) == 2 ) {
# support tidyverse selection like: df %>% select(colA, colB)
# paste these columns together
x_vector <- vector ( " character" , NROW ( x ) )
for ( i in 1 : NROW ( x ) ) {
x_vector [i ] <- paste ( pull ( x [i , ] , 1 ) , pull ( x [i , ] , 2 ) , sep = " " )
}
x <- x_vector
} else {
if ( NCOL ( x ) > 2 ) {
stop ( ' `x` can be 2 columns at most' , call. = FALSE )
}
2018-09-09 12:11:44 +02:00
x [is.null ( x ) ] <- NA
2018-07-23 14:14:03 +02:00
2018-06-08 12:06:54 +02:00
# support tidyverse selection like: df %>% select(colA)
2018-11-15 12:42:35 +01:00
if ( ! is.vector ( x ) & ! is.null ( dim ( x ) ) ) {
2018-06-08 12:06:54 +02:00
x <- pull ( x , 1 )
}
}
2018-12-14 10:52:20 +01:00
notes <- character ( 0 )
2019-02-27 11:36:12 +01:00
uncertainties <- data.frame ( input = character ( 0 ) ,
fullname = character ( 0 ) ,
mo = character ( 0 ) )
2018-09-27 23:23:48 +02:00
failures <- character ( 0 )
x_input <- x
2019-02-23 18:08:28 +01:00
# already strip leading and trailing spaces
2019-02-23 16:02:31 +01:00
x <- trimws ( x , which = " both" )
2018-09-27 23:23:48 +02:00
# only check the uniques, which is way faster
x <- unique ( x )
2018-11-30 12:05:59 +01:00
# remove empty values (to later fill them in again with NAs)
2018-10-19 00:17:03 +02:00
x <- x [ ! is.na ( x ) & ! is.null ( x ) & ! identical ( x , " " ) ]
2018-09-27 23:23:48 +02:00
2019-02-20 00:04:48 +01:00
# conversion of old MO codes from v0.5.0 (ITIS) to later versions (Catalogue of Life)
2019-02-25 15:52:32 +01:00
if ( any ( x %like% " ^[BFP]_[A-Z]{3,7}" ) & ! all ( x %in% microorganisms $ mo ) ) {
2019-02-20 00:04:48 +01:00
leftpart <- gsub ( " ^([BFP]_[A-Z]{3,7}).*" , " \\1" , x )
if ( any ( leftpart %in% names ( mo_codes_v0.5.0 ) ) ) {
rightpart <- gsub ( " ^[BFP]_[A-Z]{3,7}(.*)" , " \\1" , x )
leftpart <- mo_codes_v0.5.0 [leftpart ]
x [ ! is.na ( leftpart ) ] <- paste0 ( leftpart [ ! is.na ( leftpart ) ] , rightpart [ ! is.na ( leftpart ) ] )
}
}
2019-02-18 02:33:37 +01:00
2018-10-01 11:39:43 +02:00
# defined df to check for
if ( ! is.null ( reference_df ) ) {
if ( ! is.data.frame ( reference_df ) | NCOL ( reference_df ) < 2 ) {
2018-10-09 15:41:44 +02:00
stop ( ' `reference_df` must be a data.frame with at least two columns.' , call. = FALSE )
2018-10-01 11:39:43 +02:00
}
2019-01-21 15:53:01 +01:00
if ( ! " mo" %in% colnames ( reference_df ) ) {
stop ( " `reference_df` must contain a column `mo` with values from the 'microorganisms' data set." , call. = FALSE )
}
reference_df <- reference_df %>% filter ( ! is.na ( mo ) )
# # remove factors, just keep characters
2018-10-01 11:39:43 +02:00
suppressWarnings (
reference_df [ ] <- lapply ( reference_df , as.character )
)
}
2019-01-21 15:53:01 +01:00
2019-02-23 18:08:28 +01:00
# all empty
2019-01-08 16:23:45 +01:00
if ( all ( identical ( trimws ( x_input ) , " " ) | is.na ( x_input ) ) ) {
if ( property == " mo" ) {
2019-02-25 15:52:32 +01:00
return ( structure ( rep ( NA_character_ , length ( x_input ) ) ,
class = " mo" ) )
2019-01-08 16:23:45 +01:00
} else {
return ( rep ( NA_character_ , length ( x_input ) ) )
}
2019-01-21 15:53:01 +01:00
} else if ( all ( x %in% reference_df [ , 1 ] )
2019-02-25 15:52:32 +01:00
& all ( reference_df [ , " mo" ] %in% AMR :: microorganisms $ mo ) ) {
2019-01-21 15:53:01 +01:00
# all in reference df
2018-10-01 11:39:43 +02:00
colnames ( reference_df ) [1 ] <- " x"
suppressWarnings (
x <- data.frame ( x = x , stringsAsFactors = FALSE ) %>%
left_join ( reference_df , by = " x" ) %>%
2019-02-25 15:52:32 +01:00
left_join ( AMR :: microorganisms , by = " mo" ) %>%
2018-10-01 11:39:43 +02:00
pull ( property )
)
2019-01-21 15:53:01 +01:00
2019-02-25 15:52:32 +01:00
} else if ( all ( x %in% AMR :: microorganisms $ mo ) ) {
2019-01-21 15:53:01 +01:00
# existing mo codes when not looking for property "mo", like mo_genus("B_ESCHR_COL")
2019-02-25 15:52:32 +01:00
y <- microorganismsDT [prevalence == 1 ] [data.table ( mo = x ) , on = " mo" , ..property ] [ [1 ] ]
if ( any ( is.na ( y ) ) ) {
2019-02-27 14:22:07 +01:00
y [is.na ( y ) ] <- microorganismsDT [prevalence == 2 ] [data.table ( mo = x [is.na ( y ) ] ) ,
on = " mo" ,
..property ] [ [1 ] ]
2019-02-25 15:52:32 +01:00
}
if ( any ( is.na ( y ) ) ) {
2019-02-27 14:22:07 +01:00
y [is.na ( y ) ] <- microorganismsDT [prevalence == 3 ] [data.table ( mo = x [is.na ( y ) ] ) ,
on = " mo" ,
..property ] [ [1 ] ]
2019-02-25 15:52:32 +01:00
}
x <- y
2019-01-21 15:53:01 +01:00
2019-02-27 14:22:07 +01:00
} else if ( all ( tolower ( x ) %in% microorganismsDT $ fullname_lower ) ) {
2019-02-23 21:49:02 +01:00
# we need special treatment for very prevalent full names, they are likely!
2019-02-23 18:08:28 +01:00
# e.g. as.mo("Staphylococcus aureus")
2019-02-27 14:22:07 +01:00
y <- microorganismsDT [prevalence == 1 ] [data.table ( fullname_lower = tolower ( x ) ) , on = " fullname_lower" , ..property ] [ [1 ] ]
2019-02-25 15:52:32 +01:00
if ( any ( is.na ( y ) ) ) {
2019-02-27 14:22:07 +01:00
y [is.na ( y ) ] <- microorganismsDT [prevalence == 2 ] [data.table ( fullname_lower = tolower ( x [is.na ( y ) ] ) ) ,
on = " fullname_lower" ,
..property ] [ [1 ] ]
2019-02-25 15:52:32 +01:00
}
if ( any ( is.na ( y ) ) ) {
2019-02-27 14:22:07 +01:00
y [is.na ( y ) ] <- microorganismsDT [prevalence == 3 ] [data.table ( fullname_lower = tolower ( x [is.na ( y ) ] ) ) ,
on = " fullname_lower" ,
..property ] [ [1 ] ]
2019-02-25 15:52:32 +01:00
}
x <- y
2019-02-23 18:08:28 +01:00
2019-02-25 15:52:32 +01:00
} else if ( all ( toupper ( x ) %in% AMR :: microorganisms.codes $ code ) ) {
2019-01-21 15:53:01 +01:00
# commonly used MO codes
2019-02-25 15:52:32 +01:00
y <- as.data.table ( AMR :: microorganisms.codes ) [data.table ( code = toupper ( x ) ) , on = " code" , ]
2018-10-31 12:10:49 +01:00
x <- microorganismsDT [data.table ( mo = y [ [ " mo" ] ] ) , on = " mo" , ..property ] [ [1 ] ]
2019-02-25 15:52:32 +01:00
} else if ( ! all ( x %in% AMR :: microorganisms [ , property ] ) ) {
2018-09-24 23:33:29 +02:00
2019-02-23 18:08:28 +01:00
x_backup <- x
2018-11-24 20:25:09 +01:00
# remove spp and species
2019-02-08 16:06:54 +01:00
x <- trimws ( gsub ( " +(spp.?|ssp.?|sp.? |ss ?.?|subsp.?|subspecies|biovar |serovar |species)" , " " , x_backup , ignore.case = TRUE ) , which = " both" )
2018-11-24 20:25:09 +01:00
x_species <- paste ( x , " species" )
2018-09-27 23:23:48 +02:00
# translate to English for supported languages of mo_property
2018-12-06 14:36:39 +01:00
x <- gsub ( " (Gruppe|gruppe|groep|grupo|gruppo|groupe)" , " group" , x , ignore.case = TRUE )
2018-09-27 23:23:48 +02:00
# remove 'empty' genus and species values
x <- gsub ( " (no MO)" , " " , x , fixed = TRUE )
2018-11-24 20:25:09 +01:00
# remove non-text in case of "E. coli" except dots and spaces
x <- gsub ( " [^.a-zA-Z0-9/ \\-]+" , " " , x )
2019-02-08 16:06:54 +01:00
# replace minus by a space
x <- gsub ( " -+" , " " , x )
# replace hemolytic by haemolytic
x <- gsub ( " ha?emoly" , " haemoly" , x )
# place minus back in streptococci
2019-02-18 02:33:37 +01:00
x <- gsub ( " (alpha|beta|gamma) ha?emoly" , " \\1-haemoly" , x )
2019-02-08 16:06:54 +01:00
# remove genus as first word
x <- gsub ( " ^Genus " , " " , x )
2018-11-24 20:25:09 +01:00
2018-09-27 23:23:48 +02:00
# but spaces before and after should be omitted
x <- trimws ( x , which = " both" )
x_trimmed <- x
x_trimmed_species <- paste ( x_trimmed , " species" )
2018-12-06 14:36:39 +01:00
x_trimmed_without_group <- gsub ( " group$" , " " , x_trimmed , ignore.case = TRUE )
# remove last part from "-" or "/"
x_trimmed_without_group <- gsub ( " (.*)[-/].*" , " \\1" , x_trimmed_without_group )
2018-11-24 20:25:09 +01:00
# replace space and dot by regex sign
x_withspaces <- gsub ( " [ .]+" , " .* " , x )
x <- gsub ( " [ .]+" , " .*" , x )
2018-09-27 23:23:48 +02:00
# add start en stop regex
x <- paste0 ( ' ^' , x , ' $' )
2019-02-08 16:06:54 +01:00
x_withspaces_start_only <- paste0 ( ' ^' , x_withspaces )
2019-02-21 18:55:52 +01:00
x_withspaces_end_only <- paste0 ( x_withspaces , ' $' )
2019-02-08 16:06:54 +01:00
x_withspaces_start_end <- paste0 ( ' ^' , x_withspaces , ' $' )
2018-09-27 23:23:48 +02:00
2018-12-06 14:36:39 +01:00
# cat(paste0('x "', x, '"\n'))
# cat(paste0('x_species "', x_species, '"\n'))
2019-02-08 16:06:54 +01:00
# cat(paste0('x_withspaces_start_only "', x_withspaces_start_only, '"\n'))
2019-02-21 18:55:52 +01:00
# cat(paste0('x_withspaces_end_only "', x_withspaces_end_only, '"\n'))
2019-02-08 16:06:54 +01:00
# cat(paste0('x_withspaces_start_end "', x_withspaces_start_end, '"\n'))
2018-12-06 14:36:39 +01:00
# cat(paste0('x_backup "', x_backup, '"\n'))
# cat(paste0('x_trimmed "', x_trimmed, '"\n'))
# cat(paste0('x_trimmed_species "', x_trimmed_species, '"\n'))
# cat(paste0('x_trimmed_without_group "', x_trimmed_without_group, '"\n'))
2018-09-27 23:23:48 +02:00
2018-12-07 12:04:55 +01:00
progress <- progress_estimated ( n = length ( x ) , min_time = 3 )
2018-09-27 23:23:48 +02:00
for ( i in 1 : length ( x ) ) {
2018-12-07 12:04:55 +01:00
progress $ tick ( ) $ print ( )
2019-02-23 16:02:31 +01:00
found <- microorganismsDT [mo == toupper ( x_backup [i ] ) , ..property ] [ [1 ] ]
# is a valid MO code
if ( length ( found ) > 0 ) {
x [i ] <- found [1L ]
next
}
2019-02-08 16:06:54 +01:00
if ( tolower ( x_trimmed [i ] ) %in% c ( " " , " xxx" , " other" , " none" , " unknown" ) ) {
# empty and nonsense values, ignore without warning ("xxx" is WHONET code for 'no growth')
2018-10-19 00:17:03 +02:00
x [i ] <- NA_character_
next
}
2019-02-08 16:06:54 +01:00
if ( nchar ( gsub ( " [^a-zA-Z]" , " " , x_trimmed [i ] ) ) < 3 ) {
2018-11-24 20:25:09 +01:00
# check if search term was like "A. species", then return first genus found with ^A
2019-02-08 16:06:54 +01:00
if ( x_backup [i ] %like% " [a-z]+ species" | x_backup [i ] %like% " [a-z] spp[.]?" ) {
2018-11-24 20:25:09 +01:00
# get mo code of first hit
2019-02-08 16:06:54 +01:00
found <- microorganismsDT [fullname %like% x_withspaces_start_only [i ] , mo ]
2018-11-24 20:25:09 +01:00
if ( length ( found ) > 0 ) {
2018-11-30 12:05:59 +01:00
mo_code <- found [1L ] %>% strsplit ( " _" ) %>% unlist ( ) %>% .[1 : 2 ] %>% paste ( collapse = " _" )
found <- microorganismsDT [mo == mo_code , ..property ] [ [1 ] ]
# return first genus that begins with x_trimmed, e.g. when "E. spp."
if ( length ( found ) > 0 ) {
x [i ] <- found [1L ]
next
}
2018-11-24 20:25:09 +01:00
}
}
2018-11-30 12:05:59 +01:00
# fewer than 3 chars and not looked for species, add as failure
x [i ] <- NA_character_
failures <- c ( failures , x_backup [i ] )
next
2018-09-27 23:23:48 +02:00
}
2018-09-24 23:33:29 +02:00
2019-02-08 16:06:54 +01:00
if ( x_trimmed [i ] %like% " virus" ) {
# there is no fullname like virus, so don't try to coerce it
2019-01-21 21:24:40 +01:00
x [i ] <- NA_character_
failures <- c ( failures , x_backup [i ] )
next
}
2018-09-27 23:23:48 +02:00
# translate known trivial abbreviations to genus + species ----
if ( ! is.na ( x_trimmed [i ] ) ) {
2019-01-21 21:24:40 +01:00
if ( toupper ( x_trimmed [i ] ) %in% c ( ' MRSA' , ' MSSA' , ' VISA' , ' VRSA' ) ) {
2018-10-31 12:10:49 +01:00
x [i ] <- microorganismsDT [mo == ' B_STPHY_AUR' , ..property ] [ [1 ] ] [1L ]
2018-09-27 23:23:48 +02:00
next
}
2019-01-21 21:24:40 +01:00
if ( toupper ( x_trimmed [i ] ) %in% c ( ' MRSE' , ' MSSE' ) ) {
2018-10-31 12:10:49 +01:00
x [i ] <- microorganismsDT [mo == ' B_STPHY_EPI' , ..property ] [ [1 ] ] [1L ]
2018-09-27 23:23:48 +02:00
next
}
2018-12-06 14:36:39 +01:00
if ( toupper ( x_trimmed [i ] ) == " VRE"
| x_trimmed [i ] %like% ' (enterococci|enterokok|enterococo)[a-z]*?$' ) {
2018-10-31 12:10:49 +01:00
x [i ] <- microorganismsDT [mo == ' B_ENTRC' , ..property ] [ [1 ] ] [1L ]
2018-09-27 23:23:48 +02:00
next
}
2019-02-21 23:32:30 +01:00
if ( toupper ( x_trimmed [i ] ) %in% c ( " EHEC" , " EPEC" , " EIEC" , " STEC" , " ATEC" ) ) {
2019-02-08 16:06:54 +01:00
x [i ] <- microorganismsDT [mo == ' B_ESCHR_COL' , ..property ] [ [1 ] ] [1L ]
next
}
2018-09-27 23:23:48 +02:00
if ( toupper ( x_trimmed [i ] ) == ' MRPA' ) {
# multi resistant P. aeruginosa
2019-02-18 02:33:37 +01:00
x [i ] <- microorganismsDT [mo == ' B_PSDMN_AER' , ..property ] [ [1 ] ] [1L ]
2018-09-27 23:23:48 +02:00
next
}
2018-10-12 16:35:18 +02:00
if ( toupper ( x_trimmed [i ] ) == ' CRS'
| toupper ( x_trimmed [i ] ) == ' CRSM' ) {
# co-trim resistant S. maltophilia
2018-10-31 12:10:49 +01:00
x [i ] <- microorganismsDT [mo == ' B_STNTR_MAL' , ..property ] [ [1 ] ] [1L ]
2018-10-12 16:35:18 +02:00
next
}
2018-09-27 23:23:48 +02:00
if ( toupper ( x_trimmed [i ] ) %in% c ( ' PISP' , ' PRSP' , ' VISP' , ' VRSP' ) ) {
# peni I, peni R, vanco I, vanco R: S. pneumoniae
2019-02-18 02:33:37 +01:00
x [i ] <- microorganismsDT [mo == ' B_STRPT_PNE' , ..property ] [ [1 ] ] [1L ]
2018-09-27 23:23:48 +02:00
next
}
if ( toupper ( x_trimmed [i ] ) %like% ' ^G[ABCDFGHK]S$' ) {
2019-02-18 02:33:37 +01:00
# Streptococci, like GBS = Group B Streptococci (B_STRPT_GRB)
x [i ] <- microorganismsDT [mo == gsub ( " G([ABCDFGHK])S" , " B_STRPT_GR\\1" , x_trimmed [i ] , ignore.case = TRUE ) , ..property ] [ [1 ] ] [1L ]
2018-12-06 14:36:39 +01:00
next
}
if ( toupper ( x_trimmed [i ] ) %like% ' (streptococc|streptokok).* [ABCDFGHK]$' ) {
# Streptococci in different languages, like "estreptococos grupo B"
2019-02-18 02:33:37 +01:00
x [i ] <- microorganismsDT [mo == gsub ( " .*(streptococ|streptokok|estreptococ).* ([ABCDFGHK])$" , " B_STRPT_GR\\2" , x_trimmed [i ] , ignore.case = TRUE ) , ..property ] [ [1 ] ] [1L ]
2018-12-06 14:36:39 +01:00
next
}
if ( toupper ( x_trimmed [i ] ) %like% ' group [ABCDFGHK] (streptococ|streptokok|estreptococ)' ) {
# Streptococci in different languages, like "Group A Streptococci"
2019-02-18 02:33:37 +01:00
x [i ] <- microorganismsDT [mo == gsub ( " .*group ([ABCDFGHK]) (streptococ|streptokok|estreptococ).*" , " B_STRPT_GR\\1" , x_trimmed [i ] , ignore.case = TRUE ) , ..property ] [ [1 ] ] [1L ]
2018-09-27 23:23:48 +02:00
next
}
# CoNS/CoPS in different languages (support for German, Dutch, Spanish, Portuguese) ----
if ( tolower ( x [i ] ) %like% ' [ck]oagulas[ea] negatie?[vf]'
| tolower ( x_trimmed [i ] ) %like% ' [ck]oagulas[ea] negatie?[vf]'
| tolower ( x [i ] ) %like% ' [ck]o?ns[^a-z]?$' ) {
# coerce S. coagulase negative
2018-10-31 12:10:49 +01:00
x [i ] <- microorganismsDT [mo == ' B_STPHY_CNS' , ..property ] [ [1 ] ] [1L ]
2018-09-27 23:23:48 +02:00
next
}
if ( tolower ( x [i ] ) %like% ' [ck]oagulas[ea] positie?[vf]'
| tolower ( x_trimmed [i ] ) %like% ' [ck]oagulas[ea] positie?[vf]'
| tolower ( x [i ] ) %like% ' [ck]o?ps[^a-z]?$' ) {
# coerce S. coagulase positive
2018-10-31 12:10:49 +01:00
x [i ] <- microorganismsDT [mo == ' B_STPHY_CPS' , ..property ] [ [1 ] ] [1L ]
2018-09-27 23:23:48 +02:00
next
}
2018-12-06 14:36:39 +01:00
if ( tolower ( x [i ] ) %like% ' gram[ -]?neg.*'
| tolower ( x_trimmed [i ] ) %like% ' gram[ -]?neg.*' ) {
2018-11-02 10:27:57 +01:00
# coerce S. coagulase positive
x [i ] <- microorganismsDT [mo == ' B_GRAMN' , ..property ] [ [1 ] ] [1L ]
next
}
2018-12-06 14:36:39 +01:00
if ( tolower ( x [i ] ) %like% ' gram[ -]?pos.*'
| tolower ( x_trimmed [i ] ) %like% ' gram[ -]?pos.*' ) {
2018-11-02 10:27:57 +01:00
# coerce S. coagulase positive
x [i ] <- microorganismsDT [mo == ' B_GRAMP' , ..property ] [ [1 ] ] [1L ]
next
}
2018-12-06 14:36:39 +01:00
if ( grepl ( " [sS]almonella [A-Z][a-z]+ ?.*" , x_trimmed [i ] ) ) {
2019-02-08 16:06:54 +01:00
if ( x_trimmed [i ] %like% " Salmonella group" ) {
# Salmonella Group A to Z, just return S. species for now
x [i ] <- microorganismsDT [mo == ' B_SLMNL' , ..property ] [ [1 ] ] [1L ]
notes <- c ( notes ,
magenta ( paste0 ( " Note: " ,
italic ( " Salmonella" ) , " " , trimws ( gsub ( " Salmonella" , " " , x_trimmed [i ] ) ) ,
" was considered " ,
italic ( " Salmonella species" ) ,
" (B_SLMNL)" ) ) )
} else {
# Salmonella with capital letter species like "Salmonella Goettingen" - they're all S. enterica
x [i ] <- microorganismsDT [mo == ' B_SLMNL_ENT' , ..property ] [ [1 ] ] [1L ]
notes <- c ( notes ,
magenta ( paste0 ( " Note: " ,
italic ( " Salmonella" ) , " " , trimws ( gsub ( " Salmonella" , " " , x_trimmed [i ] ) ) ,
" was considered a subspecies of " ,
italic ( " Salmonella enterica" ) ,
" (B_SLMNL_ENT)" ) ) )
}
2018-12-06 14:36:39 +01:00
next
}
2018-09-27 23:23:48 +02:00
}
2018-08-28 13:51:13 +02:00
2018-09-27 23:23:48 +02:00
# FIRST TRY FULLNAMES AND CODES
2018-10-01 11:39:43 +02:00
# if only genus is available, return only genus
2018-09-27 23:23:48 +02:00
if ( all ( ! c ( x [i ] , x_trimmed [i ] ) %like% " " ) ) {
2019-02-27 14:22:07 +01:00
found <- microorganismsDT [fullname_lower %in% tolower ( c ( x_species [i ] , x_trimmed_species [i ] ) ) , ..property ] [ [1 ] ]
2018-09-27 23:23:48 +02:00
if ( length ( found ) > 0 ) {
x [i ] <- found [1L ]
next
}
2019-02-08 16:06:54 +01:00
if ( nchar ( x_trimmed [i ] ) >= 6 ) {
2019-02-27 14:22:07 +01:00
found <- microorganismsDT [fullname_lower %like% paste0 ( x_withspaces_start_only [i ] , " [a-z]+ species" ) , ..property ] [ [1 ] ]
2018-09-27 23:23:48 +02:00
if ( length ( found ) > 0 ) {
x [i ] <- found [1L ]
next
}
}
2019-02-08 16:06:54 +01:00
# rest of genus only is in allow_uncertain part.
2018-09-27 23:23:48 +02:00
}
2018-08-28 13:51:13 +02:00
2018-10-01 11:39:43 +02:00
# TRY OTHER SOURCES ----
2019-02-25 15:52:32 +01:00
if ( toupper ( x_backup [i ] ) %in% AMR :: microorganisms.codes [ , 1 ] ) {
mo_found <- AMR :: microorganisms.codes [toupper ( x_backup [i ] ) == AMR :: microorganisms.codes [ , 1 ] , " mo" ] [1L ]
2018-11-30 12:05:59 +01:00
if ( length ( mo_found ) > 0 ) {
x [i ] <- microorganismsDT [mo == mo_found , ..property ] [ [1 ] ] [1L ]
next
}
}
2018-11-24 20:25:09 +01:00
if ( ! is.null ( reference_df ) ) {
if ( x_backup [i ] %in% reference_df [ , 1 ] ) {
2019-01-21 15:53:01 +01:00
ref_mo <- reference_df [reference_df [ , 1 ] == x_backup [i ] , " mo" ]
2018-11-24 20:25:09 +01:00
if ( ref_mo %in% microorganismsDT [ , mo ] ) {
x [i ] <- microorganismsDT [mo == ref_mo , ..property ] [ [1 ] ] [1L ]
next
} else {
warning ( " Value '" , x_backup [i ] , " ' was found in reference_df, but '" , ref_mo , " ' is not a valid MO code." , call. = FALSE )
}
2018-10-01 11:39:43 +02:00
}
}
2019-02-21 18:55:52 +01:00
check_per_prevalence <- function ( data_to_check ,
a.x_backup ,
b.x_trimmed ,
c.x_trimmed_without_group ,
d.x_withspaces_start_end ,
e.x_withspaces_start_only ,
f.x_withspaces_end_only ) {
2019-02-18 02:33:37 +01:00
2019-02-27 14:22:07 +01:00
found <- data_to_check [fullname_lower %in% tolower ( c ( a.x_backup , b.x_trimmed ) ) , ..property ] [ [1 ] ]
2019-02-21 18:55:52 +01:00
# most probable: is exact match in fullname
2019-02-18 02:33:37 +01:00
if ( length ( found ) > 0 ) {
2019-02-21 18:55:52 +01:00
return ( found [1L ] )
2019-02-18 02:33:37 +01:00
}
2019-02-27 14:22:07 +01:00
found <- data_to_check [fullname_lower == tolower ( c.x_trimmed_without_group ) , ..property ] [ [1 ] ]
2019-02-21 18:55:52 +01:00
if ( length ( found ) > 0 ) {
return ( found [1L ] )
}
2019-02-18 02:33:37 +01:00
2019-02-21 18:55:52 +01:00
# try any match keeping spaces ----
found <- data_to_check [fullname %like% d.x_withspaces_start_end , ..property ] [ [1 ] ]
if ( length ( found ) > 0 & nchar ( b.x_trimmed ) >= 6 ) {
return ( found [1L ] )
}
2018-12-06 14:36:39 +01:00
2019-02-21 18:55:52 +01:00
# try any match keeping spaces, not ending with $ ----
found <- data_to_check [fullname %like% paste0 ( trimws ( e.x_withspaces_start_only ) , " " ) , ..property ] [ [1 ] ]
if ( length ( found ) > 0 ) {
return ( found [1L ] )
}
found <- data_to_check [fullname %like% e.x_withspaces_start_only , ..property ] [ [1 ] ]
if ( length ( found ) > 0 & nchar ( b.x_trimmed ) >= 6 ) {
return ( found [1L ] )
}
2018-09-27 23:23:48 +02:00
2019-02-21 18:55:52 +01:00
# try any match keeping spaces, not start with ^ ----
found <- data_to_check [fullname %like% paste0 ( " " , trimws ( f.x_withspaces_end_only ) ) , ..property ] [ [1 ] ]
if ( length ( found ) > 0 ) {
return ( found [1L ] )
}
found <- data_to_check [fullname %like% f.x_withspaces_end_only , ..property ] [ [1 ] ]
if ( length ( found ) > 0 & nchar ( b.x_trimmed ) >= 6 ) {
return ( found [1L ] )
}
2018-09-27 23:23:48 +02:00
2019-02-21 18:55:52 +01:00
# try splitting of characters in the middle and then find ID ----
# only when text length is 6 or lower
# like esco = E. coli, klpn = K. pneumoniae, stau = S. aureus, staaur = S. aureus
if ( nchar ( b.x_trimmed ) <= 6 ) {
x_length <- nchar ( b.x_trimmed )
x_split <- paste0 ( " ^" ,
b.x_trimmed %>% substr ( 1 , x_length / 2 ) ,
' .* ' ,
b.x_trimmed %>% substr ( ( x_length / 2 ) + 1 , x_length ) )
found <- data_to_check [fullname %like% x_split , ..property ] [ [1 ] ]
if ( length ( found ) > 0 ) {
return ( found [1L ] )
}
}
2018-09-27 23:23:48 +02:00
2019-02-21 18:55:52 +01:00
# try fullname without start and without nchar limit of >= 6 ----
# like "K. pneu rhino" >> "Klebsiella pneumoniae (rhinoscleromatis)" = KLEPNERH
found <- data_to_check [fullname %like% e.x_withspaces_start_only , ..property ] [ [1 ] ]
2018-10-29 17:26:17 +01:00
if ( length ( found ) > 0 ) {
2019-02-21 18:55:52 +01:00
return ( found [1L ] )
2018-10-29 17:26:17 +01:00
}
2018-06-08 12:06:54 +02:00
2019-02-21 18:55:52 +01:00
# didn't found any
return ( NA_character_ )
2018-11-02 10:27:57 +01:00
}
2018-09-27 23:23:48 +02:00
2019-02-21 18:55:52 +01:00
# FIRST TRY VERY PREVALENT IN HUMAN INFECTIONS ----
x [i ] <- check_per_prevalence ( data_to_check = microorganismsDT [prevalence == 1 ] ,
a.x_backup = x_backup [i ] ,
b.x_trimmed = x_trimmed [i ] ,
c.x_trimmed_without_group = x_trimmed_without_group [i ] ,
d.x_withspaces_start_end = x_withspaces_start_end [i ] ,
e.x_withspaces_start_only = x_withspaces_start_only [i ] ,
f.x_withspaces_end_only = x_withspaces_end_only [i ] )
if ( ! is.na ( x [i ] ) ) {
2018-09-24 23:33:29 +02:00
next
}
2019-02-21 18:55:52 +01:00
# THEN TRY PREVALENT IN HUMAN INFECTIONS ----
x [i ] <- check_per_prevalence ( data_to_check = microorganismsDT [prevalence == 2 ] ,
a.x_backup = x_backup [i ] ,
b.x_trimmed = x_trimmed [i ] ,
c.x_trimmed_without_group = x_trimmed_without_group [i ] ,
d.x_withspaces_start_end = x_withspaces_start_end [i ] ,
e.x_withspaces_start_only = x_withspaces_start_only [i ] ,
f.x_withspaces_end_only = x_withspaces_end_only [i ] )
if ( ! is.na ( x [i ] ) ) {
2018-09-27 23:23:48 +02:00
next
}
2019-02-21 18:55:52 +01:00
# THEN UNPREVALENT IN HUMAN INFECTIONS ----
x [i ] <- check_per_prevalence ( data_to_check = microorganismsDT [prevalence == 3 ] ,
a.x_backup = x_backup [i ] ,
b.x_trimmed = x_trimmed [i ] ,
c.x_trimmed_without_group = x_trimmed_without_group [i ] ,
d.x_withspaces_start_end = x_withspaces_start_end [i ] ,
e.x_withspaces_start_only = x_withspaces_start_only [i ] ,
f.x_withspaces_end_only = x_withspaces_end_only [i ] )
if ( ! is.na ( x [i ] ) ) {
2018-11-02 10:27:57 +01:00
next
}
2018-09-27 23:23:48 +02:00
# MISCELLANEOUS ----
# look for old taxonomic names ----
2019-02-27 14:22:07 +01:00
found <- microorganisms.oldDT [fullname_lower == tolower ( x_backup [i ] )
2019-02-18 02:33:37 +01:00
| fullname %like% x_withspaces_start_end [i ] , ]
2018-09-25 16:44:40 +02:00
if ( NROW ( found ) > 0 ) {
2019-02-18 02:33:37 +01:00
col_id_new <- found [1 , col_id_new ]
2018-11-09 13:11:54 +01:00
# when property is "ref" (which is the case in mo_ref, mo_authors and mo_year), return the old value, so:
2019-02-21 23:32:30 +01:00
# mo_ref("Chlamydia psittaci") = "Page, 1968" (with warning)
# mo_ref("Chlamydophila psittaci") = "Everett et al., 1999"
2018-11-09 13:11:54 +01:00
if ( property == " ref" ) {
x [i ] <- found [1 , ref ]
} else {
2019-02-18 02:33:37 +01:00
x [i ] <- microorganismsDT [col_id == found [1 , col_id_new ] , ..property ] [ [1 ] ]
2018-11-09 13:11:54 +01:00
}
2019-02-18 02:33:37 +01:00
was_renamed ( name_old = found [1 , fullname ] ,
name_new = microorganismsDT [col_id == found [1 , col_id_new ] , fullname ] ,
2019-02-08 16:06:54 +01:00
ref_old = found [1 , ref ] ,
2019-02-18 02:33:37 +01:00
ref_new = microorganismsDT [col_id == found [1 , col_id_new ] , ref ] ,
mo = microorganismsDT [col_id == found [1 , col_id_new ] , mo ] )
2018-09-25 16:44:40 +02:00
next
}
2018-09-27 23:23:48 +02:00
# check for uncertain results ----
if ( allow_uncertain == TRUE ) {
2018-12-14 10:52:20 +01:00
2019-02-21 23:32:30 +01:00
uncertain_fn <- function ( a.x_backup , b.x_trimmed , c.x_withspaces_start_end , d.x_withspaces_start_only ) {
2019-02-08 16:06:54 +01:00
# (1) look for genus only, part of name ----
if ( nchar ( b.x_trimmed ) > 4 & ! b.x_trimmed %like% " " ) {
if ( ! grepl ( " ^[A-Z][a-z]+" , b.x_trimmed , ignore.case = FALSE ) ) {
# not when input is like Genustext, because then Neospora would lead to Actinokineospora
2019-02-27 14:22:07 +01:00
found <- microorganismsDT [fullname_lower %like% paste ( b.x_trimmed , " species" ) , ..property ] [ [1 ] ]
2019-02-08 16:06:54 +01:00
if ( length ( found ) > 0 ) {
x [i ] <- found [1L ]
2019-02-27 11:36:12 +01:00
uncertainties <<- rbind ( uncertainties ,
data.frame ( input = a.x_backup ,
fullname = microorganismsDT [mo == found [1L ] , fullname ] [ [1 ] ] ,
mo = found [1L ] ) )
2019-02-08 16:06:54 +01:00
return ( x )
}
}
}
# (2) look again for old taxonomic names, now for G. species ----
2019-02-18 02:33:37 +01:00
found <- microorganisms.oldDT [fullname %like% c.x_withspaces_start_end
2019-02-21 23:32:30 +01:00
| fullname %like% d.x_withspaces_start_only ]
2018-12-14 11:44:15 +01:00
if ( NROW ( found ) > 0 & nchar ( b.x_trimmed ) >= 6 ) {
2018-12-14 10:52:20 +01:00
if ( property == " ref" ) {
# when property is "ref" (which is the case in mo_ref, mo_authors and mo_year), return the old value, so:
# mo_ref("Chlamydia psittaci) = "Page, 1968" (with warning)
# mo_ref("Chlamydophila psittaci) = "Everett et al., 1999"
x <- found [1 , ref ]
} else {
2019-02-18 02:33:37 +01:00
x <- microorganismsDT [col_id == found [1 , col_id_new ] , ..property ] [ [1 ] ]
2018-12-14 10:52:20 +01:00
}
2019-02-18 02:33:37 +01:00
was_renamed ( name_old = found [1 , fullname ] ,
name_new = microorganismsDT [col_id == found [1 , col_id_new ] , fullname ] ,
2019-02-08 16:06:54 +01:00
ref_old = found [1 , ref ] ,
2019-02-18 02:33:37 +01:00
ref_new = microorganismsDT [col_id == found [1 , col_id_new ] , ref ] ,
mo = microorganismsDT [col_id == found [1 , col_id_new ] , mo ] )
2019-02-27 11:36:12 +01:00
uncertainties <<- rbind ( uncertainties ,
data.frame ( input = a.x_backup ,
fullname = found [1 , fullname ] ,
mo = paste ( " CoL" , found [1 , col_id ] ) ) )
2018-12-14 10:52:20 +01:00
return ( x )
2018-11-09 13:11:54 +01:00
}
2018-09-27 23:23:48 +02:00
2019-02-08 16:06:54 +01:00
# (3) strip values between brackets ----
2018-12-14 11:44:15 +01:00
a.x_backup_stripped <- gsub ( " ( [(].*[)])" , " " , a.x_backup )
a.x_backup_stripped <- trimws ( gsub ( " " , " " , a.x_backup_stripped , fixed = TRUE ) )
found <- suppressMessages ( suppressWarnings ( exec_as.mo ( a.x_backup_stripped , clear_options = FALSE , allow_uncertain = FALSE ) ) )
if ( ! is.na ( found ) & nchar ( b.x_trimmed ) >= 6 ) {
2019-01-21 21:24:40 +01:00
found_result <- found
2018-12-14 10:52:20 +01:00
found <- microorganismsDT [mo == found , ..property ] [ [1 ] ]
2019-02-27 11:36:12 +01:00
uncertainties <<- rbind ( uncertainties ,
data.frame ( input = a.x_backup ,
fullname = microorganismsDT [mo == found_result [1L ] , fullname ] [ [1 ] ] ,
mo = found_result [1L ] ) )
2018-12-14 10:52:20 +01:00
return ( found [1L ] )
}
2018-12-06 14:36:39 +01:00
2019-02-08 16:06:54 +01:00
# (4) try to strip off one element from end and check the remains ----
2018-12-14 11:44:15 +01:00
x_strip <- a.x_backup %>% strsplit ( " " ) %>% unlist ( )
if ( length ( x_strip ) > 1 & nchar ( b.x_trimmed ) >= 6 ) {
for ( i in 1 : ( length ( x_strip ) - 1 ) ) {
x_strip_collapsed <- paste ( x_strip [1 : ( length ( x_strip ) - i ) ] , collapse = " " )
found <- suppressMessages ( suppressWarnings ( exec_as.mo ( x_strip_collapsed , clear_options = FALSE , allow_uncertain = FALSE ) ) )
if ( ! is.na ( found ) ) {
2019-01-21 21:24:40 +01:00
found_result <- found
2018-12-14 11:44:15 +01:00
found <- microorganismsDT [mo == found , ..property ] [ [1 ] ]
2019-02-27 11:36:12 +01:00
uncertainties <<- rbind ( uncertainties ,
data.frame ( input = a.x_backup ,
fullname = microorganismsDT [mo == found_result [1L ] , fullname ] [ [1 ] ] ,
mo = found_result [1L ] ) )
2019-02-08 16:06:54 +01:00
return ( found [1L ] )
}
}
}
# (5) try to strip off one element from start and check the remains ----
x_strip <- a.x_backup %>% strsplit ( " " ) %>% unlist ( )
if ( length ( x_strip ) > 1 & nchar ( b.x_trimmed ) >= 6 ) {
for ( i in 2 : ( length ( x_strip ) ) ) {
x_strip_collapsed <- paste ( x_strip [i : length ( x_strip ) ] , collapse = " " )
found <- suppressMessages ( suppressWarnings ( exec_as.mo ( x_strip_collapsed , clear_options = FALSE , allow_uncertain = FALSE ) ) )
if ( ! is.na ( found ) ) {
found_result <- found
found <- microorganismsDT [mo == found , ..property ] [ [1 ] ]
2019-02-27 11:36:12 +01:00
uncertainties <<- rbind ( uncertainties ,
data.frame ( input = a.x_backup ,
fullname = microorganismsDT [mo == found_result [1L ] , fullname ] [ [1 ] ] ,
mo = found_result [1L ] ) )
2018-12-14 11:44:15 +01:00
return ( found [1L ] )
2018-12-06 14:36:39 +01:00
}
}
}
2018-12-14 11:44:15 +01:00
2019-02-21 23:32:30 +01:00
# (6) not yet implemented taxonomic changes in Catalogue of Life ----
2019-01-21 21:24:40 +01:00
found <- suppressMessages ( suppressWarnings ( exec_as.mo ( TEMPORARY_TAXONOMY ( b.x_trimmed ) , clear_options = FALSE , allow_uncertain = FALSE ) ) )
2019-01-08 16:23:45 +01:00
if ( ! is.na ( found ) ) {
2019-01-21 21:24:40 +01:00
found_result <- found
2019-01-08 16:23:45 +01:00
found <- microorganismsDT [mo == found , ..property ] [ [1 ] ]
2019-02-27 11:36:12 +01:00
uncertainties <<- rbind ( uncertainties ,
data.frame ( input = a.x_backup ,
fullname = microorganismsDT [mo == found_result [1L ] , fullname ] [ [1 ] ] ,
mo = found_result [1L ] ) )
2019-01-08 16:23:45 +01:00
return ( found [1L ] )
}
2018-12-14 11:44:15 +01:00
# didn't found in uncertain results too
return ( NA_character_ )
2018-12-06 14:36:39 +01:00
}
2018-12-14 10:52:20 +01:00
2019-02-21 23:32:30 +01:00
x [i ] <- uncertain_fn ( x_backup [i ] , x_trimmed [i ] , x_withspaces_start_end [i ] , x_withspaces_start_only [i ] )
2018-09-27 23:23:48 +02:00
if ( ! is.na ( x [i ] ) ) {
next
}
2018-06-08 12:06:54 +02:00
}
2018-09-27 23:23:48 +02:00
# not found ----
x [i ] <- NA_character_
failures <- c ( failures , x_backup [i ] )
}
2018-06-08 12:06:54 +02:00
}
2018-07-23 14:14:03 +02:00
2019-02-08 16:06:54 +01:00
# failures
2018-07-23 14:14:03 +02:00
failures <- failures [ ! failures %in% c ( NA , NULL , NaN ) ]
2019-02-27 11:36:12 +01:00
if ( length ( failures ) > 0 & clear_options == TRUE ) {
2018-12-06 14:36:39 +01:00
options ( mo_failures = sort ( unique ( failures ) ) )
2019-02-08 16:06:54 +01:00
plural <- c ( " value" , " it" )
2019-01-21 21:24:40 +01:00
if ( n_distinct ( failures ) > 1 ) {
2019-02-08 16:06:54 +01:00
plural <- c ( " values" , " them" )
2018-12-06 14:36:39 +01:00
}
2019-01-25 13:18:41 +01:00
total_failures <- length ( x_input [x_input %in% failures & ! x_input %in% c ( NA , NULL , NaN ) ] )
total_n <- length ( x_input [ ! x_input %in% c ( NA , NULL , NaN ) ] )
2019-02-27 11:36:12 +01:00
msg <- paste0 ( " \n" , nr2char ( n_distinct ( failures ) ) , " unique input " , plural [1 ] ,
2019-01-25 13:18:41 +01:00
" (^= " , percent ( total_failures / total_n , round = 1 , force_zero = TRUE ) ,
" ) could not be coerced to a valid MO code" )
2019-01-21 21:24:40 +01:00
if ( n_distinct ( failures ) <= 10 ) {
msg <- paste0 ( msg , " : " , paste ( ' "' , unique ( failures ) , ' "' , sep = " " , collapse = ' , ' ) )
}
2019-02-08 16:06:54 +01:00
msg <- paste0 ( msg , " . Use mo_failures() to review " , plural [2 ] , " ." )
warning ( red ( msg ) ,
call. = FALSE ,
immediate. = TRUE ) # thus will always be shown, even if >= warnings
}
# uncertainties
2019-02-27 11:36:12 +01:00
if ( NROW ( uncertainties ) > 0 & clear_options == TRUE ) {
options ( mo_uncertainties = as.list ( distinct ( uncertainties , input , .keep_all = TRUE ) ) )
2019-02-08 16:06:54 +01:00
plural <- c ( " value" , " it" )
2019-02-27 11:36:12 +01:00
if ( NROW ( uncertainties ) > 1 ) {
2019-02-08 16:06:54 +01:00
plural <- c ( " values" , " them" )
}
2019-02-27 11:36:12 +01:00
msg <- paste0 ( " \nResults of " , nr2char ( NROW ( uncertainties ) ) , " input " , plural [1 ] ,
" was guessed with uncertainty. Use mo_uncertainties() to review " , plural [2 ] , " ." )
2019-01-21 21:24:40 +01:00
warning ( red ( msg ) ,
call. = FALSE ,
immediate. = TRUE ) # thus will always be shown, even if >= warnings
2018-07-23 14:14:03 +02:00
}
2018-08-28 13:51:13 +02:00
2018-09-14 10:31:21 +02:00
# Becker ----
2018-09-01 21:19:46 +02:00
if ( Becker == TRUE | Becker == " all" ) {
# See Source. It's this figure:
# https://www.ncbi.nlm.nih.gov/pmc/articles/PMC4187637/figure/F3/
2018-10-31 12:10:49 +01:00
MOs_staph <- microorganismsDT [genus == " Staphylococcus" ]
2018-09-25 16:44:40 +02:00
setkey ( MOs_staph , species )
CoNS <- MOs_staph [species %in% c ( " arlettae" , " auricularis" , " capitis" ,
" caprae" , " carnosus" , " cohnii" , " condimenti" ,
" devriesei" , " epidermidis" , " equorum" ,
" fleurettii" , " gallinarum" , " haemolyticus" ,
" hominis" , " jettensis" , " kloosii" , " lentus" ,
" lugdunensis" , " massiliensis" , " microti" ,
" muscae" , " nepalensis" , " pasteuri" , " petrasii" ,
" pettenkoferi" , " piscifermentans" , " rostri" ,
" saccharolyticus" , " saprophyticus" , " sciuri" ,
" stepanovicii" , " simulans" , " succinus" ,
2018-09-27 23:23:48 +02:00
" vitulinus" , " warneri" , " xylosus" ) , ..property ] [ [1 ] ]
2018-09-25 16:44:40 +02:00
CoPS <- MOs_staph [species %in% c ( " simiae" , " agnetis" , " chromogenes" ,
" delphini" , " felis" , " lutrae" ,
" hyicus" , " intermedius" ,
" pseudintermedius" , " pseudointermedius" ,
2018-09-27 23:23:48 +02:00
" schleiferi" ) , ..property ] [ [1 ] ]
2018-10-31 12:10:49 +01:00
x [x %in% CoNS ] <- microorganismsDT [mo == ' B_STPHY_CNS' , ..property ] [ [1 ] ] [1L ]
x [x %in% CoPS ] <- microorganismsDT [mo == ' B_STPHY_CPS' , ..property ] [ [1 ] ] [1L ]
2018-09-01 21:19:46 +02:00
if ( Becker == " all" ) {
2018-10-31 12:10:49 +01:00
x [x == microorganismsDT [mo == ' B_STPHY_AUR' , ..property ] [ [1 ] ] [1L ] ] <- microorganismsDT [mo == ' B_STPHY_CPS' , ..property ] [ [1 ] ] [1L ]
2018-09-01 21:19:46 +02:00
}
}
2018-09-14 10:31:21 +02:00
# Lancefield ----
2018-09-04 11:33:30 +02:00
if ( Lancefield == TRUE | Lancefield == " all" ) {
2018-09-27 23:23:48 +02:00
# group A - S. pyogenes
2019-02-18 02:33:37 +01:00
x [x == microorganismsDT [mo == ' B_STRPT_PYO' , ..property ] [ [1 ] ] [1L ] ] <- microorganismsDT [mo == ' B_STRPT_GRA' , ..property ] [ [1 ] ] [1L ]
2018-09-27 23:23:48 +02:00
# group B - S. agalactiae
2019-02-18 02:33:37 +01:00
x [x == microorganismsDT [mo == ' B_STRPT_AGA' , ..property ] [ [1 ] ] [1L ] ] <- microorganismsDT [mo == ' B_STRPT_GRB' , ..property ] [ [1 ] ] [1L ]
2018-09-01 21:19:46 +02:00
# group C
2018-10-31 12:10:49 +01:00
S_groupC <- microorganismsDT %>% filter ( genus == " Streptococcus" ,
species %in% c ( " equisimilis" , " equi" ,
" zooepidemicus" , " dysgalactiae" ) ) %>%
2018-09-27 23:23:48 +02:00
pull ( property )
2019-02-18 02:33:37 +01:00
x [x %in% S_groupC ] <- microorganismsDT [mo == ' B_STRPT_GRC' , ..property ] [ [1 ] ] [1L ]
2018-09-04 11:33:30 +02:00
if ( Lancefield == " all" ) {
2018-09-27 23:23:48 +02:00
# all Enterococci
2019-02-18 02:33:37 +01:00
x [x %like% " ^(Enterococcus|B_ENTRC)" ] <- microorganismsDT [mo == ' B_STRPT_GRD' , ..property ] [ [1 ] ] [1L ]
2018-09-27 23:23:48 +02:00
}
# group F - S. anginosus
2019-02-18 02:33:37 +01:00
x [x == microorganismsDT [mo == ' B_STRPT_ANG' , ..property ] [ [1 ] ] [1L ] ] <- microorganismsDT [mo == ' B_STRPT_GRF' , ..property ] [ [1 ] ] [1L ]
2018-09-27 23:23:48 +02:00
# group H - S. sanguinis
2019-02-18 02:33:37 +01:00
x [x == microorganismsDT [mo == ' B_STRPT_SAN' , ..property ] [ [1 ] ] [1L ] ] <- microorganismsDT [mo == ' B_STRPT_GRH' , ..property ] [ [1 ] ] [1L ]
2018-09-27 23:23:48 +02:00
# group K - S. salivarius
2019-02-18 02:33:37 +01:00
x [x == microorganismsDT [mo == ' B_STRPT_SAL' , ..property ] [ [1 ] ] [1L ] ] <- microorganismsDT [mo == ' B_STRPT_GRK' , ..property ] [ [1 ] ] [1L ]
2018-09-01 21:19:46 +02:00
}
2019-02-08 16:06:54 +01:00
# Wrap up ----------------------------------------------------------------
2018-10-19 13:53:31 +02:00
# comply to x, which is also unique and without empty values
x_input_unique_nonempty <- unique ( x_input [ ! is.na ( x_input ) & ! is.null ( x_input ) & ! identical ( x_input , " " ) ] )
2018-10-19 00:17:03 +02:00
2018-08-28 13:51:13 +02:00
# left join the found results to the original input values (x_input)
2018-10-19 13:53:31 +02:00
df_found <- data.frame ( input = as.character ( x_input_unique_nonempty ) ,
found = as.character ( x ) ,
2018-08-28 13:51:13 +02:00
stringsAsFactors = FALSE )
2018-09-27 23:23:48 +02:00
df_input <- data.frame ( input = as.character ( x_input ) ,
2018-08-28 13:51:13 +02:00
stringsAsFactors = FALSE )
2019-02-26 12:33:26 +01:00
2018-09-27 23:23:48 +02:00
x <- df_input %>%
left_join ( df_found ,
by = " input" ) %>%
pull ( found )
if ( property == " mo" ) {
class ( x ) <- " mo"
}
2019-02-08 16:06:54 +01:00
if ( length ( mo_renamed ( ) ) > 0 ) {
if ( has_color ( ) ) {
notes <- getOption ( " mo_renamed" )
} else {
notes <- mo_renamed ( )
}
2018-12-14 10:52:20 +01:00
notes <- sort ( notes )
for ( i in 1 : length ( notes ) ) {
2019-02-08 16:06:54 +01:00
base :: message ( blue ( paste ( " Note:" , notes [i ] ) ) )
2018-12-14 10:52:20 +01:00
}
}
2018-06-08 12:06:54 +02:00
x
}
2018-07-23 14:14:03 +02:00
2019-01-21 21:24:40 +01:00
TEMPORARY_TAXONOMY <- function ( x ) {
2019-01-08 16:23:45 +01:00
x [x %like% ' Cutibacterium' ] <- gsub ( ' Cutibacterium' , ' Propionibacterium' , x [x %like% ' Cutibacterium' ] )
2019-01-21 21:24:40 +01:00
x
2019-01-08 16:23:45 +01:00
}
2019-02-23 16:02:31 +01:00
#' @importFrom crayon italic
2019-02-08 16:06:54 +01:00
was_renamed <- function ( name_old , name_new , ref_old = " " , ref_new = " " , mo = " " ) {
2018-10-01 14:44:40 +02:00
if ( ! is.na ( ref_old ) ) {
ref_old <- paste0 ( " (" , ref_old , " )" )
} else {
ref_old <- " "
}
if ( ! is.na ( ref_new ) ) {
ref_new <- paste0 ( " (" , ref_new , " )" )
} else {
ref_new <- " "
}
2018-12-06 16:07:06 +01:00
if ( ! is.na ( mo ) ) {
mo <- paste0 ( " (" , mo , " )" )
} else {
mo <- " "
}
msg <- paste0 ( italic ( name_old ) , ref_old , " was renamed " , italic ( name_new ) , ref_new , mo )
msg <- gsub ( " et al." , italic ( " et al." ) , msg )
2019-02-08 16:06:54 +01:00
options ( mo_renamed = sort ( msg ) )
2018-09-25 16:44:40 +02:00
}
2018-08-31 13:36:19 +02:00
#' @exportMethod print.mo
#' @export
#' @noRd
print.mo <- function ( x , ... ) {
cat ( " Class 'mo'\n" )
2018-10-12 16:35:18 +02:00
x_names <- names ( x )
x <- as.character ( x )
names ( x ) <- x_names
print.default ( x , quote = FALSE )
2018-08-31 13:36:19 +02:00
}
2018-07-23 14:14:03 +02:00
2018-12-07 12:04:55 +01:00
#' @exportMethod summary.mo
2019-02-27 11:36:12 +01:00
#' @importFrom dplyr n_distinct
2018-12-07 12:04:55 +01:00
#' @export
#' @noRd
summary.mo <- function ( object , ... ) {
# unique and top 1-3
x <- object
top_3 <- unname ( top_freq ( freq ( x ) , 3 ) )
c ( " Class" = " mo" ,
" <NA>" = length ( x [is.na ( x ) ] ) ,
2019-02-27 11:36:12 +01:00
" Unique" = n_distinct ( x [ ! is.na ( x ) ] ) ,
2018-12-07 12:04:55 +01:00
" #1" = top_3 [1 ] ,
" #2" = top_3 [2 ] ,
" #3" = top_3 [3 ] )
}
2018-08-31 13:36:19 +02:00
#' @exportMethod as.data.frame.mo
2018-07-23 14:14:03 +02:00
#' @export
2018-08-31 13:36:19 +02:00
#' @noRd
2019-02-27 11:36:12 +01:00
as.data.frame.mo <- function ( x , ... ) {
2018-10-31 12:10:49 +01:00
# same as as.data.frame.character but with removed stringsAsFactors, since it will be class "mo"
2018-08-31 13:36:19 +02:00
nm <- paste ( deparse ( substitute ( x ) , width.cutoff = 500L ) ,
collapse = " " )
if ( ! " nm" %in% names ( list ( ... ) ) ) {
as.data.frame.vector ( x , ... , nm = nm )
} else {
as.data.frame.vector ( x , ... )
}
}
#' @exportMethod pull.mo
#' @export
#' @importFrom dplyr pull
#' @noRd
pull.mo <- function ( .data , ... ) {
pull ( as.data.frame ( .data ) , ... )
2018-07-23 14:14:03 +02:00
}
2018-12-06 14:36:39 +01:00
2019-02-08 16:06:54 +01:00
#' @rdname as.mo
2018-12-06 14:36:39 +01:00
#' @export
mo_failures <- function ( ) {
getOption ( " mo_failures" )
}
2019-02-08 16:06:54 +01:00
#' @rdname as.mo
2019-02-27 11:36:12 +01:00
#' @importFrom crayon italic
2019-02-08 16:06:54 +01:00
#' @export
mo_uncertainties <- function ( ) {
2019-02-27 11:36:12 +01:00
df <- as.data.frame ( getOption ( " mo_uncertainties" ) )
msg <- " "
for ( i in 1 : nrow ( df ) ) {
msg <- paste ( msg ,
paste0 ( ' "' , df [i , " input" ] , ' " -> ' , italic ( df [i , " fullname" ] ) , " (" , df [i , " mo" ] , " )" ) ,
sep = " \n" )
}
cat ( paste0 ( bold ( " Results guessed with uncertainty:" ) , msg ) )
2019-02-08 16:06:54 +01:00
}
#' @rdname as.mo
2018-12-06 14:36:39 +01:00
#' @export
mo_renamed <- function ( ) {
2019-02-27 11:36:12 +01:00
strip_style ( gsub ( " was renamed" , " ->" , getOption ( " mo_renamed" ) , fixed = TRUE ) )
}
nr2char <- function ( x ) {
if ( x %in% c ( 1 : 10 ) ) {
v <- c ( " one" = 1 , " two" = 2 , " three" = 3 , " four" = 4 , " five" = 5 ,
" six" = 6 , " seven" = 7 , " eight" = 8 , " nine" = 9 , " ten" = 10 )
names ( v [x ] )
} else {
x
}
2018-12-06 14:36:39 +01:00
}