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

(v0.7.1.9027) tibble printing

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2019-08-07 15:37:39 +02:00
parent 14c47da656
commit 90c874025a
42 changed files with 946 additions and 602 deletions
Download Patch File Download Diff File Expand all files Collapse all files

16
R/ab.R
View File

@ -262,7 +262,7 @@ is.ab <- function(x) {
#' @noRd
print.ab <- function(x, ...) {
cat("Class 'ab'\n")
print.default(as.character(x), quote = FALSE)
print(as.character(x), quote = FALSE)
}
#' @exportMethod as.data.frame.ab
@ -286,3 +286,17 @@ as.data.frame.ab <- function (x, ...) {
pull.ab <- function(.data, ...) {
pull(as.data.frame(.data), ...)
}
#' @importFrom pillar type_sum
#' @export
type_sum.ab <- function(x) {
"ab"
}
#' @importFrom pillar pillar_shaft
#' @export
pillar_shaft.ab <- function(x, ...) {
out <- format(x)
out[is.na(x)] <- NA
pillar::new_pillar_shaft_simple(out, align = "left", min_width = 4)
}

47
R/eucast_rules.R
View File

@ -228,18 +228,18 @@ eucast_rules <- function(x,
warned <- FALSE
txt_error <- function() { cat("", bgRed(white(" ERROR ")), "\n") }
txt_warning <- function() { if (warned == FALSE) { cat("", bgYellow(black(" WARNING ")), "\n") }; warned <<- TRUE }
txt_error <- function() { cat("", bgRed(white(" ERROR ")), "\n\n") }
txt_warning <- function() { if (warned == FALSE) { cat("", bgYellow(black(" WARNING "))) }; warned <<- TRUE }
txt_ok <- function(no_of_changes) {
if (warned == FALSE) {
if (no_of_changes > 0) {
if (no_of_changes == 1) {
cat(blue(" (1 new change)\n"))
cat(blue(" (1 value changed)\n"))
} else {
cat(blue(paste0(" (", formatnr(no_of_changes), " new changes)\n")))
cat(blue(paste0(" (", formatnr(no_of_changes), " values changed)\n")))
}
} else {
cat(green(" (no new changes)\n"))
cat(green(" (no values changed)\n"))
}
warned <<- FALSE
}
@ -402,20 +402,37 @@ eucast_rules <- function(x,
x_original[rows, cols] <<- to,
warning = function(w) {
if (w$message %like% 'invalid factor level') {
warning('Value "', to, '" could not be applied to column(s) `', paste(cols, collapse = '`, `'), '` because this value is not an existing factor level. You can use as.rsi() to fix this.', call. = FALSE)
x_original <<- x_original %>% mutate_at(vars(cols), ~factor(x = as.character(.), levels = c(to, levels(.))))
x <<- x %>% mutate_at(vars(cols), ~factor(x = as.character(.), levels = c(to, levels(.))))
x_original[rows, cols] <<- to
warning('Value "', to, '" added to the factor levels of column(s) `', paste(cols, collapse = '`, `'), '` because this value was not an existing factor level.\nA better way is to use as.rsi() on beforehand on antibiotic columns to guarantee the right structure.', call. = FALSE)
txt_warning()
warned <<- FALSE
} else {
warning(w$message, call. = FALSE)
txt_warning()
cat("\n") # txt_warning() does not append a "\n" on itself
}
txt_warning()
},
error = function(e) {
txt_error()
stop(e, call. = FALSE)
stop(paste0("Error in row(s) ", paste(rows[1:min(length(rows), 10)], collapse = ","),
'... while writing value "', to,
'" to column(s) `', paste(cols, collapse = "`, `"),
"` (data class:", paste(class(x_original), collapse = "/"), "):\n", e$message), call. = FALSE)
}
)
x[rows, cols] <<- x_original[rows, cols]
tryCatch(
x[rows, cols] <<- x_original[rows, cols],
error = function(e) {
stop(paste0("Error in row(s) ", paste(rows[1:min(length(rows), 10)], collapse = ","),
'... while writing value "', to,
'" to column(s) `', paste(cols, collapse = "`, `"),
"` (data class:", paste(class(x), collapse = "/"), "):\n", e$message), call. = FALSE)
}
)
# before_df might not be a data.frame, but a tibble or data.table instead
old <- as.data.frame(before_df, stringsAsFactors = FALSE)[rows,]
no_of_changes_this_run <- 0
@ -719,7 +736,7 @@ eucast_rules <- function(x,
mutate(plural = ifelse(n > 1, "s", ""),
txt = paste0(formatnr(n), " test result", plural, " added as ", new)) %>%
pull(txt) %>%
paste(" -", ., collapse = "\n") %>%
paste(" *", ., collapse = "\n") %>%
cat()
}
@ -748,16 +765,16 @@ eucast_rules <- function(x,
mutate(plural = ifelse(n > 1, "s", ""),
txt = paste0(formatnr(n), " test result", plural, " changed from ", old, " to ", new)) %>%
pull(txt) %>%
paste(" -", ., collapse = "\n") %>%
paste(" *", ., collapse = "\n") %>%
cat()
cat("\n")
}
cat(paste0(silver(strrep("-", options()$width - 1)), "\n"))
if (verbose == FALSE & nrow(verbose_info) > 0) {
cat(paste("\nUse", bold("verbose = TRUE"), "(on your original data) to get a data.frame with all specified edits instead.\n"))
cat(paste("\nUse", bold("eucast_rules(..., verbose = TRUE)"), "(on your original data) to get a data.frame with all specified edits instead.\n\n"))
} else if (verbose == TRUE) {
cat(paste(red("\nUsed 'Verbose mode' (verbose = TRUE)."), "This returns a data.frame with all specified edits.\nUse", bold("verbose = FALSE"), "to apply the rules on your data.\n"))
cat(paste(red("\nUsed 'Verbose mode' (verbose = TRUE)"), ", which returns a data.frame with all specified edits.\nUse", bold("verbose = FALSE"), "to apply the rules on your data.\n\n"))
}
}

1
R/extended.R
View File

@ -45,4 +45,3 @@ scale_type.ab <- function(x) {
# "Error: Discrete value supplied to continuous scale"
"discrete"
}

19
R/mic.R
View File

@ -173,9 +173,8 @@ as.mic <- function(x, na.rm = FALSE) {
list_missing, call. = FALSE)
}
x <- factor(x, levels = lvls, ordered = TRUE)
class(x) <- c('mic', 'ordered', 'factor')
x
structure(.Data = factor(x, levels = lvls, ordered = TRUE),
class = c('mic', 'ordered', 'factor'))
}
}
@ -279,3 +278,17 @@ barplot.mic <- function(height,
...)
axis(2, seq(0, max(table(droplevels.factor(height)))))
}
#' @importFrom pillar type_sum
#' @export
type_sum.mic <- function(x) {
"mic"
}
#' @importFrom pillar pillar_shaft
#' @export
pillar_shaft.mic <- function(x, ...) {
out <- trimws(format(x))
out[is.na(x)] <- NA
pillar::new_pillar_shaft_simple(out, align = "right", min_width = 4)
}

