From 82fec5cc513fd9cf8a495d3bda737d7e43ff790b Mon Sep 17 00:00:00 2001 From: "Matthijs S. Berends" Date: Thu, 19 Apr 2018 14:10:57 +0200 Subject: [PATCH] Try to support older R versions --- .travis.yml | 4 +-- DESCRIPTION | 3 +- NEWS.md | 2 +- R/freq.R | 2 +- R/mdro.R | 4 +++ R/misc.R | 24 +--------------- R/print.R | 59 ++++++++++++++++---------------------- R/zzz.R | 3 ++ man/print.Rd | 18 ++++++------ tests/testthat/test-misc.R | 4 +-- 10 files changed, 50 insertions(+), 73 deletions(-) create mode 100644 R/zzz.R diff --git a/.travis.yml b/.travis.yml index abee0789..4be52271 100644 --- a/.travis.yml +++ b/.travis.yml @@ -2,9 +2,7 @@ # Setting up R deps language: r -r: -- 3.1 -- 3.2 +r: 3.2 r_packages: covr cache: packages diff --git a/DESCRIPTION b/DESCRIPTION index 9248ea7e..0bcd64b0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -25,8 +25,9 @@ Description: Functions to simplify the analysis of Antimicrobial Resistance (AMR on antibiograms according to Leclercq (2013) . Depends: - R (>= 3.1.3) + R (>= 3.0.0) Imports: + backports, dplyr (>= 0.7.0), data.table (>= 1.10.0), reshape2 (>= 1.4.0), diff --git a/NEWS.md b/NEWS.md index 05bdb219..8e3030ac 100644 --- a/NEWS.md +++ b/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` diff --git a/R/freq.R b/R/freq.R index c8578f6a..bb592c0e 100644 --- a/R/freq.R +++ b/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)] } diff --git a/R/mdro.R b/R/mdro.R index b2c3ae79..53ee1521 100644 --- a/R/mdro.R +++ b/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)] diff --git a/R/misc.R b/R/misc.R index c8e133f1..eace1da5 100644 --- a/R/misc.R +++ b/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 -} diff --git a/R/print.R b/R/print.R index 2978c15e..676917bb 100644 --- a/R/print.R +++ b/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 = "", ...) { 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 diff --git a/R/zzz.R b/R/zzz.R new file mode 100644 index 00000000..1460bf58 --- /dev/null +++ b/R/zzz.R @@ -0,0 +1,3 @@ +.onLoad <- function(libname, pkgname) { + backports::import(pkgname) +} diff --git a/man/print.Rd b/man/print.Rd index a9f4ef01..13b993e2 100644 --- a/man/print.Rd +++ b/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 = "", ...) +\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) } diff --git a/tests/testthat/test-misc.R b/tests/testthat/test-misc.R index bce8a885..30792859 100644 --- a/tests/testthat/test-misc.R +++ b/tests/testthat/test-misc.R @@ -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")