check_md_args <- function(headings, drop, main, sub, nheaders, header1, locale, class) {
check_string(main)
check_string(sub)
check_count(nheaders)
check_count(header1)
check_string(locale)
check_string(class)
if (header1 < 1) error("header1 cannot be less than 1")
stopifnot(class %in% c("templates", "tables", "objects", "plots"))
if (!is.list(drop)) error("drop must be a list")
if (!all(vapply(drop, is.character, TRUE)))
error("drop must be a list of character vectors")
if (!is.list(headings)) error("headings must be a list")
if (!all(vapply(headings, is.character, TRUE)))
error("headings must be a list of character vectors")
if (!all(vapply(headings, function(x) !length(x) || !is.null(names), TRUE)))
error("headings must be a list of named character vectors")
TRUE
}
md_files <- function(headings, drop, main, sub, nheaders, header1, locale, class, is_report) {
check_md_args(headings = headings, drop = drop, main = main,
sub = sub, nheaders = nheaders, header1 = header1, locale = locale, class = class)
dir <- file.path(main, class, sub)
files <- list_files(dir, report = is_report)
if (!length(files)) return(NULL)
nsub <- max(nsubs(files))
if (length(drop) > nsub) drop <- drop[1:nsub]
if (length(headings) > nsub) headings <- headings[1:nsub]
nheaders %<>% min(nsub)
subs <- subs_matrix(files)
drop %<>% drop_rows(subs, .)
files <- files[!drop]
subs <- subs[, !drop, drop = FALSE]
if (!length(files)) return(NULL)
order <- order_headings(subs, headings, locale)
subs <- subs[,order,drop = FALSE]
files <- files[order]
subs %<>% rename_headings(headings)
subs %<>% set_headers(nheaders, header1)
files <- names(files)
names(files) <- subs
files
}
#' Markdown Plot
#'
#' Returns a string of plot in markdown format ready for inclusion in a report.
#'
#' @inheritParams md_tables
#' @param x A string of the plot name
#' @param caption A string of the caption.
#' @return A string of the plot in markdown format ready for inclusion in a report.
#' @export
md_plot <- function(x, sub = get_sub(), main = get_main(), report = get_report(),
caption = NULL, locale = "en",
ask = getOption("subfoldr.ask", TRUE)) {
if (!is.null(report) && (!is.character(report) || !length(report) == 1))
error("report must be NULL or a string")
if (!is.null(caption) && (!is.character(caption) || !length(caption) == 1))
error("caption must be NULL or a string")
check_flag(ask)
files <- md_files(headings = list(character(0)), drop = list(character(0)),
main = main, sub = sub, nheaders = 0L,
header1 = 3L,
locale = locale, class = "plots", is_report = NA)
if (!length(files)) return("")
bol <- str_detect(files, str_c("/_", x, "[.]RDS$"))
if (!any(bol)) return("")
stopifnot(sum(bol) == 1)
transfers <- md_transfers(headings = list(character(0)), drop = list(character(0)), main = main,
sub = sub, report = report, locale = locale, class = "plots", is_report = NA)
files <- files[bol]
transfers <- transfers[bol]
if (!is.null(report)) {
if (!is.character(report) || !length(report) == 1)
error("report must be NULL or a string")
if (!ask || yesno("Copy plot to directory ", report, "?")) {
transfer_files(transfers)
}
}
txt <- NULL
for (i in seq_along(files)) {
file <- files[i]
info <- readRDS(file)
caption <- if (is.null(caption)) info$caption else caption
caption %<>% add_full_stop()
caption %<>% str_c("Figure ", incr_plot_number(), ". ", .)
file %<>% str_replace("(_)([^/]+)(.RDS)", "\\2.rds")
txt %<>% c(names(files)[i])
txt %<>% c("\n<figure>") %>%
c(str_c("<img alt = \"", names(transfers)[i], "\" src = \"", names(transfers)[i],
"\" title = \"", names(transfers)[i], "\" width = \"", round(info$width / 6 * 100), "%\">")) %>%
c(str_c("<figcaption>", caption, "</figcaption>")) %>%
c("</figure>")
}
txt %<>% str_c(collapse = "\n")
txt
}
#' Markdown Table
#'
#' Returns a string of table in markdown format ready for inclusion in a report.
#'
#' @inheritParams md_tables
#' @param x A string of the table name
#' @param caption A string of the caption.
#' @return A string of the report table in markdown format ready for inclusion in a report.
#' @export
md_table <- function(x, sub = get_sub(), main = get_main(), report = get_report(),
caption = NULL, locale = "en",
ask = getOption("subfoldr.ask", TRUE)) {
if (!is.null(report) && (!is.character(report) || !length(report) == 1))
error("report must be NULL or a string")
if (!is.null(caption) && (!is.character(caption) || !length(caption) == 1))
error("caption must be NULL or a string")
check_flag(ask)
files <- md_files(headings = list(character(0)), drop = list(character(0)),
main = main, sub = sub, nheaders = 0L,
header1 = 3L,
locale = locale, class = "tables", is_report = NA)
if (!length(files)) return("")
bol <- str_detect(files, str_c("/_", x, "[.]RDS$"))
if (!any(bol)) return("")
stopifnot(sum(bol) == 1)
transfers <- md_transfers(headings = list(character(0)), drop = list(character(0)), main = main,
sub = sub, report = report, locale = locale, class = "tables", is_report = NA)
files <- files[bol]
transfers <- transfers[bol]
if (!is.null(report)) {
if (!is.character(report) || !length(report) == 1)
error("report must be NULL or a string")
if (!ask || yesno("Copy table to directory ", report, "?")) {
transfer_files(transfers)
}
}
txt <- NULL
for (i in seq_along(files)) {
file <- files[i]
caption <- if(is.null(caption)) readRDS(file)$caption else caption
caption %<>% add_full_stop()
caption %<>% str_c("Table ", incr_table_number(), ". ", .)
file %<>% str_replace("(_)([^/]+)(.RDS)", "\\2.rds")
table <- readRDS(file = file)
txt %<>% c(names(files)[i]) %>% c("")
txt %<>% c(caption) %>% c("")
txt %<>% c(knitr::kable(table, format = "markdown", row.names = FALSE))
txt %<>% c("")
}
txt %<>% str_c(collapse = "\n")
txt
}
#' Markdown Template
#'
#' Returns a string of template in markdown format ready for inclusion in a report.
#'
#' @inheritParams md_tables
#' @param x A string of the template name
#' @param caption A string of the caption.
#' @return A string of the template in markdown format ready for inclusion in a report.
#' @export
md_template <- function(x, sub = get_sub(), main = get_main(), report = get_report(),
caption = NULL, locale = "en",
ask = getOption("subfoldr.ask", TRUE)) {
if (!is.null(report) && (!is.character(report) || !length(report) == 1))
error("report must be NULL or a string")
if (!is.null(caption) && (!is.character(caption) || !length(caption) == 1))
error("caption must be NULL or a string")
check_flag(ask)
files <- md_files(headings = list(character(0)), drop = list(character(0)),
main = main, sub = sub, nheaders = 0L,
header1 = 3L,
locale = locale, class = "templates", is_report = NA)
if (!length(files)) return("")
bol <- str_detect(files, str_c("/_", x, "[.]RDS$"))
if (!any(bol)) return("")
stopifnot(sum(bol) == 1)
transfers <- md_transfers(headings = list(character(0)), drop = list(character(0)), main = main,
sub = sub, report = report, locale = locale, class = "templates", is_report = NA)
files <- files[bol]
transfers <- transfers[bol]
if (!is.null(report)) {
if (!is.character(report) || !length(report) == 1)
error("report must be NULL or a string")
if (!ask || yesno("Copy template to directory ", report, "?")) {
transfer_files(transfers)
}
}
txt <- NULL
for (i in seq_along(files)) {
file <- files[i]
caption <- if (is.null(caption)) readRDS(file)$caption else caption
caption %<>% add_full_stop()
caption %<>% str_c("Table ", incr_template_number(), ". ", .)
file %<>% str_replace("(_)([^/]+)(.RDS)", "\\2.rds")
template <- readRDS(file = file)
txt %<>% c(names(files)[i])
txt %<>% c("```")
txt %<>% c(".")
txt %<>% c(template)
txt %<>% c("..")
txt %<>% c("```")
txt %<>% c(caption)
txt %<>% c("")
}
txt %<>% str_c(collapse = "\n")
txt
}
md_transfers <- function(headings, drop, main, sub, report, locale, class, is_report) {
dir <- file.path(main, class, sub)
files <- list_files(dir, report = is_report)
if (!length(files)) return(character(0))
nsub <- max(nsubs(files))
if (length(drop) > nsub) drop <- drop[1:nsub]
if (length(headings) > nsub) headings <- headings[1:nsub]
subs <- subs_matrix(files)
drop %<>% drop_rows(subs, .)
files <- files[!drop]
subs <- subs[, !drop, drop = FALSE]
if (!length(files)) return(character(0))
order <- order_headings(subs, headings, locale)
subs <- subs[,order,drop = FALSE]
files <- files[order]
subs %<>% plyr::alply(2, str_c, collapse = "/") %>% unlist()
subs %<>% str_c(report, class, sub, ., sep = "/") %>%
str_replace_all("/{2,}", "/") %>% str_replace("/$", "")
subs %<>% str_c(class_ext(class), sep = ".")
files <- names(files)
files %<>% str_replace("(_)([^/]+[.]RDS$)", "\\2")
files %<>% str_replace("RDS$", class_ext(class))
names(files) <- subs
files
}
#' Markdown Plots
#'
#' Returns a string of plots in markdown format ready for inclusion in a report.
#'
#' @inheritParams md_tables
#' @export
md_plots <- function(sub = get_sub(), main = get_main(), report = get_report(),
headings = list(character(0)), drop = list(character(0)),
nheaders = 0L, header1 = 3L,
locale = "en",
ask = getOption("subfoldr.ask", TRUE)) {
if (!is.null(report) && (!is.character(report) || !length(report) == 1))
error("report must be NULL or a string")
check_flag(ask)
files <- md_files(headings = headings, drop = drop, main = main,
sub = sub, nheaders = nheaders,
header1 = header1,
locale = locale, class = "plots", is_report = TRUE)
transfers <- md_transfers(headings = headings, drop = drop, main = main,
sub = sub, report = report, locale = locale, class = "plots", is_report = TRUE)
if (!is.null(report)) {
if (!is.character(report) || !length(report) == 1)
error("report must be NULL or a string")
if (!ask || yesno("Copy plots to directory ", report, "?")) {
transfer_files(transfers)
csvs <- str_replace(transfers, "[.]png$", ".csv")
names(csvs) <- str_replace(names(transfers), "[.]png$", ".csv")
transfer_files(csvs)
} else names(transfers) <- transfers
} else names(transfers) <- transfers
txt <- NULL
for (i in seq_along(files)) {
file <- files[i]
info <- readRDS(file)
caption <- info$caption
caption %<>% add_full_stop()
caption %<>% str_c("Figure ", incr_plot_number(), ". ", .)
file %<>% str_replace("(_)([^/]+)(.RDS)", "\\2.rds")
txt %<>% c(names(files)[i])
txt %<>% c("\n<figure>") %>%
c(str_c("<img alt = \"", names(transfers)[i], "\" src = \"", names(transfers)[i],
"\" title = \"", names(transfers)[i], "\" width = \"", round(info$width / 6 * 100), "%\">")) %>%
c(str_c("<figcaption>", caption, "</figcaption>")) %>%
c("</figure>")
}
txt %<>% str_c(collapse = "\n")
txt
}
#' Markdown Tables
#'
#' Returns a string of tables in markdown format ready for inclusion in a report.
#'
#' The names in the character vectors in headings indicate the new headings for each subfolder.
#' By default missing subfolders receive their current name with the first letter of each word capitalized.
#' Subfolders with the name "" do not receive a heading.
#' The order of the subfolders indicates the order in which they should appear.
#' By default missing subfolders appear in alphabetical order.
#' The first named character vector is applied to the highest level of subfolders starting at sub and so on.
#' The number of character vectors indicates the number of levels that should receive headings.
#' By default the highest level of subfolders are considered to be third order headings.
#'
#' The elements in the character vectors in drop indicate the subfolders to exclude from the report.
#' Again the number of the character vector indicates the level to which it applies.
#'
#' @param headings A list of named character vectors.
#' @param drop A list of character vectors specify the subfolders to drop.
#' @param main A string of the main subfolder.
#' @param sub A string of the path to the subfolders to save the object (by default = "").
#' @param report A string indicating the report folder to copy the csv files.
#' @param nheaders An count of the number of headings to assign headers to.
#' @param header1 A count of the heading level for the first header.
#' @param locale A string of the locale.
#' @param ask A string indicating whether to ask before creating a sub directory.
#' @return A string of the report templates in markdown format ready for inclusion in a report.
#' @export
md_tables <- function(sub = get_sub(), main = get_main(), report = get_report(),
headings = list(character(0)), drop = list(character(0)),
nheaders = 0L, header1 = 3L,
locale = "en",
ask = getOption("subfoldr.ask", TRUE)) {
if (!is.null(report) && (!is.character(report) || !length(report) == 1))
error("report must be NULL or a string")
check_flag(ask)
files <- md_files(headings = headings, drop = drop, main = main,
sub = sub, nheaders = nheaders,
header1 = header1,
locale = locale, class = "tables", is_report = TRUE)
transfers <- md_transfers(headings = headings, drop = drop, main = main,
sub = sub, report = report, locale = locale, class = "tables", is_report = TRUE)
if (!is.null(report)) {
if (!is.character(report) || !length(report) == 1)
error("report must be NULL or a string")
if (!ask || yesno("Copy tables to directory ", report, "?")) {
transfer_files(transfers)
}
}
txt <- NULL
for (i in seq_along(files)) {
file <- files[i]
caption <- readRDS(file)$caption
caption %<>% add_full_stop()
caption %<>% str_c("Table ", incr_table_number(), ". ", .)
file %<>% str_replace("(_)([^/]+)(.RDS)", "\\2.rds")
table <- readRDS(file = file)
txt %<>% c(names(files)[i]) %>% c("")
txt %<>% c(caption) %>% c("")
txt %<>% c(knitr::kable(table, format = "markdown", row.names = FALSE))
txt %<>% c("")
}
txt %<>% str_c(collapse = "\n")
txt
}
#' Markdown Templates
#'
#' Returns a string of templates in markdown format ready for inclusion in a report.
#'
#' @inheritParams md_tables
#' @return A string of the report templates in markdown format ready for inclusion in a report.
#' @export
md_templates <- function(sub = get_sub(), main = get_main(), report = get_report(),
headings = list(character(0)), drop = list(character(0)),
nheaders = 0L, header1 = 3L,
locale = "en",
ask = getOption("subfoldr.ask", TRUE)) {
if (!is.null(report) && (!is.character(report) || !length(report) == 1))
error("report must be NULL or a string")
check_flag(ask)
files <- md_files(headings = headings, drop = drop, main = main,
sub = sub, nheaders = nheaders,
header1 = header1,
locale = locale, class = "templates", is_report = TRUE)
transfers <- md_transfers(headings = headings, drop = drop, main = main,
sub = sub, report = report, locale = locale, class = "templates", is_report = TRUE)
if (!is.null(report)) {
if (!is.character(report) || !length(report) == 1)
error("report must be NULL or a string")
if (!ask || yesno("Copy templates to directory ", report, "?")) {
transfer_files(transfers)
}
}
txt <- NULL
for (i in seq_along(files)) {
file <- files[i]
caption <- readRDS(file)$caption
caption %<>% add_full_stop()
caption %<>% str_c("Template ", incr_template_number(), ". ", .)
file %<>% str_replace("(_)([^/]+)(.RDS)", "\\2.rds")
template <- readRDS(file = file)
txt %<>% c(names(files)[i])
txt %<>% c("```")
txt %<>% c(".")
txt %<>% c(template)
txt %<>% c("..")
txt %<>% c("```")
txt %<>% c(caption)
txt %<>% c("")
}
txt %<>% str_c(collapse = "\n")
txt
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.