27
R/mo.R
View File

@ -268,13 +268,17 @@ as.mo <- function(x, Becker = FALSE, Lancefield = FALSE, allow_uncertain = TRUE,
}
structure(.Data = y, class = "mo")
to_class_mo(y)
}
to_class_mo <- function(x) {
structure(.Data = x, class = "mo")
}
#' @rdname as.mo
#' @export
is.mo <- function(x) {
identical(class(x), "mo")
identical(class(x), class(to_class_mo(x)))
}
#' @importFrom dplyr %>% pull left_join n_distinct progress_estimated filter distinct
@ -391,8 +395,7 @@ exec_as.mo <- function(x,
# all empty
if (all(identical(trimws(x_input), "") | is.na(x_input) | length(x) == 0)) {
if (property == "mo") {
return(structure(rep(NA_character_, length(x_input)),
class = "mo"))
return(to_class_mo(rep(NA_character_, length(x_input))))
} else {
return(rep(NA_character_, length(x_input)))
}
@ -1455,7 +1458,7 @@ exec_as.mo <- function(x,
)
if (property == "mo") {
class(x) <- "mo"
x <- to_class_mo(x)
}
if (length(mo_renamed()) > 0) {
@ -1507,6 +1510,20 @@ print.mo <- function(x, ...) {
print.default(x, quote = FALSE)
}
#' @importFrom pillar type_sum
#' @export
type_sum.mo <- function(x) {
"mo"
}
#' @importFrom pillar pillar_shaft
#' @export
pillar_shaft.mo <- function(x, ...) {
out <- format(x)
out[is.na(x)] <- NA
pillar::new_pillar_shaft_simple(out, align = "left", min_width = 11)
}
#' @exportMethod summary.mo
#' @importFrom dplyr n_distinct
#' @importFrom clean freq top_freq

3
R/mo_property.R
View File

@ -425,11 +425,10 @@ mo_validate <- function(x, property, ...) {
}
if (property == "mo") {
return(structure(x, class = "mo"))
return(to_class_mo(x))
} else if (property == "col_id") {
return(as.integer(x))
} else {
return(x)
}
}

10
R/resistance_predict.R
View File

@ -28,7 +28,7 @@
#' @param year_max highest year to use in the prediction model, defaults to 10 years after today
#' @param year_every unit of sequence between lowest year found in the data and \code{year_max}
#' @param minimum minimal amount of available isolates per year to include. Years containing less observations will be estimated by the model.
#' @param model the statistical model of choice. Defaults to a generalised linear regression model with binomial distribution (i.e. using \code{\link{glm}(..., family = \link{binomial})}), assuming that a period of zero resistance was followed by a period of increasing resistance leading slowly to more and more resistance. See Details for valid options.
#' @param model the statistical model of choice. This could be a generalised linear regression model with binomial distribution (i.e. using \code{\link{glm}(..., family = \link{binomial})}), assuming that a period of zero resistance was followed by a period of increasing resistance leading slowly to more and more resistance. See Details for all valid options.
#' @param I_as_S a logical to indicate whether values \code{I} should be treated as \code{S} (will otherwise be treated as \code{R})
#' @param preserve_measurements a logical to indicate whether predictions of years that are actually available in the data should be overwritten by the original data. The standard errors of those years will be \code{NA}.
#' @param info a logical to indicate whether textual analysis should be printed with the name and \code{\link{summary}} of the statistical model.
@ -112,7 +112,7 @@ resistance_predict <- function(x,
year_max = NULL,
year_every = 1,
minimum = 30,
model = 'binomial',
model = NULL,
I_as_S = TRUE,
preserve_measurements = TRUE,
info = TRUE,
@ -121,6 +121,10 @@ resistance_predict <- function(x,
if (nrow(x) == 0) {
stop('This table does not contain any observations.')
}
if (is.null(model)) {
stop('Choose a regression model with the `model` parameter, e.g. resistance_predict(..., model = "binomial").')
}
if (!col_ab %in% colnames(x)) {
stop('Column ', col_ab, ' not found.')
@ -252,7 +256,7 @@ resistance_predict <- function(x,
se <- predictmodel$se.fit
} else {
stop('No valid model selected.')
stop('No valid model selected. See ?resistance_predict.')
}
# prepare the output dataframe

18
R/rsi.R
View File

@ -472,3 +472,21 @@ barplot.rsi <- function(height,
axis(side = 1, labels = levels(height), at = c(1, 2, 3) + 0.5, lwd = 0)
}
}
#' @importFrom pillar type_sum
#' @export
type_sum.rsi <- function(x) {
"rsi"
}
#' @importFrom pillar pillar_shaft
#' @importFrom crayon bgGreen bgYellow bgRed white black
#' @export
pillar_shaft.rsi <- function(x, ...) {
out <- trimws(format(x))
out[is.na(x)] <- pillar::style_subtle("NA")
out[x == "S"] <- bgGreen(white(" S "))
out[x == "I"] <- bgYellow(black(" I "))
out[x == "R"] <- bgRed(white(" R "))
pillar::new_pillar_shaft_simple(out, align = "left", min_width = 4)
}