mirror of https://github.com/msberends/AMR.git
Try to support older R versions
This commit is contained in:
parent
e7396b8f39
commit
82fec5cc51
|
|
@ -2,9 +2,7 @@
|
|||
|
||||
# Setting up R deps
|
||||
language: r
|
||||
r:
|
||||
- 3.1
|
||||
- 3.2
|
||||
r: 3.2
|
||||
r_packages: covr
|
||||
cache: packages
|
||||
|
||||
|
|
|
|||
|
|
@ -25,8 +25,9 @@ Description: Functions to simplify the analysis of Antimicrobial Resistance (AMR
|
|||
on antibiograms according to Leclercq (2013)
|
||||
<doi:10.1111/j.1469-0691.2011.03703.x>.
|
||||
Depends:
|
||||
R (>= 3.1.3)
|
||||
R (>= 3.0.0)
|
||||
Imports:
|
||||
backports,
|
||||
dplyr (>= 0.7.0),
|
||||
data.table (>= 1.10.0),
|
||||
reshape2 (>= 1.4.0),
|
||||
|
|
|
|||
2
NEWS.md
2
NEWS.md
|
|
@ -9,7 +9,7 @@
|
|||
* New print format for tibbles and data.tables
|
||||
|
||||
#### Changed
|
||||
* Support for older R versions, only R 3.1.3 or later is needed
|
||||
* Support for old R versions, only R-3.0.0 (April 2013) or later is needed
|
||||
* Renamed dataset `ablist` to `antibiotics`
|
||||
* Renamed dataset `bactlist` to `microorganisms`
|
||||
* Added more microorganisms to `bactlist`
|
||||
|
|
|
|||
2
R/freq.R
2
R/freq.R
|
|
@ -161,7 +161,7 @@ freq <- function(x,
|
|||
}
|
||||
|
||||
if (mult.columns > 1) {
|
||||
NAs <- x[is.na(x) | x == trimws(strrep2('NA ', mult.columns))]
|
||||
NAs <- x[is.na(x) | x == trimws(strrep('NA ', mult.columns))]
|
||||
} else {
|
||||
NAs <- x[is.na(x)]
|
||||
}
|
||||
|
|
|
|||
4
R/mdro.R
4
R/mdro.R
|
|
@ -91,6 +91,10 @@ MDRO <- function(tbl,
|
|||
|
||||
tbl$MDRO <- 1
|
||||
|
||||
if (guideline$country$code == 'de') {
|
||||
stop("We are still working on German guidelines in this beta version.", call. = FALSE)
|
||||
}
|
||||
|
||||
if (guideline$country$code == 'nl') {
|
||||
# BRMO; Bijzonder Resistente Micro-Organismen
|
||||
aminoglycosides <- aminoglycosides[aminoglycosides %in% colnames(tbl)]
|
||||
|
|
|
|||
24
R/misc.R
24
R/misc.R
|
|
@ -49,7 +49,7 @@
|
|||
percent <- function(x, round = 1, force_zero = FALSE, ...) {
|
||||
val <- base::round(x * 100, digits = round)
|
||||
if (force_zero & any(val == as.integer(val))) {
|
||||
val[val == as.integer(val)] <- paste0(val[val == as.integer(val)], ".", strrep2(0, round))
|
||||
val[val == as.integer(val)] <- paste0(val[val == as.integer(val)], ".", strrep(0, round))
|
||||
}
|
||||
base::paste0(val, "%")
|
||||
}
|
||||
|
|
@ -111,25 +111,3 @@ size_humanreadable <- function(bytes, decimals = 1) {
|
|||
out <- paste(sprintf(paste0("%.", decimals, "f"), bytes / (1024 ^ factor)), size[factor + 1])
|
||||
out
|
||||
}
|
||||
|
||||
|
||||
# Support for older R versions --------------------------------------------
|
||||
|
||||
# strrep is only available in R 3.3 and later
|
||||
strrep2 <- function(x, times) {
|
||||
for (i in 1:length(x)) {
|
||||
x[i] <- paste(rep(x[i], times[i]), collapse = "")
|
||||
}
|
||||
x
|
||||
}
|
||||
|
||||
# trimws is only available in R 3.2 and later
|
||||
trimws <- function(x, which = "both") {
|
||||
if (which %in% c("left", "both", "l", "b")) {
|
||||
x <- gsub('^ {1,255}', '', x)
|
||||
}
|
||||
if (which %in% c("right", "both", "r", "b")) {
|
||||
x <- gsub(' {1,255}$', '', x)
|
||||
}
|
||||
x
|
||||
}
|
||||
|
|
|
|||
59
R/print.R
59
R/print.R
|
|
@ -32,17 +32,20 @@
|
|||
#' @exportMethod print.tbl_df
|
||||
#' @export
|
||||
#' @examples
|
||||
#' # still showing all values unchanged:
|
||||
#' # more reliable data view:
|
||||
#' library(dplyr)
|
||||
#' starwars
|
||||
#' print(starwars, width = 3)
|
||||
#'
|
||||
#' # compare the significance notation of this
|
||||
#' starwars %>% select(birth_year)
|
||||
#' # with this
|
||||
#' tibble:::print.tbl_df(starwars %>% select(birth_year))
|
||||
#' # This is how the tibble package prints since v1.4.0:
|
||||
#' # (mind the quite unfamiliar underscores and ending dots)
|
||||
#' tibble(now_what = c(1.2345, 2345.67, 321.456)) %>% tibble:::print.tbl_df()
|
||||
#'
|
||||
#' # supports info about groups (look at header)
|
||||
#' # This is how this AMR package prints:
|
||||
#' # (every number shown as you would expect)
|
||||
#' tibble(now_what = c(1.2345, 2345.67, 321.456))
|
||||
#'
|
||||
#' # also supports info about groups (look at header)
|
||||
#' starwars %>% group_by(homeworld, gender)
|
||||
print.tbl_df <- function(x,
|
||||
nmax = 10,
|
||||
|
|
@ -74,22 +77,10 @@ print.tbl <- function(x, ...) {
|
|||
#' @exportMethod print.data.table
|
||||
#' @export
|
||||
print.data.table <- function(x,
|
||||
nmax = 10,
|
||||
header = TRUE,
|
||||
row.names = TRUE,
|
||||
print.keys = FALSE,
|
||||
right = FALSE,
|
||||
width = 1,
|
||||
na = "<NA>",
|
||||
...) {
|
||||
prettyprint_df(x = x,
|
||||
nmax = nmax,
|
||||
header = header,
|
||||
row.names = row.names,
|
||||
print.keys = print.keys,
|
||||
right = right,
|
||||
width = width,
|
||||
na = na,
|
||||
...)
|
||||
}
|
||||
|
||||
|
|
@ -190,7 +181,7 @@ prettyprint_df <- function(x,
|
|||
# extra space of 3 chars, right to row name or number
|
||||
if (NROW(x) > 0) {
|
||||
maxrowchars <- rownames(x) %>% nchar() %>% max() + 3
|
||||
rownames(x) <- paste0(rownames(x), strrep2(" ", maxrowchars - nchar(rownames(x))))
|
||||
rownames(x) <- paste0(rownames(x), strrep(" ", maxrowchars - nchar(rownames(x))))
|
||||
} else {
|
||||
maxrowchars <- 0
|
||||
}
|
||||
|
|
@ -203,7 +194,7 @@ prettyprint_df <- function(x,
|
|||
x <- x %>% filter(row_number() %in% rows_list)
|
||||
rownames(x) <- rownames(x.bak)[rows_list]
|
||||
# set inbetweener between parts
|
||||
rownames(x)[n / 2 + 1] <- strrep2("~", maxrowchars)
|
||||
rownames(x)[n / 2 + 1] <- strrep("~", maxrowchars)
|
||||
}
|
||||
|
||||
if (header == TRUE) {
|
||||
|
|
@ -259,7 +250,7 @@ prettyprint_df <- function(x,
|
|||
# replace NAs
|
||||
if (nchar(na) < 2) {
|
||||
# make as long as the text "NA"
|
||||
na <- paste0(na, strrep2(" ", 2 - nchar(na)))
|
||||
na <- paste0(na, strrep(" ", 2 - nchar(na)))
|
||||
}
|
||||
try(x[, i] <- gsub("^NA$", na, trimws(x[, i], 'both')), silent = TRUE)
|
||||
# place class into 1st row
|
||||
|
|
@ -269,20 +260,20 @@ prettyprint_df <- function(x,
|
|||
# dashes between two parts when exceeding nmax
|
||||
maxvalchars <- max(colnames(x)[i] %>% nchar(), x[, i] %>% nchar() %>% max())
|
||||
if (n + 1 < nrow(x.bak)) {
|
||||
x[n / 2 + if_else(header == TRUE, 2, 1), i] <- strrep2("~", maxvalchars)
|
||||
x[n / 2 + if_else(header == TRUE, 2, 1), i] <- strrep("~", maxvalchars)
|
||||
}
|
||||
|
||||
# align according to `right` parameter, but only factors and text, but not MICs
|
||||
if (any(x.bak %>% pull(i) %>% class() %in% c('factor', 'character'))
|
||||
# align according to `right` parameter, but only factors, logicals text, but not MICs
|
||||
if (any(x.bak %>% pull(i) %>% class() %in% c('factor', 'character', 'logical'))
|
||||
& !("mic" %in% (x.bak %>% pull(i) %>% class()))) {
|
||||
vals <- x %>% pull(i) %>% trimws('both')
|
||||
colname <- colnames(x)[i] %>% trimws('both')
|
||||
if (right == FALSE) {
|
||||
vals <- paste0(vals, strrep2(" ", maxvalchars - nchar(vals)))
|
||||
colname <- paste0(colname, strrep2(" ", maxvalchars - nchar(colname)))
|
||||
vals <- paste0(vals, strrep(" ", maxvalchars - nchar(vals)))
|
||||
colname <- paste0(colname, strrep(" ", maxvalchars - nchar(colname)))
|
||||
} else {
|
||||
vals <- paste0(strrep2(" ", maxvalchars - nchar(vals)), vals)
|
||||
colname <- paste0(strrep2(" ", maxvalchars - nchar(colname)), colname)
|
||||
vals <- paste0(strrep(" ", maxvalchars - nchar(vals)), vals)
|
||||
colname <- paste0(strrep(" ", maxvalchars - nchar(colname)), colname)
|
||||
}
|
||||
x[, i] <- vals
|
||||
colnames(x)[i] <- colname
|
||||
|
|
@ -291,25 +282,25 @@ prettyprint_df <- function(x,
|
|||
# add left padding according to `width` parameter
|
||||
# but not in 1st col when row names are off
|
||||
if (row.names == TRUE | i > 1) {
|
||||
x[, i] <- paste0(strrep2(" ", width), x[, i])
|
||||
colnames(x)[i] <- paste0(strrep2(" ", width), colnames(x)[i])
|
||||
x[, i] <- paste0(strrep(" ", width), x[, i])
|
||||
colnames(x)[i] <- paste0(strrep(" ", width), colnames(x)[i])
|
||||
}
|
||||
|
||||
# strip columns that do not fit (3 chars as margin)
|
||||
width_console <- options()$width
|
||||
width_until_col <- x %>%
|
||||
select(1:i) %>%
|
||||
apply(1, paste, collapse = strrep2(" ", width + 1)) %>%
|
||||
apply(1, paste, collapse = strrep(" ", width + 1)) %>%
|
||||
nchar() %>%
|
||||
max()
|
||||
width_until_col_before <- x %>%
|
||||
select(1:(max(i, 2) - 1)) %>%
|
||||
apply(1, paste, collapse = strrep2(" ", width + 1)) %>%
|
||||
apply(1, paste, collapse = strrep(" ", width + 1)) %>%
|
||||
nchar() %>%
|
||||
max()
|
||||
extraspace <- maxrowchars + nchar(rownames(x)[length(rownames(x))])
|
||||
width_until_colnames <- colnames(x)[1:i] %>% paste0(collapse = strrep2(" ", width + 1)) %>% nchar() + extraspace
|
||||
width_until_colnames_before <- colnames(x)[1:(max(i, 2) - 1)] %>% paste0(collapse = strrep2(" ", width + 1)) %>% nchar() + extraspace
|
||||
width_until_colnames <- colnames(x)[1:i] %>% paste0(collapse = strrep(" ", width + 1)) %>% nchar() + extraspace
|
||||
width_until_colnames_before <- colnames(x)[1:(max(i, 2) - 1)] %>% paste0(collapse = strrep(" ", width + 1)) %>% nchar() + extraspace
|
||||
|
||||
if (i > 1 &
|
||||
(width_until_col > width_console
|
||||
|
|
|
|||
|
|
@ -0,0 +1,3 @@
|
|||
.onLoad <- function(libname, pkgname) {
|
||||
backports::import(pkgname)
|
||||
}
|
||||
18
man/print.Rd
18
man/print.Rd
|
|
@ -12,8 +12,7 @@
|
|||
|
||||
\method{print}{tbl}(x, ...)
|
||||
|
||||
\method{print}{data.table}(x, nmax = 10, header = TRUE, row.names = TRUE,
|
||||
print.keys = FALSE, right = FALSE, width = 1, na = "<NA>", ...)
|
||||
\method{print}{data.table}(x, print.keys = FALSE, ...)
|
||||
}
|
||||
\arguments{
|
||||
\item{x}{object of class \code{data.frame}.}
|
||||
|
|
@ -40,16 +39,19 @@
|
|||
Print a data table or tibble. It prints: \cr- The \strong{first and last rows} like \code{data.table}s are printed by the \code{data.table} package,\cr- A \strong{header} and \strong{left aligned text} like \code{tibble}s are printed by the \code{tibble} package with info about grouped variables,\cr- \strong{Unchanged values} and \strong{support for row names} like \code{data.frame}s are printed by the \code{base} package.
|
||||
}
|
||||
\examples{
|
||||
# still showing all values unchanged:
|
||||
# more reliable data view:
|
||||
library(dplyr)
|
||||
starwars
|
||||
print(starwars, width = 3)
|
||||
|
||||
# compare the significance notation of this
|
||||
starwars \%>\% select(birth_year)
|
||||
# with this
|
||||
tibble:::print.tbl_df(starwars \%>\% select(birth_year))
|
||||
# This is how the tibble package prints since v1.4.0:
|
||||
# (mind the quite unfamiliar underscores and ending dots)
|
||||
tibble(now_what = c(1.2345, 2345.67, 321.456)) \%>\% tibble:::print.tbl_df()
|
||||
|
||||
# supports info about groups (look at header)
|
||||
# This is how this AMR package prints:
|
||||
# (every number shown as you would expect)
|
||||
tibble(now_what = c(1.2345, 2345.67, 321.456))
|
||||
|
||||
# also supports info about groups (look at header)
|
||||
starwars \%>\% group_by(homeworld, gender)
|
||||
}
|
||||
|
|
|
|||
|
|
@ -19,8 +19,8 @@ test_that("size format works", {
|
|||
})
|
||||
|
||||
test_that("functions missing in older R versions work", {
|
||||
expect_equal(strrep2("A", 5), "AAAAA")
|
||||
expect_equal(strrep2(c("A", "B"), c(5, 2)), c("AAAAA", "BB"))
|
||||
expect_equal(strrep("A", 5), "AAAAA")
|
||||
expect_equal(strrep(c("A", "B"), c(5, 2)), c("AAAAA", "BB"))
|
||||
expect_equal(trimws(" test "), "test")
|
||||
expect_equal(trimws(" test ", "l"), "test ")
|
||||
expect_equal(trimws(" test ", "r"), " test")
|
||||
|
|
|
|||
Loading…
Reference in New Issue