mirror of
https://github.com/msberends/AMR.git
synced 2025-07-09 06:51:48 +02:00
cfta streptococci
This commit is contained in:
18
R/age.R
18
R/age.R
@ -72,9 +72,9 @@ age <- function(x, reference = Sys.Date()) {
|
||||
#' \item{A character:}
|
||||
#' \itemize{
|
||||
#' \item{\code{"children"}, equivalent of: \code{c(0, 1, 2, 4, 6, 13, 18)}. This will split on 0, 1, 2-3, 4-5, 6-12, 13-17 and 18+.}
|
||||
#' \item{\code{"elderly"} or \code{"seniors"}, equivalent of: \code{c(65, 75, 85, 95)}. This will split on 0-64, 65-74, 75-84, 85-94 and 95+.}
|
||||
#' \item{\code{"fives"}, equivalent of: \code{1:24 * 5}. This will split on 0-4, 5-9, 10-14, 15-19 and so forth, until 120.}
|
||||
#' \item{\code{"tens"}, equivalent of: \code{1:12 * 10}. This will split on 0-9, 10-19, 20-29 and so forth, until 120.}
|
||||
#' \item{\code{"elderly"} or \code{"seniors"}, equivalent of: \code{c(65, 75, 85)}. This will split on 0-64, 65-74, 75-84, 85+.}
|
||||
#' \item{\code{"fives"}, equivalent of: \code{1:20 * 5}. This will split on 0-4, 5-9, 10-14, ..., 90-94, 95-99, 100+.}
|
||||
#' \item{\code{"tens"}, equivalent of: \code{1:10 * 10}. This will split on 0-9, 10-19, 20-29, ... 80-89, 90-99, 100+.}
|
||||
#' }
|
||||
#' }
|
||||
#' @keywords age_group age
|
||||
@ -92,11 +92,11 @@ age <- function(x, reference = Sys.Date()) {
|
||||
#' age_groups(ages, c(20, 50))
|
||||
#'
|
||||
#' # split into groups of ten years
|
||||
#' age_groups(ages, 1:12 * 10)
|
||||
#' age_groups(ages, 1:10 * 10)
|
||||
#' age_groups(ages, split_at = "tens")
|
||||
#'
|
||||
#' # split into groups of five years
|
||||
#' age_groups(ages, 1:24 * 5)
|
||||
#' age_groups(ages, 1:20 * 5)
|
||||
#' age_groups(ages, split_at = "fives")
|
||||
#'
|
||||
#' # split specifically for children
|
||||
@ -117,14 +117,14 @@ age <- function(x, reference = Sys.Date()) {
|
||||
age_groups <- function(x, split_at = c(12, 25, 55, 75)) {
|
||||
if (is.character(split_at)) {
|
||||
split_at <- split_at[1L]
|
||||
if (split_at %like% "^child") {
|
||||
if (split_at %like% "^(child|kid)") {
|
||||
split_at <- c(0, 1, 2, 4, 6, 13, 18)
|
||||
} else if (split_at %like% "^(elder|senior)") {
|
||||
split_at <- c(65, 75, 85, 95)
|
||||
split_at <- c(65, 75, 85)
|
||||
} else if (split_at %like% "^five") {
|
||||
split_at <- 1:24 * 5
|
||||
split_at <- 1:20 * 5
|
||||
} else if (split_at %like% "^ten") {
|
||||
split_at <- 1:12 * 10
|
||||
split_at <- 1:10 * 10
|
||||
}
|
||||
}
|
||||
split_at <- as.integer(split_at)
|
||||
|
||||
178
R/mo_history.R
178
R/mo_history.R
@ -25,50 +25,50 @@ set_mo_history <- function(x, mo, uncertainty_level, force = FALSE) {
|
||||
# disable function
|
||||
return(base::invisible())
|
||||
|
||||
if (base::interactive() | force == TRUE) {
|
||||
mo_hist <- read_mo_history(uncertainty_level = uncertainty_level, force = force)
|
||||
df <- data.frame(x, mo, stringsAsFactors = FALSE) %>%
|
||||
distinct(x, .keep_all = TRUE) %>%
|
||||
filter(!is.na(x) & !is.na(mo))
|
||||
if (nrow(df) == 0) {
|
||||
return(base::invisible())
|
||||
}
|
||||
x <- toupper(df$x)
|
||||
mo <- df$mo
|
||||
for (i in 1:length(x)) {
|
||||
# save package version too, as both the as.mo() algorithm and the reference data set may change
|
||||
if (NROW(mo_hist[base::which(mo_hist$x == x[i] &
|
||||
mo_hist$uncertainty_level >= uncertainty_level &
|
||||
mo_hist$package_v == utils::packageVersion("AMR")),]) == 0) {
|
||||
tryCatch(
|
||||
assign(x = "mo_history",
|
||||
value = rbind(mo_hist,
|
||||
data.frame(
|
||||
x = x[i],
|
||||
mo = mo[i],
|
||||
uncertainty_level = uncertainty_level,
|
||||
package_v = base::as.character(utils::packageVersion("AMR")),
|
||||
stringsAsFactors = FALSE)),
|
||||
envir = asNamespace("AMR")),
|
||||
error = function(e) invisible())
|
||||
}
|
||||
}
|
||||
}
|
||||
return(base::invisible())
|
||||
# if (base::interactive() | force == TRUE) {
|
||||
# mo_hist <- read_mo_history(uncertainty_level = uncertainty_level, force = force)
|
||||
# df <- data.frame(x, mo, stringsAsFactors = FALSE) %>%
|
||||
# distinct(x, .keep_all = TRUE) %>%
|
||||
# filter(!is.na(x) & !is.na(mo))
|
||||
# if (nrow(df) == 0) {
|
||||
# return(base::invisible())
|
||||
# }
|
||||
# x <- toupper(df$x)
|
||||
# mo <- df$mo
|
||||
# for (i in 1:length(x)) {
|
||||
# # save package version too, as both the as.mo() algorithm and the reference data set may change
|
||||
# if (NROW(mo_hist[base::which(mo_hist$x == x[i] &
|
||||
# mo_hist$uncertainty_level >= uncertainty_level &
|
||||
# mo_hist$package_v == utils::packageVersion("AMR")),]) == 0) {
|
||||
# tryCatch(
|
||||
# assign(x = "mo_history",
|
||||
# value = rbind(mo_hist,
|
||||
# data.frame(
|
||||
# x = x[i],
|
||||
# mo = mo[i],
|
||||
# uncertainty_level = uncertainty_level,
|
||||
# package_v = base::as.character(utils::packageVersion("AMR")),
|
||||
# stringsAsFactors = FALSE)),
|
||||
# envir = asNamespace("AMR")),
|
||||
# error = function(e) invisible())
|
||||
# }
|
||||
# }
|
||||
# }
|
||||
# return(base::invisible())
|
||||
}
|
||||
|
||||
get_mo_history <- function(x, uncertainty_level, force = FALSE) {
|
||||
# disable function
|
||||
return(NA)
|
||||
|
||||
history <- read_mo_history(uncertainty_level = uncertainty_level, force = force)
|
||||
if (base::is.null(history)) {
|
||||
NA
|
||||
} else {
|
||||
data.frame(x = toupper(x), stringsAsFactors = FALSE) %>%
|
||||
left_join(history, by = "x") %>%
|
||||
pull(mo)
|
||||
}
|
||||
# history <- read_mo_history(uncertainty_level = uncertainty_level, force = force)
|
||||
# if (base::is.null(history)) {
|
||||
# NA
|
||||
# } else {
|
||||
# data.frame(x = toupper(x), stringsAsFactors = FALSE) %>%
|
||||
# left_join(history, by = "x") %>%
|
||||
# pull(mo)
|
||||
# }
|
||||
}
|
||||
|
||||
#' @importFrom dplyr %>% filter distinct
|
||||
@ -76,59 +76,59 @@ read_mo_history <- function(uncertainty_level = 2, force = FALSE, unfiltered = F
|
||||
# disable function
|
||||
return(NULL)
|
||||
|
||||
if ((!base::interactive() & force == FALSE)) {
|
||||
return(NULL)
|
||||
}
|
||||
uncertainty_level_param <- uncertainty_level
|
||||
|
||||
history <- tryCatch(get("mo_history", envir = asNamespace("AMR")),
|
||||
error = function(e) NULL)
|
||||
if (is.null(history)) {
|
||||
return(NULL)
|
||||
}
|
||||
# Below: filter on current package version.
|
||||
# Even current fullnames may be replaced by new taxonomic names, so new versions of
|
||||
# the Catalogue of Life must not lead to data corruption.
|
||||
|
||||
if (unfiltered == FALSE) {
|
||||
history <- history %>%
|
||||
filter(package_v == as.character(utils::packageVersion("AMR")),
|
||||
# only take unknowns if uncertainty_level_param is higher
|
||||
((mo == "UNKNOWN" & uncertainty_level_param == uncertainty_level) |
|
||||
(mo != "UNKNOWN" & uncertainty_level_param >= uncertainty_level))) %>%
|
||||
arrange(desc(uncertainty_level)) %>%
|
||||
distinct(x, mo, .keep_all = TRUE)
|
||||
}
|
||||
|
||||
if (nrow(history) == 0) {
|
||||
NULL
|
||||
} else {
|
||||
history
|
||||
}
|
||||
# if ((!base::interactive() & force == FALSE)) {
|
||||
# return(NULL)
|
||||
# }
|
||||
# uncertainty_level_param <- uncertainty_level
|
||||
#
|
||||
# history <- tryCatch(get("mo_history", envir = asNamespace("AMR")),
|
||||
# error = function(e) NULL)
|
||||
# if (is.null(history)) {
|
||||
# return(NULL)
|
||||
# }
|
||||
# # Below: filter on current package version.
|
||||
# # Even current fullnames may be replaced by new taxonomic names, so new versions of
|
||||
# # the Catalogue of Life must not lead to data corruption.
|
||||
#
|
||||
# if (unfiltered == FALSE) {
|
||||
# history <- history %>%
|
||||
# filter(package_v == as.character(utils::packageVersion("AMR")),
|
||||
# # only take unknowns if uncertainty_level_param is higher
|
||||
# ((mo == "UNKNOWN" & uncertainty_level_param == uncertainty_level) |
|
||||
# (mo != "UNKNOWN" & uncertainty_level_param >= uncertainty_level))) %>%
|
||||
# arrange(desc(uncertainty_level)) %>%
|
||||
# distinct(x, mo, .keep_all = TRUE)
|
||||
# }
|
||||
#
|
||||
# if (nrow(history) == 0) {
|
||||
# NULL
|
||||
# } else {
|
||||
# history
|
||||
# }
|
||||
}
|
||||
|
||||
#' @rdname as.mo
|
||||
#' @importFrom crayon red
|
||||
#' @importFrom utils menu
|
||||
#' @export
|
||||
# @rdname as.mo
|
||||
# @importFrom crayon red
|
||||
# @importFrom utils menu
|
||||
# @export
|
||||
clean_mo_history <- function(...) {
|
||||
if (!is.null(read_mo_history())) {
|
||||
if (interactive() & !isTRUE(list(...)$force)) {
|
||||
q <- menu(title = paste("This will remove all",
|
||||
format(nrow(read_mo_history(999, unfiltered = TRUE)), big.mark = ","),
|
||||
"microbial IDs determined previously in this session. Are you sure?"),
|
||||
choices = c("Yes", "No"),
|
||||
graphics = FALSE)
|
||||
if (q != 1) {
|
||||
return(invisible())
|
||||
}
|
||||
}
|
||||
tryCatch(
|
||||
assign(x = "mo_history",
|
||||
value = NULL,
|
||||
envir = asNamespace("AMR")),
|
||||
error = function(e) invisible())
|
||||
cat(red("History removed."))
|
||||
}
|
||||
# if (!is.null(read_mo_history())) {
|
||||
# if (interactive() & !isTRUE(list(...)$force)) {
|
||||
# q <- menu(title = paste("This will remove all",
|
||||
# format(nrow(read_mo_history(999, unfiltered = TRUE)), big.mark = ","),
|
||||
# "microbial IDs determined previously in this session. Are you sure?"),
|
||||
# choices = c("Yes", "No"),
|
||||
# graphics = FALSE)
|
||||
# if (q != 1) {
|
||||
# return(invisible())
|
||||
# }
|
||||
# }
|
||||
# tryCatch(
|
||||
# assign(x = "mo_history",
|
||||
# value = NULL,
|
||||
# envir = asNamespace("AMR")),
|
||||
# error = function(e) invisible())
|
||||
# cat(red("History removed."))
|
||||
# }
|
||||
}
|
||||
|
||||
|
||||
@ -247,10 +247,13 @@ mo_phylum <- function(x, language = get_locale(), ...) {
|
||||
#' @rdname mo_property
|
||||
#' @export
|
||||
mo_kingdom <- function(x, language = get_locale(), ...) {
|
||||
if (all(x %in% AMR::microorganisms$kingdom)) {
|
||||
return(x)
|
||||
}
|
||||
x <- as.mo(x, language = "en", ...)
|
||||
kngdm <- mo_validate(x = x, property = "kingdom", ...)
|
||||
if (language != "en") {
|
||||
unknowns <- as.mo(x, ...) == "UNKOWN"
|
||||
kngdm[unknowns] <- mo_translate(kngdm[unknowns], language = language)
|
||||
kngdm[x == "UNKNOWN"] <- mo_translate(kngdm[x == "UNKNOWN"], language = language)
|
||||
}
|
||||
kngdm
|
||||
}
|
||||
@ -264,7 +267,6 @@ mo_type <- function(x, language = get_locale(), ...) {
|
||||
#' @rdname mo_property
|
||||
#' @export
|
||||
mo_gramstain <- function(x, language = get_locale(), ...) {
|
||||
x.bak <- x
|
||||
x.mo <- as.mo(x, language = "en", ...)
|
||||
x.phylum <- mo_phylum(x.mo, language = "en")
|
||||
x[x.phylum %in% c("Actinobacteria",
|
||||
|
||||
Reference in New Issue
Block a user