Nothing
#' @importFrom data.table fwrite
#' @importFrom utils write.table
export_delim <- function(file, x, fwrite = TRUE, sep = "\t", row.names = FALSE,
col.names = TRUE, append = FALSE, ...) {
if (isTRUE(fwrite) & !inherits(file, "connection")) {
if (isTRUE(append)) {
data.table::fwrite(x, file = file, sep = sep, row.names = row.names,
col.names = FALSE, append = TRUE, ...)
} else {
data.table::fwrite(x, file = file, sep = sep, row.names = row.names,
col.names = col.names, append = FALSE, ...)
}
} else {
if (isTRUE(fwrite) & inherits(file, "connection")) {
message("data.table::fwrite() does not support writing to connections. Using utils::write.table() instead.")
}
if (isTRUE(append)) {
write.table(x, file = file, sep = sep, row.names = row.names,
col.names = FALSE, append = TRUE, ...)
} else {
write.table(x, file = file, sep = sep, row.names = row.names,
col.names = col.names, append = FALSE, ...)
}
}
}
#' @export
.export.rio_txt <- function(file, x, ...) {
export_delim(x = x, file = file, ...)
}
#' @export
.export.rio_tsv <- function(file, x, ...) {
export_delim(x = x, file = file, ...)
}
#' @export
.export.rio_csv <- function(file, x, sep = ",", dec = ".", ...) {
export_delim(x = x, file = file, sep = sep, dec = dec, ...)
}
#' @export
.export.rio_csv2 <- function(file, x, sep = ";", dec = ",", ...) {
export_delim(x = x, file = file, sep = sep, dec = dec, ...)
}
#' @export
.export.rio_csvy <- function(file, x, sep = ",", dec = ".", yaml = TRUE, ...) {
export_delim(x = x, file = file, sep = sep, dec = dec, yaml = TRUE, ...)
}
#' @export
.export.rio_psv <- function(file, x, ...) {
export_delim(x = x, file = file, sep = "|", ...)
}
#' @importFrom utils capture.output write.csv
#' @export
.export.rio_fwf <- function(file, x, verbose = getOption("verbose", FALSE), sep = "", row.names = FALSE, quote = FALSE, col.names = FALSE, digits = getOption("digits", 7), ...) {
dat <- lapply(x, function(col) {
if (is.character(col)) {
col <- as.numeric(as.factor(col))
} else if(is.factor(col)) {
col <- as.integer(col)
}
if (is.integer(col)) {
return(sprintf("%i",col))
}
if (is.numeric(col)) {
decimals <- strsplit(as.character(col), ".", fixed = TRUE)
m1 <- max(nchar(unlist(lapply(decimals, `[`, 1))), na.rm = TRUE)
decimals_2 <- unlist(lapply(decimals, `[`, 2))
decimals_2_nchar <- nchar(decimals_2[!is.na(decimals_2)])
if (length(decimals_2_nchar)) {
m2 <- max(decimals_2_nchar, na.rm = TRUE)
} else {
m2 <- 0
}
if (!is.finite(m2)) {
m2 <- digits
}
return(formatC(sprintf(fmt = paste0("%0.",m2,"f"), col), width = (m1+m2+1)))
} else if(is.logical(col)) {
return(sprintf("%i",col))
}
})
dat <- do.call(cbind, dat)
n <- nchar(dat[1,]) + c(rep(nchar(sep), ncol(dat)-1), 0)
col_classes <- sapply(x, class)
col_classes[col_classes == "factor"] <- "integer"
dict <- cbind.data.frame(variable = names(n),
class = col_classes,
width = unname(n),
columns = paste0(c(1, cumsum(n)+1)[-length(n)], "-", cumsum(n)),
stringsAsFactors = FALSE)
if (isTRUE(verbose)) {
message("Columns:")
message(paste0(capture.output(dict), collapse = "\n"))
if (sep == "") {
message(paste0('\nRead in with:\n',
'import("', file, '",\n',
' widths = c(', paste0(n, collapse = ","), '),\n',
' col.names = c("', paste0(names(n), collapse = '","'), '"),\n',
' colClasses = c("', paste0(col_classes, collapse = '","') ,'"))\n'), domain = NA)
}
}
cat(paste0("#", capture.output(write.csv(dict, row.names = FALSE, quote = FALSE))), file = file, sep = "\n")
utils::write.table(dat, file = file, append = TRUE, row.names = row.names, sep = sep, quote = quote,
col.names = col.names, ...)
}
#' @export
.export.rio_r <- function(file, x, ...) {
dput(x, file = file, ...)
}
#' @export
.export.rio_dump <- function(file, x, ...) {
dump(as.character(substitute(x)), file = file, ...)
}
#' @export
.export.rio_rds <- function(file, x, ...) {
saveRDS(object = x, file = file, ...)
}
#' @export
.export.rio_rdata <- function(file, x, ...) {
if (is.data.frame(x)) {
return(save(x, file = file, ...))
} else if (is.list(x)) {
e <- as.environment(x)
save(list = names(x), file = file, envir = e, ...)
} else if (is.environment(x)) {
save(list = ls(x), file = file, envir = x, ...)
} else if (is.character(x)) {
save(list = x, file = file, ...)
} else {
stop("'x' must be a data.frame, list, or environment")
}
}
#' @export
.export.rio_rda <- .export.rio_rdata
#' @export
.export.rio_feather <- function(file, x, ...) {
requireNamespace("feather")
feather::write_feather(x = x, path = file)
}
#' @export
.export.rio_fst <- function(file, x, ...) {
requireNamespace("fst")
fst::write.fst(x = x, path = file, ...)
}
#' @export
.export.rio_matlab <- function(file, x, ...) {
requireNamespace("rmatio")
rmatio::write.mat(object = x, filename = file, ...)
}
#' @importFrom haven write_sav
#' @export
.export.rio_sav <- function(file, x, ...) {
x <- restore_labelled(x)
haven::write_sav(data = x, path = file, ...)
}
#' @importFrom haven write_sav
#' @export
.export.rio_zsav <- function(file, x, compress = TRUE, ...) {
x <- restore_labelled(x)
haven::write_sav(data = x, path = file, compress = compress, ...)
}
#' @importFrom haven write_dta
#' @export
.export.rio_dta <- function(file, x, ...) {
x <- restore_labelled(x)
haven::write_dta(data = x, path = file, ...)
}
#' @importFrom haven write_sas
#' @export
.export.rio_sas7bdat <- function(file, x, ...) {
x <- restore_labelled(x)
haven::write_sas(data = x, path = file, ...)
}
#' @importFrom haven write_xpt
#' @export
.export.rio_xpt <- function(file, x, ...) {
x <- restore_labelled(x)
haven::write_xpt(data = x, path = file, ...)
}
#' @importFrom foreign write.dbf
#' @export
.export.rio_dbf <- function(file, x, ...) {
foreign::write.dbf(dataframe = x, file = file, ...)
}
#' @export
.export.rio_json <- function(file, x, ...) {
requireNamespace("jsonlite")
cat(jsonlite::toJSON(x, ...), file = file)
}
#' @importFrom foreign write.arff
#' @export
.export.rio_arff <- function(file, x, ...) {
foreign::write.arff(x = x, file = file, ...)
}
#' @importFrom openxlsx write.xlsx
#' @export
.export.rio_xlsx <- function(file, x, which, ...) {
dots <- list(...)
if (!missing(which)) {
if (file.exists(file)) {
wb <- openxlsx::loadWorkbook(file = file)
sheets <- openxlsx::getSheetNames(file = file)
if (is.numeric(which)) {
if (which <= length(sheets)) {
which <- sheets[which]
} else {
which <- paste("Sheet", length(sheets) + 1L)
}
}
if (!which %in% sheets) {
openxlsx::addWorksheet(wb, sheet = which)
} else {
openxlsx::removeWorksheet(wb, sheet = which)
openxlsx::addWorksheet(wb, sheet = which)
openxlsx::worksheetOrder(wb) <- sheets
}
openxlsx::writeData(wb, sheet = which, x = x)
openxlsx::saveWorkbook(wb, file = file, overwrite = TRUE)
} else {
openxlsx::write.xlsx(x = x, file = file, sheetName = which, ...)
}
} else {
openxlsx::write.xlsx(x = x, file = file, ...)
}
}
#' @export
.export.rio_ods <- function(file, x, ...) {
requireNamespace("readODS")
readODS::write_ods(x = x, path = file)
}
#' @export
.export.rio_html <- function(file, x, ...) {
requireNamespace("xml2")
html <- xml2::read_html("<!doctype html><html><head>\n<title>R Exported Data</title>\n</head><body>\n</body>\n</html>")
bod <- xml2::xml_children(html)[[2]]
if (is.data.frame(x)) {
x <- list(x)
}
for (i in seq_along(x)) {
x[[i]][] <- lapply(x[[i]], as.character)
x[[i]][] <- lapply(x[[i]], function(v) gsub('&','&',v))
names(x[[i]]) <- gsub('&','&',names(x[[i]]))
tab <- xml2::xml_add_child(bod, "table")
# add header row
invisible(xml2::xml_add_child(tab, xml2::read_xml(paste0(twrap(paste0(twrap(names(x[[i]]), "th"), collapse = ""), "tr"), "\n"))))
# add data
for (j in seq_len(nrow(x[[i]]))) {
xml2::xml_add_child(tab, xml2::read_xml(paste0(twrap(paste0(twrap(unlist(x[[i]][j, , drop = TRUE]), "td"), collapse = ""), "tr"), "\n")))
}
}
xml2::write_xml(html, file = file, ...)
}
#' @export
.export.rio_xml <- function(file, x, ...) {
requireNamespace("xml2")
root <- ""
xml <- xml2::read_xml(paste0("<",as.character(substitute(x)),">\n</",as.character(substitute(x)),">\n"))
att <- attributes(x)[!names(attributes(x)) %in% c("names", "row.names", "class")]
for (a in seq_along(att)) {
xml2::xml_attr(xml, names(att)[a]) <- att[[a]]
}
# remove illegal characters
row.names(x) <- gsub('&', '&', row.names(x))
colnames(x) <- gsub('[ &]', '.', colnames(x))
x[] <- lapply(x, function(v) gsub('&', '&', v))
# add data
for (i in seq_len(nrow(x))) {
thisrow <- xml2::xml_add_child(xml, "Observation")
xml2::xml_attr(thisrow, "row.name") <- row.names(x)[i]
for (j in seq_along(x)) {
xml2::xml_add_child(thisrow, xml2::read_xml(paste0(twrap(x[i, j, drop = TRUE], names(x)[j]), "\n")))
}
}
xml2::write_xml(xml, file = file, ...)
}
#' @export
.export.rio_yml <- function(file, x, ...) {
requireNamespace("yaml")
cat(yaml::as.yaml(x, ...), file = file)
}
#' @export
.export.rio_clipboard <- function(file, x, row.names = FALSE, col.names = TRUE, sep = "\t", ...) {
requireNamespace("clipr")
clipr::write_clip(content = x, row.names = row.names, col.names = col.names, sep = sep, ...)
}
#' @export
.export.rio_pzfx <- function(file, x, ..., row_names=FALSE) {
requireNamespace("pzfx")
pzfx::write_pzfx(x=x, path=file, ..., row_names=row_names)
}
#' @export
.export.rio_parquet <- function(file, x, ...) {
requireNamespace("arrow")
arrow::write_parquet(x=x, sink=file, ...)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.