freq - decimals

.gitlab-ci.yml

@@ -5,6 +5,7 @@
 # how the Docker+R images work: https://hub.docker.com/r/rocker/r-ver/
 R 3:
     image: rocker/r-ver:3 # test on R v3.*.*
+    allow_failure: true
     script:
     - apt-get update
     # install dependencies for package
@@ -14,13 +15,15 @@ R 3:
     # remove vignettes folder and get VignetteBuilder field out of DESCRIPTION file
     - rm -rf vignettes
     - Rscript -e 'd <- read.dcf("DESCRIPTION"); d[, colnames(d) == "VignetteBuilder"] <- NA; write.dcf(d, "DESCRIPTION")'
+    # set environmental variable
+    - Rscript -e 'Sys.setenv(NOT_CRAN = "true")'
     # build package
     - R CMD build . --no-build-vignettes --no-manual
     - PKG_FILE_NAME=$(ls -1t *.tar.gz | head -n 1)
     - R CMD check "${PKG_FILE_NAME}" --no-build-vignettes --no-manual --as-cran
     # code coverage
     - apt-get install --yes git
-    - Rscript -e "cc <- covr::package_coverage(); covr::codecov(coverage = cc, token = '50ffa0aa-fee0-4f8b-a11d-8c7edc6d32ca'); cat('Code coverage:', covr::percent_coverage(cc))"
+    - Rscript -e 'cc <- covr::package_coverage(); covr::codecov(coverage = cc, token = "50ffa0aa-fee0-4f8b-a11d-8c7edc6d32ca"); cat("Code coverage:", covr::percent_coverage(cc))'
     coverage: '/Code coverage: \d+\.\d+/'
     artifacts:
       paths:

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: AMR
-Version: 0.5.0.9002
+Version: 0.5.0.9003
-Date: 2018-12-07
+Date: 2018-12-10
 Title: Antimicrobial Resistance Analysis
 Authors@R: c(
     person(

NEWS.md

@@ -9,13 +9,17 @@
   * Finds better results when input is in other languages
   * Better handling for subspecies
   * Better handling for *Salmonellae*
-  * There will be looked for uncertain results at default - these results will be returned with a informative warning
+  * There will be looked for uncertain results at default - these results will be returned with an informative warning
-  * Extended manual text about algorithms
+  * Manual now contains more info about the algorithms
+  * Progress bar will be shown when it takes more than 3 seconds to get results
 * Function `first_isolate` will now use a column named like "patid" for the patient ID, when this parameter was left blank
 * Reduce false positives for `is.rsi.eligible`
 * Summaries of class `mo` will now return the top 3 and the unique count, e.g. using `summary(mo)`
 * Small text updates to summaries of class `rsi` and `mic`
-* Function `as.mo` now prints a progress bar when it takes more than 3 seconds the get results
+* Frequency tables (`freq` function):
+  * Added header info for class `mo` to show unique count of families, genera and species
+  * Now honours the `decimal.mark` setting, which just like `format` defaults to `getOption("OutDec")`
+  * The new `big.mark` parameter will at default be `","` when `decimal.mark = "."` and `"."` otherwise
 
 
 # 0.5.0 (latest stable release)

R/freq.R

@@ -32,6 +32,7 @@
 #' @param title text to show above frequency table, at default to tries to coerce from the variables passed to \code{x}
 #' @param na a character string to should be used to show empty (\code{NA}) values (only useful when \code{na.rm = FALSE})
 #' @param sep a character string to separate the terms when selecting multiple columns
+#' @inheritParams base::format
 #' @param f a frequency table
 #' @param n number of top \emph{n} items to return, use -n for the bottom \emph{n} items. It will include more than \code{n} rows if there are ties.
 #' @details Frequency tables (or frequency distributions) are summaries of the distribution of values in a sample. With the `freq` function, you can create univariate frequency tables. Multiple variables will be pasted into one variable, so it forces a univariate distribution. This package also has a vignette available to explain the use of this function further, run \code{browseVignettes("AMR")} to read it.
@@ -182,7 +183,9 @@ frequency_tbl <- function(x,
                           header = !markdown,
                           title = NULL,
                           na = "<NA>",
-                          sep = " ") {
+                          sep = " ",
+                          decimal.mark = getOption("OutDec"),
+                          big.mark = ifelse(decimal.mark != ",", ",", ".")) {
 
   mult.columns <- 0
   x.group = character(0)
@@ -314,8 +317,8 @@ frequency_tbl <- function(x,
   }
 
   if (NROW(x) > 0) {
-    na_txt <- paste0(NAs %>% length() %>% format(), ' = ',
+    na_txt <- paste0(NAs %>% length() %>% format(decimal.mark = decimal.mark, big.mark = big.mark), ' = ',
-                     (NAs %>% length() / (NAs %>% length() + x %>% length())) %>% percent(force_zero = TRUE, round = digits) %>%
+                     (NAs %>% length() / (NAs %>% length() + x %>% length())) %>% percent(force_zero = TRUE, round = digits, decimal.mark = decimal.mark) %>%
                        sub('NaN', '0', ., fixed = TRUE))
     if (!na_txt %like% "^0 =") {
       na_txt <- red(na_txt)
@@ -327,14 +330,21 @@ frequency_tbl <- function(x,
     na_txt <- ""
   }
 
-  header_txt <- header_txt %>% paste0(markdown_line, '\nLength:    ', (NAs %>% length() + x %>% length()) %>% format(),
+  header_txt <- header_txt %>% paste0(markdown_line, '\nLength:    ', (NAs %>% length() + x %>% length()) %>% format(decimal.mark = decimal.mark, big.mark = big.mark),
                                       ' ', na_txt)
-  header_txt <- header_txt %>% paste0(markdown_line, '\nUnique:    ', x %>% n_distinct() %>% format())
+  header_txt <- header_txt %>% paste0(markdown_line, '\nUnique:    ', x %>% n_distinct() %>% format(decimal.mark = decimal.mark, big.mark = big.mark))
 
   if (NROW(x) > 0 & any(class(x) == "character")) {
     header_txt <- header_txt %>% paste0('\n')
-    header_txt <- header_txt %>% paste0(markdown_line, '\nShortest:  ', x %>% base::nchar() %>% base::min(na.rm = TRUE))
+    header_txt <- header_txt %>% paste0(markdown_line, '\nShortest:  ', x %>% base::nchar() %>% base::min(na.rm = TRUE) %>% format(decimal.mark = decimal.mark, big.mark = big.mark))
-    header_txt <- header_txt %>% paste0(markdown_line, '\nLongest:   ', x %>% base::nchar() %>% base::max(na.rm = TRUE))
+    header_txt <- header_txt %>% paste0(markdown_line, '\nLongest:   ', x %>% base::nchar() %>% base::max(na.rm = TRUE) %>% format(decimal.mark = decimal.mark, big.mark = big.mark))
+  }
+
+  if (NROW(x) > 0 & any(class(x) == "mo")) {
+    header_txt <- header_txt %>% paste0('\n')
+    header_txt <- header_txt %>% paste0(markdown_line, '\nFamilies:  ', x %>% mo_family() %>% n_distinct() %>% format(decimal.mark = decimal.mark, big.mark = big.mark))
+    header_txt <- header_txt %>% paste0(markdown_line, '\nGenera:    ', x %>% mo_genus() %>% n_distinct() %>% format(decimal.mark = decimal.mark, big.mark = big.mark))
+    header_txt <- header_txt %>% paste0(markdown_line, '\nSpecies:   ', x %>% mo_species() %>% n_distinct() %>% format(decimal.mark = decimal.mark, big.mark = big.mark))
   }
 
   if (NROW(x) > 0 & any(class(x) == "difftime") & !is.hms(x)) {
@@ -349,13 +359,13 @@ frequency_tbl <- function(x,
     Tukey_five <- stats::fivenum(x, na.rm = TRUE)
     x_align <- 'r'
     header_txt <- header_txt %>% paste0('\n')
-    header_txt <- header_txt %>% paste(markdown_line, '\nMean:     ', x %>% base::mean(na.rm = TRUE) %>% format(digits = digits))
+    header_txt <- header_txt %>% paste(markdown_line, '\nMean:     ', x %>% base::mean(na.rm = TRUE) %>% format(digits = digits, decimal.mark = decimal.mark, big.mark = big.mark))
-    header_txt <- header_txt %>% paste0(markdown_line, '\nStd. dev.: ', x %>% stats::sd(na.rm = TRUE) %>% format(digits = digits),
+    header_txt <- header_txt %>% paste0(markdown_line, '\nStd. dev.: ', x %>% stats::sd(na.rm = TRUE) %>% format(digits = digits, decimal.mark = decimal.mark, big.mark = big.mark),
-                                        ' (CV: ', x %>% cv(na.rm = TRUE) %>% format(digits = digits),
+                                        ' (CV: ', x %>% cv(na.rm = TRUE) %>% format(digits = digits, decimal.mark = decimal.mark, big.mark = big.mark),
-                                        ', MAD: ', x %>% stats::mad(na.rm = TRUE) %>% format(digits = digits), ')')
+                                        ', MAD: ', x %>% stats::mad(na.rm = TRUE) %>% format(digits = digits, decimal.mark = decimal.mark, big.mark = big.mark), ')')
-    header_txt <- header_txt %>% paste0(markdown_line, '\nFive-Num:  ', Tukey_five %>% format(digits = digits) %>% trimws() %>% paste(collapse = ' | '),
+    header_txt <- header_txt %>% paste0(markdown_line, '\nFive-Num:  ', Tukey_five %>% format(digits = digits, decimal.mark = decimal.mark, big.mark = big.mark) %>% trimws() %>% paste(collapse = ' | '),
-                                        ' (IQR: ', (Tukey_five[4] - Tukey_five[2]) %>% format(digits = digits),
+                                        ' (IQR: ', (Tukey_five[4] - Tukey_five[2]) %>% format(digits = digits, decimal.mark = decimal.mark, big.mark = big.mark),
-                                        ', CQV: ', x %>% cqv(na.rm = TRUE) %>% format(digits = digits), ')')
+                                        ', CQV: ', x %>% cqv(na.rm = TRUE) %>% format(digits = digits, decimal.mark = decimal.mark, big.mark = big.mark), ')')
     outlier_length <- length(boxplot.stats(x)$out)
     header_txt <- header_txt %>% paste0(markdown_line, '\nOutliers:  ', outlier_length)
     if (outlier_length > 0) {
@@ -367,8 +377,8 @@ frequency_tbl <- function(x,
     cnt_S <- sum(x == "S", na.rm = TRUE)
     cnt_IR <- sum(x %in% c("I", "R"), na.rm = TRUE)
     header_txt <- header_txt %>% paste(markdown_line, '\n%IR:      ',
-                                       (cnt_IR / sum(!is.na(x), na.rm = TRUE)) %>% percent(force_zero = TRUE, round = digits),
+                                       (cnt_IR / sum(!is.na(x), na.rm = TRUE)) %>% percent(force_zero = TRUE, round = digits, decimal.mark = decimal.mark),
-                                       paste0('(ratio S : IR = 1.0 : ', (cnt_IR / cnt_S) %>% format(digits = 1, nsmall = 1), ")"))
+                                       paste0('(ratio S : IR = 1.0 : ', (cnt_IR / cnt_S) %>% format(digits = 1, nsmall = 1, decimal.mark = decimal.mark, big.mark = big.mark), ")"))
     if (NROW(x) < 30) {
       header_txt <- header_txt %>% paste(markdown_line, red('\nToo few isolates for reliable resistance interpretation.'))
     }
@@ -391,15 +401,15 @@ frequency_tbl <- function(x,
       # hms
       header_txt <- header_txt %>% paste0(markdown_line, '\nEarliest:  ', mindate %>% format(formatdates) %>% trimws())
       header_txt <- header_txt %>% paste0(markdown_line, '\nLatest:    ', maxdate %>% format(formatdates) %>% trimws(),
-                                          ' (+', difftime(maxdate, mindate, units = 'mins') %>% as.double() %>% format(digits = digits), ' min.)')
+                                          ' (+', difftime(maxdate, mindate, units = 'mins') %>% as.double() %>% format(digits = digits, decimal.mark = decimal.mark, big.mark = big.mark), ' min.)')
     } else {
       # other date formats
       header_txt <- header_txt %>% paste0(markdown_line, '\nOldest:    ', mindate %>% format(formatdates) %>% trimws())
       header_txt <- header_txt %>% paste0(markdown_line, '\nNewest:    ', maxdate %>% format(formatdates) %>% trimws(),
-                                          ' (+', difftime(maxdate, mindate, units = 'auto') %>% as.double() %>% format(digits = digits), ')')
+                                          ' (+', difftime(maxdate, mindate, units = 'auto') %>% as.double() %>% format(digits = digits, decimal.mark = decimal.mark, big.mark = big.mark), ')')
     }
     header_txt <- header_txt %>% paste0(markdown_line, '\nMedian:    ', mediandate %>% format(formatdates) %>% trimws(),
-                                        ' (~', percent(median_days / maxdate_days, round = 0), ')')
+                                        ' (~', percent(median_days / maxdate_days, round = 0, decimal.mark = decimal.mark), ')')
   }
   if (any(class(x) == 'POSIXlt')) {
     x <- x %>% format(formatdates)
@@ -485,6 +495,8 @@ frequency_tbl <- function(x,
                        row_names = row.names,
                        column_names = column_names,
                        column_align = column_align,
+                       decimal.mark = decimal.mark,
+                       big.mark = big.mark,
                        tbl_format = tbl_format,
                        na = na,
                        nmax = nmax,
@@ -573,7 +585,10 @@ diff.frequency_tbl <- function(x, y, ...) {
 #' @importFrom crayon bold silver
 #' @export
 print.frequency_tbl <- function(x, nmax = getOption("max.print.freq", default = 15),
-                                markdown = !interactive(), header = !markdown, ...) {
+                                markdown = !interactive(), header = !markdown,
+                                decimal.mark = getOption("OutDec"),
+                                big.mark = ifelse(decimal.mark != ",", ",", "."),
+                                ...) {
 
   opt <- attr(x, 'opt')
 
@@ -612,6 +627,12 @@ print.frequency_tbl <- function(x, nmax = getOption("max.print.freq", default =
     opt$nmax <- nmax
     opt$nmax.set <- TRUE
   }
+  if (!missing(decimal.mark)) {
+    opt$decimal.mark <- decimal.mark
+  }
+  if (!missing(big.mark)) {
+    opt$big.mark <- big.mark
+  }
   dots <- list(...)
   if ("markdown" %in% names(dots)) {
     if (dots$markdown == TRUE) {
@@ -677,11 +698,11 @@ print.frequency_tbl <- function(x, nmax = getOption("max.print.freq", default =
     }
     footer <- paste(footer,
                     ' -- omitted ',
-                    format(x.rows - opt$nmax),
+                    format(x.rows - opt$nmax, big.mark = opt$big.mark),
                     ' entries, n = ',
-                    format(x.unprinted),
+                    format(x.unprinted, big.mark = opt$big.mark),
                     ' (',
-                    (x.unprinted / (x.unprinted + x.printed)) %>% percent(force_zero = TRUE),
+                    (x.unprinted / (x.unprinted + x.printed)) %>% percent(force_zero = TRUE, decimal.mark = opt$decimal.mark),
                     ') ]\n', sep = '')
     if (opt$tbl_format == "pandoc") {
       footer <- silver(footer) # only silver in regular printing
@@ -692,7 +713,7 @@ print.frequency_tbl <- function(x, nmax = getOption("max.print.freq", default =
 
   if ("item" %in% colnames(x)) {
     if (any(class(x$item) %in% c('double', 'integer', 'numeric', 'raw', 'single'))) {
-      x$item <- format(x$item)
+      x$item <- format(x$item, decimal.mark = opt$decimal.mark, big.mark = opt$big.mark)
     }
   } else {
     opt$column_names <- opt$column_names[!opt$column_names == "Item"]
@@ -701,22 +722,22 @@ print.frequency_tbl <- function(x, nmax = getOption("max.print.freq", default =
     if (all(x$count == 1)) {
       warning('All observations are unique.', call. = FALSE)
     }
-    x$count <- format(x$count)
+    x$count <- format(x$count, decimal.mark = opt$decimal.mark, big.mark = opt$big.mark)
   } else {
     opt$column_names <- opt$column_names[!opt$column_names == "Count"]
   }
   if ("percent" %in% colnames(x)) {
-    x$percent <- percent(x$percent, force_zero = TRUE)
+    x$percent <- percent(x$percent, force_zero = TRUE, decimal.mark = opt$decimal.mark)
   } else {
     opt$column_names <- opt$column_names[!opt$column_names == "Percent"]
   }
   if ("cum_count" %in% colnames(x)) {
-    x$cum_count <- format(x$cum_count)
+    x$cum_count <- format(x$cum_count, decimal.mark = opt$decimal.mark, big.mark = opt$big.mark)
   } else {
     opt$column_names <- opt$column_names[!opt$column_names == "Cum. Count"]
   }
   if ("cum_percent" %in% colnames(x)) {
-    x$cum_percent <- percent(x$cum_percent, force_zero = TRUE)
+    x$cum_percent <- percent(x$cum_percent, force_zero = TRUE, decimal.mark = opt$decimal.mark)
   } else {
     opt$column_names <- opt$column_names[!opt$column_names == "Cum. Percent"]
   }

R/misc.R

@@ -27,7 +27,10 @@ addin_insert_like <- function() {
 }
 
 # No export, no Rd
-percent <- function(x, round = 1, force_zero = FALSE, ...) {
+percent <- function(x, round = 1, force_zero = FALSE, decimal.mark = getOption("OutDec"), ...) {
+
+  decimal.mark.options <- getOption("OutDec")
+  options(OutDec = ".")
 
   # https://stackoverflow.com/a/12688836/4575331
   round2 <- function(x, n) (trunc((abs(x) * 10 ^ n) + 0.5) / 10 ^ n) * sign(x)
@@ -46,6 +49,10 @@ percent <- function(x, round = 1, force_zero = FALSE, ...) {
   }
   pct <- base::paste0(val, "%")
   pct[pct %in% c("NA%", "NaN%")] <- NA_character_
+  if (decimal.mark != ".") {
+    pct <- gsub(".", decimal.mark, pct, fixed = TRUE)
+  }
+  options(OutDec = decimal.mark.options)
   pct
 }
 

appveyor.yml

@@ -16,10 +16,11 @@ cache:
 # Adapt as necessary starting from here
 
 environment:
-  global:
   R_ARCH: x64
   GCC_PATH: mingw_64
   WARNINGS_ARE_ERRORS: 1
+  PKGTYPE: win.binary
+  # USE_RTOOLS: true
 
   matrix:
   - R_VERSION: release

man/freq.Rd

@@ -10,17 +10,22 @@
 frequency_tbl(x, ..., sort.count = TRUE,
   nmax = getOption("max.print.freq"), na.rm = TRUE, row.names = TRUE,
   markdown = !interactive(), digits = 2, quote = FALSE,
-  header = !markdown, title = NULL, na = "<NA>", sep = " ")
+  header = !markdown, title = NULL, na = "<NA>", sep = " ",
+  decimal.mark = getOption("OutDec"), big.mark = ifelse(decimal.mark !=
+  ",", ",", "."))
 
 freq(x, ..., sort.count = TRUE, nmax = getOption("max.print.freq"),
   na.rm = TRUE, row.names = TRUE, markdown = !interactive(),
   digits = 2, quote = FALSE, header = !markdown, title = NULL,
-  na = "<NA>", sep = " ")
+  na = "<NA>", sep = " ", decimal.mark = getOption("OutDec"),
+  big.mark = ifelse(decimal.mark != ",", ",", "."))
 
 top_freq(f, n)
 
 \method{print}{frequency_tbl}(x, nmax = getOption("max.print.freq",
-  default = 15), markdown = !interactive(), header = !markdown, ...)
+  default = 15), markdown = !interactive(), header = !markdown,
+  decimal.mark = getOption("OutDec"), big.mark = ifelse(decimal.mark !=
+  ",", ",", "."), ...)
 }
 \arguments{
 \item{x}{vector of any class or a \code{\link{data.frame}}, \code{\link{tibble}} (may contain a grouping variable) or \code{\link{table}}}
@@ -49,6 +54,14 @@ top_freq(f, n)
 
 \item{sep}{a character string to separate the terms when selecting multiple columns}
 
+\item{decimal.mark}{%
+    used for prettying (longish) numerical and complex sequences.
+    Passed to \code{\link{prettyNum}}: that help page explains the details.}
+
+\item{big.mark}{%
+    used for prettying (longish) numerical and complex sequences.
+    Passed to \code{\link{prettyNum}}: that help page explains the details.}
+
 \item{f}{a frequency table}
 
 \item{n}{number of top \emph{n} items to return, use -n for the bottom \emph{n} items. It will include more than \code{n} rows if there are ties.}

tests/testthat/test-freq.R

@@ -26,8 +26,9 @@ test_that("frequency table works", {
   expect_output(print(freq(septic_patients$age, markdown = TRUE, title = "TITLE")))
 
   # character
-  expect_output(print(freq(septic_patients$mo)))
   expect_output(suppressWarnings(print(freq(microorganisms$fullname))))
+  # mo
+  expect_output(print(freq(septic_patients$mo)))
   # integer
   expect_output(print(freq(septic_patients$age)))
   # date