Try to support older R versions

.travis.yml

@@ -2,9 +2,7 @@
 
 # Setting up R deps
 language: r
-r:
+r: 3.2
-- 3.1
-- 3.2
 r_packages: covr
 cache: packages
 

DESCRIPTION

@@ -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),

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`

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)]
   }

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)]

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
-}

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
+#' # This is how the tibble package prints since v1.4.0:
-#' starwars %>% select(birth_year)
+#' # (mind the quite unfamiliar underscores and ending dots)
-#' # with this
+#' tibble(now_what = c(1.2345, 2345.67, 321.456)) %>% tibble:::print.tbl_df()
-#' tibble:::print.tbl_df(starwars %>% select(birth_year))
 #'
-#' # 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
+    # align according to `right` parameter, but only factors, logicals text, but not MICs
-    if (any(x.bak %>% pull(i) %>% class() %in% c('factor', 'character'))
+    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)))
+        vals <- paste0(vals, strrep(" ", maxvalchars - nchar(vals)))
-        colname <- paste0(colname, strrep2(" ", maxvalchars - nchar(colname)))
+        colname <- paste0(colname, strrep(" ", maxvalchars - nchar(colname)))
       } else {
-        vals <- paste0(strrep2(" ", maxvalchars - nchar(vals)), vals)
+        vals <- paste0(strrep(" ", maxvalchars - nchar(vals)), vals)
-        colname <- paste0(strrep2(" ", maxvalchars - nchar(colname)), colname)
+        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])
+      x[, i] <- paste0(strrep(" ", width), x[, i])
-      colnames(x)[i] <- paste0(strrep2(" ", width), colnames(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 <- colnames(x)[1:i] %>% paste0(collapse = strrep(" ", 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_before <- colnames(x)[1:(max(i, 2) - 1)] %>% paste0(collapse = strrep(" ", width + 1)) %>% nchar() + extraspace
 
     if (i > 1 &
         (width_until_col > width_console

R/zzz.R

@@ -0,0 +1,3 @@
+.onLoad <- function(libname, pkgname) {
+  backports::import(pkgname)
+}

man/print.Rd

@@ -12,8 +12,7 @@
 
 \method{print}{tbl}(x, ...)
 
-\method{print}{data.table}(x, nmax = 10, header = TRUE, row.names = TRUE,
+\method{print}{data.table}(x, print.keys = FALSE, ...)
-  print.keys = FALSE, right = FALSE, width = 1, na = "<NA>", ...)
 }
 \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
+# This is how the tibble package prints since v1.4.0:
-starwars \%>\% select(birth_year)
+# (mind the quite unfamiliar underscores and ending dots)
-# with this
+tibble(now_what = c(1.2345, 2345.67, 321.456)) \%>\% tibble:::print.tbl_df()
-tibble:::print.tbl_df(starwars \%>\% select(birth_year))
 
-# 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)
 }

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(strrep("A", 5), "AAAAA")
-  expect_equal(strrep2(c("A", "B"), c(5, 2)), c("AAAAA", "BB"))
+  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")