mirror of
https://github.com/msberends/AMR.git
synced 2025-07-09 13:42:04 +02:00
(v0.7.1.9027) tibble printing
This commit is contained in:
16
R/ab.R
16
R/ab.R
@ -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)
|
||||
}
|
||||
|
@ -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"))
|
||||
}
|
||||
}
|
||||
|
||||
|
@ -45,4 +45,3 @@ scale_type.ab <- function(x) {
|
||||
# "Error: Discrete value supplied to continuous scale"
|
||||
"discrete"
|
||||
}
|
||||
|
||||
|
19
R/mic.R
19
R/mic.R
@ -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
27
R/mo.R
@ -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
|
||||
|
@ -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)
|
||||
}
|
||||
|
||||
}
|
||||
|
@ -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
18
R/rsi.R
@ -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)
|
||||
}
|
||||
|
Reference in New Issue
Block a user