addins and small improvements to microorganisms dataset

R/globals.R

@@ -17,6 +17,7 @@
 # ==================================================================== #
 
 globalVariables(c('abname',
+                  'antibiotics',
                   'atc',
                   'bactid',
                   'cnt',
@@ -36,6 +37,7 @@ globalVariables(c('abname',
                   'key_ab_other',
                   'median',
                   'mic',
+                  'microorganisms',
                   'mocode',
                   'molis',
                   'n',
@@ -43,7 +45,9 @@ globalVariables(c('abname',
                   'patient_id',
                   'quantile',
                   'real_first_isolate',
+                  'septic_patients',
                   'species',
                   'umcg',
+                  'View',
                   'y',
                   '.'))

R/guess_bactid.R

@@ -96,6 +96,10 @@ guess_bactid <- function(x) {
       # avoid detection of Pasteurella aerogenes in case of Pseudomonas aeruginosa
       x[i] <- 'Pseudomonas aeruginosa'
     }
+    if (tolower(x[i]) %like% 'coagulase') {
+      # coerce S. coagulase negative
+      x[i] <- 'Coagulase Negative Staphylococcus (CNS)'
+    }
 
     # translate known trivial names to genus+species
     if (!is.na(x.bak[i])) {

R/like.R

@@ -0,0 +1,80 @@
+# ==================================================================== #
+# TITLE                                                                #
+# Antimicrobial Resistance (AMR) Analysis                              #
+#                                                                      #
+# AUTHORS                                                              #
+# Berends MS (m.s.berends@umcg.nl), Luz CF (c.f.luz@umcg.nl)           #
+#                                                                      #
+# LICENCE                                                              #
+# This program is free software; you can redistribute it and/or modify #
+# it under the terms of the GNU General Public License version 2.0,    #
+# as published by the Free Software Foundation.                        #
+#                                                                      #
+# This program is distributed in the hope that it will be useful,      #
+# but WITHOUT ANY WARRANTY; without even the implied warranty of       #
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the        #
+# GNU General Public License for more details.                         #
+# ==================================================================== #
+
+#' Pattern Matching
+#'
+#' Convenient wrapper around \code{\link[base]{grepl}} to match a pattern: \code{a \%like\% b}. It always returns a \code{logical} vector and is always case-insensitive. Also, \code{pattern} (\code{b}) can be as long as \code{x} (\code{a}) to compare items of each index in both vectors.
+#' @inheritParams base::grepl
+#' @return A \code{logical} vector
+#' @name like
+#' @rdname like
+#' @export
+#' @details Using RStudio? This function can also be inserted from the Addins menu and can have its own Keyboard Shortcut like Ctrl+Shift+L or Cmd+Shift+L (see Tools > Modify Keyboard Shortcuts...).
+#' @source Idea from the \href{https://github.com/Rdatatable/data.table/blob/master/R/like.R}{\code{like} function from the \code{data.table} package}, but made it case insensitive at default and let it support multiple patterns.
+#' @seealso \code{\link[base]{grep}}
+#' @examples
+#' # simple test
+#' a <- "This is a test"
+#' b <- "TEST"
+#' a %like% b
+#' #> TRUE
+#' b %like% a
+#' #> FALSE
+#'
+#' # also supports multiple patterns, length must be equal to x
+#' a <- c("Test case", "Something different", "Yet another thing")
+#' b <- c("case", "diff", "yet")
+#' a %like% b
+#' #> TRUE TRUE TRUE
+#'
+#' # get frequencies of bacteria whose name start with 'Ent' or 'ent'
+#' library(dplyr)
+#' septic_patients %>%
+#'   left_join_microorganisms() %>%
+#'   filter(genus %like% '^ent') %>%
+#'   freq(genus, species)
+like <- function(x, pattern) {
+  if (length(pattern) > 1) {
+    if (length(x) != length(pattern)) {
+      pattern <- pattern[1]
+      warning('only the first element of argument `pattern` used for `%like%`', call. = FALSE)
+    } else {
+      # x and pattern are of same length, so items with each other
+      res <- vector(length = length(pattern))
+      for (i in 1:length(res)) {
+        if (is.factor(x[i])) {
+          res[i] <- as.integer(x[i]) %in% base::grep(pattern[i], levels(x[i]), ignore.case = TRUE)
+        } else {
+          res[i] <- base::grepl(pattern[i], x[i], ignore.case = TRUE)
+        }
+      }
+      return(res)
+    }
+  }
+
+  # the regular way how grepl works; just one pattern against one or more x
+  if (is.factor(x)) {
+    as.integer(x) %in% base::grep(pattern, levels(x), ignore.case = TRUE)
+  } else {
+    base::grepl(pattern, x, ignore.case = TRUE)
+  }
+}
+
+#' @rdname like
+#' @export
+"%like%" <- like

R/misc.R

@@ -16,33 +16,32 @@
 # GNU General Public License for more details.                         #
 # ==================================================================== #
 
-#' Pattern Matching
-#'
-#' Convenience function to compare a vector with a pattern, like \code{\link[base]{grep}}. It always returns a \code{logical} vector and is always case-insensitive.
-#' @inheritParams base::grep
-#' @return A \code{logical} vector
-#' @name like
-#' @rdname like
-#' @export
-#' @source Inherited from the \href{https://github.com/Rdatatable/data.table/blob/master/R/like.R}{\code{like} function from the \code{data.table} package}, but made it case insensitive at default.
-#' @examples
-#' library(dplyr)
-#' # get unique occurences of bacteria whose name start with 'Ent'
-#' septic_patients %>%
-#'   left_join_microorganisms() %>%
-#'   filter(fullname %like% '^Ent') %>%
-#'   pull(fullname) %>%
-#'   unique()
-"%like%" <- function(x, pattern) {
-  if (length(pattern) > 1) {
-    pattern <- pattern[1]
-    warning('only the first element of argument `pattern` used for `%like%`', call. = FALSE)
-  }
-  if (is.factor(x)) {
-    as.integer(x) %in% base::grep(pattern, levels(x), ignore.case = TRUE)
-  } else {
-    base::grepl(pattern, x, ignore.case = TRUE)
-  }
+# No export, no Rd
+addin_insert_in <- function() {
+  rstudioapi::insertText(" %in% ")
+}
+
+# No export, no Rd
+addin_insert_like <- function() {
+  rstudioapi::insertText(" %like% ")
+}
+
+#  No export, no Rd
+#' @importFrom utils View
+addin_open_antibiotics <- function() {
+  View(antibiotics)
+}
+
+#  No export, no Rd
+#' @importFrom utils View
+addin_open_microorganisms <- function() {
+  View(microorganisms)
+}
+
+#  No export, no Rd
+#' @importFrom utils View
+addin_open_septic_patients <- function() {
+  View(septic_patients)
 }
 
 # No export, no Rd

R/p.symbol.R

@@ -18,23 +18,22 @@
 
 #' Symbol of a p value
 #'
-#' Return the symbol related to the p value: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
+#' Return the symbol related to the p value: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1. Values above \code{p = 1} will return \code{NA}.
 #' @param p p value
 #' @param emptychar text to show when \code{p > 0.1}
 #' @return Text
 #' @export
 p.symbol <- function(p, emptychar = " ") {
-  instelling.oud <- options()$scipen
+  setting.bak <- options()$scipen
   options(scipen = 999)
-  s <- ''
-  s[1:length(p)] <- ''
+  s <- vector(mode = "character", length = length(p))
   for (i in 1:length(p)) {
     if (is.na(p[i])) {
-      s[i] <- NA
+      s[i] <- NA_character_
       next
     }
     if (p[i] > 1) {
-      s[i] <- NA
+      s[i] <- NA_character_
       next
     } else {
       p_test <- p[i]
@@ -52,6 +51,6 @@ p.symbol <- function(p, emptychar = " ") {
       s[i] <- '***'
     }
   }
-  options(scipen = instelling.oud)
+  options(scipen = setting.bak)
   s
 }