P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2025-07-09 04:42:22 +02:00
Code Releases Activity

v0.6.1

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2019-03-28 21:33:28 +01:00
parent 429814c29b
commit b25f2d6213
10 changed files with 143 additions and 82 deletions
Download Patch File Download Diff File Expand all files Collapse all files

76
R/eucast_rules.R
View File

@ -454,10 +454,10 @@ eucast_rules <- function(tbl,
stop(e, call. = FALSE)
}
)
suppressMessages(
suppressWarnings(
tbl[rows, cols] <<- to
))
# suppressMessages(
# suppressWarnings(
# tbl[rows, cols] <<- to
# ))
after <- as.character(unlist(as.list(tbl_original[rows, cols])))
@ -489,46 +489,22 @@ eucast_rules <- function(tbl,
number_newly_changed_to_R
if (verbose == TRUE) {
for (r in 1:length(rows)) {
for (c in 1:length(cols)) {
old <- before_df[rows[r], cols[c]]
new <- tbl[rows[r], cols[c]]
if (!identical(old, new)) {
verbose_new <- data.frame(row = rows[r],
col = cols[c],
mo = tbl_original[rows[r], col_mo],
mo_fullname = "",
old = old,
new = new,
rule_source = strip_style(rule[1]),
rule_group = strip_style(rule[2]),
stringsAsFactors = FALSE)
verbose_info <<- rbind(verbose_info, verbose_new)
}
}
old <- as.data.frame(tbl_bak, stringsAsFactors = FALSE)[rows,]
new <- as.data.frame(tbl, stringsAsFactors = FALSE)[rows,]
MOs <- as.data.frame(tbl_original, stringsAsFactors = FALSE)[rows, col_mo][[1]]
for (i in 1:length(cols)) {
verbose_new <- data.frame(row = rows,
col = cols[i],
mo = MOs,
mo_fullname = "",
old = as.character(old[, cols[i]]),
new = as.character(new[, cols[i]]),
rule_source = strip_style(rule[1]),
rule_group = strip_style(rule[2]),
stringsAsFactors = FALSE)
colnames(verbose_new) <- c("row", "col", "mo", "mo_fullname", "old", "new", "rule_source", "rule_group")
verbose_info <<- rbind(verbose_info, verbose_new)
}
# verbose_new <- data.frame(row = integer(0),
# col = character(0),
# old = character(0),
# new = character(0),
# rule_source = character(0),
# rule_group = character(0),
# stringsAsFactors = FALSE)
# a <<- rule
# for (i in 1:length(cols)) {
# # add new row for every affected column
# verbose_new <- data.frame(rule_type = strip_style(rule[1]),
# rule_set = strip_style(rule[2]),
# force_to = to,
# found = length(before),
# changed = sum(before != after, na.rm = TRUE),
# target_column = cols[i],
# stringsAsFactors = FALSE)
# verbose_new$target_rows <- list(unname(rows))
# rownames(verbose_new) <- NULL
# verbose_info <<- rbind(verbose_info, verbose_new)
# }
}
}
}
@ -543,6 +519,7 @@ eucast_rules <- function(tbl,
# save original table
tbl_original <- tbl
tbl_bak <- tbl
# join to microorganisms data set
tbl <- tbl %>%
@ -1886,9 +1863,9 @@ eucast_rules <- function(tbl,
format(x, big.mark = big.mark, decimal.mark = decimal.mark)
}
cat(bold(paste('\n=> EUCAST rules', paste0(wouldve, 'affected'),
number_affected_rows %>% length() %>% formatnr(),
'out of', nrow(tbl_original) %>% formatnr(),
'rows\n')))
number_affected_rows %>% length() %>% formatnr(),
'out of', nrow(tbl_original) %>% formatnr(),
'rows\n')))
total_added <- number_added_S + number_added_I + number_added_R
total_changed <- number_changed_to_S + number_changed_to_I + number_changed_to_R
cat(colour(paste0(" -> ", wouldve, "added ",
@ -1905,6 +1882,9 @@ eucast_rules <- function(tbl,
formatnr(number_changed_to_I), " to I; ",
formatnr(number_changed_to_R), " to R)"),
"\n")))
if (verbose == FALSE) {
cat(paste("Use", bold("verbose = TRUE"), "to get a data.frame with all specified edits.\n"))
}
}
if (verbose == TRUE) {
@ -1913,6 +1893,9 @@ eucast_rules <- function(tbl,
verbose_info$mo_fullname <- mo_fullname(verbose_info$mo)
)
)
verbose_info <- verbose_info %>%
filter(!is.na(new) & !identical(old, new)) %>%
arrange(row)
return(verbose_info)
}
@ -1932,3 +1915,4 @@ interpretive_reading <- function(...) {
.Deprecated("eucast_rules")
eucast_rules(...)
}

6
R/guess_ab_col.R
View File

