mirror of
https://github.com/msberends/AMR.git
synced 2025-07-09 19:41:49 +02:00
removed clipboard functions as it violated CRAN policies
This commit is contained in:
165
R/clipboard.R
165
R/clipboard.R
@ -1,165 +0,0 @@
|
||||
#' Import/export from clipboard
|
||||
#'
|
||||
#' @description These are helper functions around \code{\link{read.table}} and \code{\link{write.table}} to import from and export to clipboard with support for Windows, Linux and macOS.
|
||||
#'
|
||||
#' The data will be read and written as tab-separated by default, which makes it possible to copy and paste from other software like Excel and SPSS without further transformation.
|
||||
#'
|
||||
#' This also supports automatic column type transformation, with AMR classes \code{\link{as.rsi}} and \code{\link{as.mic}}.
|
||||
#' @rdname clipboard
|
||||
#' @name clipboard
|
||||
#' @inheritParams base::data.frame
|
||||
#' @inheritParams utils::read.table
|
||||
#' @inheritParams utils::write.table
|
||||
#' @inheritParams readr::locale
|
||||
#' @param startrow \emph{n}th row to start importing from. When \code{header = TRUE}, the import will start on row \code{startrow} \emph{below} the header.
|
||||
#' @param as_vector a logical value indicating whether data consisting of only one column should be imported as vector using \code{\link[dplyr]{pull}}. This will strip off the header.
|
||||
#' @param guess_col_types a logical value indicating whether column types should be guessed and transformed automatically with \code{\link[readr]{parse_guess}} from the \code{readr} package. Besides, the antimicrobial classes in this AMR package (\code{\link{as.rsi}} and \code{\link{as.mic}}) are also supported.
|
||||
#' @param remove_ASCII_escape_char remove ASCII escape character
|
||||
#' @param info print info to console
|
||||
#' @keywords clipboard clipboard_import clipboard_export import export
|
||||
#' @importFrom dplyr %>% pull as_tibble
|
||||
#' @importFrom clipr read_clip_tbl write_clip
|
||||
#' @importFrom utils read.delim write.table object.size
|
||||
#' @importFrom readr parse_guess locale
|
||||
#' @details
|
||||
#' The parameter \code{stringsAsFactors} defaults to \code{FALSE}, as opposed to most base \R methods.
|
||||
#'
|
||||
#' The parameters \code{date_format} and \code{time_format} also support generic date and time formats like \code{"dd-mm-yyyy"} like Excel.
|
||||
#'
|
||||
#' \if{html}{
|
||||
#' \strong{Example for copying from Excel:}
|
||||
#' \out{<div style="text-align: left">}\figure{clipboard_copy.png}\out{</div>}
|
||||
#' \cr
|
||||
#' \strong{And pasting in R:} \cr
|
||||
#' \cr
|
||||
#' \code{> data <- clipboard_import()} \cr
|
||||
#' \code{> data} \cr
|
||||
#' \out{<div style="text-align: left">}\figure{clipboard_paste.png}\out{</div>}
|
||||
#' \cr
|
||||
#' \strong{The resulting data contains the right RSI-classes:} \cr
|
||||
#' \cr
|
||||
#' \code{> data$amox} \cr
|
||||
#' \out{<div style="text-align: left">}\figure{clipboard_rsi.png}\out{</div>}
|
||||
#' }
|
||||
#' @export
|
||||
#' @examples
|
||||
#' \dontrun{
|
||||
#'
|
||||
#' df1 <- data.frame(a = letters[1:12],
|
||||
#' b = runif(n = 12, min = 1000, max = 2000),
|
||||
#' stringsAsFactors = FALSE)
|
||||
#' clipboard_export(df1)
|
||||
#' df2 <- clipboard_import()
|
||||
#' identical(df1, df2)
|
||||
#'
|
||||
#' # send frequency table to clipboard (e.g. for pasting in Excel)
|
||||
#' septic_patients %>%
|
||||
#' freq(age) %>%
|
||||
#' format() %>% # this will format the percentages
|
||||
#' clipboard_export()
|
||||
#' }
|
||||
clipboard_import <- function(sep = '\t',
|
||||
quote = "",
|
||||
header = TRUE,
|
||||
dec = ".",
|
||||
na = c("", "NA", "NULL"),
|
||||
stringsAsFactors = FALSE,
|
||||
startrow = 1,
|
||||
as_vector = TRUE,
|
||||
guess_col_types = TRUE,
|
||||
date_names = 'en',
|
||||
date_format = '%Y-%m-%d',
|
||||
time_format = '%H:%M',
|
||||
remove_ASCII_escape_char = FALSE,
|
||||
tz = "UTC",
|
||||
encoding = "UTF-8",
|
||||
info = TRUE) {
|
||||
|
||||
if (!clipr::clipr_available() & Sys.info()['sysname'] == "Linux") {
|
||||
# try to support on X11, by setting the R variable DISPLAY
|
||||
Sys.setenv(DISPLAY = "localhost:10.0")
|
||||
}
|
||||
|
||||
# this will fail when clipr is (still) not available
|
||||
import_tbl <- clipr::read_clip_tbl(file = file,
|
||||
sep = sep,
|
||||
quote = quote,
|
||||
header = header,
|
||||
strip.white = TRUE,
|
||||
dec = dec,
|
||||
na.strings = na,
|
||||
encoding = 'UTF-8',
|
||||
stringsAsFactors = stringsAsFactors)
|
||||
|
||||
# use tibble, so column types will be translated correctly
|
||||
import_tbl <- as_tibble(import_tbl)
|
||||
|
||||
if (startrow > 1) {
|
||||
# would else lose column headers
|
||||
import_tbl <- import_tbl[startrow:NROW(import_tbl),]
|
||||
}
|
||||
|
||||
colnames(import_tbl) <- gsub('[.]+', '_', colnames(import_tbl))
|
||||
|
||||
if (guess_col_types == TRUE) {
|
||||
if (info == TRUE) {
|
||||
cat('Transforming data by guessing column types...')
|
||||
}
|
||||
import_tbl <- tbl_parse_guess(tbl = import_tbl,
|
||||
date_names = date_names,
|
||||
date_format = date_format,
|
||||
time_format = time_format,
|
||||
decimal_mark = dec,
|
||||
tz = tz,
|
||||
encoding = encoding,
|
||||
remove_ASCII_escape_char = remove_ASCII_escape_char,
|
||||
na = na)
|
||||
if (info == TRUE) {
|
||||
cat('OK\n')
|
||||
}
|
||||
}
|
||||
|
||||
if (NCOL(import_tbl) == 1 & as_vector == TRUE) {
|
||||
import_tbl <- import_tbl %>% pull(1)
|
||||
}
|
||||
|
||||
# and transform back to data.frame
|
||||
import_tbl <- as.data.frame(import_tbl, stringsAsFactors = stringsAsFactors)
|
||||
|
||||
if (info == TRUE) {
|
||||
cat("Successfully imported from clipboard:", NROW(import_tbl), "obs. of", NCOL(import_tbl), "variables.\n")
|
||||
}
|
||||
|
||||
import_tbl
|
||||
|
||||
}
|
||||
|
||||
#' @rdname clipboard
|
||||
#' @importFrom dplyr %>% pull as_tibble
|
||||
#' @export
|
||||
clipboard_export <- function(x,
|
||||
sep = '\t',
|
||||
dec = ".",
|
||||
na = "",
|
||||
header = TRUE,
|
||||
info = TRUE) {
|
||||
|
||||
if (!clipr::clipr_available() & Sys.info()['sysname'] == "Linux") {
|
||||
# try to support on X11, by setting the R variable DISPLAY
|
||||
Sys.setenv(DISPLAY = "localhost:10.0")
|
||||
}
|
||||
|
||||
clipr::write_clip(content = x,
|
||||
na = na,
|
||||
sep = sep,
|
||||
row.names = FALSE,
|
||||
col.names = header,
|
||||
dec = dec,
|
||||
quote = FALSE)
|
||||
|
||||
if (info == TRUE) {
|
||||
cat("Successfully exported to clipboard:", NROW(x), "obs. of", NCOL(x), "variables.\n")
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
96
R/misc.R
96
R/misc.R
@ -110,99 +110,3 @@ size_humanreadable <- function(bytes, decimals = 1) {
|
||||
out <- paste(sprintf(paste0("%.", decimals, "f"), bytes / (1024 ^ factor)), size[factor + 1])
|
||||
out
|
||||
}
|
||||
|
||||
# based on readr::parse_guess
|
||||
tbl_parse_guess <- function(tbl,
|
||||
date_names = 'en',
|
||||
date_format = '%Y-%m-%d',
|
||||
time_format = '%H:%M',
|
||||
decimal_mark = '.',
|
||||
tz = "UTC",
|
||||
encoding = "UTF-8",
|
||||
remove_ASCII_escape_char = FALSE,
|
||||
na = c("", "NA", "NULL")) {
|
||||
|
||||
date_format <- date_generic(date_format)
|
||||
time_format <- date_generic(time_format)
|
||||
# set col types with readr
|
||||
for (i in 1:ncol(tbl)) {
|
||||
if (!all(tbl %>% pull(i) %>% class() %in% c('list', 'matrix'))) {
|
||||
tbl[, i] <- readr::parse_guess(x = tbl %>% pull(i) %>% as.character(),
|
||||
na = na,
|
||||
locale = readr::locale(date_names = date_names,
|
||||
date_format = date_format,
|
||||
time_format = time_format,
|
||||
decimal_mark = decimal_mark,
|
||||
encoding = encoding,
|
||||
tz = tz,
|
||||
asciify = FALSE))
|
||||
}
|
||||
if (any(tbl %>% pull(i) %>% class() %in% c('factor', 'character'))) {
|
||||
if (remove_ASCII_escape_char == TRUE) {
|
||||
# remove ASCII escape character: https://en.wikipedia.org/wiki/Escape_character#ASCII_escape_character
|
||||
tbl[, i] <- tbl %>% pull(i) %>% gsub('\033', ' ', ., fixed = TRUE)
|
||||
}
|
||||
if (tbl %>% pull(i) %>% is.rsi.eligible()) {
|
||||
# look for RSI
|
||||
tbl[, i] <- as.rsi(tbl[, i])
|
||||
}
|
||||
}
|
||||
# convert to MIC class when ends on `_mic`
|
||||
if (colnames(tbl)[i] %like% '_mic$') {
|
||||
tbl[, i] <- as.mic(tbl[, i])
|
||||
}
|
||||
}
|
||||
tbl
|
||||
}
|
||||
|
||||
# transforms date format like "dddd d mmmm yyyy" to "%A %e %B %Y"
|
||||
date_generic <- function(format) {
|
||||
if (!grepl('%', format, fixed = TRUE)) {
|
||||
|
||||
# first months and minutes, after that everything is case INsensitive
|
||||
format <- gsub('mmmm', '%B1', format, fixed = TRUE)
|
||||
format <- gsub('mmm', '%b', format, fixed = TRUE)
|
||||
format <- gsub('mm', '%m', format, fixed = TRUE)
|
||||
format <- gsub('MM', '%M1', format, fixed = TRUE)
|
||||
format <- format %>%
|
||||
tolower() %>%
|
||||
gsub('%b1', '%B', ., fixed = TRUE) %>%
|
||||
gsub('%m1', '%M', ., fixed = TRUE)
|
||||
|
||||
# dates
|
||||
format <- gsub('dddd', '%A', format, fixed = TRUE)
|
||||
format <- gsub('ddd', '%a', format, fixed = TRUE)
|
||||
format <- gsub('dd', '%!', format, fixed = TRUE)
|
||||
format <- gsub('d', '%e', format, fixed = TRUE)
|
||||
format <- gsub('%!', '%d', format, fixed = TRUE)
|
||||
|
||||
format <- gsub('ww', '%V', format, fixed = TRUE)
|
||||
format <- gsub('w', '%V', format, fixed = TRUE)
|
||||
|
||||
format <- gsub('qq', 'Qq', format, fixed = TRUE) # so will be 'Q%%q' after this
|
||||
format <- gsub('kk', 'Kq', format, fixed = TRUE)
|
||||
format <- gsub('k', 'q', format, fixed = TRUE)
|
||||
format <- gsub('q', '%%q', format, fixed = TRUE)
|
||||
|
||||
format <- gsub('yyyy_iso', '%G', format, fixed = TRUE)
|
||||
format <- gsub('jjjj_iso', '%G', format, fixed = TRUE)
|
||||
format <- gsub('yyyy', '%Y', format, fixed = TRUE)
|
||||
format <- gsub('jjjj', '%Y', format, fixed = TRUE)
|
||||
format <- gsub('yy_iso', '%g', format, fixed = TRUE)
|
||||
format <- gsub('jj_iso', '%g', format, fixed = TRUE)
|
||||
format <- gsub('yy', '%y', format, fixed = TRUE)
|
||||
format <- gsub('jj', '%y', format, fixed = TRUE)
|
||||
|
||||
# time
|
||||
format <- gsub('hh', '%H', format, fixed = TRUE)
|
||||
format <- gsub('h', '%k', format, fixed = TRUE)
|
||||
format <- gsub('ss', '%S', format, fixed = TRUE)
|
||||
|
||||
# seconds since the Epoch, 1970-01-01 00:00:00
|
||||
format <- gsub('unix', '%s', format, fixed = TRUE)
|
||||
# Equivalent to %Y-%m-%d (the ISO 8601 date format)
|
||||
format <- gsub('iso', '%F', format, fixed = TRUE)
|
||||
|
||||
}
|
||||
format
|
||||
}
|
||||
|
||||
Reference in New Issue
Block a user