From 9478ab71bed00af1c1ff0dc04fcc02acf183359f Mon Sep 17 00:00:00 2001 From: "Matthijs S. Berends" Date: Mon, 10 Dec 2018 10:13:40 +0100 Subject: [PATCH] freq - decimals --- .gitlab-ci.yml | 5 ++- DESCRIPTION | 4 +- NEWS.md | 10 +++-- R/freq.R | 77 ++++++++++++++++++++++++-------------- R/misc.R | 9 ++++- appveyor.yml | 9 +++-- man/freq.Rd | 19 ++++++++-- tests/testthat/test-freq.R | 3 +- 8 files changed, 93 insertions(+), 43 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 42a019d0..2db5a15f 100644 --- a/.gitlab-ci.yml +++ b/.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: diff --git a/DESCRIPTION b/DESCRIPTION index 442231f3..222717b5 100755 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: AMR -Version: 0.5.0.9002 -Date: 2018-12-07 +Version: 0.5.0.9003 +Date: 2018-12-10 Title: Antimicrobial Resistance Analysis Authors@R: c( person( diff --git a/NEWS.md b/NEWS.md index d6f01efd..11a1eae4 100755 --- a/NEWS.md +++ b/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 - * Extended manual text about algorithms + * There will be looked for uncertain results at default - these results will be returned with an informative warning + * 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) diff --git a/R/freq.R b/R/freq.R index c7a5fa88..b879c5ca 100755 --- a/R/freq.R +++ b/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 = "", - 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(), ' = ', - (NAs %>% length() / (NAs %>% length() + x %>% length())) %>% percent(force_zero = TRUE, round = digits) %>% + 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, 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, '\nLongest: ', x %>% base::nchar() %>% base::max(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) %>% 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 %>% paste0(markdown_line, '\nStd. dev.: ', x %>% stats::sd(na.rm = TRUE) %>% format(digits = digits), - ' (CV: ', x %>% cv(na.rm = TRUE) %>% format(digits = digits), - ', MAD: ', x %>% stats::mad(na.rm = TRUE) %>% format(digits = digits), ')') - header_txt <- header_txt %>% paste0(markdown_line, '\nFive-Num: ', Tukey_five %>% format(digits = digits) %>% trimws() %>% paste(collapse = ' | '), - ' (IQR: ', (Tukey_five[4] - Tukey_five[2]) %>% format(digits = digits), - ', CQV: ', x %>% cqv(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, decimal.mark = decimal.mark, big.mark = big.mark), + ' (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, decimal.mark = decimal.mark, big.mark = big.mark), ')') + 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, decimal.mark = decimal.mark, big.mark = big.mark), + ', 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), - paste0('(ratio S : IR = 1.0 : ', (cnt_IR / cnt_S) %>% format(digits = 1, nsmall = 1), ")")) + (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, 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"] } diff --git a/R/misc.R b/R/misc.R index 065b3b45..9fea4386 100755 --- a/R/misc.R +++ b/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 } diff --git a/appveyor.yml b/appveyor.yml index 94e5f795..25b40a89 100644 --- a/appveyor.yml +++ b/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 + R_ARCH: x64 + GCC_PATH: mingw_64 + WARNINGS_ARE_ERRORS: 1 + PKGTYPE: win.binary + # USE_RTOOLS: true matrix: - R_VERSION: release diff --git a/man/freq.Rd b/man/freq.Rd index ec293872..cd478b27 100755 --- a/man/freq.Rd +++ b/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 = "", sep = " ") + header = !markdown, title = NULL, 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 = "", sep = " ") + 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.} diff --git a/tests/testthat/test-freq.R b/tests/testthat/test-freq.R index fa59b4e4..8d7e52a3 100755 --- a/tests/testthat/test-freq.R +++ b/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