@ -54,7 +54,7 @@ guess_ab_col <- function(tbl = NULL, col = NULL, verbose = FALSE) {
if (is.null(tbl) & is.null(col)) {
return(as.name("guess_ab_col"))
}
#stop("This function should not be called directly.")
if (length(col) > 1) {
warning("argument 'col' has length > 1 and only the first element will be used")
col <- col[1]
@ -114,7 +114,7 @@ guess_ab_col <- function(tbl = NULL, col = NULL, verbose = FALSE) {
if (length(ab_result) == 0) {
if (verbose == TRUE) {
message('no result found for col "', col, '"')
message('no column found for input "', col, '"')
}
return(NULL)
} else {
@ -124,7 +124,7 @@ guess_ab_col <- function(tbl = NULL, col = NULL, verbose = FALSE) {
}
if (length(result) == 0) {
if (verbose == TRUE) {
message('no result found for col "', col, '"')
message('no column found for input "', col, '"')
}
return(NULL)
}

6
R/mo.R
View File

@ -61,7 +61,11 @@
#' The algorithm uses data from the Catalogue of Life (see below) and from one other source (see \code{?microorganisms}).
#'
#' \strong{Self-learning algoritm} \cr
#' The \code{as.mo()} function gains experience from previously determined microbial IDs and learns from it. This drastically improves both speed and reliability. Use \code{clean_mo_history()} to reset the algorithms. Only experience from your current \code{AMR} package version is used. This is done because in the future the taxonomic tree (which is included in this package) may change for any organism and it consequently has to rebuild its knowledge. Usually, any guess after the first try runs 80-95\% faster than the first try. The algorithm saves its previous findings to \code{~/.Rhistory_mo}.
#' The \code{as.mo()} function gains experience from previously determined microbial IDs and learns from it. This drastically improves both speed and reliability. Use \code{clean_mo_history()} to reset the algorithms. Only experience from your current \code{AMR} package version is used. This is done because in the future the taxonomic tree (which is included in this package) may change for any organism and it consequently has to rebuild its knowledge.
#'
#' Usually, any guess after the first try runs 80-95\% faster than the first try.
#'
#' For now, learning only works per session. If R is closed or terminated, the algorithms reset. This will probably be resolved in a next version.
#'
#' \strong{Intelligent rules} \cr
#' This function uses intelligent rules to help getting fast and logical results. It tries to find matches in this order:

59
R/mo_history.R
View File

@ -19,10 +19,9 @@
# Visit our website for more info: https://msberends.gitab.io/AMR. #
# ==================================================================== #
# print successful as.mo coercions to file, not uncertain ones
# print successful as.mo coercions to AMR environment
#' @importFrom dplyr %>% distinct filter
set_mo_history <- function(x, mo, uncertainty_level, force = FALSE) {
file_location <- base::path.expand('~/.Rhistory_mo')
if (base::interactive() | force == TRUE) {
mo_hist <- read_mo_history(uncertainty_level = uncertainty_level, force = force)
df <- data.frame(x, mo, stringsAsFactors = FALSE) %>%
@ -37,12 +36,17 @@ set_mo_history <- function(x, mo, uncertainty_level, force = FALSE) {
# 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_version == utils::packageVersion("AMR")),]) == 0) {
base::write(x = c(x[i], mo[i], uncertainty_level, base::as.character(utils::packageVersion("AMR"))),
file = file_location,
ncolumns = 4,
append = TRUE,
sep = "\t")
mo_hist$package_v == utils::packageVersion("AMR")),]) == 0) {
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"))
}
}
}
@ -50,35 +54,35 @@ set_mo_history <- function(x, mo, uncertainty_level, force = FALSE) {
}
get_mo_history <- function(x, uncertainty_level, force = FALSE) {
file_read <- read_mo_history(uncertainty_level = uncertainty_level, force = force)
if (base::is.null(file_read)) {
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(file_read, by = "x") %>%
left_join(history, by = "x") %>%
pull(mo)
}
}
#' @importFrom dplyr %>% filter distinct
read_mo_history <- function(uncertainty_level = 2, force = FALSE, unfiltered = FALSE) {
file_location <- base::path.expand('~/.Rhistory_mo')
if (!base::file.exists(file_location) | (!base::interactive() & force == FALSE)) {
if ((!base::interactive() & force == FALSE)) {
return(NULL)
}
uncertainty_level_param <- uncertainty_level
file_read <- utils::read.table(file = file_location,
header = FALSE,
sep = "\t",
col.names = c("x", "mo", "uncertainty_level", "package_version"),
stringsAsFactors = FALSE)
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) {
file_read <- file_read %>%
filter(package_version == utils::packageVersion("AMR"),
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))) %>%
@ -86,10 +90,10 @@ read_mo_history <- function(uncertainty_level = 2, force = FALSE, unfiltered = F
distinct(x, mo, .keep_all = TRUE)
}
if (nrow(file_read) == 0) {
if (nrow(history) == 0) {
NULL
} else {
file_read
history
}
}
@ -98,20 +102,21 @@ read_mo_history <- function(uncertainty_level = 2, force = FALSE, unfiltered = F
#' @importFrom utils menu
#' @export
clean_mo_history <- function(...) {
file_location <- base::path.expand('~/.Rhistory_mo')
if (file.exists(file_location)) {
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 = ","),
"previously determined microbial IDs. Are you sure?"),
"microbial IDs determined previously in this session. Are you sure?"),
choices = c("Yes", "No"),
graphics = FALSE)
if (q != 1) {
return(invisible())
}
}
unlink(file_location)
cat(red("File", file_location, "removed."))
assign(x = "mo_history",
value = NULL,
envir = asNamespace("AMR"))
cat(red("History removed."))
}
}