R/print.R

In msberends/certedata: Tools for Data Analysis at Certe

# ==================================================================== #
# TITLE                                                                #
# Tools for Data Analysis at Certe                                     #
#                                                                      #
# AUTHORS                                                              #
# Berends MS (m.berends@certe.nl)                                      #
# Meijer BC (b.meijer@certe.nl)                                        #
# Hassing EEA (e.hassing@certe.nl)                                     #
#                                                                      #
# COPYRIGHT                                                            #
# (c) 2019 Certe Medische diagnostiek & advies - https://www.certe.nl  #
#                                                                      #
# LICENCE                                                              #
# This R package 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 R package 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.                         #
# ==================================================================== #

prettyprint_df <- function(x, 
                           n = 10,
                           print.keys = FALSE,
                           ...) {
  
  # data.table where keys should be printed
  if (print.keys == TRUE) {
    printDT(x,
            print.keys = TRUE,
            ...
    )
    return(invisible())
  }

  # save old values
  pillar.subtle_num <- getOption("pillar.subtle_num")
  pillar.neg <- getOption("pillar.neg")
  pillar.bold <- getOption("pillar.bold")
  # apply new values
  options(pillar.subtle_num = FALSE)
  options(pillar.neg = FALSE)
  options(pillar.bold = TRUE)
  
  tryCatch(print(tibble::trunc_mat(x, n = n, ...)),
           error = function(e) print(x))
  
  # reset values to old values
  options(pillar.subtle_num = pillar.subtle_num)
  options(pillar.neg = pillar.neg)
  options(pillar.bold = pillar.bold)
  
}

printDT <- data.table:::print.data.table
#' @noRd
#' @exportMethod print.data.table
#' @export
print.data.table <- function(x,
                             print.keys = FALSE,
                             ...) {
  prettyprint_df(x = x,
                 print.keys = print.keys,
                 ...)
}

#' @noRd
#' @exportMethod print.data.frame
#' @export print.data.frame
#' @export
print.data.frame <- function(x, n = 10, row.names = NULL, ...) {
  prettyprint_df(x = x, n = n, ...)
}

#' @noRd
#' @exportMethod print.sf
#' @export
print.sf <- function(x, n = 10, ...) {
  prettyprint_df(x = x, n = n, ...)
}

#' @importFrom tibble tbl_sum
#' @exportMethod tbl_sum.data.frame
#' @export 
tbl_sum.data.frame <- function (x) {
  if (identical(colnames(x), c("expr", "min", "lq", "mean", "median", "uq", "max", "neval"))) {
    # is microbenchmark
    NULL
  } else {
    classes <- paste("A", paste(rev(class(x)), collapse = "/"))
    dims <- dplyr::dim_desc(x)
    dims <- gsub("[", "", dims, fixed = TRUE)
    dims <- gsub("]", "", dims, fixed = TRUE)
    names(dims) <- classes
    dims
  }
}

tibble_col_format2_r <- function(x, ...) {
  out <- trimws(format2(x))
  out[is.na(x)] <- pillar::style_na(NA)
  pillar::new_pillar_shaft_simple(out, align = "right")
}
tibble_col_format2_l <- function(x, ...) {
  out <- trimws(x)
  out[is.na(x)] <- pillar::style_na(NA)
  if (all(x %like% "^00[0-9]{8}$", na.rm = TRUE)) {
    # MOLIS-nummers
    out <- paste0("00",
                  crayon::make_style("grey")("-"),
                  substr(out, 3, 6),
                  crayon::make_style("grey")("-"),
                  substr(out, 7, 10))
  }
  pillar::new_pillar_shaft_simple(out, align = "left")
}

#' @importFrom pillar pillar_shaft
#' @export 
pillar_shaft.numeric <- tibble_col_format2_r

#' @importFrom pillar pillar_shaft
#' @export 
pillar_shaft.integer <- tibble_col_format2_r

#' @importFrom pillar pillar_shaft
#' @export 
pillar_shaft.percent <- tibble_col_format2_r

#' @importFrom pillar pillar_shaft
#' @export 
pillar_shaft.character <- tibble_col_format2_l

#' @importFrom pillar pillar_shaft
#' @export 
pillar_shaft.logical <- function(x, ...) {
  out <- rep(NA, length(x))
  out[x] <- crayon::green("TRUE")
  out[!x] <- crayon::red("FALSE")
  out[is.na(x)] <- pillar::style_subtle("NA")
  pillar::new_pillar_shaft_simple(out, width = 5, align = "left")
}