Nothing
R/write_report_html.R
In reporter: Creates Statistical Reports
Defines functions
page_setup_html
update_page
update_page_numbers_html
write_content_html
paginate_content_html
get_html_document
remove_image_files
write_report_html
# Write Report HTML -------------------------------------------------------
#' @title
#' Write an HTML report to the file system
#'
#' @description
#' This function writes a report_spec object to the file system, using the
#' parameters provided in the object.
#'
#' @param x The report_spec object to write.
#' @return The report spec.
#' @noRd
write_report_html <- function(rs) {
orig_path <- rs$modified_path
if (file.exists(orig_path)) {
file.remove(orig_path)
}
remove_image_files(orig_path)
# Establish content and body sizes
rs <- page_setup_html(rs)
# Document header is mostly independent of content
hdr <- get_html_document(rs)
# Put content in a new variable
ls <- rs$content
# Get content and break it into pages
# Needs to return a list of pages so preview can work
# Page numbers need to be included
bdy <- paginate_content_html(rs, ls)
# Get column widths
rs$column_widths <- bdy[["widths"]]
# Deal with preview
if (!is.null(rs$preview)) {
if (rs$preview < length(bdy[[1]]$pages))
bdy[[1]]$pages <- bdy[[1]]$pages[seq(1, rs$preview)]
}
# Write content to file system
# Later we can just return the stream
rs <- write_content_html(rs, hdr, bdy, rs$page_template)
# Update page numbers for title headers
update_page_numbers_html(orig_path, rs$pages)
return(rs)
}
#' @noRd
remove_image_files <- function(htmlpath) {
f <- paste0(gsub(".html", "", basename(htmlpath)), "-")
d <- dirname(htmlpath)
im <- paste0(d, "/images")
ret <- FALSE
if (dir.exists(im)) {
fls <- list.files(path = im, paste0("^", f), full.names = TRUE,
include.dirs = FALSE, no.. = TRUE)
ret <- file.remove(fls)
}
return(ret)
}
#' @description Returns header for HTML document. This is independent of content,
#' except for the page header and footer.
#' @noRd
get_html_document <- function(rs) {
# Set up vectors
ret <- c()
sty <- rs$style
conv <- rs$twip_conversion
fnt <- rs$font
if (tolower(rs$font) == "times")
fnt <- "Times New Roman"
u <- rs$units
if (rs$units == "inches")
u <- "in"
# Prepare header
ret[length(ret) + 1] <- paste0("<!DOCTYPE html>\n",
"<html>\n", "<head>")
ret[length(ret) + 1] <- "<style>"
ret[length(ret) + 1] <- paste0("@media print{\n",
"@page {size:", rs$orientation, ";",
"margin:0;}\n",
".noprint{display:none;}}")
ret[length(ret) + 1] <- paste0("body {\nfont-family: ", fnt,
";\nfont-size: ", rs$font_size, "pt;\n",
"margin-top: ", rs$margin_top, u, ";\n",
"margin-bottom: ",
round(rs$margin_bottom/2, 3), u, ";\n",
"margin-left: ", rs$margin_left, u, ";\n",
"margin-right: ", rs$margin_right, u, ";\n",
get_style_html(rs, "background_color"),
get_style_html(rs, "text_color"),
"}")
brdrcolor <- get_style(rs, "border_color")
if (brdrcolor == "")
brdrcolor <- "black"
ret[length(ret) + 1] <- paste0(".thdr {",
"border-bottom: thin solid ", brdrcolor, ";",
get_style_html(rs, "table_header_background"),
get_style_html(rs, "table_header_font_color"),
get_style_html(rs, "table_header_font_bold", FALSE),
"}")
ret[length(ret) + 1] <- paste0(".shdr {",
get_style_html(rs, "table_header_background"),
get_style_html(rs, "table_header_font_color"),
get_style_html(rs, "table_header_font_bold", FALSE),
"}")
ret[length(ret) + 1] <- paste0(".tdc {text-align:center;}")
ret[length(ret) + 1] <- paste0(".tdl {text-align:left;}")
ret[length(ret) + 1] <- paste0(".tdr {text-align:right;}")
ret[length(ret) + 1] <- paste0(".tc {",
get_style_html(rs, "table_body_background"),
"}")
ret[length(ret) + 1] <- paste0(".tbs {",
get_style_html(rs, "table_body_font_color"),
"}")
ret[length(ret) + 1] <- paste0(".tbstr {",
get_style_html(rs, "table_body_stripe"),
"}")
ret[length(ret) + 1] <- paste0(".ts {",
get_style_html(rs, "table_stub_background"),
get_style_html(rs, "table_stub_font_bold"),
get_style_html(rs, "table_stub_font_color"),
"}")
ret[length(ret) + 1] <- paste0(".tlr {",
get_style_html(rs, "table_label_row_bold"),
"}")
ret[length(ret) + 1] <- paste0("table {",
"border-spacing: 0;",
"border-collapse: collapse;",
"}")
ret[length(ret) + 1] <- paste0("td {padding:0px 2px 0px 2px;}")
ret[length(ret) + 1] <- "</style>"
ret[length(ret) + 1] <- "</head>\n<body>"
return(ret)
}
#' @noRd
paginate_content_html <- function(rs, ls) {
ret <- c()
last_object <- FALSE
last_page_lines <- 0
table_widths <- list()
hrf <- has_bottom_footnotes(rs)
if (hrf == FALSE)
hrf <- has_page_footer(rs)
# Loop through content objects
for (i in seq_along(ls)) {
pgs <- list() # list of vectors with page rtf lines
lns <- c()
# Set last object flag
if (i == length(ls))
last_object <- TRUE
else
last_object <- FALSE
# Put content and object in variables for convenience
cntnt <- ls[[i]]
obj <- cntnt$object
# Remove blank row if last content object
cbr <- cntnt$blank_row
if (last_object) {
if (all(cbr == "below"))
cbr <- "none"
else if (all(cbr == "all"))
cbr <- "above"
}
# Break each content type into a list of pages
if (any(class(obj) == "table_spec")) {
res <- create_table_pages_html(rs, cntnt, last_page_lines)
# Collect multiple pages and line counts
for (j in seq_len(length(res$page_list))) {
pgs[[length(pgs) + 1]] <- res$page_list[[j]]$html
lns[[length(lns) + 1]] <- res$page_list[[j]]$lines
}
# Retrieve table widths. These are useful for debugging.
# Assigned to returning report object.
table_widths[[length(table_widths) + 1]] <- res$widths
} else if (any(class(obj) == "text_spec")) {
res <- create_text_pages_html(rs, cntnt, last_page_lines, cbr)
for (j in seq_len(length(res$html))) {
pgs[[length(pgs) + 1]] <- res$html[[j]]
lns[[length(lns) + 1]] <- res$lines[[j]]
}
} else if (any(class(obj) == "plot_spec")) {
res <- create_plot_pages_html(rs, cntnt, last_page_lines, tempdir())
for (j in seq_len(length(res$html))) {
pgs[[length(pgs) + 1]] <- res$html[[j]]
lns[[length(lns) + 1]] <- res$lines[[j]]
}
}
# Store pages and lines with content objects
# The content settings will be used when writing content
ls[[i]]$pages <- pgs
ls[[i]]$lines <- lns
# This section of code is appending blank lines to get
# footnotes at the bottom of the page. The complication
# is when there are multiple pieces of content, and user-defined
# page breaks. So these can't be added earlier in
# the process. In short, these blanks are for in between
# pieces of content. Blanks within a piece of content are
# handled in the create_table_*, create_text_*, and create_plot_*
# functions.
# Capture last page
last_page <- pgs[[length(pgs)]]
# Capture number of lines on the last page
last_page_lines <- lns[[length(lns)]] + last_page_lines
# print(last_page_lines)
if (length(pgs) > 1)
last_page_lines <- lns[[length(lns)]]
# If there is a page break or it's the last object in the
# content list, add the blank lines if needed.
if (rs$paper_size != "none") {
if ((ls[[i]]$page_break | last_object) & hrf) {
# Add extra offsets if table has a lot of borders turned on
# to avoid undesired page wraps
boff <- 0
if (any(class(obj) == "table_spec") &
any(obj$borders %in% c("all", "inside"))) {
#boff <- round(last_page_lines * rs$border_height / rs$row_height)
boff <- 1
}
blnks <- c()
bl <- rs$body_line_count - last_page_lines - boff
if (bl > 0)
blnks <- rep("<br>", bl)
last_page <- append(last_page, blnks)
last_page_lines <- 0
}
}
if (cntnt$page_break == TRUE | last_page_lines >= rs$body_line_count)
last_page_lines <- 0
ls[[i]]$pages[[length(pgs)]] <- last_page
}
# Can return something else if needed here
ret <- list(widths = table_widths, pages = ls)
return(ret)
}
# Could be consolidated with RTF.
#' @title Write out content
#' @description This loop writes out pages created in paginate_content
#' Page template items added to the report (titles/footnotes/title_header)
#' are added in this step. That means these items need to have been accounted
#' for in the previous steps.
#' @noRd
write_content_html <- function(rs, hdr, body, pt) {
# Kill existing file
if (file.exists(rs$modified_path))
file.remove(rs$modified_path)
counter <- 0
page <- 0
last_object <- FALSE
last_page <- FALSE
page_open <- FALSE
f <- file(rs$modified_path, open="a", encoding = "native.enc")
writeLines(hdr, con = f, useBytes = TRUE)
for (cont in body$pages) {
# Increment counter
counter <- counter + 1
page <- 0
# Set last_object flag
if (counter == length(body$pages))
last_object <- TRUE
else
last_object <- FALSE
ta <- "align=\"left\" "
if (cont$align == "right")
ta <- "align=\"right\" "
else if (cont$align %in% c("center", "centre"))
ta <- "align=\"center\" "
for (pg in cont$pages) {
page <- page + 1
if (page == length(cont$pages))
last_page <- TRUE
else
last_page <- FALSE
#print(page_open)
if (page_open == FALSE) {
if (!is.null(rs$page_template$page_header) &
!is.null(rs$page_template$page_header$html))
writeLines(update_page(rs$page_template$page_header$html, rs$pages),
con = f, useBytes = TRUE)
# Write content div to keep page together
writeLines(paste0("<div ", ta, ">"), con = f, useBytes = TRUE)
if (!is.null(rs$title_hdr) & !is.null(pt$title_hdr$html))
writeLines(update_page(pt$title_hdr$html, rs$pages), con = f,
useBytes = TRUE)
if (!is.null(rs$titles) & !is.null(pt$titles$html))
writeLines(pt$titles$html, con = f, useBytes = TRUE)
}
if (!is.null(pg)) {
writeLines(pg, con = f, useBytes = TRUE)
}
# Set page_open flag based on status of page_break and current objects
if (last_object == FALSE & last_page == TRUE & cont$page_break == FALSE)
page_open <- TRUE
else
page_open <- FALSE
if (page_open == FALSE) {
if (!is.null(rs$footnotes) & !is.null(pt$footnotes$html))
writeLines(update_page(pt$footnotes$html, rs$pages),
con = f, useBytes = TRUE)
# Content div
writeLines("</div>", con = f, useBytes = TRUE)
if (!is.null(rs$page_template$page_footer) &
!is.null(rs$page_template$page_footer$html))
writeLines(update_page(rs$page_template$page_footer$html, rs$pages),
con = f, useBytes = TRUE)
# Add form feed character for text page break
if (last_object == FALSE | last_page == FALSE) {
if (is.null(rs$pages))
rs$pages <- 1
else
rs$pages <- rs$pages + 1
writeLines(rs$page_break_html, con = f, useBytes = TRUE)
}
}
if (last_object == TRUE & last_page == TRUE) {
rs$pages <- rs$pages + 1
}
}
}
writeLines("</body></html>", con = f, useBytes = TRUE)
close(f)
return(rs)
}
#' @description Could be consolidated with RTF
#' @noRd
update_page_numbers_html <- function(path, tpg) {
lns <- readLines(path, encoding = "UTF-8")
lns <- gsub("[tpg]", tpg, lns, fixed = TRUE)
f <- file(path, open = "w+", encoding = "native.enc")
writeLines(lns, con = f, useBytes = TRUE)
close(f)
}
update_page <- function(lns, pg) {
ret <- gsub("[pg]", pg + 1, lns, fixed = TRUE)
return(ret)
}
# Setup Functions ---------------------------------------------------------
# # A lot of these values are guesses. Need to test.
# # Row height and line height were defined independently in case
# # they are different. Right now, appear to be the same.
#' @description Setup page for content
#' @details Calculates available space for content and prepares text lines
#' for page template.
#' @noRd
page_setup_html <- function(rs) {
debug <- FALSE
if (is.null(rs$font_size))
rs$font_size <- 10
if (is.null(rs$font))
rs$font <- "Courier"
if (rs$font == "fixed")
rs$font <- "Courier"
if (rs$font_size == 8) {
if (tolower(rs$font) == "times")
rh <- 0.1178
else
rh <- 0.127451
gtr <- .1
cw <- .1 # na
} else if (rs$font_size == 9) {
if (tolower(rs$font) == "times")
rh <- 0.158
else
rh <- 0.148
cw <- .11 # na
gtr <- .1
} else if (rs$font_size == 10) {
if (tolower(rs$font) == "times")
rh <- 0.17
else
rh <- 0.1585366
gtr <- .11
cw <- .11 # na
} else if (rs$font_size == 11) {
if (tolower(rs$font) == "times")
rh <- 0.18
else
rh <- 0.168 # na
gtr <- .1
cw <- .11 # na
} else if (rs$font_size == 12) {
# inches
rh <- 0.1911765
gtr <- 0.11
cw <- .12 #na
}
rs$border_height <- 1/72
if (rs$units == "cm") {
rh <- ccm(rh)
cw <- ccm(cw)
rs$border_height <- ccm(rs$border_height)
gtr <- ccm(gtr)
}
rs$row_height <- rh
rs$line_height <- rh
rs$char_width <- cw
# Content size is the page size minus margins, in units of measure
rs$content_size <- get_content_size(rs)
rs$line_size <- rs$content_size[["width"]]
rs$gutter_width <- gtr
if (rs$units == "cm")
rs$gutter_width <- ccm(rs$gutter_width)
rs$page_break_html <- paste0("<hr class=\"noprint\"><div style=\"page-break-before: always;",
"height:", rs$margin_top,
units_html(rs$units), ";", "\"></div>")
if (is.null(rs$user_line_count)) {
rs$line_count <- round(rs$content_size[[1]] / rh)
} else
rs$line_count <- rs$user_line_count
if (debug) {
print(paste("Font Size:", rs$font_size))
print(paste("Content Height:", rs$content_size[[1]]))
print(paste("Content Width:", rs$content_size[[2]]))
print(paste("Line Count:", rs$line_count))
print(paste("Line Height:", rs$line_height))
print(paste("Gutter Width:", rs$gutter_width))
print(paste("Char Width:", rs$char_width))
}
#
# Get page template
pt <- page_template_html(rs)
rs$page_template <- pt
# Get the page template row count
# Include all the rows associated with the page template
rs$page_template_header_count <- sum(pt$page_header$lines, pt$titles$lines,
pt$title_hdr$lines, pt$page_by$lines)
if (debug)
print(paste("Page Template Header Count:", rs$page_template_header_count))
rs$page_template_footer_count <- sum(pt$footnotes$lines, pt$page_footer$lines)
if (debug)
print(paste("Page Template Footer Count:", rs$page_template_footer_count))
rs$page_template_row_count <- rs$page_template_header_count +
rs$page_template_footer_count
if (debug)
print(paste("Page Template Row Count:", rs$page_template_row_count))
# Body line count is the number of rows available for content on each page
rs$body_line_count <- rs$line_count - rs$page_template_row_count
if (debug)
print(paste0("Body Line Count: ", rs$body_line_count))
return(rs)
}
Try the reporter package in your browser
Any scripts or data that you put into this service are public.
reporter documentation built on May 29, 2024, 4:43 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions page_setup_html update_page update_page_numbers_html write_content_html paginate_content_html get_html_document remove_image_files write_report_html
# Write Report HTML -------------------------------------------------------
#' @title
#' Write an HTML report to the file system
#'
#' @description
#' This function writes a report_spec object to the file system, using the
#' parameters provided in the object.
#'
#' @param x The report_spec object to write.
#' @return The report spec.
#' @noRd
write_report_html <- function(rs) {
orig_path <- rs$modified_path
if (file.exists(orig_path)) {
file.remove(orig_path)
}
remove_image_files(orig_path)
# Establish content and body sizes
rs <- page_setup_html(rs)
# Document header is mostly independent of content
hdr <- get_html_document(rs)
# Put content in a new variable
ls <- rs$content
# Get content and break it into pages
# Needs to return a list of pages so preview can work
# Page numbers need to be included
bdy <- paginate_content_html(rs, ls)
# Get column widths
rs$column_widths <- bdy[["widths"]]
# Deal with preview
if (!is.null(rs$preview)) {
if (rs$preview < length(bdy[[1]]$pages))
bdy[[1]]$pages <- bdy[[1]]$pages[seq(1, rs$preview)]
}
# Write content to file system
# Later we can just return the stream
rs <- write_content_html(rs, hdr, bdy, rs$page_template)
# Update page numbers for title headers
update_page_numbers_html(orig_path, rs$pages)
return(rs)
}
#' @noRd
remove_image_files <- function(htmlpath) {
f <- paste0(gsub(".html", "", basename(htmlpath)), "-")
d <- dirname(htmlpath)
im <- paste0(d, "/images")
ret <- FALSE
if (dir.exists(im)) {
fls <- list.files(path = im, paste0("^", f), full.names = TRUE,
include.dirs = FALSE, no.. = TRUE)
ret <- file.remove(fls)
}
return(ret)
}
#' @description Returns header for HTML document. This is independent of content,
#' except for the page header and footer.
#' @noRd
get_html_document <- function(rs) {
# Set up vectors
ret <- c()
sty <- rs$style
conv <- rs$twip_conversion
fnt <- rs$font
if (tolower(rs$font) == "times")
fnt <- "Times New Roman"
u <- rs$units
if (rs$units == "inches")
u <- "in"
# Prepare header
ret[length(ret) + 1] <- paste0("<!DOCTYPE html>\n",
"<html>\n", "<head>")
ret[length(ret) + 1] <- "<style>"
ret[length(ret) + 1] <- paste0("@media print{\n",
"@page {size:", rs$orientation, ";",
"margin:0;}\n",
".noprint{display:none;}}")
ret[length(ret) + 1] <- paste0("body {\nfont-family: ", fnt,
";\nfont-size: ", rs$font_size, "pt;\n",
"margin-top: ", rs$margin_top, u, ";\n",
"margin-bottom: ",
round(rs$margin_bottom/2, 3), u, ";\n",
"margin-left: ", rs$margin_left, u, ";\n",
"margin-right: ", rs$margin_right, u, ";\n",
get_style_html(rs, "background_color"),
get_style_html(rs, "text_color"),
"}")
brdrcolor <- get_style(rs, "border_color")
if (brdrcolor == "")
brdrcolor <- "black"
ret[length(ret) + 1] <- paste0(".thdr {",
"border-bottom: thin solid ", brdrcolor, ";",
get_style_html(rs, "table_header_background"),
get_style_html(rs, "table_header_font_color"),
get_style_html(rs, "table_header_font_bold", FALSE),
"}")
ret[length(ret) + 1] <- paste0(".shdr {",
get_style_html(rs, "table_header_background"),
get_style_html(rs, "table_header_font_color"),
get_style_html(rs, "table_header_font_bold", FALSE),
"}")
ret[length(ret) + 1] <- paste0(".tdc {text-align:center;}")
ret[length(ret) + 1] <- paste0(".tdl {text-align:left;}")
ret[length(ret) + 1] <- paste0(".tdr {text-align:right;}")
ret[length(ret) + 1] <- paste0(".tc {",
get_style_html(rs, "table_body_background"),
"}")
ret[length(ret) + 1] <- paste0(".tbs {",
get_style_html(rs, "table_body_font_color"),
"}")
ret[length(ret) + 1] <- paste0(".tbstr {",
get_style_html(rs, "table_body_stripe"),
"}")
ret[length(ret) + 1] <- paste0(".ts {",
get_style_html(rs, "table_stub_background"),
get_style_html(rs, "table_stub_font_bold"),
get_style_html(rs, "table_stub_font_color"),
"}")
ret[length(ret) + 1] <- paste0(".tlr {",
get_style_html(rs, "table_label_row_bold"),
"}")
ret[length(ret) + 1] <- paste0("table {",
"border-spacing: 0;",
"border-collapse: collapse;",
"}")
ret[length(ret) + 1] <- paste0("td {padding:0px 2px 0px 2px;}")
ret[length(ret) + 1] <- "</style>"
ret[length(ret) + 1] <- "</head>\n<body>"
return(ret)
}
#' @noRd
paginate_content_html <- function(rs, ls) {
ret <- c()
last_object <- FALSE
last_page_lines <- 0
table_widths <- list()
hrf <- has_bottom_footnotes(rs)
if (hrf == FALSE)
hrf <- has_page_footer(rs)
# Loop through content objects
for (i in seq_along(ls)) {
pgs <- list() # list of vectors with page rtf lines
lns <- c()
# Set last object flag
if (i == length(ls))
last_object <- TRUE
else
last_object <- FALSE
# Put content and object in variables for convenience
cntnt <- ls[[i]]
obj <- cntnt$object
# Remove blank row if last content object
cbr <- cntnt$blank_row
if (last_object) {
if (all(cbr == "below"))
cbr <- "none"
else if (all(cbr == "all"))
cbr <- "above"
}
# Break each content type into a list of pages
if (any(class(obj) == "table_spec")) {
res <- create_table_pages_html(rs, cntnt, last_page_lines)
# Collect multiple pages and line counts
for (j in seq_len(length(res$page_list))) {
pgs[[length(pgs) + 1]] <- res$page_list[[j]]$html
lns[[length(lns) + 1]] <- res$page_list[[j]]$lines
}
# Retrieve table widths. These are useful for debugging.
# Assigned to returning report object.
table_widths[[length(table_widths) + 1]] <- res$widths
} else if (any(class(obj) == "text_spec")) {
res <- create_text_pages_html(rs, cntnt, last_page_lines, cbr)
for (j in seq_len(length(res$html))) {
pgs[[length(pgs) + 1]] <- res$html[[j]]
lns[[length(lns) + 1]] <- res$lines[[j]]
}
} else if (any(class(obj) == "plot_spec")) {
res <- create_plot_pages_html(rs, cntnt, last_page_lines, tempdir())
for (j in seq_len(length(res$html))) {
pgs[[length(pgs) + 1]] <- res$html[[j]]
lns[[length(lns) + 1]] <- res$lines[[j]]
}
}
# Store pages and lines with content objects
# The content settings will be used when writing content
ls[[i]]$pages <- pgs
ls[[i]]$lines <- lns
# This section of code is appending blank lines to get
# footnotes at the bottom of the page. The complication
# is when there are multiple pieces of content, and user-defined
# page breaks. So these can't be added earlier in
# the process. In short, these blanks are for in between
# pieces of content. Blanks within a piece of content are
# handled in the create_table_*, create_text_*, and create_plot_*
# functions.
# Capture last page
last_page <- pgs[[length(pgs)]]
# Capture number of lines on the last page
last_page_lines <- lns[[length(lns)]] + last_page_lines
# print(last_page_lines)
if (length(pgs) > 1)
last_page_lines <- lns[[length(lns)]]
# If there is a page break or it's the last object in the
# content list, add the blank lines if needed.
if (rs$paper_size != "none") {
if ((ls[[i]]$page_break | last_object) & hrf) {
# Add extra offsets if table has a lot of borders turned on
# to avoid undesired page wraps
boff <- 0
if (any(class(obj) == "table_spec") &
any(obj$borders %in% c("all", "inside"))) {
#boff <- round(last_page_lines * rs$border_height / rs$row_height)
boff <- 1
}
blnks <- c()
bl <- rs$body_line_count - last_page_lines - boff
if (bl > 0)
blnks <- rep("<br>", bl)
last_page <- append(last_page, blnks)
last_page_lines <- 0
}
}
if (cntnt$page_break == TRUE | last_page_lines >= rs$body_line_count)
last_page_lines <- 0
ls[[i]]$pages[[length(pgs)]] <- last_page
}
# Can return something else if needed here
ret <- list(widths = table_widths, pages = ls)
return(ret)
}
# Could be consolidated with RTF.
#' @title Write out content
#' @description This loop writes out pages created in paginate_content
#' Page template items added to the report (titles/footnotes/title_header)
#' are added in this step. That means these items need to have been accounted
#' for in the previous steps.
#' @noRd
write_content_html <- function(rs, hdr, body, pt) {
# Kill existing file
if (file.exists(rs$modified_path))
file.remove(rs$modified_path)
counter <- 0
page <- 0
last_object <- FALSE
last_page <- FALSE
page_open <- FALSE
f <- file(rs$modified_path, open="a", encoding = "native.enc")
writeLines(hdr, con = f, useBytes = TRUE)
for (cont in body$pages) {
# Increment counter
counter <- counter + 1
page <- 0
# Set last_object flag
if (counter == length(body$pages))
last_object <- TRUE
else
last_object <- FALSE
ta <- "align=\"left\" "
if (cont$align == "right")
ta <- "align=\"right\" "
else if (cont$align %in% c("center", "centre"))
ta <- "align=\"center\" "
for (pg in cont$pages) {
page <- page + 1
if (page == length(cont$pages))
last_page <- TRUE
else
last_page <- FALSE
#print(page_open)
if (page_open == FALSE) {
if (!is.null(rs$page_template$page_header) &
!is.null(rs$page_template$page_header$html))
writeLines(update_page(rs$page_template$page_header$html, rs$pages),
con = f, useBytes = TRUE)
# Write content div to keep page together
writeLines(paste0("<div ", ta, ">"), con = f, useBytes = TRUE)
if (!is.null(rs$title_hdr) & !is.null(pt$title_hdr$html))
writeLines(update_page(pt$title_hdr$html, rs$pages), con = f,
useBytes = TRUE)
if (!is.null(rs$titles) & !is.null(pt$titles$html))
writeLines(pt$titles$html, con = f, useBytes = TRUE)
}
if (!is.null(pg)) {
writeLines(pg, con = f, useBytes = TRUE)
}
# Set page_open flag based on status of page_break and current objects
if (last_object == FALSE & last_page == TRUE & cont$page_break == FALSE)
page_open <- TRUE
else
page_open <- FALSE
if (page_open == FALSE) {
if (!is.null(rs$footnotes) & !is.null(pt$footnotes$html))
writeLines(update_page(pt$footnotes$html, rs$pages),
con = f, useBytes = TRUE)
# Content div
writeLines("</div>", con = f, useBytes = TRUE)
if (!is.null(rs$page_template$page_footer) &
!is.null(rs$page_template$page_footer$html))
writeLines(update_page(rs$page_template$page_footer$html, rs$pages),
con = f, useBytes = TRUE)
# Add form feed character for text page break
if (last_object == FALSE | last_page == FALSE) {
if (is.null(rs$pages))
rs$pages <- 1
else
rs$pages <- rs$pages + 1
writeLines(rs$page_break_html, con = f, useBytes = TRUE)
}
}
if (last_object == TRUE & last_page == TRUE) {
rs$pages <- rs$pages + 1
}
}
}
writeLines("</body></html>", con = f, useBytes = TRUE)
close(f)
return(rs)
}
#' @description Could be consolidated with RTF
#' @noRd
update_page_numbers_html <- function(path, tpg) {
lns <- readLines(path, encoding = "UTF-8")
lns <- gsub("[tpg]", tpg, lns, fixed = TRUE)
f <- file(path, open = "w+", encoding = "native.enc")
writeLines(lns, con = f, useBytes = TRUE)
close(f)
}
update_page <- function(lns, pg) {
ret <- gsub("[pg]", pg + 1, lns, fixed = TRUE)
return(ret)
}
# Setup Functions ---------------------------------------------------------
# # A lot of these values are guesses. Need to test.
# # Row height and line height were defined independently in case
# # they are different. Right now, appear to be the same.
#' @description Setup page for content
#' @details Calculates available space for content and prepares text lines
#' for page template.
#' @noRd
page_setup_html <- function(rs) {
debug <- FALSE
if (is.null(rs$font_size))
rs$font_size <- 10
if (is.null(rs$font))
rs$font <- "Courier"
if (rs$font == "fixed")
rs$font <- "Courier"
if (rs$font_size == 8) {
if (tolower(rs$font) == "times")
rh <- 0.1178
else
rh <- 0.127451
gtr <- .1
cw <- .1 # na
} else if (rs$font_size == 9) {
if (tolower(rs$font) == "times")
rh <- 0.158
else
rh <- 0.148
cw <- .11 # na
gtr <- .1
} else if (rs$font_size == 10) {
if (tolower(rs$font) == "times")
rh <- 0.17
else
rh <- 0.1585366
gtr <- .11
cw <- .11 # na
} else if (rs$font_size == 11) {
if (tolower(rs$font) == "times")
rh <- 0.18
else
rh <- 0.168 # na
gtr <- .1
cw <- .11 # na
} else if (rs$font_size == 12) {
# inches
rh <- 0.1911765
gtr <- 0.11
cw <- .12 #na
}
rs$border_height <- 1/72
if (rs$units == "cm") {
rh <- ccm(rh)
cw <- ccm(cw)
rs$border_height <- ccm(rs$border_height)
gtr <- ccm(gtr)
}
rs$row_height <- rh
rs$line_height <- rh
rs$char_width <- cw
# Content size is the page size minus margins, in units of measure
rs$content_size <- get_content_size(rs)
rs$line_size <- rs$content_size[["width"]]
rs$gutter_width <- gtr
if (rs$units == "cm")
rs$gutter_width <- ccm(rs$gutter_width)
rs$page_break_html <- paste0("<hr class=\"noprint\"><div style=\"page-break-before: always;",
"height:", rs$margin_top,
units_html(rs$units), ";", "\"></div>")
if (is.null(rs$user_line_count)) {
rs$line_count <- round(rs$content_size[[1]] / rh)
} else
rs$line_count <- rs$user_line_count
if (debug) {
print(paste("Font Size:", rs$font_size))
print(paste("Content Height:", rs$content_size[[1]]))
print(paste("Content Width:", rs$content_size[[2]]))
print(paste("Line Count:", rs$line_count))
print(paste("Line Height:", rs$line_height))
print(paste("Gutter Width:", rs$gutter_width))
print(paste("Char Width:", rs$char_width))
}
#
# Get page template
pt <- page_template_html(rs)
rs$page_template <- pt
# Get the page template row count
# Include all the rows associated with the page template
rs$page_template_header_count <- sum(pt$page_header$lines, pt$titles$lines,
pt$title_hdr$lines, pt$page_by$lines)
if (debug)
print(paste("Page Template Header Count:", rs$page_template_header_count))
rs$page_template_footer_count <- sum(pt$footnotes$lines, pt$page_footer$lines)
if (debug)
print(paste("Page Template Footer Count:", rs$page_template_footer_count))
rs$page_template_row_count <- rs$page_template_header_count +
rs$page_template_footer_count
if (debug)
print(paste("Page Template Row Count:", rs$page_template_row_count))
# Body line count is the number of rows available for content on each page
rs$body_line_count <- rs$line_count - rs$page_template_row_count
if (debug)
print(paste0("Body Line Count: ", rs$body_line_count))
return(rs)
}
Try the reporter package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.