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 #
2020-01-05 17:22:09 +01:00
# (c) 2018-2020 Berends MS, Luz CF et al. #
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. #
# #
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. #
2019-04-05 18:47:39 +02:00
# Visit our website for more info: https://msberends.gitlab.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-11-28 22:32:17 +01:00
#' Use this function to determine a valid microorganism ID ([`mo`]). Determination is done using intelligent rules and the complete taxonomic kingdoms Bacteria, Chromista, Protozoa, Archaea and most microbial species from the kingdom Fungi (see Source). The input can be almost anything: a full name (like `"Staphylococcus aureus"`), an abbreviated name (like `"S. aureus"`), an abbreviation known in the field (like `"MRSA"`), or just a genus. Please see *Examples*.
2020-01-05 17:22:09 +01:00
#' @inheritSection lifecycle Stable lifecycle
2019-11-28 22:32:17 +01:00
#' @param x a character vector or a [`data.frame`] with one or two columns
#' @param Becker a logical to indicate whether *Staphylococci* should be categorised into coagulase-negative *Staphylococci* ("CoNS") and coagulase-positive *Staphylococci* ("CoPS") instead of their own species, according to Karsten Becker *et al.* (1,2). Note that this does not include species that were newly named after these publications, like *S. caeli*.
2018-09-04 11:33:30 +02:00
#'
2019-12-20 15:05:58 +01:00
#' This excludes *Staphylococcus aureus* at default, use `Becker = "all"` to also categorise *S. aureus* as "CoPS".
2019-11-28 22:32:17 +01:00
#' @param Lancefield a logical to indicate whether beta-haemolytic *Streptococci* should be categorised into Lancefield groups instead of their own species, according to Rebecca C. Lancefield (3). These *Streptococci* will be categorised in their first group, e.g. *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
#'
2019-12-20 15:05:58 +01:00
#' This excludes *Enterococci* at default (who are in group D), use `Lancefield = "all"` to also categorise all *Enterococci* as group D.
2019-11-28 22:32:17 +01:00
#' @param allow_uncertain a number between `0` (or `"none"`) and `3` (or `"all"`), or `TRUE` (= `2`) or `FALSE` (= `0`) to indicate whether the input should be checked for less probable results, please see *Details*
#' @param reference_df a [`data.frame`] to use for extra reference when translating `x` to a valid [`mo`]. See [set_mo_source()] and [get_mo_source()] to automate the usage of your own codes (e.g. used in your analysis or organisation).
2019-03-15 13:57:25 +01:00
#' @param ... other parameters passed on to functions
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
2019-11-28 22:32:17 +01:00
#' ## General info
#'
#' A microorganism ID from this package (class: [`mo`]) typically looks like these examples:
#' ```
2019-09-18 15:46:09 +02:00
#' Code Full name
#' --------------- --------------------------------------
#' B_KLBSL Klebsiella
#' B_KLBSL_PNMN Klebsiella pneumoniae
#' B_KLBSL_PNMN_RHNS Klebsiella pneumoniae rhinoscleromatis
#' | | | |
#' | | | |
#' | | | ---> subspecies, a 4-5 letter acronym
#' | | ----> species, a 4-5 letter acronym
#' | ----> genus, a 5-7 letter acronym
2019-03-26 14:24:03 +01:00
#' ----> taxonomic kingdom: A (Archaea), AN (Animalia), B (Bacteria),
2019-08-13 16:15:08 +02:00
#' C (Chromista), F (Fungi), P (Protozoa)
2019-11-28 22:32:17 +01:00
#' ```
2018-08-01 08:03:31 +02:00
#'
2019-11-28 22:32:17 +01:00
#' Values that cannot be coered will be considered 'unknown' and will get the MO code `UNKNOWN`.
2019-03-02 22:47:04 +01:00
#'
2020-02-09 22:04:29 +01:00
#' Use the [`mo_*`][mo_property()] functions to get properties based on the returned code, see Examples.
2019-03-15 13:57:25 +01:00
#'
2019-11-28 22:32:17 +01:00
#' The algorithm uses data from the Catalogue of Life (see below) and from one other source (see [microorganisms]).
2019-09-15 22:57:30 +02:00
#'
2019-11-28 22:32:17 +01:00
#' The [as.mo()] function uses several coercion rules for fast and logical results. It assesses the input matching criteria in the following order:
#'
#' 1. Human pathogenic prevalence: the function starts with more prevalent microorganisms, followed by less prevalent ones;
#' 2. Taxonomic kingdom: the function starts with determining Bacteria, then Fungi, then Protozoa, then others;
#' 3. Breakdown of input values to identify possible matches.
2018-09-24 23:33:29 +02:00
#'
2020-02-09 22:04:29 +01:00
#' This will lead to the effect that e.g. `"E. coli"` (a microorganism highly prevalent in humans) will return the microbial ID of *Escherichia coli* and not *Entamoeba coli* (a microorganism less prevalent in humans), although the latter would alphabetically come first.
2019-11-15 15:25:03 +01:00
#'
2019-11-28 22:32:17 +01:00
#' ## Coping with uncertain results
2019-09-23 13:53:50 +02:00
#'
2019-11-28 22:32:17 +01:00
#' In addition, the [as.mo()] function can differentiate four levels of uncertainty to guess valid results:
#' - Uncertainty level 0: no additional rules are applied;
#' - Uncertainty level 1: allow previously accepted (but now invalid) taxonomic names and minor spelling errors;
#' - Uncertainty level 2: allow all of level 1, strip values between brackets, inverse the words of the input, strip off text elements from the end keeping at least two elements;
#' - Uncertainty level 3: allow all of level 1 and 2, strip off text elements from the end, allow any part of a taxonomic name.
2019-09-23 13:53:50 +02:00
#'
#' This leads to e.g.:
2020-03-14 14:05:43 +01:00
#' - `"Streptococcus group B (known as S. agalactiae)"`. The text between brackets will be removed and a warning will be thrown that the result *Streptococcus group B* (``r as.mo("Streptococcus group B")``) needs review.
#' - `"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 *Staphylococcus aureus* (``r as.mo("Staphylococcus aureus")``) needs review.
#' - `"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 *Neisseria gonorrhoeae* (``r as.mo("Neisseria gonorrhoeae")``) needs review.
2018-12-07 12:04:55 +01:00
#'
2019-11-28 22:32:17 +01:00
#' The level of uncertainty can be set using the argument `allow_uncertain`. The default is `allow_uncertain = TRUE`, which is equal to uncertainty level 2. Using `allow_uncertain = FALSE` is equal to uncertainty level 0 and will skip all rules. You can also use e.g. `as.mo(..., allow_uncertain = 1)` to only allow up to level 1 uncertainty.
2019-09-23 13:53:50 +02:00
#'
2019-11-28 22:32:17 +01:00
#' There are three helper functions that can be run after then [as.mo()] function:
#' - Use [mo_uncertainties()] to get a [`data.frame`] with all values that were coerced to a valid value, but with uncertainty. The output contains a score, that is calculated as \eqn{(n - 0.5 * L) / n}, where *n* is the number of characters of the returned full name of the microorganism, and *L* is the [Levenshtein distance](https://en.wikipedia.org/wiki/Levenshtein_distance) between that full name and the user input.
#' - Use [mo_failures()] to get a [`vector`] with all values that could not be coerced to a valid value.
#' - Use [mo_renamed()] to get a [`data.frame`] with all values that could be coerced based on an old, previously accepted taxonomic name.
2019-02-08 16:06:54 +01:00
#'
2019-11-28 22:32:17 +01:00
#' ## Microbial prevalence of pathogens in humans
#'
#' The intelligent rules consider the prevalence of microorganisms in humans grouped into three groups, which is available as the `prevalence` columns in the [microorganisms] and [microorganisms.old] data sets. The grouping into prevalence groups is based on experience from several microbiological laboratories in the Netherlands in conjunction with international reports on pathogen prevalence.
2019-09-23 13:53:50 +02:00
#'
2019-11-28 22:32:17 +01:00
#' Group 1 (most prevalent microorganisms) consists of all microorganisms where the taxonomic class is Gammaproteobacteria or where the taxonomic genus is *Enterococcus*, *Staphylococcus* or *Streptococcus*. This group consequently contains all common Gram-negative bacteria, such as *Pseudomonas* and *Legionella* and all species within the order Enterobacteriales.
2019-09-23 13:53:50 +02:00
#'
2019-11-28 22:32:17 +01:00
#' Group 2 consists of all microorganisms where the taxonomic phylum is Proteobacteria, Firmicutes, Actinobacteria or Sarcomastigophora, or where the taxonomic genus is *Aspergillus*, *Bacteroides*, *Candida*, *Capnocytophaga*, *Chryseobacterium*, *Cryptococcus*, *Elisabethkingia*, *Flavobacterium*, *Fusobacterium*, *Giardia*, *Leptotrichia*, *Mycoplasma*, *Prevotella*, *Rhodotorula*, *Treponema*, *Trichophyton* or *Ureaplasma*.
2019-09-23 13:53:50 +02:00
#'
#' Group 3 (least prevalent microorganisms) consists of all other microorganisms.
2019-02-20 00:04:48 +01:00
#' @inheritSection catalogue_of_life Catalogue of Life
2019-05-20 12:00:18 +02:00
# (source as a section here, so it can be inherited by other man pages:)
2018-09-24 23:33:29 +02:00
#' @section Source:
2019-11-28 22:32:17 +01:00
#' 1. Becker K *et al.* **Coagulase-Negative Staphylococci**. 2014. Clin Microbiol Rev. 27(4): 870– 926. <https://dx.doi.org/10.1128/CMR.00109-13>
#' 2. Becker K *et al.* **Implications of identifying the recently defined members of the *S. aureus* complex, *S. argenteus* and *S. schweitzeri*: A position paper of members of the ESCMID Study Group for staphylococci and Staphylococcal Diseases (ESGS).** 2019. Clin Microbiol Infect. <https://doi.org/10.1016/j.cmi.2019.02.028>
#' 3. Lancefield RC **A serological differentiation of human and other groups of hemolytic streptococci**. 1933. J Exp Med. 57(4): 571– 95. <https://dx.doi.org/10.1084/jem.57.4.571>
#' 4. Catalogue of Life: Annual Checklist (public online taxonomic database), <http://www.catalogueoflife.org> (check included annual version with [catalogue_of_life_version()]).
2018-06-08 12:06:54 +02:00
#' @export
2019-11-28 22:32:17 +01:00
#' @return A [`character`] vector with class [`mo`]
#' @seealso [microorganisms] for the [`data.frame`] that is being used to determine ID's.
#'
#' The [mo_property()] functions (like [mo_genus()], [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!
2019-03-01 09:34:04 +01:00
#' @importFrom dplyr %>% pull left_join
2018-06-08 12:06:54 +02:00
#' @examples
2019-07-02 16:48:52 +02:00
#' \donttest{
2019-09-18 15:46:09 +02:00
#' # These examples all return "B_STPHY_AURS", the ID of S. aureus:
2019-03-09 08:21:00 +01:00
#' as.mo("sau") # WHONET code
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)")
2019-11-15 15:25:03 +01:00
#' as.mo("Zthafilokkoockus oureuz") # handles incorrect spelling
2020-01-27 19:14:23 +01:00
#' as.mo("MRSA") # Methicillin Resistant S. aureus
#' as.mo("VISA") # Vancomycin Intermediate S. aureus
#' as.mo("VRSA") # Vancomycin Resistant S. aureus
#' as.mo(22242419) # Catalogue of Life ID
#' as.mo(115329001) # SNOMED CT code
#'
2019-03-18 14:29:41 +01:00
#' # Dyslexia is no problem - these all work:
#' as.mo("Ureaplasma urealyticum")
#' as.mo("Ureaplasma urealyticus")
#' as.mo("Ureaplasmium urealytica")
#' as.mo("Ureaplazma urealitycium")
#'
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-09-18 15:46:09 +02:00
#' as.mo("S. epidermidis") # will remain species: B_STPHY_EPDR
#' as.mo("S. epidermidis", Becker = TRUE) # will not remain species: B_STPHY_CONS
2018-08-02 13:15:45 +02:00
#'
2019-09-18 15:46:09 +02:00
#' as.mo("S. pyogenes") # will remain species: B_STRPT_PYGN
#' as.mo("S. pyogenes", Lancefield = TRUE) # will not remain species: B_STRPT_GRPA
2018-08-02 13:15:45 +02:00
#'
2019-03-18 14:29:41 +01:00
#' # All mo_* functions use as.mo() internally too (see ?mo_property):
2018-09-24 23:33:29 +02:00
#' mo_genus("E. coli") # returns "Escherichia"
2019-08-13 16:15:08 +02:00
#' mo_gramstain("E. coli") # returns "Gram negative"
#'
2019-07-02 16:48:52 +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-11-23 12:39:57 +01:00
as.mo <- function ( x ,
Becker = FALSE ,
Lancefield = FALSE ,
allow_uncertain = TRUE ,
reference_df = get_mo_source ( ) ,
... ) {
2020-02-14 19:54:13 +01:00
check_dataset_integrity ( )
2019-08-12 19:07:15 +02:00
2020-04-13 21:09:56 +02:00
# start off with replaced language-specific non-ASCII characters with ASCII characters
2020-04-14 15:10:09 +02:00
x <- parse_and_convert ( x )
2020-04-13 21:09:56 +02:00
2019-06-02 19:23:19 +02:00
# WHONET: xxx = no growth
x [tolower ( as.character ( paste0 ( x , " " ) ) ) %in% c ( " " , " xxx" , " na" , " nan" ) ] <- NA_character_
2020-04-13 21:09:56 +02:00
# Laboratory systems: remove entries like "no growth" etc
x [trimws2 ( x ) %like% " (no .*growth|keine? .*wachtstum|geen .*groei|no .*crecimientonon|sem .*crescimento|pas .*croissance)" ] <- NA_character_
x [trimws2 ( x ) %like% " ^(no|not|kein|geen|niet|non|sem) [a-z]+" ] <- " UNKNOWN"
2019-08-12 19:07:15 +02:00
2019-03-26 14:24:03 +01:00
uncertainty_level <- translate_allow_uncertain ( allow_uncertain )
2020-01-31 23:27:38 +01:00
2019-03-05 22:47:42 +01:00
if ( mo_source_isvalid ( reference_df )
2019-02-26 12:33:26 +01:00
& isFALSE ( Becker )
& isFALSE ( Lancefield )
2019-03-01 09:34:04 +01:00
& ! is.null ( reference_df )
2019-10-11 17:21:02 +02:00
& all ( x %in% reference_df [ , 1 ] [ [1 ] ] ) ) {
2019-08-12 19:07:15 +02:00
2019-03-01 09:34:04 +01:00
# has valid own reference_df
# (data.table not faster here)
2019-03-05 22:47:42 +01:00
reference_df <- reference_df %>% filter ( ! is.na ( mo ) )
# keep only first two columns, second must be mo
if ( colnames ( reference_df ) [1 ] == " mo" ) {
reference_df <- reference_df [ , c ( 2 , 1 ) ]
} else {
reference_df <- reference_df [ , c ( 1 , 2 ) ]
}
2019-03-01 09:34:04 +01:00
colnames ( reference_df ) [1 ] <- " x"
2019-03-05 22:47:42 +01:00
# remove factors, just keep characters
suppressWarnings (
reference_df [ ] <- lapply ( reference_df , as.character )
)
2019-03-01 09:34:04 +01:00
suppressWarnings (
y <- data.frame ( x = x , stringsAsFactors = FALSE ) %>%
left_join ( reference_df , by = " x" ) %>%
pull ( " mo" )
)
2019-08-12 19:07:15 +02:00
2019-09-15 22:57:30 +02:00
} else if ( all ( x %in% microorganismsDT $ mo )
2019-03-12 12:19:27 +01:00
& isFALSE ( Becker )
& isFALSE ( Lancefield ) ) {
2019-02-26 12:33:26 +01:00
y <- x
2019-08-12 19:07:15 +02:00
2019-03-18 14:29:41 +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 ,
2019-03-26 14:24:03 +01:00
allow_uncertain = uncertainty_level , reference_df = reference_df ,
2019-05-10 16:44:59 +02:00
... )
2019-03-18 14:29:41 +01:00
}
2019-08-12 19:07:15 +02:00
2019-08-07 15:37:39 +02:00
to_class_mo ( y )
}
to_class_mo <- function ( x ) {
structure ( .Data = x , class = " mo" )
2018-09-27 23:23:48 +02:00
}
#' @rdname as.mo
#' @export
is.mo <- function ( x ) {
2020-01-31 23:27:38 +01:00
inherits ( x , " mo" )
2018-09-27 23:23:48 +02:00
}
2020-03-14 14:05:43 +01:00
#' @importFrom dplyr %>% pull left_join n_distinct filter distinct
2018-10-31 12:10:49 +01:00
#' @importFrom data.table data.table as.data.table setkey
2019-07-01 14:03:15 +02:00
#' @importFrom crayon magenta red blue silver italic
2019-11-03 22:24:42 +01:00
#' @importFrom cleaner percentage
2020-02-14 19:54:13 +01:00
# param property a column name of microorganisms
2019-03-15 17:36:42 +01:00
# param initial_search logical - is FALSE when coming from uncertain tries, which uses exec_as.mo internally too
2019-08-12 19:07:15 +02:00
# param dyslexia_mode logical - also check for characters that resemble others
2019-03-18 14:29:41 +01:00
# param debug logical - show different lookup texts while searching
2019-09-20 14:18:29 +02:00
# param reference_data_to_use data.frame - the data set to check for
2019-03-15 13:57:25 +01:00
exec_as.mo <- function ( x ,
Becker = FALSE ,
Lancefield = FALSE ,
allow_uncertain = TRUE ,
reference_df = get_mo_source ( ) ,
property = " mo" ,
2019-03-15 17:36:42 +01:00
initial_search = TRUE ,
2019-08-12 19:07:15 +02:00
dyslexia_mode = FALSE ,
2019-09-15 22:57:30 +02:00
debug = FALSE ,
reference_data_to_use = microorganismsDT ) {
2019-12-21 10:56:06 +01:00
2020-02-14 19:54:13 +01:00
check_dataset_integrity ( )
2019-08-12 19:07:15 +02:00
2020-04-13 21:09:56 +02:00
# start off with replaced language-specific non-ASCII characters with ASCII characters
2020-04-14 15:10:09 +02:00
x <- parse_and_convert ( x )
2020-04-13 21:09:56 +02:00
2019-06-02 19:23:19 +02:00
# WHONET: xxx = no growth
x [tolower ( as.character ( paste0 ( x , " " ) ) ) %in% c ( " " , " xxx" , " na" , " nan" ) ] <- NA_character_
2020-04-13 21:09:56 +02:00
# Laboratory systems: remove entries like "no growth" etc
x [trimws2 ( x ) %like% " (no .*growth|keine? .*wachtstum|geen .*groei|no .*crecimientonon|sem .*crescimento|pas .*croissance)" ] <- NA_character_
x [trimws2 ( x ) %like% " ^(no|not|kein|geen|niet|non|sem) [a-z]+" ] <- " UNKNOWN"
2019-03-15 17:36:42 +01:00
if ( initial_search == TRUE ) {
2018-12-06 14:36:39 +01:00
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 )
}
2019-08-20 11:40:54 +02:00
options ( mo_renamed_last_run = NULL )
2020-04-14 15:10:09 +02:00
2019-08-20 11:40:54 +02:00
uncertainties <- data.frame ( uncertainty = integer ( 0 ) ,
input = character ( 0 ) ,
2019-02-27 11:36:12 +01:00
fullname = character ( 0 ) ,
2019-08-20 11:40:54 +02:00
renamed_to = character ( 0 ) ,
mo = character ( 0 ) ,
stringsAsFactors = FALSE )
2018-09-27 23:23:48 +02:00
failures <- character ( 0 )
2019-03-26 14:24:03 +01:00
uncertainty_level <- translate_allow_uncertain ( allow_uncertain )
2019-09-18 15:46:09 +02:00
old_mo_warning <- FALSE
2019-08-12 19:07:15 +02:00
2018-09-27 23:23:48 +02:00
x_input <- x
2019-02-23 18:08:28 +01:00
# already strip leading and trailing spaces
2020-04-13 21:09:56 +02:00
x <- trimws ( x )
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)
2019-06-02 19:23:19 +02:00
# ("xxx" is WHONET code for 'no growth')
2019-03-05 22:47:42 +01:00
x <- x [ ! is.na ( x )
& ! is.null ( x )
& ! identical ( x , " " )
2019-06-02 19:23:19 +02:00
& ! identical ( x , " xxx" ) ]
2019-08-12 19:07:15 +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-09-15 22:57:30 +02:00
if ( any ( x %like_case% " ^[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 ) ) ) {
2019-09-18 15:46:09 +02:00
old_mo_warning <- TRUE
2019-02-20 00:04:48 +01:00
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-05-20 12:00:18 +02:00
# now check if some are still old
still_old <- x [x %in% names ( mo_codes_v0.5.0 ) ]
if ( length ( still_old ) > 0 ) {
2019-09-18 15:46:09 +02:00
old_mo_warning <- TRUE
2019-05-20 12:00:18 +02:00
x [x %in% names ( mo_codes_v0.5.0 ) ] <- data.frame ( old = still_old , stringsAsFactors = FALSE ) %>%
left_join ( data.frame ( old = names ( mo_codes_v0.5.0 ) ,
new = mo_codes_v0.5.0 ,
stringsAsFactors = FALSE ) , by = " old" ) %>%
# if they couldn't be found, replace them with the old ones again,
# so they will throw a warning in the end
mutate ( new = ifelse ( is.na ( new ) , old , new ) ) %>%
pull ( new )
}
2019-02-20 00:04:48 +01:00
}
2019-08-12 19:07:15 +02:00
2018-10-01 11:39:43 +02:00
# defined df to check for
if ( ! is.null ( reference_df ) ) {
2019-03-05 22:47:42 +01:00
if ( ! mo_source_isvalid ( reference_df ) ) {
2019-01-21 15:53:01 +01:00
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 ) )
2019-03-05 22:47:42 +01:00
# keep only first two columns, second must be mo
if ( colnames ( reference_df ) [1 ] == " mo" ) {
reference_df <- reference_df [ , c ( 2 , 1 ) ]
} else {
reference_df <- reference_df [ , c ( 1 , 2 ) ]
}
colnames ( reference_df ) [1 ] <- " x"
# remove factors, just keep characters
2018-10-01 11:39:43 +02:00
suppressWarnings (
reference_df [ ] <- lapply ( reference_df , as.character )
)
}
2019-08-12 19:07:15 +02:00
2019-02-23 18:08:28 +01:00
# all empty
2019-03-06 14:39:02 +01:00
if ( all ( identical ( trimws ( x_input ) , " " ) | is.na ( x_input ) | length ( x ) == 0 ) ) {
2019-01-08 16:23:45 +01:00
if ( property == " mo" ) {
2019-08-07 15:37:39 +02:00
return ( to_class_mo ( rep ( NA_character_ , length ( x_input ) ) ) )
2019-01-08 16:23:45 +01:00
} else {
return ( rep ( NA_character_ , length ( x_input ) ) )
}
2019-08-12 19:07:15 +02:00
2019-03-05 22:47:42 +01:00
} else if ( all ( x %in% reference_df [ , 1 ] [ [1 ] ] ) ) {
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" ) %>%
2020-02-14 19:54:13 +01:00
left_join ( microorganisms , by = " mo" ) %>%
2018-10-01 11:39:43 +02:00
pull ( property )
)
2019-08-12 19:07:15 +02:00
2019-09-15 22:57:30 +02:00
} else if ( all ( x %in% reference_data_to_use $ 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-12-21 10:56:06 +01:00
y <- reference_data_to_use [prevalence == 1 ] [data.table ( mo = x ) ,
on = " mo" ,
..property ] [ [1 ] ]
2019-02-25 15:52:32 +01:00
if ( any ( is.na ( y ) ) ) {
2019-09-15 22:57:30 +02:00
y [is.na ( y ) ] <- reference_data_to_use [prevalence == 2 ] [data.table ( mo = x [is.na ( y ) ] ) ,
2019-10-08 22:21:33 +02:00
on = " mo" ,
..property ] [ [1 ] ]
2019-02-25 15:52:32 +01:00
}
if ( any ( is.na ( y ) ) ) {
2019-09-15 22:57:30 +02:00
y [is.na ( y ) ] <- reference_data_to_use [prevalence == 3 ] [data.table ( mo = x [is.na ( y ) ] ) ,
2019-10-08 22:21:33 +02:00
on = " mo" ,
..property ] [ [1 ] ]
2019-02-25 15:52:32 +01:00
}
x <- y
2019-08-12 19:07:15 +02:00
2019-09-15 22:57:30 +02:00
} else if ( all ( tolower ( x ) %in% reference_data_to_use $ 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-12-21 10:56:06 +01:00
x <- reference_data_to_use [data.table ( fullname_lower = tolower ( x ) ) ,
on = " fullname_lower" ,
..property ] [ [1 ] ]
2019-08-12 19:07:15 +02:00
2020-02-14 19:54:13 +01:00
} else if ( all ( toupper ( x ) %in% microorganisms.codes $ code ) ) {
2019-01-21 15:53:01 +01:00
# commonly used MO codes
2020-02-14 19:54:13 +01:00
y <- as.data.table ( microorganisms.codes ) [data.table ( code = toupper ( x ) ) ,
2019-12-21 10:56:06 +01:00
on = " code" , ]
2019-08-12 19:07:15 +02:00
2019-12-21 10:56:06 +01:00
x <- reference_data_to_use [data.table ( mo = y [ [ " mo" ] ] ) ,
on = " mo" ,
..property ] [ [1 ] ]
2019-08-12 19:07:15 +02:00
2019-09-18 15:46:09 +02:00
} else if ( all ( x %in% microorganisms.translation $ mo_old ) ) {
# is an old mo code, used in previous versions of this package
old_mo_warning <- TRUE
2019-12-21 10:56:06 +01:00
y <- as.data.table ( microorganisms.translation ) [data.table ( mo_old = x ) ,
on = " mo_old" , " mo_new" ] [ [1 ] ]
y <- reference_data_to_use [data.table ( mo = y ) ,
on = " mo" ,
..property ] [ [1 ] ]
2019-09-18 15:46:09 +02:00
x <- y
2020-02-14 19:54:13 +01:00
} else if ( ! all ( x %in% microorganisms [ , property ] ) ) {
2019-08-12 19:07:15 +02:00
2019-09-15 22:57:30 +02:00
strip_whitespace <- function ( x , dyslexia_mode ) {
2019-05-28 16:50:40 +02:00
# all whitespaces (tab, new lines, etc.) should be one space
# and spaces before and after should be omitted
2020-04-13 21:09:56 +02:00
trimmed <- trimws2 ( x )
2019-09-15 22:57:30 +02:00
# also, make sure the trailing and leading characters are a-z or 0-9
# in case of non-regex
if ( dyslexia_mode == FALSE ) {
trimmed <- gsub ( " ^[^a-zA-Z0-9)(]+" , " " , trimmed )
trimmed <- gsub ( " [^a-zA-Z0-9)(]+$" , " " , trimmed )
}
trimmed
2019-05-28 16:50:40 +02:00
}
2019-08-12 19:07:15 +02:00
2019-10-23 14:48:25 +02:00
x_backup_untouched <- x
2019-09-15 22:57:30 +02:00
x <- strip_whitespace ( x , dyslexia_mode )
2019-02-23 18:08:28 +01:00
x_backup <- x
2019-08-12 19:07:15 +02:00
2019-09-15 22:57:30 +02:00
# from here on case-insensitive
x <- tolower ( x )
2019-09-18 15:46:09 +02:00
x_backup [grepl ( " ^(fungus|fungi)$" , x ) ] <- " F_FUNGUS" # will otherwise become the kingdom
2018-11-24 20:25:09 +01:00
# remove spp and species
2019-09-23 17:32:05 +02:00
x <- gsub ( " +(spp.?|ssp.?|sp.? |ss ?.?|subsp.?|subspecies|biovar |serovar |species)" , " " , x )
x <- gsub ( " (spp.?|subsp.?|subspecies|biovar|serovar|species)" , " " , x )
2020-04-13 21:09:56 +02:00
x <- gsub ( " ^([a-z]{2,4})(spe.?)$" , " \\1" , x ) # when ending in SPE instead of SPP and preceded by 2-4 characters
2019-09-15 22:57:30 +02:00
x <- strip_whitespace ( x , dyslexia_mode )
2020-04-13 21:09:56 +02:00
2019-03-12 12:19:27 +01:00
x_backup_without_spp <- x
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
2019-09-15 22:57:30 +02:00
x <- gsub ( " (gruppe|groep|grupo|gruppo|groupe)" , " group" , x )
# no groups and complexes as ending
x <- gsub ( " (complex|group)$" , " " , x )
x <- gsub ( " ((an)?aero+b)[a-z]*" , " " , x )
2019-09-18 15:46:09 +02:00
x <- gsub ( " ^atyp[a-z]*" , " " , x )
2019-09-15 22:57:30 +02:00
x <- gsub ( " (vergroen)[a-z]*" , " viridans" , x )
2019-09-18 15:46:09 +02:00
x <- gsub ( " [a-z]*diff?erent[a-z]*" , " " , x )
2019-09-15 22:57:30 +02:00
x <- gsub ( " (hefe|gist|gisten|levadura|lievito|fermento|levure)[a-z]*" , " yeast" , x )
x <- gsub ( " (schimmels?|mofo|molde|stampo|moisissure|fungi)[a-z]*" , " fungus" , x )
x <- gsub ( " fungus[ph|f]rya" , " fungiphrya" , x )
2020-04-13 21:09:56 +02:00
# no contamination
x <- gsub ( " (contamination|kontamination|mengflora|contaminaci.n|contamina..o)" , " " , x )
2018-11-24 20:25:09 +01:00
# remove non-text in case of "E. coli" except dots and spaces
2019-09-18 15:46:09 +02:00
x <- trimws ( gsub ( " [^.a-zA-Z0-9/ \\-]+" , " " , x ) )
2020-02-09 22:04:29 +01:00
# but make sure that dots are followed by a space
x <- gsub ( " [.] ?" , " . " , x )
2019-02-08 16:06:54 +01:00
# replace minus by a space
x <- gsub ( " -+" , " " , x )
# replace hemolytic by haemolytic
2019-09-15 22:57:30 +02:00
x <- gsub ( " ha?emoly" , " haemoly" , x )
2019-02-08 16:06:54 +01:00
# place minus back in streptococci
2019-09-15 22:57:30 +02:00
x <- gsub ( " (alpha|beta|gamma).?ha?emoly" , " \\1-haemoly" , x )
2019-02-08 16:06:54 +01:00
# remove genus as first word
2019-09-15 22:57:30 +02:00
x <- gsub ( " ^genus " , " " , x )
2019-11-15 15:25:03 +01:00
# remove 'uncertain'-like texts
2019-09-15 22:57:30 +02:00
x <- trimws ( gsub ( " (uncertain|susp[ie]c[a-z]+|verdacht)" , " " , x ) )
2019-08-13 16:15:08 +02:00
# allow characters that resemble others = dyslexia_mode ----
2019-08-12 19:07:15 +02:00
if ( dyslexia_mode == TRUE ) {
2019-06-07 22:47:37 +02:00
x <- tolower ( x )
x <- gsub ( " [iy]+" , " [iy]+" , x )
x <- gsub ( " (c|k|q|qu|s|z|x|ks)+" , " (c|k|q|qu|s|z|x|ks)+" , x )
2019-08-13 16:15:08 +02:00
x <- gsub ( " (ph|hp|f|v)+" , " (ph|hp|f|v)+" , x )
x <- gsub ( " (th|ht|t)+" , " (th|ht|t)+" , x )
2019-06-07 22:47:37 +02:00
x <- gsub ( " a+" , " a+" , x )
x <- gsub ( " u+" , " u+" , x )
2019-06-27 11:57:45 +02:00
# allow any ending of -um, -us, -ium, -icum, -ius, -icus, -ica and -a (needs perl for the negative backward lookup):
2019-08-06 14:39:22 +02:00
x <- gsub ( " (u\\+\\(c\\|k\\|q\\|qu\\+\\|s\\|z\\|x\\|ks\\)\\+)(?![a-z])" ,
2019-09-15 22:57:30 +02:00
" (u[s|m]|[iy][ck]?u[ms]|[iy]?[ck]?a)" , x , perl = TRUE )
2019-08-06 14:39:22 +02:00
x <- gsub ( " (\\[iy\\]\\+\\(c\\|k\\|q\\|qu\\+\\|s\\|z\\|x\\|ks\\)\\+a\\+)(?![a-z])" ,
2019-09-15 22:57:30 +02:00
" (u[s|m]|[iy][ck]?u[ms]|[iy]?[ck]?a)" , x , perl = TRUE )
2019-08-06 14:39:22 +02:00
x <- gsub ( " (\\[iy\\]\\+u\\+m)(?![a-z])" ,
2019-09-15 22:57:30 +02:00
" (u[s|m]|[iy][ck]?u[ms]|[iy]?[ck]?a)" , x , perl = TRUE )
x <- gsub ( " e+" , " e+" , x )
x <- gsub ( " o+" , " o+" , x )
2019-06-07 22:47:37 +02:00
x <- gsub ( " (.)\\1+" , " \\1+" , x )
2019-11-15 15:25:03 +01:00
# allow multiplication of all other consonants
2019-11-15 16:50:46 +01:00
x <- gsub ( " ([bdgjlnrw]+)" , " \\1+" , x )
2019-08-06 14:39:22 +02:00
# allow ending in -en or -us
2019-09-15 22:57:30 +02:00
x <- gsub ( " e\\+n(?![a-z[])" , " (e+n|u+(c|k|q|qu|s|z|x|ks)+)" , x , perl = TRUE )
2019-11-15 15:25:03 +01:00
# if the input is longer than 10 characters, allow any forgotten consonant between all characters, as some might just have forgotten one...
2019-08-13 16:15:08 +02:00
# this will allow "Pasteurella damatis" to be correctly read as "Pasteurella dagmatis".
2019-11-15 15:25:03 +01:00
consonants <- paste ( letters [ ! letters %in% c ( " a" , " e" , " i" , " o" , " u" ) ] , collapse = " " )
x [nchar ( x_backup_without_spp ) > 10 ] <- gsub ( " [+]" , paste0 ( " +[" , consonants , " ]?" ) , x [nchar ( x_backup_without_spp ) > 10 ] )
# allow au and ou after all these regex implementations
x <- gsub ( " a+[bcdfghjklmnpqrstvwxyz]?u+[bcdfghjklmnpqrstvwxyz]?" , " (a+u+|o+u+)[bcdfghjklmnpqrstvwxyz]?" , x , fixed = TRUE )
x <- gsub ( " o+[bcdfghjklmnpqrstvwxyz]?u+[bcdfghjklmnpqrstvwxyz]?" , " (a+u+|o+u+)[bcdfghjklmnpqrstvwxyz]?" , x , fixed = TRUE )
2019-06-07 22:47:37 +02:00
}
2019-09-15 22:57:30 +02:00
x <- strip_whitespace ( x , dyslexia_mode )
2019-11-15 16:50:46 +01:00
# make sure to remove regex overkill (will lead to errors)
x <- gsub ( " ++" , " +" , x , fixed = TRUE )
x <- gsub ( " ?+" , " ?" , x , fixed = TRUE )
2019-10-08 22:21:33 +02:00
2018-09-27 23:23:48 +02:00
x_trimmed <- x
x_trimmed_species <- paste ( x_trimmed , " species" )
2019-09-15 22:57:30 +02:00
x_trimmed_without_group <- gsub ( " gro.u.p$" , " " , x_trimmed )
2018-12-06 14:36:39 +01:00
# 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
2019-10-11 17:21:02 +02:00
x <- paste0 ( " ^" , x , " $" )
2019-09-15 22:57:30 +02:00
2019-10-11 17:21:02 +02:00
x_withspaces_start_only <- paste0 ( " ^" , x_withspaces )
x_withspaces_end_only <- paste0 ( x_withspaces , " $" )
x_withspaces_start_end <- paste0 ( " ^" , x_withspaces , " $" )
2019-08-12 19:07:15 +02:00
2019-08-06 14:39:22 +02:00
if ( isTRUE ( debug ) ) {
2019-11-18 12:10:47 +01:00
cat ( paste0 ( blue ( " x" ) , ' "' , x , ' "\n' ) )
cat ( paste0 ( blue ( " x_species" ) , ' "' , x_species , ' "\n' ) )
cat ( paste0 ( blue ( " x_withspaces_start_only" ) , ' "' , x_withspaces_start_only , ' "\n' ) )
cat ( paste0 ( blue ( " x_withspaces_end_only" ) , ' "' , x_withspaces_end_only , ' "\n' ) )
cat ( paste0 ( blue ( " x_withspaces_start_end" ) , ' "' , x_withspaces_start_end , ' "\n' ) )
cat ( paste0 ( blue ( " x_backup" ) , ' "' , x_backup , ' "\n' ) )
cat ( paste0 ( blue ( " x_backup_without_spp" ) , ' "' , x_backup_without_spp , ' "\n' ) )
cat ( paste0 ( blue ( " x_trimmed" ) , ' "' , x_trimmed , ' "\n' ) )
cat ( paste0 ( blue ( " x_trimmed_species" ) , ' "' , x_trimmed_species , ' "\n' ) )
cat ( paste0 ( blue ( " x_trimmed_without_group" ) , ' "' , x_trimmed_without_group , ' "\n' ) )
2019-03-18 14:29:41 +01:00
}
2019-08-12 19:07:15 +02:00
2020-01-27 19:14:23 +01:00
if ( initial_search == TRUE ) {
progress <- progress_estimated ( n = length ( x ) , min_time = 3 )
# before we start, omit the ones that are obvious - MO codes and full names
skip_vect <- rep ( FALSE , length ( x ) )
skip_vect [toupper ( x_backup ) %in% reference_data_to_use $ mo ] <- TRUE
skip_vect [tolower ( x_backup ) %in% reference_data_to_use $ fullname_lower ] <- TRUE
x [toupper ( x_backup ) %in% reference_data_to_use $ mo ] <- reference_data_to_use [data.table ( mo = toupper ( x_backup [toupper ( x_backup ) %in% reference_data_to_use $ mo ] ) ) ,
on = " mo" ,
..property ] [ [1 ] ]
x [tolower ( x_backup ) %in% reference_data_to_use $ fullname_lower ] <- reference_data_to_use [data.table ( fullname_lower = tolower ( x_backup [tolower ( x_backup ) %in% reference_data_to_use $ fullname_lower ] ) ) ,
on = " fullname_lower" ,
..property ] [ [1 ] ]
}
2019-10-11 17:21:02 +02:00
for ( i in seq_len ( length ( x ) ) ) {
2019-08-12 19:07:15 +02:00
2020-01-27 19:14:23 +01:00
if ( initial_search == TRUE ) {
progress $ tick ( ) $ print ( )
if ( isTRUE ( skip_vect [i ] ) ) {
next
}
}
2019-08-12 19:07:15 +02:00
2019-09-18 15:46:09 +02:00
if ( x_backup [i ] %like_case% " \\(unknown [a-z]+\\)" ) {
x [i ] <- " UNKNOWN"
next
}
2019-12-21 10:56:06 +01:00
found <- reference_data_to_use [mo == toupper ( x_backup [i ] ) ,
..property ] [ [1 ] ]
2019-02-23 16:02:31 +01:00
# is a valid MO code
if ( length ( found ) > 0 ) {
x [i ] <- found [1L ]
next
}
2019-08-12 19:07:15 +02:00
2019-09-18 15:46:09 +02:00
if ( x_backup [i ] %in% microorganisms.translation $ mo_old ) {
# is an old mo code, used in previous versions of this package
old_mo_warning <- TRUE
2019-12-21 10:56:06 +01:00
found <- reference_data_to_use [mo == microorganisms.translation [which ( microorganisms.translation $ mo_old == x_backup [i ] ) , " mo_new" ] ,
..property ] [ [1 ] ]
2019-09-18 15:46:09 +02:00
if ( length ( found ) > 0 ) {
x [i ] <- found [1L ]
next
}
}
2019-12-21 10:56:06 +01:00
2019-10-23 14:48:25 +02:00
if ( toupper ( x_backup_untouched [i ] ) %in% microorganisms.codes $ code ) {
# is a WHONET code, like "HA-"
2019-12-21 10:56:06 +01:00
found <- microorganismsDT [mo == microorganisms.codes [which ( microorganisms.codes $ code == toupper ( x_backup_untouched [i ] ) ) , " mo" ] [1L ] ,
..property ] [ [1 ] ]
2019-10-23 14:48:25 +02:00
if ( length ( found ) > 0 ) {
x [i ] <- found [1L ]
next
}
}
2019-09-18 15:46:09 +02:00
2019-12-21 10:56:06 +01:00
found <- reference_data_to_use [fullname_lower %in% tolower ( c ( x_backup [i ] , x_backup_without_spp [i ] ) ) ,
..property ] [ [1 ] ]
2019-03-12 12:19:27 +01:00
# most probable: is exact match in fullname
if ( length ( found ) > 0 ) {
x [i ] <- found [1L ]
next
}
2019-08-12 19:07:15 +02:00
2020-01-27 19:14:23 +01:00
# exact SNOMED code
if ( x_backup [i ] %like% " ^[0-9]+$" ) {
snomed_found <- unlist ( lapply ( reference_data_to_use $ snomed ,
function ( s ) if ( x_backup [i ] %in% s ) {
TRUE
} else {
FALSE
} ) )
found <- reference_data_to_use [snomed_found == TRUE ,
..property ] [ [1 ] ]
if ( length ( found ) > 0 ) {
x [i ] <- found [1L ]
next
}
}
# very probable: is G. species
2019-12-21 10:56:06 +01:00
found <- reference_data_to_use [g_species %in% gsub ( " [^a-z0-9/ \\-]+" , " " ,
tolower ( c ( x_backup [i ] , x_backup_without_spp [i ] ) ) ) ,
..property ] [ [1 ] ]
if ( length ( found ) > 0 ) {
x [i ] <- found [1L ]
next
}
found <- reference_data_to_use [col_id == x_backup [i ] ,
..property ] [ [1 ] ]
2019-06-22 14:49:12 +02:00
# is a valid Catalogue of Life ID
if ( NROW ( found ) > 0 ) {
x [i ] <- found [1L ]
next
}
2019-08-12 19:07:15 +02:00
2019-09-23 17:32:05 +02:00
# WHONET and other common LIS codes
2020-02-14 19:54:13 +01:00
if ( any ( toupper ( c ( x_backup [i ] , x_backup_without_spp [i ] ) ) %in% microorganisms.codes $ code ) ) {
mo_found <- microorganisms.codes [which ( microorganisms.codes $ code %in% toupper ( c ( x_backup [i ] , x_backup_without_spp [i ] ) ) ) , " mo" ] [1L ]
2019-09-23 17:32:05 +02:00
if ( length ( mo_found ) > 0 ) {
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == mo_found ,
..property ] [ [1 ] ] [1L ]
2019-09-23 17:32:05 +02:00
next
}
}
2019-12-21 10:56:06 +01:00
2019-09-23 17:32:05 +02:00
if ( ! is.null ( reference_df ) ) {
# self-defined reference
if ( x_backup [i ] %in% reference_df [ , 1 ] ) {
2019-09-23 20:55:54 +02:00
ref_mo <- reference_df [reference_df [ , 1 ] == x_backup [i ] , " mo" ] [ [1L ] ]
if ( ref_mo %in% microorganismsDT [ , mo ] ) {
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == ref_mo ,
..property ] [ [1 ] ] [1L ]
2019-09-23 17:32:05 +02:00
next
} else {
warning ( " Value '" , x_backup [i ] , " ' was found in reference_df, but '" , ref_mo , " ' is not a valid MO code." , call. = FALSE )
}
}
}
2019-08-12 19:07:15 +02:00
2019-06-02 19:23:19 +02:00
# WHONET: xxx = no growth
if ( tolower ( as.character ( paste0 ( x_backup_without_spp [i ] , " " ) ) ) %in% c ( " " , " xxx" , " na" , " nan" ) ) {
2018-10-19 00:17:03 +02:00
x [i ] <- NA_character_
next
}
2019-08-12 19:07:15 +02:00
2019-03-12 12:19:27 +01:00
if ( tolower ( x_backup_without_spp [i ] ) %in% c ( " other" , " none" , " unknown" ) ) {
2019-03-02 22:47:04 +01:00
# empty and nonsense values, ignore without warning
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == " UNKNOWN" ,
..property ] [ [1 ] ]
2019-03-02 22:47:04 +01:00
next
}
2019-08-12 19:07:15 +02:00
2019-05-10 16:44:59 +02:00
# check for very small input, but ignore the O antigens of E. coli
if ( nchar ( gsub ( " [^a-zA-Z]" , " " , x_trimmed [i ] ) ) < 3
2019-09-15 22:57:30 +02:00
& ! x_backup_without_spp [i ] %like_case% " [Oo]?(26|103|104|104|111|121|145|157)" ) {
2018-11-30 12:05:59 +01:00
# fewer than 3 chars and not looked for species, add as failure
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == " UNKNOWN" ,
..property ] [ [1 ] ]
2019-03-18 14:29:41 +01:00
if ( initial_search == TRUE ) {
failures <- c ( failures , x_backup [i ] )
2019-03-15 17:36:42 +01:00
}
2018-11-30 12:05:59 +01:00
next
2018-09-27 23:23:48 +02:00
}
2019-08-12 19:07:15 +02:00
2020-04-13 21:09:56 +02:00
if ( x_backup_without_spp [i ] %like_case% " (virus|viridae)" ) {
# there is no fullname like virus or viridae, so don't try to coerce it
2019-09-18 15:46:09 +02:00
x [i ] <- NA_character_
2019-01-21 21:24:40 +01:00
next
}
2019-08-12 19:07:15 +02:00
2018-09-27 23:23:48 +02:00
# translate known trivial abbreviations to genus + species ----
if ( ! is.na ( x_trimmed [i ] ) ) {
2019-10-11 17:21:02 +02:00
if ( toupper ( x_backup_without_spp [i ] ) %in% c ( " MRSA" , " MSSA" , " VISA" , " VRSA" )
2019-09-16 12:00:56 +02:00
| x_backup_without_spp [i ] %like_case% " (mrsa|mssa|visa|vrsa) " ) {
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == " B_STPHY_AURS" ,
..property ] [ [1 ] ] [1L ]
2018-09-27 23:23:48 +02:00
next
}
2019-10-11 17:21:02 +02:00
if ( toupper ( x_backup_without_spp [i ] ) %in% c ( " MRSE" , " MSSE" )
2019-09-16 12:00:56 +02:00
| x_backup_without_spp [i ] %like_case% " (mrse|msse) " ) {
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == " B_STPHY_EPDR" ,
..property ] [ [1 ] ] [1L ]
2018-09-27 23:23:48 +02:00
next
}
2019-03-12 12:19:27 +01:00
if ( toupper ( x_backup_without_spp [i ] ) == " VRE"
2019-09-16 12:00:56 +02:00
| x_backup_without_spp [i ] %like_case% " vre "
2019-10-11 17:21:02 +02:00
| x_backup_without_spp [i ] %like_case% " (enterococci|enterokok|enterococo)[a-z]*?$" ) {
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == " B_ENTRC" ,
..property ] [ [1 ] ] [1L ]
2018-09-27 23:23:48 +02:00
next
}
2019-06-22 14:49:12 +02:00
# support for:
# - AIEC (Adherent-Invasive E. coli)
# - ATEC (Atypical Entero-pathogenic E. coli)
# - DAEC (Diffusely Adhering E. coli)
# - EAEC (Entero-Aggresive E. coli)
# - EHEC (Entero-Haemorrhagic E. coli)
# - EIEC (Entero-Invasive E. coli)
# - EPEC (Entero-Pathogenic E. coli)
# - ETEC (Entero-Toxigenic E. coli)
# - NMEC (Neonatal Meningitis‐ causing E. coli)
# - STEC (Shiga-toxin producing E. coli)
# - UPEC (Uropathogenic E. coli)
2019-06-07 22:47:37 +02:00
if ( toupper ( x_backup_without_spp [i ] ) %in% c ( " AIEC" , " ATEC" , " DAEC" , " EAEC" , " EHEC" , " EIEC" , " EPEC" , " ETEC" , " NMEC" , " STEC" , " UPEC" )
2019-09-01 13:16:57 +02:00
# also support O-antigens of E. coli: O26, O103, O104, O111, O121, O145, O157
2019-09-15 22:57:30 +02:00
| x_backup_without_spp [i ] %like_case% " o?(26|103|104|111|121|145|157)" ) {
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == " B_ESCHR_COLI" ,
..property ] [ [1 ] ] [1L ]
2019-02-08 16:06:54 +01:00
next
}
2019-10-11 17:21:02 +02:00
if ( toupper ( x_backup_without_spp [i ] ) == " MRPA"
2019-09-16 12:00:56 +02:00
| x_backup_without_spp [i ] %like_case% " mrpa " ) {
2018-09-27 23:23:48 +02:00
# multi resistant P. aeruginosa
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == " B_PSDMN_ARGN" ,
..property ] [ [1 ] ] [1L ]
2018-09-27 23:23:48 +02:00
next
}
2019-10-11 17:21:02 +02:00
if ( toupper ( x_backup_without_spp [i ] ) == " CRSM" ) {
2018-10-12 16:35:18 +02:00
# co-trim resistant S. maltophilia
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == " B_STNTR_MLTP" ,
..property ] [ [1 ] ] [1L ]
2018-10-12 16:35:18 +02:00
next
}
2019-10-11 17:21:02 +02:00
if ( toupper ( x_backup_without_spp [i ] ) %in% c ( " PISP" , " PRSP" , " VISP" , " VRSP" )
2019-09-16 12:00:56 +02:00
| x_backup_without_spp [i ] %like_case% " (pisp|prsp|visp|vrsp) " ) {
2018-09-27 23:23:48 +02:00
# peni I, peni R, vanco I, vanco R: S. pneumoniae
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == " B_STRPT_PNMN" ,
..property ] [ [1 ] ] [1L ]
2018-09-27 23:23:48 +02:00
next
}
2019-10-11 17:21:02 +02:00
if ( x_backup_without_spp [i ] %like_case% " ^g[abcdfghk]s$" ) {
2019-09-18 15:46:09 +02:00
# Streptococci, like GBS = Group B Streptococci (B_STRPT_GRPB)
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == toupper ( gsub ( " g([abcdfghk])s" , " B_STRPT_GRP\\1" , x_backup_without_spp [i ] ) ) ,
..property ] [ [1 ] ] [1L ]
2018-12-06 14:36:39 +01:00
next
}
2019-10-11 17:21:02 +02:00
if ( x_backup_without_spp [i ] %like_case% " (streptococ|streptokok).* [abcdfghk]$" ) {
2018-12-06 14:36:39 +01:00
# Streptococci in different languages, like "estreptococos grupo B"
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == toupper ( gsub ( " .*(streptococ|streptokok|estreptococ).* ([abcdfghk])$" , " B_STRPT_GRP\\2" , x_backup_without_spp [i ] ) ) ,
..property ] [ [1 ] ] [1L ]
2018-12-06 14:36:39 +01:00
next
}
2019-10-11 17:21:02 +02:00
if ( x_backup_without_spp [i ] %like_case% " group [abcdfghk] (streptococ|streptokok|estreptococ)" ) {
2018-12-06 14:36:39 +01:00
# Streptococci in different languages, like "Group A Streptococci"
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == toupper ( gsub ( " .*group ([abcdfghk]) (streptococ|streptokok|estreptococ).*" , " B_STRPT_GRP\\1" , x_backup_without_spp [i ] ) ) ,
..property ] [ [1 ] ] [1L ]
2018-09-27 23:23:48 +02:00
next
}
2019-10-11 17:21:02 +02:00
if ( x_backup_without_spp [i ] %like_case% " haemoly.*strept" ) {
2019-08-06 14:39:22 +02:00
# Haemolytic streptococci in different languages
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == " B_STRPT_HAEM" ,
..property ] [ [1 ] ] [1L ]
2019-08-06 14:39:22 +02:00
next
}
2018-09-27 23:23:48 +02:00
# CoNS/CoPS in different languages (support for German, Dutch, Spanish, Portuguese) ----
2019-10-11 17:21:02 +02:00
if ( x_backup_without_spp [i ] %like_case% " [ck]oagulas[ea] negatie?[vf]"
| x_trimmed [i ] %like_case% " [ck]oagulas[ea] negatie?[vf]"
| x_backup_without_spp [i ] %like_case% " [ck]o?ns[^a-z]?$" ) {
2018-09-27 23:23:48 +02:00
# coerce S. coagulase negative
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == " B_STPHY_CONS" ,
..property ] [ [1 ] ] [1L ]
2018-09-27 23:23:48 +02:00
next
}
2019-10-11 17:21:02 +02:00
if ( x_backup_without_spp [i ] %like_case% " [ck]oagulas[ea] positie?[vf]"
| x_trimmed [i ] %like_case% " [ck]oagulas[ea] positie?[vf]"
| x_backup_without_spp [i ] %like_case% " [ck]o?ps[^a-z]?$" ) {
2018-09-27 23:23:48 +02:00
# coerce S. coagulase positive
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == " B_STPHY_COPS" ,
..property ] [ [1 ] ] [1L ]
2018-09-27 23:23:48 +02:00
next
}
2019-08-13 16:15:08 +02:00
# streptococcal groups: milleri and viridans
2019-11-15 15:25:03 +01:00
if ( x_trimmed [i ] %like_case% " strepto.* mil+er+i"
| x_backup_without_spp [i ] %like_case% " strepto.* mil+er+i"
2019-10-11 17:21:02 +02:00
| x_backup_without_spp [i ] %like_case% " mgs[^a-z]?$" ) {
2019-08-13 16:15:08 +02:00
# Milleri Group Streptococcus (MGS)
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == " B_STRPT_MILL" ,
..property ] [ [1 ] ] [1L ]
2019-08-13 16:15:08 +02:00
next
}
2019-10-11 17:21:02 +02:00
if ( x_trimmed [i ] %like_case% " strepto.* viridans"
| x_backup_without_spp [i ] %like_case% " strepto.* viridans"
| x_backup_without_spp [i ] %like_case% " vgs[^a-z]?$" ) {
2019-08-13 16:15:08 +02:00
# Viridans Group Streptococcus (VGS)
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == " B_STRPT_VIRI" ,
..property ] [ [1 ] ] [1L ]
2019-08-13 16:15:08 +02:00
next
}
2019-10-11 17:21:02 +02:00
if ( x_backup_without_spp [i ] %like_case% " gram[ -]?neg.*"
| x_backup_without_spp [i ] %like_case% " negatie?[vf]"
| x_trimmed [i ] %like_case% " gram[ -]?neg.*" ) {
2019-03-12 12:19:27 +01:00
# coerce Gram negatives
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == " B_GRAMN" ,
..property ] [ [1 ] ] [1L ]
2018-11-02 10:27:57 +01:00
next
}
2019-10-11 17:21:02 +02:00
if ( x_backup_without_spp [i ] %like_case% " gram[ -]?pos.*"
| x_backup_without_spp [i ] %like_case% " positie?[vf]"
| x_trimmed [i ] %like_case% " gram[ -]?pos.*" ) {
2019-03-12 12:19:27 +01:00
# coerce Gram positives
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == " B_GRAMP" ,
..property ] [ [1 ] ] [1L ]
2018-11-02 10:27:57 +01:00
next
}
2019-10-11 17:21:02 +02:00
if ( x_backup_without_spp [i ] %like_case% " mycoba[ck]teri.[nm]?$" ) {
2019-09-18 15:46:09 +02:00
# coerce Gram positives
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == " B_MYCBC" ,
..property ] [ [1 ] ] [1L ]
2019-09-18 15:46:09 +02:00
next
}
2019-09-15 22:57:30 +02:00
if ( x_backup_without_spp [i ] %like_case% " salmonella [a-z]+ ?.*" ) {
if ( x_backup_without_spp [i ] %like_case% " salmonella group" ) {
2019-02-08 16:06:54 +01:00
# Salmonella Group A to Z, just return S. species for now
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == " B_SLMNL" ,
..property ] [ [1 ] ] [1L ]
2019-09-12 15:08:53 +02:00
next
2020-01-26 20:20:00 +01:00
} else if ( grepl ( " [sS]almonella [A-Z][a-z]+ ?.*" , x_backup [i ] , ignore.case = FALSE ) &
! x_backup [i ] %like% " t[iy](ph|f)[iy]" ) {
2019-02-08 16:06:54 +01:00
# Salmonella with capital letter species like "Salmonella Goettingen" - they're all S. enterica
2020-01-26 20:20:00 +01:00
# except for S. typhi, S. paratyphi, S. typhimurium
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == " B_SLMNL_ENTR" ,
..property ] [ [1 ] ] [1L ]
2019-07-01 14:03:15 +02:00
uncertainties <- rbind ( uncertainties ,
2019-09-12 15:08:53 +02:00
format_uncertainty_as_df ( uncertainty_level = 1 ,
2019-09-23 21:24:37 +02:00
input = x_backup [i ] ,
2019-09-18 15:46:09 +02:00
result_mo = " B_SLMNL_ENTR" ) )
2019-09-12 15:08:53 +02:00
next
2019-02-08 16:06:54 +01:00
}
2018-12-06 14:36:39 +01:00
}
2019-08-06 14:39:22 +02:00
# trivial names known to the field:
2019-09-15 22:57:30 +02:00
if ( " meningococcus" %like_case% x_trimmed [i ] ) {
2019-09-18 15:46:09 +02:00
# coerce Neisseria meningitidis
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == " B_NESSR_MNNG" ,
..property ] [ [1 ] ] [1L ]
2019-08-06 14:39:22 +02:00
next
}
2019-09-15 22:57:30 +02:00
if ( " gonococcus" %like_case% x_trimmed [i ] ) {
2019-09-18 15:46:09 +02:00
# coerce Neisseria gonorrhoeae
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == " B_NESSR_GNRR" ,
..property ] [ [1 ] ] [1L ]
2019-08-06 14:39:22 +02:00
next
}
2019-09-15 22:57:30 +02:00
if ( " pneumococcus" %like_case% x_trimmed [i ] ) {
2019-09-18 15:46:09 +02:00
# coerce Streptococcus penumoniae
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == " B_STRPT_PNMN" ,
..property ] [ [1 ] ] [1L ]
2019-08-06 14:39:22 +02:00
next
}
2018-09-27 23:23:48 +02:00
}
2019-08-12 19:07:15 +02:00
2019-09-15 22:57:30 +02:00
# NOW RUN THROUGH DIFFERENT PREVALENCE LEVELS
check_per_prevalence <- function ( data_to_check ,
2019-09-20 14:18:29 +02:00
data.old_to_check ,
2019-09-15 22:57:30 +02:00
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 ,
g.x_backup_without_spp ,
h.x_species ,
i.x_trimmed_species ) {
# FIRST TRY FULLNAMES AND CODES ----
# if only genus is available, return only genus
if ( all ( ! c ( x [i ] , b.x_trimmed ) %like_case% " " ) ) {
2019-12-21 10:56:06 +01:00
found <- data_to_check [fullname_lower %in% c ( h.x_species , i.x_trimmed_species ) ,
..property ] [ [1 ] ]
2018-09-27 23:23:48 +02:00
if ( length ( found ) > 0 ) {
x [i ] <- found [1L ]
2019-09-15 22:57:30 +02:00
return ( x [i ] )
2018-09-27 23:23:48 +02:00
}
2019-09-15 22:57:30 +02:00
if ( nchar ( g.x_backup_without_spp ) >= 6 ) {
2019-12-21 10:56:06 +01:00
found <- data_to_check [fullname_lower %like_case% paste0 ( " ^" , unregex ( g.x_backup_without_spp ) , " [a-z]+" ) ,
..property ] [ [1 ] ]
2019-09-15 22:57:30 +02:00
if ( length ( found ) > 0 ) {
x [i ] <- found [1L ]
return ( x [i ] )
}
}
# rest of genus only is in allow_uncertain part.
2018-09-27 23:23:48 +02:00
}
2019-09-15 22:57:30 +02:00
2019-09-23 17:32:05 +02:00
# allow no codes less than 4 characters long, was already checked for WHONET earlier
2019-09-15 22:57:30 +02:00
if ( nchar ( g.x_backup_without_spp ) < 4 ) {
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == " UNKNOWN" ,
..property ] [ [1 ] ]
2019-09-15 22:57:30 +02:00
if ( initial_search == TRUE ) {
failures <- c ( failures , a.x_backup )
}
return ( x [i ] )
2019-03-15 17:36:42 +01:00
}
2019-08-12 19:07:15 +02:00
2019-03-12 12:19:27 +01:00
# try probable: trimmed version of fullname ----
2019-12-21 10:56:06 +01:00
found <- data_to_check [fullname_lower %in% tolower ( g.x_backup_without_spp ) ,
..property ] [ [1 ] ]
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-08-12 19:07:15 +02:00
2019-02-21 18:55:52 +01:00
# try any match keeping spaces ----
2019-12-21 10:56:06 +01:00
found <- data_to_check [fullname_lower %like_case% d.x_withspaces_start_end ,
..property ] [ [1 ] ]
2019-03-12 12:19:27 +01:00
if ( length ( found ) > 0 & nchar ( g.x_backup_without_spp ) >= 6 ) {
2019-02-21 18:55:52 +01:00
return ( found [1L ] )
}
2019-08-12 19:07:15 +02:00
2019-02-21 18:55:52 +01:00
# try any match keeping spaces, not ending with $ ----
2019-12-21 10:56:06 +01:00
found <- data_to_check [fullname_lower %like_case% paste0 ( trimws ( e.x_withspaces_start_only ) , " " ) ,
..property ] [ [1 ] ]
2019-02-21 18:55:52 +01:00
if ( length ( found ) > 0 ) {
return ( found [1L ] )
}
2019-12-21 10:56:06 +01:00
found <- data_to_check [fullname_lower %like_case% e.x_withspaces_start_only ,
..property ] [ [1 ] ]
2019-03-12 12:19:27 +01:00
if ( length ( found ) > 0 & nchar ( g.x_backup_without_spp ) >= 6 ) {
2019-02-21 18:55:52 +01:00
return ( found [1L ] )
}
2019-08-12 19:07:15 +02:00
2019-02-21 18:55:52 +01:00
# try any match keeping spaces, not start with ^ ----
2019-12-21 10:56:06 +01:00
found <- data_to_check [fullname_lower %like_case% paste0 ( " " , trimws ( f.x_withspaces_end_only ) ) ,
..property ] [ [1 ] ]
2019-02-21 18:55:52 +01:00
if ( length ( found ) > 0 ) {
return ( found [1L ] )
}
2019-08-12 19:07:15 +02:00
2019-03-18 14:29:41 +01:00
# try a trimmed version
2019-09-15 22:57:30 +02:00
found <- data_to_check [fullname_lower %like_case% b.x_trimmed
2019-12-21 10:56:06 +01:00
| fullname_lower %like_case% c.x_trimmed_without_group ,
..property ] [ [1 ] ]
2019-03-18 14:29:41 +01:00
if ( length ( found ) > 0 & nchar ( g.x_backup_without_spp ) >= 6 ) {
return ( found [1L ] )
}
2019-08-12 19:07:15 +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
2019-03-12 12:19:27 +01:00
if ( nchar ( g.x_backup_without_spp ) <= 6 ) {
x_length <- nchar ( g.x_backup_without_spp )
2019-02-21 18:55:52 +01:00
x_split <- paste0 ( " ^" ,
2019-03-12 12:19:27 +01:00
g.x_backup_without_spp %>% substr ( 1 , x_length / 2 ) ,
2019-10-11 17:21:02 +02:00
" .* " ,
2019-03-12 12:19:27 +01:00
g.x_backup_without_spp %>% substr ( ( x_length / 2 ) + 1 , x_length ) )
2019-12-21 10:56:06 +01:00
found <- data_to_check [fullname_lower %like_case% x_split ,
..property ] [ [1 ] ]
2019-02-21 18:55:52 +01:00
if ( length ( found ) > 0 ) {
return ( found [1L ] )
}
}
2019-08-12 19:07:15 +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
2019-12-21 10:56:06 +01:00
found <- data_to_check [fullname_lower %like_case% 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
}
2019-08-12 19:07:15 +02:00
2019-09-15 22:57:30 +02:00
# MISCELLANEOUS ----
2019-09-20 14:18:29 +02:00
2019-09-15 22:57:30 +02:00
# look for old taxonomic names ----
2019-09-20 12:33:05 +02:00
# wait until prevalence == 2 to run the old taxonomic results on both prevalence == 1 and prevalence == 2
2019-09-20 14:18:29 +02:00
found <- data.old_to_check [fullname_lower == tolower ( a.x_backup )
2019-10-11 17:21:02 +02:00
| fullname_lower %like_case% d.x_withspaces_start_end , ]
2019-09-20 14:18:29 +02:00
if ( NROW ( found ) > 0 ) {
col_id_new <- found [1 , col_id_new ]
# when property is "ref" (which is the case in mo_ref, mo_authors and mo_year), return the old value, so:
2019-10-11 17:21:02 +02:00
# mo_ref() of "Chlamydia psittaci" will be "Page, 1968" (with warning)
# mo_ref() of "Chlamydophila psittaci" will be "Everett et al., 1999"
2019-09-20 14:18:29 +02:00
if ( property == " ref" ) {
x [i ] <- found [1 , ref ]
} else {
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [col_id == found [1 , col_id_new ] ,
..property ] [ [1 ] ]
2019-09-20 14:18:29 +02:00
}
options ( mo_renamed_last_run = found [1 , fullname ] )
was_renamed ( name_old = found [1 , fullname ] ,
name_new = microorganismsDT [col_id == found [1 , col_id_new ] , fullname ] ,
ref_old = found [1 , ref ] ,
ref_new = microorganismsDT [col_id == found [1 , col_id_new ] , ref ] ,
mo = microorganismsDT [col_id == found [1 , col_id_new ] , mo ] )
return ( x [i ] )
2019-03-12 12:19:27 +01:00
}
2019-08-12 19:07:15 +02:00
2019-09-15 22:57:30 +02:00
# check for uncertain results ----
uncertain_fn <- function ( a.x_backup ,
b.x_trimmed ,
d.x_withspaces_start_end ,
e.x_withspaces_start_only ,
f.x_withspaces_end_only ,
g.x_backup_without_spp ,
uncertain.reference_data_to_use ) {
2019-08-12 19:07:15 +02:00
2019-09-15 22:57:30 +02:00
if ( uncertainty_level == 0 ) {
# do not allow uncertainties
return ( NA_character_ )
2019-08-12 19:07:15 +02:00
}
2019-09-15 22:57:30 +02:00
# UNCERTAINTY LEVEL 1 ----
if ( uncertainty_level >= 1 ) {
now_checks_for_uncertainty_level <- 1
# (1) look again for old taxonomic names, now for G. species ----
if ( isTRUE ( debug ) ) {
cat ( " \n[ UNCERTAINTY LEVEL" , now_checks_for_uncertainty_level , " ] (1) look again for old taxonomic names, now for G. species\n" )
2018-12-14 10:52:20 +01:00
}
2019-09-15 22:57:30 +02:00
if ( isTRUE ( debug ) ) {
message ( " Running '" , d.x_withspaces_start_end , " ' and '" , e.x_withspaces_start_only , " '" )
2019-03-26 14:24:03 +01:00
}
2019-09-20 14:18:29 +02:00
found <- data.old_to_check [fullname_lower %like_case% d.x_withspaces_start_end
2019-10-08 22:21:33 +02:00
| fullname_lower %like_case% e.x_withspaces_start_only ]
2019-09-15 22:57:30 +02:00
if ( NROW ( found ) > 0 & nchar ( g.x_backup_without_spp ) >= 6 ) {
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-12-21 10:56:06 +01:00
x <- microorganismsDT [col_id == found [1 , col_id_new ] ,
..property ] [ [1 ] ]
2019-09-15 22:57:30 +02:00
}
was_renamed ( name_old = found [1 , fullname ] ,
name_new = microorganismsDT [col_id == found [1 , col_id_new ] , fullname ] ,
ref_old = found [1 , ref ] ,
ref_new = microorganismsDT [col_id == found [1 , col_id_new ] , ref ] ,
mo = microorganismsDT [col_id == found [1 , col_id_new ] , mo ] )
options ( mo_renamed_last_run = found [1 , fullname ] )
uncertainties <<- rbind ( uncertainties ,
format_uncertainty_as_df ( uncertainty_level = now_checks_for_uncertainty_level ,
input = a.x_backup ,
result_mo = microorganismsDT [col_id == found [1 , col_id_new ] , mo ] ) )
return ( x )
}
# (2) Try with misspelled input ----
# just rerun with dyslexia_mode = TRUE will used the extensive regex part above
if ( isTRUE ( debug ) ) {
cat ( " \n[ UNCERTAINTY LEVEL" , now_checks_for_uncertainty_level , " ] (2) Try with misspelled input\n" )
}
if ( isTRUE ( debug ) ) {
message ( " Running '" , a.x_backup , " '" )
}
# first try without dyslexia mode
found <- suppressMessages ( suppressWarnings ( exec_as.mo ( a.x_backup , initial_search = FALSE , dyslexia_mode = FALSE , allow_uncertain = FALSE , debug = debug , reference_data_to_use = uncertain.reference_data_to_use ) ) )
if ( empty_result ( found ) ) {
# then with dyslexia mode
found <- suppressMessages ( suppressWarnings ( exec_as.mo ( a.x_backup , initial_search = FALSE , dyslexia_mode = TRUE , allow_uncertain = FALSE , debug = debug , reference_data_to_use = uncertain.reference_data_to_use ) ) )
}
if ( ! empty_result ( found ) ) {
found_result <- found
2019-12-21 10:56:06 +01:00
found <- reference_data_to_use [mo == found ,
..property ] [ [1 ] ]
2019-09-15 22:57:30 +02:00
uncertainties <<- rbind ( uncertainties ,
format_uncertainty_as_df ( uncertainty_level = now_checks_for_uncertainty_level ,
input = a.x_backup ,
result_mo = found_result [1L ] ) )
return ( found [1L ] )
2019-07-01 14:03:15 +02:00
}
}
2019-08-12 19:07:15 +02:00
2019-09-15 22:57:30 +02:00
# UNCERTAINTY LEVEL 2 ----
if ( uncertainty_level >= 2 ) {
now_checks_for_uncertainty_level <- 2
# (3) look for genus only, part of name ----
if ( isTRUE ( debug ) ) {
cat ( " \n[ UNCERTAINTY LEVEL" , now_checks_for_uncertainty_level , " ] (3) look for genus only, part of name\n" )
}
if ( nchar ( g.x_backup_without_spp ) > 4 & ! b.x_trimmed %like_case% " " ) {
if ( ! grepl ( " ^[A-Z][a-z]+" , b.x_trimmed , ignore.case = FALSE ) ) {
if ( isTRUE ( debug ) ) {
message ( " Running '" , paste ( b.x_trimmed , " species" ) , " '" )
}
# not when input is like Genustext, because then Neospora would lead to Actinokineospora
2019-12-21 10:56:06 +01:00
found <- uncertain.reference_data_to_use [fullname_lower %like_case% paste ( b.x_trimmed , " species" ) ,
..property ] [ [1 ] ]
2019-09-15 22:57:30 +02:00
if ( length ( found ) > 0 ) {
x [i ] <- found [1L ]
uncertainties <<- rbind ( uncertainties ,
format_uncertainty_as_df ( uncertainty_level = now_checks_for_uncertainty_level ,
input = a.x_backup ,
result_mo = found_result [1L ] ) )
return ( x )
}
2019-08-12 19:07:15 +02:00
}
2019-09-15 22:57:30 +02:00
}
# (4) strip values between brackets ----
if ( isTRUE ( debug ) ) {
cat ( " \n[ UNCERTAINTY LEVEL" , now_checks_for_uncertainty_level , " ] (4) strip values between brackets\n" )
}
a.x_backup_stripped <- gsub ( " ( *[(].*[)] *)" , " " , a.x_backup )
a.x_backup_stripped <- trimws ( gsub ( " +" , " " , a.x_backup_stripped ) )
if ( isTRUE ( debug ) ) {
message ( " Running '" , a.x_backup_stripped , " '" )
}
# first try without dyslexia mode
found <- suppressMessages ( suppressWarnings ( exec_as.mo ( a.x_backup_stripped , initial_search = FALSE , dyslexia_mode = FALSE , allow_uncertain = FALSE , debug = debug , reference_data_to_use = uncertain.reference_data_to_use ) ) )
if ( empty_result ( found ) ) {
# then with dyslexia mode
found <- suppressMessages ( suppressWarnings ( exec_as.mo ( a.x_backup_stripped , initial_search = FALSE , dyslexia_mode = TRUE , allow_uncertain = FALSE , debug = debug , reference_data_to_use = uncertain.reference_data_to_use ) ) )
}
if ( ! empty_result ( found ) & nchar ( g.x_backup_without_spp ) >= 6 ) {
found_result <- found
2019-12-21 10:56:06 +01:00
found <- reference_data_to_use [mo == found ,
..property ] [ [1 ] ]
2019-09-15 22:57:30 +02:00
uncertainties <<- rbind ( uncertainties ,
format_uncertainty_as_df ( uncertainty_level = now_checks_for_uncertainty_level ,
input = a.x_backup ,
result_mo = found_result [1L ] ) )
return ( found [1L ] )
}
# (5) inverse input ----
if ( isTRUE ( debug ) ) {
cat ( " \n[ UNCERTAINTY LEVEL" , now_checks_for_uncertainty_level , " ] (5) inverse input\n" )
}
a.x_backup_inversed <- paste ( rev ( unlist ( strsplit ( a.x_backup , split = " " ) ) ) , collapse = " " )
if ( isTRUE ( debug ) ) {
message ( " Running '" , a.x_backup_inversed , " '" )
}
# first try without dyslexia mode
found <- suppressMessages ( suppressWarnings ( exec_as.mo ( a.x_backup_inversed , initial_search = FALSE , dyslexia_mode = FALSE , allow_uncertain = FALSE , debug = debug , reference_data_to_use = uncertain.reference_data_to_use ) ) )
if ( empty_result ( found ) ) {
# then with dyslexia mode
found <- suppressMessages ( suppressWarnings ( exec_as.mo ( a.x_backup_inversed , initial_search = FALSE , dyslexia_mode = TRUE , allow_uncertain = FALSE , debug = debug , reference_data_to_use = uncertain.reference_data_to_use ) ) )
}
if ( ! empty_result ( found ) & nchar ( g.x_backup_without_spp ) >= 6 ) {
found_result <- found
2019-12-21 10:56:06 +01:00
found <- reference_data_to_use [mo == found ,
..property ] [ [1 ] ]
2019-09-15 22:57:30 +02:00
uncertainties <<- rbind ( uncertainties ,
format_uncertainty_as_df ( uncertainty_level = now_checks_for_uncertainty_level ,
input = a.x_backup ,
result_mo = found_result [1L ] ) )
return ( found [1L ] )
}
# (6) try to strip off half an element from end and check the remains ----
if ( isTRUE ( debug ) ) {
cat ( " \n[ UNCERTAINTY LEVEL" , now_checks_for_uncertainty_level , " ] (6) try to strip off half an element from end and check the remains\n" )
}
2020-02-09 22:04:29 +01:00
x_strip <- a.x_backup %>% strsplit ( " [ .]" ) %>% unlist ( )
2019-09-15 22:57:30 +02:00
if ( length ( x_strip ) > 1 ) {
2019-10-11 17:21:02 +02:00
for ( i in seq_len ( length ( x_strip ) - 1 ) ) {
2019-09-15 22:57:30 +02:00
lastword <- x_strip [length ( x_strip ) - i + 1 ]
lastword_half <- substr ( lastword , 1 , as.integer ( nchar ( lastword ) / 2 ) )
# remove last half of the second term
2019-10-11 17:21:02 +02:00
x_strip_collapsed <- paste ( c ( x_strip [seq_len ( length ( x_strip ) - i ) ] , lastword_half ) , collapse = " " )
2019-09-15 22:57:30 +02:00
if ( nchar ( x_strip_collapsed ) >= 4 & nchar ( lastword_half ) > 2 ) {
if ( isTRUE ( debug ) ) {
message ( " Running '" , x_strip_collapsed , " '" )
}
# first try without dyslexia mode
found <- suppressMessages ( suppressWarnings ( exec_as.mo ( x_strip_collapsed , initial_search = FALSE , dyslexia_mode = FALSE , allow_uncertain = FALSE , debug = debug , reference_data_to_use = uncertain.reference_data_to_use ) ) )
if ( empty_result ( found ) ) {
# then with dyslexia mode
found <- suppressMessages ( suppressWarnings ( exec_as.mo ( x_strip_collapsed , initial_search = FALSE , dyslexia_mode = TRUE , allow_uncertain = FALSE , debug = debug , reference_data_to_use = uncertain.reference_data_to_use ) ) )
}
if ( ! empty_result ( found ) ) {
found_result <- found
2019-12-21 10:56:06 +01:00
found <- reference_data_to_use [mo == found ,
..property ] [ [1 ] ]
2019-09-15 22:57:30 +02:00
uncertainties <<- rbind ( uncertainties ,
format_uncertainty_as_df ( uncertainty_level = now_checks_for_uncertainty_level ,
input = a.x_backup ,
result_mo = found_result [1L ] ) )
return ( found [1L ] )
}
2019-03-26 14:24:03 +01:00
}
2019-03-12 12:19:27 +01:00
}
}
2019-09-15 22:57:30 +02:00
# (7) try to strip off one element from end and check the remains ----
if ( isTRUE ( debug ) ) {
cat ( " \n[ UNCERTAINTY LEVEL" , now_checks_for_uncertainty_level , " ] (7) try to strip off one element from end and check the remains\n" )
2019-03-26 14:24:03 +01:00
}
2019-09-15 22:57:30 +02:00
if ( length ( x_strip ) > 1 ) {
2019-10-11 17:21:02 +02:00
for ( i in seq_len ( length ( x_strip ) - 1 ) ) {
x_strip_collapsed <- paste ( x_strip [seq_len ( length ( x_strip ) - i ) ] , collapse = " " )
2019-09-15 22:57:30 +02:00
if ( nchar ( x_strip_collapsed ) >= 6 ) {
if ( isTRUE ( debug ) ) {
message ( " Running '" , x_strip_collapsed , " '" )
}
# first try without dyslexia mode
found <- suppressMessages ( suppressWarnings ( exec_as.mo ( x_strip_collapsed , initial_search = FALSE , dyslexia_mode = FALSE , allow_uncertain = FALSE , debug = debug , reference_data_to_use = uncertain.reference_data_to_use ) ) )
if ( empty_result ( found ) ) {
# then with dyslexia mode
found <- suppressMessages ( suppressWarnings ( exec_as.mo ( x_strip_collapsed , initial_search = FALSE , dyslexia_mode = TRUE , allow_uncertain = FALSE , debug = debug , reference_data_to_use = uncertain.reference_data_to_use ) ) )
}
if ( ! empty_result ( found ) ) {
found_result <- found
2019-12-21 10:56:06 +01:00
found <- reference_data_to_use [mo == found ,
..property ] [ [1 ] ]
2019-09-15 22:57:30 +02:00
uncertainties <<- rbind ( uncertainties ,
format_uncertainty_as_df ( uncertainty_level = now_checks_for_uncertainty_level ,
input = a.x_backup ,
result_mo = found_result [1L ] ) )
return ( found [1L ] )
}
}
}
2019-08-13 16:15:08 +02:00
}
2019-09-15 22:57:30 +02:00
# (8) check for unknown yeasts/fungi ----
if ( isTRUE ( debug ) ) {
cat ( " \n[ UNCERTAINTY LEVEL" , now_checks_for_uncertainty_level , " ] (8) check for unknown yeasts/fungi\n" )
}
if ( b.x_trimmed %like_case% " yeast" ) {
found <- " F_YEAST"
found_result <- found
2019-12-21 10:56:06 +01:00
found <- microorganismsDT [mo == found ,
..property ] [ [1 ] ]
2019-09-15 22:57:30 +02:00
uncertainties <<- rbind ( uncertainties ,
format_uncertainty_as_df ( uncertainty_level = now_checks_for_uncertainty_level ,
input = a.x_backup ,
result_mo = found_result [1L ] ) )
return ( found [1L ] )
}
if ( b.x_trimmed %like_case% " (fungus|fungi)" & ! b.x_trimmed %like_case% " fungiphrya" ) {
found <- " F_FUNGUS"
found_result <- found
2019-12-21 10:56:06 +01:00
found <- microorganismsDT [mo == found ,
..property ] [ [1 ] ]
2019-09-15 22:57:30 +02:00
uncertainties <<- rbind ( uncertainties ,
format_uncertainty_as_df ( uncertainty_level = now_checks_for_uncertainty_level ,
input = a.x_backup ,
result_mo = found_result [1L ] ) )
return ( found [1L ] )
}
# (9) try to strip off one element from start and check the remains (only allow >= 2-part name outcome) ----
if ( isTRUE ( debug ) ) {
cat ( " \n[ UNCERTAINTY LEVEL" , now_checks_for_uncertainty_level , " ] (9) try to strip off one element from start and check the remains (only allow >= 2-part name outcome)\n" )
}
2020-02-09 22:04:29 +01:00
x_strip <- a.x_backup %>% strsplit ( " [ .]" ) %>% unlist ( )
2019-09-15 22:57:30 +02:00
if ( length ( x_strip ) > 1 & nchar ( g.x_backup_without_spp ) >= 6 ) {
for ( i in 2 : ( length ( x_strip ) ) ) {
x_strip_collapsed <- paste ( x_strip [i : length ( x_strip ) ] , collapse = " " )
2019-08-12 19:07:15 +02:00
if ( isTRUE ( debug ) ) {
message ( " Running '" , x_strip_collapsed , " '" )
}
# first try without dyslexia mode
2019-09-15 22:57:30 +02:00
found <- suppressMessages ( suppressWarnings ( exec_as.mo ( x_strip_collapsed , initial_search = FALSE , dyslexia_mode = FALSE , allow_uncertain = FALSE , debug = debug , reference_data_to_use = uncertain.reference_data_to_use ) ) )
2019-08-12 19:07:15 +02:00
if ( empty_result ( found ) ) {
# then with dyslexia mode
2019-09-15 22:57:30 +02:00
found <- suppressMessages ( suppressWarnings ( exec_as.mo ( x_strip_collapsed , initial_search = FALSE , dyslexia_mode = TRUE , allow_uncertain = FALSE , debug = debug , reference_data_to_use = uncertain.reference_data_to_use ) ) )
2019-08-12 19:07:15 +02:00
}
2019-06-27 11:57:45 +02:00
if ( ! empty_result ( found ) ) {
found_result <- found
2019-12-21 10:56:06 +01:00
found <- reference_data_to_use [mo == found_result [1L ] ,
..property ] [ [1 ] ]
2019-09-15 22:57:30 +02:00
# uncertainty level 2 only if searched part contains a space (otherwise it will be found with lvl 3)
if ( x_strip_collapsed %like_case% " " ) {
uncertainties <<- rbind ( uncertainties ,
format_uncertainty_as_df ( uncertainty_level = now_checks_for_uncertainty_level ,
input = a.x_backup ,
result_mo = found_result [1L ] ) )
return ( found [1L ] )
2019-06-27 11:57:45 +02:00
}
}
}
}
}
2019-09-15 22:57:30 +02:00
# UNCERTAINTY LEVEL 3 ----
if ( uncertainty_level >= 3 ) {
now_checks_for_uncertainty_level <- 3
# (10) try to strip off one element from start and check the remains (any text size) ----
if ( isTRUE ( debug ) ) {
cat ( " \n[ UNCERTAINTY LEVEL" , now_checks_for_uncertainty_level , " ] (10) try to strip off one element from start and check the remains (any text size)\n" )
}
2020-02-09 22:04:29 +01:00
x_strip <- a.x_backup %>% strsplit ( " [ .]" ) %>% unlist ( )
2019-09-15 22:57:30 +02:00
if ( length ( x_strip ) > 1 & nchar ( g.x_backup_without_spp ) >= 6 ) {
for ( i in 2 : ( length ( x_strip ) ) ) {
x_strip_collapsed <- paste ( x_strip [i : length ( x_strip ) ] , collapse = " " )
2019-08-12 19:07:15 +02:00
if ( isTRUE ( debug ) ) {
message ( " Running '" , x_strip_collapsed , " '" )
}
# first try without dyslexia mode
2019-09-15 22:57:30 +02:00
found <- suppressMessages ( suppressWarnings ( exec_as.mo ( x_strip_collapsed , initial_search = FALSE , dyslexia_mode = FALSE , allow_uncertain = FALSE , debug = debug , reference_data_to_use = uncertain.reference_data_to_use ) ) )
2019-08-12 19:07:15 +02:00
if ( empty_result ( found ) ) {
# then with dyslexia mode
2019-09-15 22:57:30 +02:00
found <- suppressMessages ( suppressWarnings ( exec_as.mo ( x_strip_collapsed , initial_search = FALSE , dyslexia_mode = TRUE , allow_uncertain = FALSE , debug = debug , reference_data_to_use = uncertain.reference_data_to_use ) ) )
2019-08-12 19:07:15 +02:00
}
2019-03-12 12:19:27 +01:00
if ( ! empty_result ( found ) ) {
found_result <- found
2019-12-21 10:56:06 +01:00
found <- reference_data_to_use [mo == found ,
..property ] [ [1 ] ]
2019-03-12 12:19:27 +01:00
uncertainties <<- rbind ( uncertainties ,
2019-08-20 11:40:54 +02:00
format_uncertainty_as_df ( uncertainty_level = now_checks_for_uncertainty_level ,
input = a.x_backup ,
result_mo = found_result [1L ] ) )
2019-03-26 14:24:03 +01:00
return ( found [1L ] )
}
}
}
2019-09-15 22:57:30 +02:00
# (11) try to strip off one element from end and check the remains (any text size) ----
# (this is in fact 7 but without nchar limit of >=6)
if ( isTRUE ( debug ) ) {
cat ( " \n[ UNCERTAINTY LEVEL" , now_checks_for_uncertainty_level , " ] (11) try to strip off one element from end and check the remains (any text size)\n" )
2019-08-06 14:39:22 +02:00
}
2019-09-15 22:57:30 +02:00
if ( length ( x_strip ) > 1 ) {
2019-10-11 17:21:02 +02:00
for ( i in seq_len ( length ( x_strip ) - 1 ) ) {
x_strip_collapsed <- paste ( x_strip [seq_len ( length ( x_strip ) - i ) ] , collapse = " " )
2019-09-15 22:57:30 +02:00
if ( isTRUE ( debug ) ) {
message ( " Running '" , x_strip_collapsed , " '" )
}
# first try without dyslexia mode
found <- suppressMessages ( suppressWarnings ( exec_as.mo ( x_strip_collapsed , initial_search = FALSE , dyslexia_mode = FALSE , allow_uncertain = FALSE , debug = debug , reference_data_to_use = uncertain.reference_data_to_use ) ) )
if ( empty_result ( found ) ) {
# then with dyslexia mode
found <- suppressMessages ( suppressWarnings ( exec_as.mo ( x_strip_collapsed , initial_search = FALSE , dyslexia_mode = TRUE , allow_uncertain = FALSE , debug = debug , reference_data_to_use = uncertain.reference_data_to_use ) ) )
}
if ( ! empty_result ( found ) ) {
found_result <- found
2019-12-21 10:56:06 +01:00
found <- reference_data_to_use [mo == found ,
..property ] [ [1 ] ]
2019-03-26 14:24:03 +01:00
uncertainties <<- rbind ( uncertainties ,
2019-08-20 11:40:54 +02:00
format_uncertainty_as_df ( uncertainty_level = now_checks_for_uncertainty_level ,
input = a.x_backup ,
result_mo = found_result [1L ] ) )
2019-03-12 12:19:27 +01:00
return ( found [1L ] )
}
2019-02-08 16:06:54 +01:00
}
}
2019-09-15 22:57:30 +02:00
# (12) part of a name (very unlikely match) ----
if ( isTRUE ( debug ) ) {
cat ( " \n[ UNCERTAINTY LEVEL" , now_checks_for_uncertainty_level , " ] (12) part of a name (very unlikely match)\n" )
2018-12-06 14:36:39 +01:00
}
2019-09-15 22:57:30 +02:00
if ( isTRUE ( debug ) ) {
message ( " Running '" , f.x_withspaces_end_only , " '" )
}
found <- reference_data_to_use [fullname_lower %like_case% f.x_withspaces_end_only ]
if ( nrow ( found ) > 0 ) {
found_result <- found [ [ " mo" ] ]
if ( ! empty_result ( found_result ) & nchar ( g.x_backup_without_spp ) >= 6 ) {
2019-12-21 10:56:06 +01:00
found <- reference_data_to_use [mo == found_result [1L ] ,
..property ] [ [1 ] ]
2019-08-12 19:07:15 +02:00
uncertainties <<- rbind ( uncertainties ,
2019-08-20 11:40:54 +02:00
format_uncertainty_as_df ( uncertainty_level = now_checks_for_uncertainty_level ,
input = a.x_backup ,
result_mo = found_result [1L ] ) )
2019-08-12 19:07:15 +02:00
return ( found [1L ] )
}
}
}
2019-09-15 22:57:30 +02:00
# didn't found in uncertain results too
return ( NA_character_ )
}
# uncertain results
# wait until prevalence == 2 to run the uncertain results on both prevalence == 1 and prevalence == 2
if ( nrow ( data_to_check ) == nrow ( microorganismsDT [prevalence == 2 ] ) ) {
x [i ] <- uncertain_fn ( a.x_backup = a.x_backup ,
b.x_trimmed = b.x_trimmed ,
d.x_withspaces_start_end = d.x_withspaces_start_end ,
e.x_withspaces_start_only = e.x_withspaces_start_only ,
f.x_withspaces_end_only = f.x_withspaces_end_only ,
g.x_backup_without_spp = g.x_backup_without_spp ,
uncertain.reference_data_to_use = microorganismsDT [prevalence %in% c ( 1 , 2 ) ] )
if ( ! empty_result ( x [i ] ) ) {
return ( x [i ] )
2019-08-12 19:07:15 +02:00
}
2019-09-15 22:57:30 +02:00
} else if ( nrow ( data_to_check ) == nrow ( microorganismsDT [prevalence == 3 ] ) ) {
x [i ] <- uncertain_fn ( a.x_backup = a.x_backup ,
b.x_trimmed = b.x_trimmed ,
d.x_withspaces_start_end = d.x_withspaces_start_end ,
e.x_withspaces_start_only = e.x_withspaces_start_only ,
f.x_withspaces_end_only = f.x_withspaces_end_only ,
g.x_backup_without_spp = g.x_backup_without_spp ,
uncertain.reference_data_to_use = microorganismsDT [prevalence == 3 ] )
if ( ! empty_result ( x [i ] ) ) {
return ( x [i ] )
2019-01-08 16:23:45 +01:00
}
2018-12-06 14:36:39 +01:00
}
2019-08-12 19:07:15 +02:00
2019-09-15 22:57:30 +02:00
# didn't found any
2019-03-12 12:19:27 +01:00
return ( NA_character_ )
}
2019-09-15 22:57:30 +02:00
# FIRST TRY VERY PREVALENT IN HUMAN INFECTIONS ----
x [i ] <- check_per_prevalence ( data_to_check = reference_data_to_use [prevalence == 1 ] ,
2019-09-20 14:18:29 +02:00
data.old_to_check = microorganisms.oldDT [prevalence == 1 ] ,
2019-09-15 22:57:30 +02:00
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 ] ,
g.x_backup_without_spp = x_backup_without_spp [i ] ,
h.x_species = x_species [i ] ,
i.x_trimmed_species = x_trimmed_species [i ] )
if ( ! empty_result ( x [i ] ) ) {
next
}
# THEN TRY PREVALENT IN HUMAN INFECTIONS ----
x [i ] <- check_per_prevalence ( data_to_check = reference_data_to_use [prevalence == 2 ] ,
2019-09-20 14:50:02 +02:00
data.old_to_check = microorganisms.oldDT [prevalence %in% c ( 2 , 3 ) ] , # run all other old MOs the second time,
2019-10-08 22:21:33 +02:00
# otherwise e.g. mo_ref("Chlamydia psittaci") doesn't work correctly
2019-09-15 22:57:30 +02:00
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 ] ,
g.x_backup_without_spp = x_backup_without_spp [i ] ,
h.x_species = x_species [i ] ,
i.x_trimmed_species = x_trimmed_species [i ] )
if ( ! empty_result ( x [i ] ) ) {
next
}
# THEN UNPREVALENT IN HUMAN INFECTIONS ----
x [i ] <- check_per_prevalence ( data_to_check = reference_data_to_use [prevalence == 3 ] ,
2019-09-20 14:50:02 +02:00
data.old_to_check = microorganisms.oldDT [prevalence == 999 ] ,
2019-09-15 22:57:30 +02:00
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 ] ,
g.x_backup_without_spp = x_backup_without_spp [i ] ,
h.x_species = x_species [i ] ,
i.x_trimmed_species = x_trimmed_species [i ] )
2019-03-12 12:19:27 +01:00
if ( ! empty_result ( x [i ] ) ) {
next
2018-06-08 12:06:54 +02:00
}
2019-08-12 19:07:15 +02:00
2019-03-18 14:29:41 +01:00
# no results found: make them UNKNOWN ----
2019-12-21 10:56:06 +01:00
x [i ] <- microorganismsDT [mo == " UNKNOWN" ,
..property ] [ [1 ] ]
2019-03-18 14:29:41 +01:00
if ( initial_search == TRUE ) {
failures <- c ( failures , x_backup [i ] )
2019-03-15 17:36:42 +01:00
}
2018-09-27 23:23:48 +02:00
}
2018-06-08 12:06:54 +02:00
}
2019-08-12 19:07:15 +02:00
2019-03-15 17:36:42 +01:00
# handling failures ----
2019-03-18 14:29:41 +01:00
failures <- failures [ ! failures %in% c ( NA , NULL , NaN ) ]
2019-03-15 17:36:42 +01:00
if ( length ( failures ) > 0 & initial_search == TRUE ) {
2018-12-06 14:36:39 +01:00
options ( mo_failures = sort ( unique ( failures ) ) )
2019-03-12 12:19:27 +01:00
plural <- c ( " value" , " it" , " was" )
2019-01-21 21:24:40 +01:00
if ( n_distinct ( failures ) > 1 ) {
2019-03-12 12:19:27 +01:00
plural <- c ( " values" , " them" , " were" )
2018-12-06 14:36:39 +01:00
}
2020-04-13 21:09:56 +02:00
x_input_clean <- trimws2 ( x_input )
total_failures <- length ( x_input_clean [as.character ( x_input_clean ) %in% as.character ( failures ) & ! x_input %in% c ( NA , NULL , NaN ) ] )
2019-01-25 13:18:41 +01:00
total_n <- length ( x_input [ ! x_input %in% c ( NA , NULL , NaN ) ] )
2019-03-12 12:19:27 +01:00
msg <- paste0 ( nr2char ( n_distinct ( failures ) ) , " unique " , plural [1 ] ,
2019-09-30 16:45:36 +02:00
" (covering " , percentage ( total_failures / total_n ) ,
2019-03-02 22:47:04 +01:00
" ) could not be coerced and " , plural [3 ] , " considered 'unknown'" )
2019-01-21 21:24:40 +01:00
if ( n_distinct ( failures ) <= 10 ) {
2019-10-11 17:21:02 +02:00
msg <- paste0 ( msg , " : " , paste ( ' "' , unique ( failures ) , ' "' , sep = " " , collapse = " , " ) )
2019-01-21 21:24:40 +01:00
}
2020-04-13 21:09:56 +02:00
msg <- paste0 ( msg , " .\nUse mo_failures() to review " , plural [2 ] , " . Edit the `allow_uncertain` parameter if needed (see ?as.mo)." )
2020-02-14 19:54:13 +01:00
warning ( red ( paste0 ( " \n" , msg ) ) ,
2019-02-08 16:06:54 +01:00
call. = FALSE ,
immediate. = TRUE ) # thus will always be shown, even if >= warnings
}
2019-03-15 17:36:42 +01:00
# handling uncertainties ----
if ( NROW ( uncertainties ) > 0 & initial_search == TRUE ) {
2019-02-27 11:36:12 +01:00
options ( mo_uncertainties = as.list ( distinct ( uncertainties , input , .keep_all = TRUE ) ) )
2019-08-12 19:07:15 +02:00
2019-11-15 16:50:46 +01:00
plural <- c ( " " , " it" , " was" )
2019-02-27 11:36:12 +01:00
if ( NROW ( uncertainties ) > 1 ) {
2019-11-15 16:50:46 +01:00
plural <- c ( " s" , " them" , " were" )
2019-02-08 16:06:54 +01:00
}
2020-01-27 19:14:23 +01:00
msg <- paste0 ( " Result" , plural [1 ] , " of " , nr2char ( NROW ( uncertainties ) ) , " value" , plural [1 ] ,
2019-11-15 16:50:46 +01:00
" " , plural [3 ] , " guessed with uncertainty. Use mo_uncertainties() to review " , plural [2 ] , " ." )
2020-02-14 19:54:13 +01:00
warning ( red ( paste0 ( " \n" , msg ) ) ,
2019-01-21 21:24:40 +01:00
call. = FALSE ,
immediate. = TRUE ) # thus will always be shown, even if >= warnings
2018-07-23 14:14:03 +02:00
}
2019-08-12 19:07:15 +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" ,
2019-03-26 14:24:03 +01:00
" caprae" , " carnosus" , " chromogenes" , " cohnii" , " condimenti" ,
" devriesei" , " epidermidis" , " equorum" , " felis" ,
2018-09-25 16:44:40 +02:00
" fleurettii" , " gallinarum" , " haemolyticus" ,
" hominis" , " jettensis" , " kloosii" , " lentus" ,
" lugdunensis" , " massiliensis" , " microti" ,
" muscae" , " nepalensis" , " pasteuri" , " petrasii" ,
" pettenkoferi" , " piscifermentans" , " rostri" ,
" saccharolyticus" , " saprophyticus" , " sciuri" ,
" stepanovicii" , " simulans" , " succinus" ,
2019-03-26 14:24:03 +01:00
" vitulinus" , " warneri" , " xylosus" )
2019-12-21 10:56:06 +01:00
| ( species == " schleiferi" & subspecies %in% c ( " schleiferi" , " " ) ) ,
..property ] [ [1 ] ]
2019-03-26 14:24:03 +01:00
CoPS <- MOs_staph [species %in% c ( " simiae" , " agnetis" ,
" delphini" , " lutrae" ,
2018-09-25 16:44:40 +02:00
" hyicus" , " intermedius" ,
" pseudintermedius" , " pseudointermedius" ,
2019-03-26 14:24:03 +01:00
" schweitzeri" , " argenteus" )
2019-12-21 10:56:06 +01:00
| ( species == " schleiferi" & subspecies == " coagulans" ) ,
..property ] [ [1 ] ]
2019-08-12 19:07:15 +02:00
2019-03-26 14:24:03 +01:00
# warn when species found that are not in Becker (2014, PMID 25278577) and Becker (2019, PMID 30872103)
post_Becker <- c ( " argensis" , " caeli" , " cornubiensis" , " edaphicus" )
2019-12-21 10:56:06 +01:00
if ( any ( x %in% MOs_staph [species %in% post_Becker ,
..property ] [ [1 ] ] ) ) {
2019-08-12 19:07:15 +02:00
2019-07-01 14:03:15 +02:00
warning ( " Becker " , italic ( " et al." ) , " (2014, 2019) does not contain these species named after their publication: " ,
2019-03-26 14:24:03 +01:00
italic ( paste ( " S." ,
2019-12-21 10:56:06 +01:00
sort ( mo_species ( unique ( x [x %in% MOs_staph [species %in% post_Becker ,
..property ] [ [1 ] ] ] ) ) ) ,
2019-03-26 14:24:03 +01:00
collapse = " , " ) ) ,
2019-07-01 14:03:15 +02:00
" ." ,
2019-03-26 14:24:03 +01:00
call. = FALSE ,
immediate. = TRUE )
}
2019-08-12 19:07:15 +02:00
2019-12-21 10:56:06 +01:00
x [x %in% CoNS ] <- microorganismsDT [mo == " B_STPHY_CONS" ,
..property ] [ [1 ] ] [1L ]
x [x %in% CoPS ] <- microorganismsDT [mo == " B_STPHY_COPS" ,
..property ] [ [1 ] ] [1L ]
2018-09-01 21:19:46 +02:00
if ( Becker == " all" ) {
2019-12-21 10:56:06 +01:00
x [x %in% microorganismsDT [mo %like_case% " ^B_STPHY_AURS" ,
..property ] [ [1 ] ] ] <- microorganismsDT [mo == " B_STPHY_COPS" ,
..property ] [ [1 ] ] [1L ]
2018-09-01 21:19:46 +02:00
}
}
2019-08-12 19:07:15 +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-12-21 10:56:06 +01:00
x [x == microorganismsDT [mo == " B_STRPT_PYGN" ,
..property ] [ [1 ] ] [1L ] ] <- microorganismsDT [mo == " B_STRPT_GRPA" ,
..property ] [ [1 ] ] [1L ]
2018-09-27 23:23:48 +02:00
# group B - S. agalactiae
2019-12-21 10:56:06 +01:00
x [x == microorganismsDT [mo == " B_STRPT_AGLC" ,
..property ] [ [1 ] ] [1L ] ] <- microorganismsDT [mo == " B_STRPT_GRPB" ,
..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-12-21 10:56:06 +01:00
x [x %in% S_groupC ] <- microorganismsDT [mo == " B_STRPT_GRPC" ,
..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-12-21 10:56:06 +01:00
x [x %like% " ^(Enterococcus|B_ENTRC)" ] <- microorganismsDT [mo == " B_STRPT_GRPD" ,
..property ] [ [1 ] ] [1L ]
2018-09-27 23:23:48 +02:00
}
# group F - S. anginosus
2019-12-21 10:56:06 +01:00
x [x == microorganismsDT [mo == " B_STRPT_ANGN" ,
..property ] [ [1 ] ] [1L ] ] <- microorganismsDT [mo == " B_STRPT_GRPF" ,
..property ] [ [1 ] ] [1L ]
2018-09-27 23:23:48 +02:00
# group H - S. sanguinis
2019-12-21 10:56:06 +01:00
x [x == microorganismsDT [mo == " B_STRPT_SNGN" ,
..property ] [ [1 ] ] [1L ] ] <- microorganismsDT [mo == " B_STRPT_GRPH" ,
..property ] [ [1 ] ] [1L ]
2018-09-27 23:23:48 +02:00
# group K - S. salivarius
2019-12-21 10:56:06 +01:00
x [x == microorganismsDT [mo == " B_STRPT_SLVR" ,
..property ] [ [1 ] ] [1L ] ] <- microorganismsDT [mo == " B_STRPT_GRPK" ,
..property ] [ [1 ] ] [1L ]
2018-09-01 21:19:46 +02:00
}
2019-08-12 19:07:15 +02:00
2019-02-08 16:06:54 +01:00
# Wrap up ----------------------------------------------------------------
2019-08-12 19:07:15 +02:00
2018-10-19 13:53:31 +02:00
# comply to x, which is also unique and without empty values
2019-03-05 22:47:42 +01:00
x_input_unique_nonempty <- unique ( x_input [ ! is.na ( x_input )
& ! is.null ( x_input )
& ! identical ( x_input , " " )
2019-06-02 19:23:19 +02:00
& ! identical ( x_input , " xxx" ) ] )
2019-08-12 19:07:15 +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-08-12 19:07:15 +02:00
2019-03-18 14:29:41 +01:00
suppressWarnings (
x <- df_input %>%
left_join ( df_found ,
by = " input" ) %>%
pull ( found )
)
2019-08-12 19:07:15 +02:00
2018-09-27 23:23:48 +02:00
if ( property == " mo" ) {
2019-08-07 15:37:39 +02:00
x <- to_class_mo ( x )
2018-09-27 23:23:48 +02:00
}
2019-08-12 19:07:15 +02:00
2019-02-08 16:06:54 +01:00
if ( length ( mo_renamed ( ) ) > 0 ) {
2019-07-01 14:03:15 +02:00
print ( mo_renamed ( ) )
2018-12-14 10:52:20 +01:00
}
2019-08-12 19:07:15 +02:00
2019-09-22 12:41:45 +02:00
if ( old_mo_warning == TRUE & property != " mo" ) {
2019-09-23 13:53:50 +02:00
warning ( " The input contained old microorganism IDs from previous versions of this package.\nPlease use `as.mo()` on these old IDs to transform them to the new format.\nSUPPORT FOR THIS WILL BE DROPPED IN A FUTURE VERSION." , call. = FALSE )
2019-09-18 15:46:09 +02:00
}
2018-06-08 12:06:54 +02:00
x
}
2018-07-23 14:14:03 +02:00
2019-03-02 22:47:04 +01:00
empty_result <- function ( x ) {
2019-03-12 12:19:27 +01:00
all ( x %in% c ( NA , " UNKNOWN" ) )
2019-03-02 22:47:04 +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 = " " ) {
2019-09-15 22:57:30 +02:00
newly_set <- data.frame ( old_name = name_old ,
2019-09-18 15:46:09 +02:00
old_ref = ref_old ,
2019-09-15 22:57:30 +02:00
new_name = name_new ,
new_ref = ref_new ,
mo = mo ,
stringsAsFactors = FALSE )
already_set <- getOption ( " mo_renamed" )
if ( ! is.null ( already_set ) ) {
options ( mo_renamed = rbind ( already_set , newly_set ) )
2018-10-01 14:44:40 +02:00
} else {
2019-09-15 22:57:30 +02:00
options ( mo_renamed = newly_set )
2018-10-01 14:44:40 +02:00
}
2018-09-25 16:44:40 +02:00
}
2019-08-20 11:40:54 +02:00
format_uncertainty_as_df <- function ( uncertainty_level ,
input ,
result_mo ) {
if ( ! is.null ( getOption ( " mo_renamed_last_run" , default = NULL ) ) ) {
# was found as a renamed mo
df <- data.frame ( uncertainty = uncertainty_level ,
input = input ,
fullname = getOption ( " mo_renamed_last_run" ) ,
renamed_to = microorganismsDT [mo == result_mo , fullname ] [ [1 ] ] ,
mo = result_mo ,
stringsAsFactors = FALSE )
options ( mo_renamed_last_run = NULL )
} else {
df <- data.frame ( uncertainty = uncertainty_level ,
input = input ,
fullname = microorganismsDT [mo == result_mo , fullname ] [ [1 ] ] ,
renamed_to = NA_character_ ,
mo = result_mo ,
stringsAsFactors = FALSE )
}
df
}
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
2020-03-14 14:05:43 +01:00
#' @importFrom vctrs vec_ptype_abbr
2019-08-07 15:37:39 +02:00
#' @export
2020-03-14 14:05:43 +01:00
vec_ptype_abbr.mo <- function ( x , ... ) {
2019-08-07 15:37:39 +02:00
" mo"
}
2020-03-14 14:05:43 +01:00
#' @importFrom vctrs vec_ptype_full
#' @export
vec_ptype_full.mo <- function ( x , ... ) {
" mo"
}
#' @importFrom vctrs vec_ptype2
#' @export
vec_ptype2.mo <- function ( x , y , ... ) {
vctrs :: vec_ptype2 ( x = as.character ( x ) , y = as.character ( y ) , ... )
}
#' @importFrom vctrs vec_cast
#' @export
vec_cast.mo <- function ( x , to , ... ) {
as.mo ( vctrs :: vec_cast ( x = as.character ( x ) , to = as.character ( to ) , ... ) )
}
#' @importFrom vctrs vec_cast
#' @export
vec_cast.mo.mo <- function ( x , to , ... ) {
as.mo ( vctrs :: vec_cast ( x = as.character ( x ) , to = as.character ( to ) , ... ) )
}
#' @importFrom vctrs vec_cast
#' @export
vec_cast.mo.character <- function ( x , to , ... ) {
vctrs :: vec_cast ( x = as.character ( x ) , to = as.character ( to ) , ... )
}
#' @importFrom vctrs vec_cast
#' @export
vec_cast.character.mo <- function ( x , to , ... ) {
as.mo ( vctrs :: vec_cast ( x = as.character ( x ) , to = as.character ( to ) , ... ) )
}
2019-08-07 15:37:39 +02:00
#' @importFrom pillar pillar_shaft
#' @export
pillar_shaft.mo <- function ( x , ... ) {
out <- format ( x )
2019-08-26 16:02:03 +02:00
# grey out the kingdom (part until first "_")
out [ ! is.na ( x ) ] <- gsub ( " ^([A-Z]+_)(.*)" , paste0 ( pillar :: style_subtle ( " \\1" ) , " \\2" ) , out [ ! is.na ( x ) ] )
# and grey out every _
out [ ! is.na ( x ) ] <- gsub ( " _" , pillar :: style_subtle ( " _" ) , out [ ! is.na ( x ) ] )
2019-08-12 14:48:09 +02:00
2019-08-26 16:02:03 +02:00
# markup NA and UNKNOWN
2019-08-12 14:48:09 +02:00
out [is.na ( x ) ] <- pillar :: style_na ( " NA" )
out [x == " UNKNOWN" ] <- pillar :: style_na ( " UNKNOWN" )
2020-04-14 14:12:31 +02:00
2019-11-18 12:10:47 +01:00
# make it always fit exactly
2020-04-14 14:12:31 +02:00
pillar :: new_pillar_shaft_simple ( out ,
align = " left" ,
width = max ( nchar ( x ) ) + ifelse ( length ( x [x %in% c ( NA , " UNKNOWN" ) ] ) > 0 ,
2 ,
0 ) )
2019-08-07 15:37:39 +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
2019-11-03 22:24:42 +01:00
#' @importFrom cleaner freq top_freq
2018-12-07 12:04:55 +01:00
#' @export
#' @noRd
summary.mo <- function ( object , ... ) {
# unique and top 1-3
2019-09-18 15:46:09 +02:00
x <- as.mo ( object )
2018-12-07 12:04:55 +01:00
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 , ... )
}
}
2019-08-12 14:48:09 +02:00
#' @exportMethod [.mo
2018-08-31 13:36:19 +02:00
#' @export
#' @noRd
2019-08-14 14:57:06 +02:00
" [.mo" <- function ( x , ... ) {
2019-08-12 14:48:09 +02:00
y <- NextMethod ( )
2019-08-14 14:57:06 +02:00
attributes ( y ) <- attributes ( x )
y
}
2019-08-26 16:02:03 +02:00
#' @exportMethod [[.mo
2019-08-14 14:57:06 +02:00
#' @export
#' @noRd
2019-08-26 16:02:03 +02:00
" [[.mo" <- function ( x , ... ) {
2019-08-14 14:57:06 +02:00
y <- NextMethod ( )
2019-08-26 16:02:03 +02:00
attributes ( y ) <- attributes ( x )
2019-08-14 14:57:06 +02:00
y
}
2019-08-26 16:02:03 +02:00
#' @exportMethod [<-.mo
2019-08-14 14:57:06 +02:00
#' @export
#' @noRd
2019-08-26 16:02:03 +02:00
" [<-.mo" <- function ( i , j , ... , value ) {
2019-08-14 14:57:06 +02:00
y <- NextMethod ( )
2019-08-26 16:02:03 +02:00
attributes ( y ) <- attributes ( i )
2020-04-13 21:09:56 +02:00
# must only contain valid MOs
2020-02-14 19:54:13 +01:00
class_integrity_check ( y , " microorganism code" , c ( as.character ( microorganisms $ mo ) ,
2019-12-21 10:56:06 +01:00
as.character ( microorganisms.translation $ mo_old ) ) )
2019-08-14 14:57:06 +02:00
}
#' @exportMethod [[<-.mo
#' @export
#' @noRd
2019-08-26 16:02:03 +02:00
" [[<-.mo" <- function ( i , j , ... , value ) {
2019-08-14 14:57:06 +02:00
y <- NextMethod ( )
2019-08-26 16:02:03 +02:00
attributes ( y ) <- attributes ( i )
2020-04-13 21:09:56 +02:00
# must only contain valid MOs
2020-02-14 19:54:13 +01:00
class_integrity_check ( y , " microorganism code" , c ( as.character ( microorganisms $ mo ) ,
2019-12-21 10:56:06 +01:00
as.character ( microorganisms.translation $ mo_old ) ) )
2019-08-14 14:57:06 +02:00
}
#' @exportMethod c.mo
#' @export
#' @noRd
c.mo <- function ( x , ... ) {
y <- NextMethod ( )
attributes ( y ) <- attributes ( x )
2020-04-13 21:09:56 +02:00
# must only contain valid MOs
2020-02-14 19:54:13 +01:00
class_integrity_check ( y , " microorganism code" , c ( as.character ( microorganisms $ mo ) ,
2019-12-21 10:56:06 +01:00
as.character ( microorganisms.translation $ mo_old ) ) )
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-07-01 14:03:15 +02:00
if ( is.null ( getOption ( " mo_uncertainties" ) ) ) {
return ( NULL )
}
2019-02-28 13:56:28 +01:00
structure ( .Data = as.data.frame ( getOption ( " mo_uncertainties" ) , stringsAsFactors = FALSE ) ,
class = c ( " mo_uncertainties" , " data.frame" ) )
}
#' @exportMethod print.mo_uncertainties
2019-08-09 14:28:46 +02:00
#' @importFrom crayon green yellow red white black bgGreen bgYellow bgRed
2019-11-15 15:25:03 +01:00
#' @importFrom cleaner percentage
2019-02-28 13:56:28 +01:00
#' @export
#' @noRd
print.mo_uncertainties <- function ( x , ... ) {
2019-03-12 12:19:27 +01:00
if ( NROW ( x ) == 0 ) {
return ( NULL )
}
2019-07-01 14:03:15 +02:00
cat ( paste0 ( bold ( nr2char ( nrow ( x ) ) , paste0 ( " unique result" , ifelse ( nrow ( x ) > 1 , " s" , " " ) , " guessed with uncertainty:" ) ) ,
" \n(1 = " , green ( " renamed/misspelled" ) ,
2019-02-28 13:56:28 +01:00
" , 2 = " , yellow ( " uncertain" ) ,
" , 3 = " , red ( " very uncertain" ) , " )\n" ) )
2019-08-12 19:07:15 +02:00
2019-02-27 11:36:12 +01:00
msg <- " "
2019-10-11 17:21:02 +02:00
for ( i in seq_len ( nrow ( x ) ) ) {
2019-02-28 13:56:28 +01:00
if ( x [i , " uncertainty" ] == 1 ) {
colour1 <- green
2019-03-26 14:24:03 +01:00
colour2 <- function ( ... ) bgGreen ( white ( ... ) )
2019-02-28 13:56:28 +01:00
} else if ( x [i , " uncertainty" ] == 2 ) {
colour1 <- yellow
2019-08-09 14:28:46 +02:00
colour2 <- function ( ... ) bgYellow ( black ( ... ) )
2019-02-28 13:56:28 +01:00
} else {
colour1 <- red
2019-03-26 14:24:03 +01:00
colour2 <- function ( ... ) bgRed ( white ( ... ) )
2019-02-28 13:56:28 +01:00
}
2019-02-27 11:36:12 +01:00
msg <- paste ( msg ,
2019-03-26 14:24:03 +01:00
paste0 ( colour2 ( paste0 ( " [" , x [i , " uncertainty" ] , " ] " ) ) , ' "' , x [i , " input" ] , ' " -> ' ,
2019-08-20 11:40:54 +02:00
colour1 ( paste0 ( italic ( x [i , " fullname" ] ) ,
ifelse ( ! is.na ( x [i , " renamed_to" ] ) , paste ( " , renamed to" , italic ( x [i , " renamed_to" ] ) ) , " " ) ,
2019-11-15 15:25:03 +01:00
" (" , x [i , " mo" ] ,
" , score: " , percentage ( levenshtein_fraction ( x [i , " input" ] , x [i , " fullname" ] ) , digits = 1 ) ,
" )" ) ) ) ,
2019-02-27 11:36:12 +01:00
sep = " \n" )
}
2019-02-28 13:56:28 +01:00
cat ( msg )
2019-02-08 16:06:54 +01:00
}
#' @rdname as.mo
2019-09-15 22:57:30 +02:00
#' @importFrom dplyr distinct
2018-12-06 14:36:39 +01:00
#' @export
mo_renamed <- function ( ) {
2019-07-01 14:03:15 +02:00
items <- getOption ( " mo_renamed" )
if ( is.null ( items ) ) {
2019-09-15 22:57:30 +02:00
items <- data.frame ( )
} else {
items <- distinct ( items , old_name , .keep_all = TRUE )
2019-07-01 14:03:15 +02:00
}
structure ( .Data = items ,
2019-09-15 22:57:30 +02:00
class = c ( " mo_renamed" , " data.frame" ) )
2019-02-28 13:56:28 +01:00
}
#' @exportMethod print.mo_renamed
2019-09-15 22:57:30 +02:00
#' @importFrom crayon blue italic
2019-02-28 13:56:28 +01:00
#' @export
#' @noRd
print.mo_renamed <- function ( x , ... ) {
2019-09-15 22:57:30 +02:00
if ( NROW ( x ) == 0 ) {
return ( invisible ( ) )
}
2019-10-11 17:21:02 +02:00
for ( i in seq_len ( nrow ( x ) ) ) {
2019-09-15 22:57:30 +02:00
message ( blue ( paste0 ( " NOTE: " ,
2019-10-08 22:21:33 +02:00
italic ( x $ old_name [i ] ) , ifelse ( x $ old_ref [i ] %in% c ( " " , NA ) , " " ,
paste0 ( " (" , gsub ( " et al." , italic ( " et al." ) , x $ old_ref [i ] ) , " )" ) ) ,
" was renamed " ,
italic ( x $ new_name [i ] ) , ifelse ( x $ new_ref [i ] %in% c ( " " , NA ) , " " ,
paste0 ( " (" , gsub ( " et al." , italic ( " et al." ) , x $ new_ref [i ] ) , " )" ) ) ,
" [" , x $ mo [i ] , " ]" ) ) )
2019-09-15 22:57:30 +02:00
}
2019-02-27 11:36:12 +01:00
}
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
}
2019-03-15 13:57:25 +01:00
unregex <- function ( x ) {
gsub ( " [^a-zA-Z0-9 -]" , " " , x )
}
2019-03-18 14:29:41 +01:00
2019-03-26 14:24:03 +01:00
translate_allow_uncertain <- function ( allow_uncertain ) {
if ( isTRUE ( allow_uncertain ) ) {
# default to uncertainty level 2
allow_uncertain <- 2
} else {
2019-08-13 16:15:08 +02:00
allow_uncertain [tolower ( allow_uncertain ) == " none" ] <- 0
allow_uncertain [tolower ( allow_uncertain ) == " all" ] <- 3
2019-03-26 14:24:03 +01:00
allow_uncertain <- as.integer ( allow_uncertain )
if ( ! allow_uncertain %in% c ( 0 : 3 ) ) {
2019-08-13 16:15:08 +02:00
stop ( ' `allow_uncertain` must be a number between 0 (or "none") and 3 (or "all"), or TRUE (= 2) or FALSE (= 0).' , call. = FALSE )
2019-03-26 14:24:03 +01:00
}
}
allow_uncertain
}
2019-07-01 14:03:15 +02:00
get_mo_failures_uncertainties_renamed <- function ( ) {
list ( failures = getOption ( " mo_failures" ) ,
uncertainties = getOption ( " mo_uncertainties" ) ,
renamed = getOption ( " mo_renamed" ) )
}
load_mo_failures_uncertainties_renamed <- function ( metadata ) {
options ( " mo_failures" = metadata $ failures )
options ( " mo_uncertainties" = metadata $ uncertainties )
options ( " mo_renamed" = metadata $ renamed )
}
2019-11-15 15:25:03 +01:00
#' @importFrom utils adist
levenshtein_fraction <- function ( input , output ) {
levenshtein <- double ( length = length ( input ) )
for ( i in seq_len ( length ( input ) ) ) {
2020-04-14 14:12:31 +02:00
# determine Levenshtein distance, but maximise to nchar of output
2019-11-15 15:25:03 +01:00
levenshtein [i ] <- base :: min ( base :: as.double ( adist ( input [i ] , output [i ] , ignore.case = TRUE ) ) ,
base :: nchar ( output [i ] ) )
}
# self-made score between 0 and 1 (for % certainty, so 0 means huge distance, 1 means no distance)
( base :: nchar ( output ) - 0.5 * levenshtein ) / nchar ( output )
}
2020-04-13 21:09:56 +02:00
trimws2 <- function ( x ) {
trimws ( gsub ( " [\\s]+" , " " , x , perl = TRUE ) )
}
2020-04-14 15:10:09 +02:00
parse_and_convert <- function ( x ) {
2020-04-13 21:09:56 +02:00
tryCatch ( {
2020-04-14 15:10:09 +02:00
if ( ! is.null ( dim ( x ) ) ) {
if ( NCOL ( x ) > 2 ) {
stop ( " A maximum of two columns is allowed." , call. = FALSE )
} else if ( NCOL ( x ) == 2 ) {
# support tidyverse selection like: df %>% select(colA, colB)
# paste these columns together
x <- as.data.frame ( x , stringsAsFactors = FALSE )
colnames ( x ) <- c ( " A" , " B" )
x <- paste ( x $ A , x $ B )
} else {
# support tidyverse selection like: df %>% select(colA)
x <- as.data.frame ( x , stringsAsFactors = FALSE ) [ [1 ] ]
}
}
x [is.null ( x ) ] <- NA
2020-04-13 21:09:56 +02:00
parsed <- iconv ( x , to = " UTF-8" )
parsed [is.na ( parsed ) & ! is.na ( x ) ] <- iconv ( x [is.na ( parsed ) & ! is.na ( x ) ] , from = " Latin1" , to = " ASCII//TRANSLIT" )
2020-04-14 14:12:31 +02:00
parsed <- gsub ( ' "' , " " , parsed , fixed = TRUE )
} , error = function ( e ) stop ( e $ message , call. = FALSE ) ) # this will also be thrown when running `as.mo(no_existing_object)`
parsed
2020-04-13 21:09:56 +02:00
}