diff --git a/DESCRIPTION b/DESCRIPTION index 6a3c0aba..e665f88a 100755 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -32,7 +32,6 @@ Imports: clipr, curl, dplyr (>= 0.7.0), - data.table (>= 1.10.0), reshape2 (>= 1.4.0), xml2 (>= 1.0.0), knitr (>= 1.0.0), diff --git a/NAMESPACE b/NAMESPACE index 271e6f96..af4a241a 100755 --- a/NAMESPACE +++ b/NAMESPACE @@ -15,12 +15,9 @@ S3method(kurtosis,matrix) S3method(plot,frequency_tbl) S3method(plot,mic) S3method(plot,rsi) -S3method(print,data.table) S3method(print,frequency_tbl) S3method(print,mic) S3method(print,rsi) -S3method(print,tbl) -S3method(print,tbl_df) S3method(skewness,data.frame) S3method(skewness,default) S3method(skewness,matrix) @@ -83,12 +80,9 @@ exportMethods(kurtosis.matrix) exportMethods(plot.frequency_tbl) exportMethods(plot.mic) exportMethods(plot.rsi) -exportMethods(print.data.table) exportMethods(print.frequency_tbl) exportMethods(print.mic) exportMethods(print.rsi) -exportMethods(print.tbl) -exportMethods(print.tbl_df) exportMethods(skewness) exportMethods(skewness.data.frame) exportMethods(skewness.default) @@ -99,7 +93,6 @@ importFrom(broom,tidy) importFrom(clipr,read_clip_tbl) importFrom(clipr,write_clip) importFrom(curl,nslookup) -importFrom(data.table,data.table) importFrom(dplyr,"%>%") importFrom(dplyr,all_vars) importFrom(dplyr,any_vars) @@ -112,14 +105,11 @@ importFrom(dplyr,filter) importFrom(dplyr,filter_at) importFrom(dplyr,group_by) importFrom(dplyr,group_by_at) -importFrom(dplyr,group_size) -importFrom(dplyr,group_vars) importFrom(dplyr,if_else) importFrom(dplyr,lag) importFrom(dplyr,left_join) importFrom(dplyr,mutate) importFrom(dplyr,n_distinct) -importFrom(dplyr,n_groups) importFrom(dplyr,progress_estimated) importFrom(dplyr,pull) importFrom(dplyr,row_number) diff --git a/NEWS.md b/NEWS.md index 3e900a5c..65c72b55 100755 --- a/NEWS.md +++ b/NEWS.md @@ -21,6 +21,7 @@ ratio(c(772, 1611, 737), ratio = "1:2:1") * Functions `clipboard_import` and `clipboard_export` as helper functions to quickly copy and paste from/to software like Excel and SPSS #### Changed +* Pretty printing for tibbles removed as it is not really the scope of this package * `%like%` now supports multiple patterns * Frequency tables are now actual `data.frame`s with altered console printing to make it look like a frequency table. Because of this, the parameter `toConsole` is not longer needed. * Small translational improvements to the `septic_patients` dataset @@ -34,7 +35,6 @@ ratio(c(772, 1611, 737), ratio = "1:2:1") * Improved `first_isolate` algorithm to exclude isolates where bacteria ID or genus is unavailable * Fix for warning *hybrid evaluation forced for row_number* ([`924b62`](https://github.com/tidyverse/dplyr/commit/924b62)) from the `dplyr` package v0.7.5 and above * Support for 1 or 2 columns as input for `guess_bactid` -* Fix for printing tibbles where characters would be accidentally transformed to factors #### Other * Unit testing for R 3.0 and the latest available release: https://travis-ci.org/msberends/AMR diff --git a/R/print.R b/R/print.R deleted file mode 100755 index 153c214b..00000000 --- a/R/print.R +++ /dev/null @@ -1,352 +0,0 @@ -# ==================================================================== # -# TITLE # -# Antimicrobial Resistance (AMR) Analysis # -# # -# AUTHORS # -# Berends MS (m.s.berends@umcg.nl), Luz CF (c.f.luz@umcg.nl) # -# # -# LICENCE # -# This program is free software; you can redistribute it and/or modify # -# it under the terms of the GNU General Public License version 2.0, # -# as published by the Free Software Foundation. # -# # -# This program is distributed in the hope that it will be useful, # -# but WITHOUT ANY WARRANTY; without even the implied warranty of # -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # -# GNU General Public License for more details. # -# ==================================================================== # - -#' Printing Data Tables and Tibbles -#' -#' 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. -#' @inheritParams base::print.data.frame -#' @param nmax amount of rows to print in total. When the total amount of rows exceeds this limit, the first and last \code{nmax / 2} rows will be printed. Use \code{nmax = NA} to print all rows. -#' @param header print header with information about data size and tibble grouping -#' @param print.keys print keys for \code{data.table} -#' @param na value to print instead of NA -#' @param width amount of white spaces to keep between columns, must be at least 1 -#' @rdname print -#' @name print -#' @importFrom dplyr %>% n_groups group_vars group_size filter pull select -#' @importFrom data.table data.table -#' @importFrom utils object.size -#' @exportMethod print.tbl_df -#' @export -#' @examples -#' # more reliable data view: -#' library(dplyr) -#' starwars -#' print(starwars, width = 3) -#' -#' # 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() -#' -#' # 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, - header = TRUE, - row.names = TRUE, - right = FALSE, - width = 1, - na = "", - ...) { - prettyprint_df(x = x, - nmax = nmax, - header = header, - row.names = row.names, - print.keys = FALSE, - right = right, - width = width, - na = na, - ...) -} - -#' @rdname print -#' @exportMethod print.tbl -#' @export -print.tbl <- function(x, ...) { - prettyprint_df(x, ...) -} - -#' @rdname print -#' @exportMethod print.data.table -#' @export -print.data.table <- function(x, - print.keys = FALSE, - ...) { - prettyprint_df(x = x, - print.keys = print.keys, - ...) -} - -printDT <- data.table:::print.data.table -prettyprint_df <- function(x, - nmax = 10, - header = TRUE, - row.names = TRUE, - print.keys = FALSE, - right = FALSE, - width = 1, - na = "", - ...) { - - ansi_reset <- "\u001B[0m" - ansi_black <- "\u001B[30m" - ansi_red <- "\u001B[31m" - ansi_green <- "\u001B[32m" - ansi_yellow <- "\u001B[33m" - ansi_blue <- "\u001B[34m" - ansi_purple <- "\u001B[35m" - ansi_cyan <- "\u001B[36m" - ansi_white <- "\u001B[37m" - ansi_gray <- "\u001B[38;5;246m" - - if (width < 1) { - stop('`width` must be at least 1.', call. = FALSE) - } - - if (is.na(nmax)) { - nmax <- NROW(x) - } - n <- nmax - if (n %% 2 == 1) { - # odd number; add 1 - n <- n + 1 - } - - width <- width - 1 - - if ('tbl_df' %in% class(x)) { - type <- 'tibble' - } else if ('data.table' %in% class(x)) { - type <- 'data.table' - } else { - type <- 'data.frame' - } - - if (header == TRUE) { - if (NCOL(x) == 1) { - vars <- 'variable' - } else { - vars <- 'variables' - } - - size <- object.size(x) %>% as.double() %>% size_humanreadable() - - cat(paste0("A ", type,": ", - format(NROW(x)), - " obs. of ", - format(NCOL(x)), - " ", vars, - ansi_gray, " (", size, ")\n", ansi_reset)) - if ('grouped_df' %in% class(x) & n_groups(x) > 0) { - cat(paste0("Grouped by ", - x %>% group_vars() %>% paste0(ansi_red, ., ansi_reset) %>% paste0(collapse = " and "), - ansi_gray, - " (", - x %>% n_groups(), - " groups with sizes between ", - x %>% group_size() %>% min(), - " and ", - x %>% group_size() %>% max(), - ")\n", - ansi_reset)) - } - if (!is.null(attributes(x)$qry)) { - cat(paste0(ansi_gray, "This data contains a query. Use qry() to view it.\n", ansi_reset)) - } - cat("\n") - } - - # data.table where keys should be printed - if (print.keys == TRUE) { - printDT(x, - class = header, - row.names = row.names, - print.keys = TRUE, - right = right, - ... - ) - return(invisible()) - } - - # tibbles give warning when setting column names - x <- x %>% base::as.data.frame(stringsAsFactors = FALSE) - - # 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), strrep(" ", maxrowchars - nchar(rownames(x)))) - } else { - maxrowchars <- 0 - } - - x.bak <- x - - if (n + 1 < nrow(x)) { - # remove in between part, 1 extra for ~~~~ between first and last part - rows_list <- c(1:(n / 2 + 1), (nrow(x) - (n / 2) + 1):nrow(x)) - x <- as.data.frame(x.bak[rows_list,], stringsAsFactors = FALSE) - colnames(x) <- colnames(x.bak) - rownames(x) <- rownames(x.bak)[rows_list] - # set inbetweener between parts - rownames(x)[n / 2 + 1] <- strrep("~", maxrowchars) - } - - if (header == TRUE) { - # add 1 row for classes - # class will be marked up per column - if (NROW(x.bak) > 0) { - rownames.x <- rownames(x) - # suppress warnings because dplyr want us to use library(dplyr) when using filter(row_number()) - suppressWarnings( - x <- x %>% - filter(row_number() == 1) %>% - rbind(x, stringsAsFactors = FALSE) - ) - rownames(x) <- c('*', rownames.x) - } - - # select 1st class per column and abbreviate - classes <- x.bak %>% - sapply(class) %>% - lapply( - function(c) { - # do print all POSIX classes like "POSct/t" - if ('POSIXct' %in% c) { - paste0('POS', - c %>% - gsub('POSIX', '', .) %>% - paste0(collapse = '/')) - } else { - if (NCOL(.) > 1) { - .[1, ] - } else { - c[[1]] - } - } - }) %>% - unlist() %>% - gsub("character", "chr", ., fixed = TRUE) %>% - gsub("complex", "cplx", ., fixed = TRUE) %>% - gsub("Date", "Date", ., fixed = TRUE) %>% - gsub("double", "dbl", ., fixed = TRUE) %>% - gsub("expression", "expr", ., fixed = TRUE) %>% - gsub("factor", "fct", ., fixed = TRUE) %>% - gsub("IDate", "IDat", ., fixed = TRUE) %>% - gsub("integer", "int", ., fixed = TRUE) %>% - gsub("integer64", "i64", ., fixed = TRUE) %>% - gsub("list", "list", ., fixed = TRUE) %>% - gsub("logical", "lgl", ., fixed = TRUE) %>% - gsub("numeric", "dbl", ., fixed = TRUE) %>% - gsub("ordered", "ord", ., fixed = TRUE) %>% - gsub("percent", "pct", ., fixed = TRUE) %>% - gsub("single", "sgl", ., fixed = TRUE) %>% - paste0("<", ., ">") - } - - # markup cols - - for (i in 1:ncol(x)) { - if (all(!class(x[, i]) %in% class(x.bak[, i]))) { - class(x[, i]) <- class(x.bak[, i]) - } - try(x[, i] <- format(x %>% pull(i)), silent = TRUE) - # replace NAs - if (nchar(na) < 2) { - # make as long as the text "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 - if (header == TRUE) { - x[1, i] <- classes[i] - } - # 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] <- strrep("~", maxvalchars) - } - - # 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, strrep(" ", maxvalchars - nchar(vals))) - colname <- paste0(colname, strrep(" ", maxvalchars - nchar(colname))) - } else { - vals <- paste0(strrep(" ", maxvalchars - nchar(vals)), vals) - colname <- paste0(strrep(" ", maxvalchars - nchar(colname)), colname) - } - x[, i] <- vals - colnames(x)[i] <- colname - } - - # 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(strrep(" ", width), x[, i]) - colnames(x)[i] <- paste0(strrep(" ", width), colnames(x)[i]) - } - - # strip columns that do not fit (width + 2 extra chars as margin) - width_console <- options()$width - width_until_col <- x %>% - select(1:i) %>% - apply(1, paste, collapse = strrep(" ", width + 2)) %>% - nchar() %>% - max() - width_until_col_before <- x %>% - select(1:(max(i, 2) - 1)) %>% - apply(1, paste, collapse = strrep(" ", width + 2)) %>% - nchar() %>% - max() - extraspace <- maxrowchars + nchar(rownames(x)[length(rownames(x))]) - 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 - | width_until_colnames > width_console)) { - if (width_until_col_before > width_console - | width_until_colnames_before > width_console) { - x <- x[, 1:(i - 2)] - } else { - x <- x[, 1:(i - 1)] - } - break - } - } - - # empty table, row name of header should be "*" - if (NROW(x.bak) == 0) { - rownames(x) <- '* ' - } - - # and here it is... - suppressWarnings( - base::print.data.frame(x, row.names = row.names, ...) - ) - - # print rest of col names when they were stripped - if (ncol(x) < ncol(x.bak)) { - x.notshown <- x.bak %>% select((ncol(x) + 1):ncol(x.bak)) - if (ncol(x.notshown) == 1) { - cat('... and 1 more column: ') - } else { - cat('... and', ncol(x.notshown), 'more columns: ') - } - cat(x.notshown %>% - colnames() %>% - paste0(' ', ansi_gray, classes[(ncol(x) + 1):ncol(x.bak)], ansi_reset) %>% - paste0(collapse = ", "), '\n') - } -} diff --git a/man/print.Rd b/man/print.Rd deleted file mode 100755 index 13b993e2..00000000 --- a/man/print.Rd +++ /dev/null @@ -1,57 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/print.R -\name{print} -\alias{print} -\alias{print.tbl_df} -\alias{print.tbl} -\alias{print.data.table} -\title{Printing Data Tables and Tibbles} -\usage{ -\method{print}{tbl_df}(x, nmax = 10, header = TRUE, row.names = TRUE, - right = FALSE, width = 1, na = "", ...) - -\method{print}{tbl}(x, ...) - -\method{print}{data.table}(x, print.keys = FALSE, ...) -} -\arguments{ -\item{x}{object of class \code{data.frame}.} - -\item{nmax}{amount of rows to print in total. When the total amount of rows exceeds this limit, the first and last \code{nmax / 2} rows will be printed. Use \code{nmax = NA} to print all rows.} - -\item{header}{print header with information about data size and tibble grouping} - -\item{row.names}{logical (or character vector), indicating whether (or - what) row names should be printed.} - -\item{right}{logical, indicating whether or not strings should be - right-aligned. The default is right-alignment.} - -\item{width}{amount of white spaces to keep between columns, must be at least 1} - -\item{na}{value to print instead of NA} - -\item{...}{optional arguments to \code{print} or \code{plot} methods.} - -\item{print.keys}{print keys for \code{data.table}} -} -\description{ -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{ -# more reliable data view: -library(dplyr) -starwars -print(starwars, width = 3) - -# 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() - -# 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-print.R b/tests/testthat/test-print.R deleted file mode 100755 index ca3e0ad8..00000000 --- a/tests/testthat/test-print.R +++ /dev/null @@ -1,11 +0,0 @@ -context("print.R") - - -test_that("tibble printing works", { - library(dplyr) - library(data.table) - expect_output(print(starwars)) - expect_output(print(starwars %>% group_by(homeworld, gender))) - expect_output(print(starwars %>% as.data.table(), print.keys = TRUE)) - expect_output(print(septic_patients)) -})