P281424
/
AMR
mirror of https://github.com/msberends/AMR.git
1
0
Fork 0
Code Releases Activity

remove print function, out of scope

This commit is contained in:
dr. M.S. (Matthijs) Berends 2018-07-11 20:12:19 +02:00
parent e3e10c2e88
commit a28289562a
6 changed files with 1 additions and 432 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
DESCRIPTION
View File

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

10
NAMESPACE
View File

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

2
NEWS.md
View File

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

352
R/print.R
View File

@ -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 = "<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 = "<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')
}
}

57
man/print.Rd
View File

@ -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 = "<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)
}

11
tests/testthat/test-print.R
View File

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