Nothing
R/page_template_html.R
In reporter: Creates Statistical Reports
Defines functions
get_page_numbers_html
get_cell_borders_html
get_page_by_html
get_title_header_html
get_footnotes_html_back
get_footnotes_html
get_titles_html_back
get_titles_html
get_page_footer_html
get_page_header_html
page_template_html
# The page template is everything except the content: page header/footer,
# titles, footnotes, etc.
# Page Template HTML Functions ---------------------------------------------
#' Create a page template with header, titles, footnotes, and footer.
#' @param rs The report spec
#' @return The page template object
#' @noRd
page_template_html <- function(rs) {
pt <- structure(list(), class = c("page_template_html", "list"))
pt$page_header <- get_page_header_html(rs)
pt$title_hdr <- get_title_header_html(rs$title_hdr, rs$line_size, rs)
pt$titles <- get_titles_html(rs$titles, rs$line_size, rs)
pt$footnotes <- c()
if (!is.null(rs$footnotes)) {
if (!is.null(rs$footnotes[[1]])) {
if (rs$footnotes[[1]]$valign == "bottom")
pt$footnotes <- get_footnotes_html(rs$footnotes, rs$line_size, rs)
}
}
pt$page_footer <- get_page_footer_html(rs)
pt$lines <- sum(pt$page_header$lines, pt$page_footer$lines,
pt$title_hdr$lines, pt$titles$lines, pt$footnotes$lines)
# Page by not here. Messes up line counts.
return(pt)
}
#' @import grDevices
#' @noRd
get_page_header_html <- function(rs) {
ret <- ""
cnt <- 0
# hl <- rs$page_header_left
# hr <- rs$page_header_right
# maxh <- max(length(hl), length(hr))
# # User controlled width of left column
# lwdth <- rs$page_header_width
# if (is.null(lwdth))
# lwdth <- rs$content_size[["width"]]/2
#
# # Calculate right column width
# rwdth <- rs$content_size[["width"]] - lwdth
# lpct <- round(lwdth / rs$content_size[["width"]] * 100)
# rpct <- round(rwdth / rs$content_size[["width"]] * 100)
if ((!is.null(rs$header_image_left) & is.null(rs$page_header_left)) |
(!is.null(rs$header_image_center) & is.null(rs$page_header_center)) |
(!is.null(rs$header_image_right) & is.null(rs$page_header_right))) {
stop("`page_header` must be used when using `header_image`.")
}
# Make sure the length is 3, NA will be imputed later.
width <- c(rs$page_header_width, rep(NA, 3 - length(rs$page_header_width)))
image_left <- FALSE
image_center <- FALSE
image_right <- FALSE
if (!is.null(rs$header_image_left)) {
image_left <- TRUE
hl <- rs$header_image_left
} else{
hl <- rs$page_header_left
}
if (!is.null(rs$header_image_right)) {
image_right <- TRUE
hr <- rs$header_image_right
} else {
hr <- rs$page_header_right
}
if (!is.null(rs$header_image_center)) {
image_center <- TRUE
hc <- rs$header_image_center
# Default center cell is not displayed, open it when picture exists
if (width[2] == 0) {
width[2] <- NA
}
} else {
hc <- rs$page_header_center
}
hl_num <- ifelse(image_left, length(hl$image_path), length(hl))
hc_num <- ifelse(image_center, length(hc$image_path), length(hc))
hr_num <- ifelse(image_right, length(hr$image_path) , length(hr))
maxh <- max(hl_num, hc_num, hr_num)
# Calculate the widths
total_width <- sum(width, na.rm = T)
if (total_width > rs$content_size[["width"]]) {
stop(sprintf("Total width of page footer %s %s cannot be greater than content width %s %s.",
total_width,
rs$units,
rs$content_size[["width"]],
rs$units))
} else {
na_num <- sum(is.na(width))
imputed_width <- (rs$content_size[["width"]] - total_width) / na_num
left_width <- ifelse(is.na(width[1]), imputed_width, width[1])
center_width <- ifelse(is.na(width[2]), imputed_width, width[2])
right_width <- ifelse(is.na(width[3]), imputed_width, width[3])
left_pct <- 100 * left_width/rs$content_size[["width"]]
center_pct <- 100 * center_width/rs$content_size[["width"]]
right_pct <- 100 * right_width/rs$content_size[["width"]]
}
if (maxh > 0) {
# ret <- paste0("<table ",
# "style=\"width:100%\">",
# "<colgroup>\n<col style=\"width:", left_pct, "%\">\n",
# "<col style=\"width:", right_pct,"%\">\n</colgroup>\n")
ret <- paste0("<table ",
"style=\"width:100%\">",
"<colgroup>\n",
ifelse(left_pct > 0, paste0("<col style=\"width:", left_pct, "%\">\n"), ""),
ifelse(center_pct > 0, paste0("<col style=\"width:", center_pct, "%\">\n"), ""),
ifelse(right_pct > 0, paste0("<col style=\"width:", right_pct,"%\">\n"), ""),
"</colgroup>\n")
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
u <- rs$units
if (rs$units == "inches") {
u <- "in"
}
lcnt <- 0
ccnt <- 0
rcnt <- 0
lheight <- 0
cheight <- 0
rheight <- 0
max_height <- 0
for (i in seq(1, maxh)) {
ret <- paste0(ret, "<tr>")
if (left_width > 0) {
if (hl_num >= i) {
if (image_left == FALSE) {
# Split strings if they exceed width
tmp <- split_string_html(hl[[i]], left_width, rs$units)
ret <- paste0(ret, "<td style=\"text-align:left\">", encodeHTML(tmp$html),
"</td>\n")
lcnt <- tmp$lines
} else {
# Get image code
tmp_nm <- tempfile(tmpdir = tempdir(), fileext = ".jpg")
file.copy(hl$image_path[i], tmp_nm, overwrite = TRUE)
hl$width <- min(hl$width, left_width)
img <- get_image_html(tmp_nm, rs$modified_path, hl, rs$units)
ret <- paste0(ret, "<td style=\"text-align:left\">", img, "</td>")
lheight <- hl$height
}
} else {
ret <- paste0(ret, "<td style=\"text-align:left\"> </td>\n")
lcnt <- 1
}
}
if (center_width > 0) {
if (hc_num >= i) {
if (image_center == FALSE) {
# Split strings if they exceed width
tmp3 <- split_string_html(hc[[i]], center_width, rs$units)
ret <- paste0(ret, "<td style=\"text-align:center\">", encodeHTML(tmp3$html),
"</td>\n")
ccnt <- tmp3$lines
} else {
# Get image code
tmp_nm <- tempfile(tmpdir = tempdir(), fileext = ".jpg")
file.copy(hc$image_path[i], tmp_nm, overwrite = TRUE)
hc$width <- min(hc$width, center_width)
img <- get_image_html(tmp_nm, rs$modified_path, hc, rs$units)
ret <- paste0(ret, "<td style=\"text-align:center\">", img, "</td>")
cheight <- hc$height
}
} else {
ret <- paste0(ret, "<td style=\"text-align:center\"> </td>\n")
ccnt <- 1
}
}
if (right_width) {
if (hr_num >= i) {
if (image_right == FALSE) {
# Split strings if they exceed width
tmp2 <- split_string_html(hr[[i]], right_width, rs$units)
ret <- paste0(ret, "<td style=\"text-align:right\">", encodeHTML(tmp2$html),
"</td></tr>\n")
rcnt <- tmp2$lines
} else {
# Get image code
tmp_nm <- tempfile(tmpdir = tempdir(), fileext = ".jpg")
file.copy(hr$image_path[i], tmp_nm, overwrite = TRUE)
hr$width <- min(hr$width, right_width)
img <- get_image_html(tmp_nm, rs$modified_path, hr, rs$units)
ret <- paste0(ret, "<td style=\"text-align:right\">", img, "</td>")
rheight <- hr$height
}
} else {
ret <- paste0(ret, "<td style=\"text-align:right\"> </td></tr>\n")
rcnt <- 1
}
}
# if (lcnt > rcnt)
# cnt <- cnt + lcnt
# else
# cnt <- cnt + rcnt
cnt <- cnt + max(lcnt, ccnt, rcnt)
max_height <- max_height + max(lheight, cheight, rheight)
}
ret <- paste0(ret, "</table>")
dev.off()
if (max_height > 0) {
cnt <- max(cnt, round(max_height/ rs$line_height))
}
if (rs$page_header_blank_row == "below") {
ret <- paste0(ret, "<br>")
cnt <- cnt + 1
}
}
res <- list(html = ret, lines = cnt)
return(res)
}
#' @import grDevices
#' @noRd
get_page_footer_html <- function(rs) {
ret <- ""
cnt <- 1
# fl <- rs$page_footer_left
# fc <- rs$page_footer_center
# fr <- rs$page_footer_right
#
# maxf <- max(length(fl), length(fc), length(fr))
if ((!is.null(rs$footer_image_left) & is.null(rs$page_footer_left)) |
(!is.null(rs$footer_image_right) & is.null(rs$page_footer_right)) |
(!is.null(rs$footer_image_center) & is.null(rs$page_footer_center))) {
stop("`page_footer` must be used when using `footer_image`.")
}
image_left <- FALSE
image_center <- FALSE
image_right <- FALSE
if (!is.null(rs$footer_image_left)) {
fl <- rs$footer_image_left
image_left <- TRUE
} else {
fl <- rs$page_footer_left
}
if (!is.null(rs$footer_image_center)) {
fc <- rs$footer_image_center
image_center <- TRUE
} else {
fc <- rs$page_footer_center
}
if (!is.null(rs$footer_image_right)) {
fr <- rs$footer_image_right
image_right <- TRUE
} else {
fr <- rs$page_footer_right
}
fl_num <- ifelse(image_left, length(fl$image_path), length(fl))
fc_num <- ifelse(image_center, length(fc$image_path), length(fc))
fr_num <- ifelse(image_right, length(fr$image_path) , length(fr))
maxf <- max(fl_num, fc_num, fr_num)
if (maxf > 0) {
width <- rs$page_footer_width
# Make sure the length is 3, NA will be imputed later.
width <- c(width, rep(NA, 3 - length(width)))
total_width <- sum(width, na.rm = T)
if (total_width > rs$content_size[["width"]]) {
stop(sprintf("Total width of page footer %s %s cannot be greater than content width %s %s.",
total_width,
rs$units,
rs$content_size[["width"]],
rs$units))
} else {
na_num <- sum(is.na(width))
imputed_width <- (rs$content_size[["width"]] - total_width) / na_num
left_width <- ifelse(is.na(width[1]), imputed_width, width[1])
center_width <- ifelse(is.na(width[2]), imputed_width, width[2])
right_width <- ifelse(is.na(width[3]), imputed_width, width[3])
left_pct <- 100 * left_width/rs$content_size[["width"]]
center_pct <- 100 * center_width/rs$content_size[["width"]]
right_pct <- 100 * right_width/rs$content_size[["width"]]
}
# ret <- paste0("<br>\n<table ",
# "style=\"width:100%\">\n",
# paste0("<colgroup>\n<col style=\"width:", left_pct,"%\">\n"),
# paste0("<col style=\"width:", center_pct,"%\">\n"),
# paste0("<col style=\"width:", right_pct,"%\">\n</colgroup>\n"))
ret <- paste0("<br>\n<table ",
"style=\"width:100%\">\n",
"<colgroup>\n",
ifelse(left_pct > 0, paste0("<col style=\"width:", left_pct,"%\">\n"), ""),
ifelse(center_pct > 0, paste0("<col style=\"width:", center_pct,"%\">\n"), ""),
ifelse(right_pct > 0, paste0("<col style=\"width:", right_pct,"%\">\n"), ""),
"</colgroup>\n")
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
u <- rs$units
if (u == "inches") {
u <- "in"
}
lcnt <- 0
ccnt <- 0
rcnt <- 0
lheight <- 0
cheight <- 0
rheight <- 0
max_height <- 0
for (i in seq(1, maxf)) {
ret <- paste0(ret, "<tr>")
if (left_width > 0) {
if (fl_num >= i) {
if (image_left == FALSE) {
# Split strings if they exceed width
tmp1 <- split_string_html(fl[[i]], left_width, rs$units)
ret <- paste0(ret, "<td style=\"text-align:left\">", encodeHTML(tmp1$html),
"</td>")
lcnt <- tmp1$lines
} else {
# Get image code
tmp_nm <- tempfile(tmpdir = tempdir(), fileext = ".jpg")
file.copy(fl$image_path[i], tmp_nm, overwrite = TRUE)
fl$width <- min(fl$width, left_width)
img <- get_image_html(tmp_nm, rs$modified_path, fl, rs$units)
ret <- paste0(ret, "<td style=\"text-align:left\">", img, "</td>")
lheight <- fl$height
}
} else {
ret <- paste0(ret, "<td style=\"text-align:left\"> </td>")
lcnt <- 1
}
}
if (center_width > 0) {
if (fc_num >= i) {
if (image_center == FALSE) {
# Split strings if they exceed width
tmp2 <- split_string_html(fc[[i]], center_width, rs$units)
ret <- paste0(ret, "<td style=\"text-align:center\">", encodeHTML(tmp2$html),
"</td>")
ccnt <- tmp2$lines
} else {
# Get image code
tmp_nm <- tempfile(tmpdir = tempdir(), fileext = ".jpg")
file.copy(fc$image_path[i], tmp_nm, overwrite = TRUE)
fc$width <- min(fc$width, center_width)
img <- get_image_html(tmp_nm, rs$modified_path, fc, rs$units)
ret <- paste0(ret, "<td style=\"text-align:center\">", img, "</td>")
cheight <- fc$height
}
} else {
ret <- paste0(ret, "<td style=\"text-align:center\"> </td>")
ccnt <- 1
}
}
if (right_width > 0) {
if (fr_num >= i) {
if (image_right == FALSE) {
tmp3 <- split_string_html(fr[[i]], right_width, rs$units)
ret <- paste0(ret, "<td style=\"text-align:right\">", encodeHTML(tmp3$html),
"</td>")
rcnt <- tmp3$lines
} else {
# Get image code
tmp_nm <- tempfile(tmpdir = tempdir(), fileext = ".jpg")
file.copy(fr$image_path[i], tmp_nm, overwrite = TRUE)
fr$width <- min(fr$width, right_width)
img <- get_image_html(tmp_nm, rs$modified_path, fr, rs$units)
ret <- paste0(ret, "<td style=\"text-align:right\">", img, "</td>")
rheight <- fr$height
}
} else {
ret <- paste0(ret, "<td style=\"text-align:right\"> </td>")
rcnt <- 1
}
}
cnt <- cnt + max(lcnt, ccnt, rcnt)
max_height <- max_height + max(lheight, cheight, rheight)
}
dev.off()
if (max_height > 0) {
cnt <- max(cnt, round(max_height/ rs$line_height))
}
ret <- paste0(ret, "</tr>\n")
}
ret <- paste0(ret, "</table>\n")
res <- list(html = paste0(ret, collapse = ""),
lines = cnt)
return(res)
}
#' @import grDevices
#' @noRd
get_titles_html <- function(ttllst, content_width, rs, talgn = "center") {
ret <- c()
cnt <- 0
border_flag <- FALSE
# ta <- "align=\"left\" "
# if (talgn == "right")
# ta <- "align=\"right\" "
# else if (talgn %in% c("center", "centre"))
# ta <- "align=\"center\" "
sty <- paste0(get_style_html(rs, "title_font_color"),
get_style_html(rs, "title_background"),
get_style_html(rs, "title_font_bold"),
get_style_html(rs, "title_font_size"))
u <- rs$units
if (rs$units == "inches")
u <- "in"
if (length(ttllst) > 0) {
for (ttls in ttllst) {
cols <- ttls$columns
if (ttls$width == "page")
width <- rs$content_size[["width"]]
else if (ttls$width == "content")
width <- content_width
else if (is.numeric(ttls$width))
width <- ttls$width
w <- round(width, 3)
cwidth <- width / cols
cw <- w / cols
if (ttls$align %in% c("centre", "center"))
algn <- "text-align: center;"
else if (ttls$align == "right")
algn <- "text-align: right;"
else
algn <- "text-align: left;"
alcnt <- 0
blcnt <- 0
# Open device context
pdf(NULL)
if (!is.null(ttls$font_size)) {
ttlfs <- ttls$font_size
} else {
ttlfs <- rs$font_size
}
par(family = get_font_family(rs$font), ps = ttlfs)
ret[length(ret) + 1] <- paste0("<table ",
"style=\"width:", w, u, ";",
sty,
"\">\n")
al <- ""
if (any(ttls$blank_row %in% c("above", "both"))) {
alcnt <- 1
tb <- get_cell_borders_html(1, 1, length(ttls$titles) + alcnt,
1, ttls$borders,
border_color = get_style(rs, "border_color"))
if (tb == "")
al <- paste0("<tr><td colspan=\"", cols, "\"> </td></tr>\n")
else
al <- paste0("<tr><td style=\"", tb, "\" colspan=\"", cols,
"\"> </td></tr>\n")
# Can append now, since it is first
ret[length(ret) + 1] <- al
cnt <- cnt + 1
}
bl <- ""
if (any(ttls$blank_row %in% c("below", "both"))) {
blcnt <- 1
tb <- get_cell_borders_html(length(ttls$titles) + alcnt + blcnt, 1,
length(ttls$titles) + alcnt + blcnt,
1, ttls$borders,
border_color = get_style(rs, "border_color"))
if (tb == "")
bl <- paste0("<tr><td colspan=\"", cols, "\"> </td></tr>\n")
else
bl <- paste0("<tr><td style=\"", tb, "\" colspan=\"", cols,
"\"> </td></tr>\n")
# Wait to append until after title rows
cnt <- cnt + 1
}
i <- 1
while (i <= length(ttls$titles)) {
# Calculate current row
rwnum <- ceiling(i / cols)
mxlns <- 0
rw <- "<tr>"
for (j in seq_len(cols)) {
b <- get_cell_borders_html(rwnum + alcnt, j,
length(ttls$titles) + alcnt + blcnt,
cols, ttls$borders,
border_color = get_style(rs, "border_color"))
# Not all cells have titles
if (i > length(ttls$titles))
vl <- ""
else
vl <- ttls$titles[[i]]
# Deal with column alignments
if (cols == 1) {
calgn <- algn
} else if (cols == 2) {
if (j == 1)
calgn <- "text-align: left;"
else
calgn <- "text-align: right;"
} else if (cols == 3) {
if (j == 1)
calgn <- "text-align: left;"
else if (j == 2)
calgn <- "text-align: center;"
else if (j == 3)
calgn <- "text-align: right;"
}
cws <- paste0("width:", cw, u, ";")
valgn <- "vertical-align:text-top;"
# Split title strings if they exceed width
tmp <- split_string_html(vl, cwidth, rs$units)
# Track max lines for counting
if (tmp$lines > mxlns)
mxlns <- tmp$lines
if (ttls$bold)
tstr <- paste0("<b>", encodeHTML(tmp$html), "</b>")
else
tstr <- encodeHTML(tmp$html)
fz <- ""
if (!is.null(ttls$font_size)){
fz <- paste0("font-size:", ttls$font_size, "pt;")
}
# Concatenate title string
rw <- paste0(rw, paste0("<td style=\"", cws, b, fz, calgn, valgn, "\">",
tstr, "</td>\n"))
i <- i + 1
}
ret <- append(ret, paste0(rw, "</tr>\n"))
# Keep track of lines
cnt <- cnt + mxlns
# A flag to indicate that this block has bottom borders.
# Used to eliminate border duplication on subsequent blocks.
if ("bottom" %in% get_outer_borders(ttls$borders))
border_flag <- TRUE
}
# Append blank row at bottom
if (bl != "")
ret <- append(ret, bl)
ret[length(ret) + 1] <- "</table>"
dev.off()
}
}
res <- list(html = paste0(ret, collapse = ""),
lines = cnt,
border_flag = border_flag)
return(res)
}
#' @import grDevices
#' @noRd
get_titles_html_back <- function(ttllst, content_width, rs, talgn = "center") {
ret <- c()
cnt <- 0
border_flag <- FALSE
# ta <- "align=\"left\" "
# if (talgn == "right")
# ta <- "align=\"right\" "
# else if (talgn %in% c("center", "centre"))
# ta <- "align=\"center\" "
sty <- paste0(get_style_html(rs, "title_font_color"),
get_style_html(rs, "title_background"),
get_style_html(rs, "title_font_bold"),
get_style_html(rs, "title_font_size"))
u <- rs$units
if (rs$units == "inches")
u <- "in"
if (length(ttllst) > 0) {
for (ttls in ttllst) {
if (ttls$width == "page")
width <- rs$content_size[["width"]]
else if (ttls$width == "content")
width <- content_width
else if (is.numeric(ttls$width))
width <- ttls$width
w <- round(width, 3)
if (ttls$align %in% c("centre", "center"))
algn <- "text-align: center;"
else if (ttls$align == "right")
algn <- "text-align: right;"
else
algn <- "text-align: left;"
alcnt <- 0
blcnt <- 0
# Open device context
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
ret[length(ret) + 1] <- paste0("<table ",
"style=\"width:", w, u, ";",
algn, sty,
"\">\n")
for (i in seq_along(ttls$titles)) {
al <- ""
if (i == 1) {
if (any(ttls$blank_row %in% c("above", "both"))) {
alcnt <- 1
tb <- get_cell_borders_html(i, 1, length(ttls$titles) + alcnt,
1, ttls$borders,
border_color = get_style(rs, "border_color"))
if (tb == "")
al <- "<tr><td> </td></tr>\n"
else
al <- paste0("<tr><td style=\"", tb, "\"> </td></tr>\n")
cnt <- cnt + 1
}
}
bl <- ""
if (i == length(ttls$titles)) {
if (any(ttls$blank_row %in% c("below", "both"))) {
blcnt <- 1
tb <- get_cell_borders_html(i + alcnt + blcnt, 1,
length(ttls$titles) + alcnt + blcnt,
1, ttls$borders,
border_color = get_style(rs, "border_color"))
if (tb == "")
bl <- "<tr><td> </td></tr>\n"
else
bl <- paste0("<tr><td style=\"", tb, "\"> </td></tr>\n")
cnt <- cnt + 1
}
}
b <- get_cell_borders_html(i + alcnt, 1,
length(ttls$titles) + alcnt + blcnt,
1, ttls$borders,
border_color = get_style(rs, "border_color"))
# Split title strings if they exceed width
tmp <- split_string_html(ttls$titles[[i]], width, rs$units)
if (ttls$bold)
tstr <- paste0("<b>", encodeHTML(tmp$html), "</b>")
else
tstr <- encodeHTML(tmp$html)
fz <- ""
if (!is.null(ttls$font_size)){
fz <- paste0("font-size:", ttls$font_size, "pt;")
}
# Concatenate title string
if (al != "")
ret <- append(ret, al)
if (b == "" & fz == "") {
ret <- append(ret, paste0("<tr><td>", tstr,
"</td></tr>\n"))
} else {
ret <- append(ret, paste0("<tr><td style=\"", b, fz, "\">",
tstr,
"</td></tr>\n"))
}
if (bl != "")
ret <- append(ret, bl)
cnt <- cnt + tmp$lines
# A flag to indicate that this block has bottom borders.
# Used to eliminate border duplication on subsequent blocks.
if ("bottom" %in% get_outer_borders(ttls$borders))
border_flag <- TRUE
}
ret[length(ret) + 1] <- "</table>"
dev.off()
}
}
res <- list(html = paste0(ret, collapse = ""),
lines = cnt,
border_flag = border_flag)
return(res)
}
#' @import grDevices
#' @noRd
get_footnotes_html <- function(ftnlst, content_width, rs, talgn = "center",
ex_brdr = FALSE) {
ret <- c()
cnt <- 0
exclude_top <- NULL
if (ex_brdr)
exclude_top <- "top"
u <- rs$units
if (rs$units == "inches")
u <- "in"
sty <- paste0(get_style_html(rs, "footnote_font_color"),
get_style_html(rs, "footnote_background"),
get_style_html(rs, "footnote_font_bold"))
if (length(ftnlst) > 0) {
for (ftnts in ftnlst) {
cols <- ftnts$columns
if (ftnts$width == "page")
width <- rs$content_size[["width"]]
else if (ftnts$width == "content")
width <- content_width
else if (is.numeric(ftnts$width))
width <- ftnts$width
w <- round(width, 3)
cwidth <- width / cols
cw <- w / cols
if (ftnts$align %in% c("centre", "center"))
algn <- "text-align: center;"
else if (ftnts$align == "right")
algn <- "text-align: right;"
else
algn <- "text-align: left;"
alcnt <- 0
blcnt <- 0
pdf(NULL)
if (!is.null(ftnts$font_size)) {
ftntfs <- ftnts$font_size
} else {
ftntfs <- rs$font_size
}
par(family = get_font_family(rs$font), ps = ftntfs)
ret[length(ret) + 1] <- paste0("<table ",
"style=\"width:", w, u, ";",
algn, sty,
"\">\n")
al <- ""
if (any(ftnts$blank_row %in% c("above", "both"))) {
alcnt <- 1
tb <- get_cell_borders_html(1, 1, length(ftnts$footnotes) + alcnt,
1, ftnts$borders, exclude = exclude_top,
border_color = get_style(rs, "border_color"))
if (tb == "")
al <- paste0("<tr><td colspan=\"", cols, "\"> </td></tr>\n")
else
al <- paste0("<tr><td style=\"", tb, "\" colspan=\"", cols,
"\"> </td></tr>\n")
# Can append now, since it is first
ret[length(ret) + 1] <- al
cnt <- cnt + 1
}
bl <- ""
if (any(ftnts$blank_row %in% c("below", "both"))) {
blcnt <- 1
tb <- get_cell_borders_html(length(ftnts$footnotes) + alcnt + blcnt, 1,
length(ftnts$footnotes) + alcnt + blcnt,
1, ftnts$borders,
border_color = get_style(rs, "border_color"))
if (tb == "")
bl <- paste0("<tr><td colspan=\"", cols, "\"> </td></tr>\n")
else
bl <- paste0("<tr><td style=\"", tb, "\" colspan=\"", cols,
"\"> </td></tr>\n")
cnt <- cnt + 1
}
i <- 1
while (i <= length(ftnts$footnotes)) {
# Calculate current row
rwnum <- ceiling(i / cols)
mxlns <- 0
rw <- "<tr>"
for (j in seq_len(cols)) {
b <- get_cell_borders_html(rwnum + alcnt, j,
length(ftnts$footnotes) + alcnt + blcnt,
cols, ftnts$borders, exclude = exclude_top,
border_color = get_style(rs, "border_color"))
# Not all cells have titles
if (i > length(ftnts$footnotes))
vl <- ""
else
vl <- ftnts$footnotes[[i]]
# Deal with column alignments
if (cols == 1) {
calgn <- algn
} else if (cols == 2) {
if (j == 1)
calgn <- "text-align: left;"
else
calgn <- "text-align: right;"
} else if (cols == 3) {
if (j == 1)
calgn <- "text-align: left;"
else if (j == 2)
calgn <- "text-align: center;"
else if (j == 3)
calgn <- "text-align: right;"
}
cws <- paste0("width:", cw, u, ";")
valgn <- "vertical-align:text-top;"
# Split footnote strings if they exceed width
tmp <- split_string_html(vl, cwidth, rs$units)
# Track max lines for counting
if (tmp$lines > mxlns)
mxlns <- tmp$lines
if (ftnts$italics)
txt <- paste0("<i>", encodeHTML(tmp$html), "</i>")
else
txt <- encodeHTML(tmp$html)
# if (b == "")
# ret <- append(ret, paste0("<tr><td>", txt,
# "</td></tr>\n"))
# else {
# ret <- append(ret, paste0("<tr><td style=\"", b, "\">",
# txt,
# "</td></tr>\n"))
#}
fz <- ""
if (!is.null(ftnts$font_size)){
fz <- paste0("font-size:", ftnts$font_size, "pt;")
}
# Concat tags and footnote content
rw <- paste0(rw, paste0("<td style=\"", cws, b, fz, calgn, valgn, "\">",
txt, "</td>\n"))
i <- i + 1
}
ret <- append(ret, paste0(rw, "</tr>\n"))
# Keep track of lines
cnt <- cnt + mxlns
}
if (bl != "")
ret <- append(ret, bl)
ret[length(ret) + 1] <- "</table>"
dev.off()
}
}
res <- list(html = paste0(ret, collapse = ""),
lines = cnt)
return(res)
}
#' @import grDevices
#' @noRd
get_footnotes_html_back <- function(ftnlst, content_width, rs, talgn = "center",
ex_brdr = FALSE) {
ret <- c()
cnt <- 0
exclude_top <- NULL
if (ex_brdr)
exclude_top <- "top"
u <- rs$units
if (rs$units == "inches")
u <- "in"
sty <- paste0(get_style_html(rs, "footnote_font_color"),
get_style_html(rs, "footnote_background"),
get_style_html(rs, "footnote_font_bold"))
if (length(ftnlst) > 0) {
for (ftnts in ftnlst) {
if (ftnts$width == "page")
width <- rs$content_size[["width"]]
else if (ftnts$width == "content")
width <- content_width
else if (is.numeric(ftnts$width))
width <- ftnts$width
w <- round(width, 3)
if (ftnts$align %in% c("centre", "center"))
algn <- "text-align: center;"
else if (ftnts$align == "right")
algn <- "text-align: right;"
else
algn <- "text-align: left;"
alcnt <- 0
blcnt <- 0
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
ret[length(ret) + 1] <- paste0("<table ",
"style=\"width:", w, u, ";",
algn, sty,
"\">\n")
for (i in seq_along(ftnts$footnotes)) {
al <- ""
if (i == 1) {
if (any(ftnts$blank_row %in% c("above", "both"))) {
alcnt <- 1
tb <- get_cell_borders_html(i, 1, length(ftnts$footnotes) + alcnt,
1, ftnts$borders, exclude = exclude_top,
border_color = get_style(rs, "border_color"))
if (tb == "")
al <- "<tr><td> </td></tr>\n"
else
al <- paste0("<tr><td style=\"", tb, "\"> </td></tr>\n")
cnt <- cnt + 1
}
}
bl <- ""
if (i == length(ftnts$footnotes)) {
if (any(ftnts$blank_row %in% c("below", "both"))) {
blcnt <- 1
tb <- get_cell_borders_html(i + alcnt + blcnt, 1,
length(ftnts$footnotes) + alcnt + blcnt,
1, ftnts$borders,
border_color = get_style(rs, "border_color"))
if (tb == "")
bl <- "<tr><td> </td></tr>\n"
else
bl <- paste0("<tr><td style=\"", tb, "\"> </td></tr>\n")
cnt <- cnt + 1
}
}
b <- get_cell_borders_html(i + alcnt, 1,
length(ftnts$footnotes) + alcnt + blcnt,
1, ftnts$borders, exclude = exclude_top,
border_color = get_style(rs, "border_color"))
# Split footnote strings if they exceed width
tmp <- split_string_html(ftnts$footnotes[[i]], width, rs$units)
if (al != "")
ret <- append(ret, al)
if (ftnts$italics)
txt <- paste0("<i>", encodeHTML(tmp$html), "</i>")
else
txt <- encodeHTML(tmp$html)
if (b == "")
ret <- append(ret, paste0("<tr><td>", txt,
"</td></tr>\n"))
else {
ret <- append(ret, paste0("<tr><td style=\"", b, "\">",
txt,
"</td></tr>\n"))
}
if (bl != "")
ret <- append(ret, bl)
cnt <- cnt + tmp$lines
}
ret[length(ret) + 1] <- "</table>"
dev.off()
}
}
res <- list(html = paste0(ret, collapse = ""),
lines = cnt)
return(res)
}
#' @import grDevices
#' @noRd
get_title_header_html <- function(thdrlst, content_width, rs, talgn = "center") {
ret <- c()
cnt <- 0
border_flag <- FALSE
u <- rs$units
if (rs$units == "inches")
u <- "in"
if (length(thdrlst) > 0) {
for (ttlhdr in thdrlst) {
if (ttlhdr$width == "page")
width <- rs$content_size[["width"]]
else if (ttlhdr$width == "content")
width <- content_width
else if (is.numeric(ttlhdr$width))
width <- ttlhdr$width
w <- round(width, 3)
mx <- max(length(ttlhdr$titles), length(ttlhdr$right))
alcnt <- 0
blcnt <- 0
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
ret[length(ret) + 1] <- paste0("<table ",
"style=\"width:", w, u, ";",
"\">\n",
"<colgroup><col style=\"width:70%;\">\n",
"<col style=\"width:30%;\"></colgroup>\n")
for(i in seq_len(mx)) {
al <- ""
if (i == 1) {
if (any(ttlhdr$blank_row %in% c("above", "both"))) {
alcnt <- 1
tb1 <- get_cell_borders_html(i, 1, mx + alcnt,
2, ttlhdr$borders,
border_color = get_style(rs, "border_color"))
tb2 <- get_cell_borders_html(i, 2, mx + alcnt,
2, ttlhdr$borders,
border_color = get_style(rs, "border_color"))
al <- paste0("<tr><td style=\"text-align:left;", tb1, "\"> </td>",
"<td style=\"text-align:right;", tb2,
"\"> </td></tr>\n")
cnt <- cnt + 1
}
}
bl <- ""
if (i == mx) {
if (any(ttlhdr$blank_row %in% c("below", "both"))) {
blcnt <- 1
tb1 <- get_cell_borders_html(i + alcnt + blcnt, 1,
mx + alcnt + blcnt,
2, ttlhdr$borders,
border_color = get_style(rs, "border_color"))
tb2 <- get_cell_borders_html(i + alcnt + blcnt, 2,
mx + alcnt + blcnt,
2, ttlhdr$borders,
border_color = get_style(rs, "border_color"))
bl <- paste0("<tr><td style=\"text-align:left;", tb1, "\"> </td>",
"<td style=\"text-align:right;", tb2,
"\"> </td></tr>\n")
cnt <- cnt + 1
}
}
if (length(ttlhdr$titles) >= i) {
# Split strings if they exceed width
tmp1 <- split_string_html(ttlhdr$titles[[i]], width * .7, rs$units)
ttl <- tmp1$html
tcnt <- tmp1$lines
} else {
ttl <- ""
tcnt <- 1
}
if (length(ttlhdr$right) >= i) {
tmp2 <- split_string_html(ttlhdr$right[[i]],
width * .3, rs$units)
hdr <- get_page_numbers_html(tmp2$html, FALSE)
hdr <- tmp2$html
hcnt <- tmp2$lines
} else {
hdr <- ""
hcnt <- 1
}
b1 <- get_cell_borders_html(i + alcnt, 1, mx + alcnt + blcnt,
2, ttlhdr$borders,
border_color = get_style(rs, "border_color"))
b2 <- get_cell_borders_html(i + alcnt, 2, mx+ alcnt + blcnt,
2, ttlhdr$borders,
border_color = get_style(rs, "border_color"))
if (al != "")
ret <- append(ret, al)
ret <- append(ret, paste0("<tr><td style=\"text-align:left;", b1, "\">",
encodeHTML(ttl),
"</td><td style=\"text-align:right;", b2, "\">",
encodeHTML(hdr),
"</td></tr>\n"))
if (bl != "")
ret <- append(ret, bl)
if (tcnt > hcnt)
cnt <- cnt + tcnt
else
cnt <- cnt + hcnt
if ("bottom" %in% get_outer_borders(ttlhdr$borders))
border_flag <- TRUE
}
ret[length(ret) + 1] <- "</table>\n"
dev.off()
}
}
res <- list(html = paste0(ret, collapse = ""),
lines = cnt,
border_flag = border_flag)
return(res)
}
#' Get page by text strings suitable for printing
#' @import stringi
#' @return A vector of strings
#' @noRd
get_page_by_html <- function(pgby, width, value, rs, talgn, ex_brdr = FALSE, pgby_cnt = NULL) {
if (is.null(width)) {
stop("width cannot be null.")
}
if (is.null(value))
value <- get_pgby_value(value, pgby_cnt)
ll <- width
ret <- c()
cnt <- 0
border_flag <- FALSE
exclude_top <- NULL
if (ex_brdr)
exclude_top <- "top"
if (!is.null(pgby)) {
if (!any(class(pgby) == "page_by"))
stop("pgby parameter value is not a page_by.")
w <- paste0("width:", round(width, 3), units_html(rs$units), ";")
if (pgby$align %in% c("centre", "center"))
algn <- "text-align: center;"
else if (pgby$align == "right")
algn <- "text-align: right;"
else
algn <- "text-align: left;"
ret[length(ret) + 1] <- paste0("<table style=\"", algn, w, "\">\n")
trows <- 1
brow <- 1
if (pgby$blank_row %in% c("above", "both")) {
trows <- trows + 1
brow <- 2
}
if (pgby$blank_row %in% c("below", "both"))
trows <- trows + 1
if (pgby$blank_row %in% c("above", "both")) {
tb <- get_cell_borders_html(1, 1, trows, 1, pgby$borders,
exclude = exclude_top,
border_color = get_style(rs, "border_color"))
ret[length(ret) + 1] <- paste0("<tr><td style=\"", tb,
"\"> </td></tr>\n")
cnt <- cnt + 1
}
tb <- get_cell_borders_html(brow, 1 , trows, 1, pgby$borders,
exclude = exclude_top,
border_color = get_style(rs, "border_color"))
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
# # Account for multiple pgby lines
# tmp <- split_string_html(value, width, rs$units)
#
# dev.off()
#
# vl <- tmp$html
# cnt <- cnt + tmp$lines
#
# # Construct HTML for page by
# ret[length(ret) + 1] <- paste0("<tr><td style=\"", tb, "\">",
# pgby$label, encodeHTML(vl), "</td></tr>\n")
# #cnt <- cnt + 1
# Add bold
if (pgby$bold %in% c(TRUE, FALSE)) {
if (substr(pgby$label, nchar(pgby$label), nchar(pgby$label)) != " "){
sep <- " "
} else {
sep <- ""
}
tmp <- split_string_html(paste0(pgby$label, sep, value), width, rs$units)
vl <- tmp$html
cnt <- cnt + tmp$lines
if (pgby$bold ) {
page_by_text <- paste0("<b>", encodeHTML(vl), "</b>")
} else {
page_by_text <- encodeHTML(vl)
}
} else if (pgby$bold %in% c("value", "label")) {
# Split label
label_split <- split_string_html(pgby$label, width, rs$units)
cnt <- cnt + label_split$lines
# Use remain width to split value
remain_width <- width - label_split$widths[length(label_split$widths)]
value_split <- split_string_html(value, remain_width, rs$units)
if (value_split$widths[1] > remain_width) {
# If first width is bigger than remaining width, it means value starts a new line
value_split <- split_string_html(value, width, rs$units)
cnt <- cnt + value_split$lines
value_split_txt <- value_split$html
} else {
# Otherwise, split with full width if there is a second line
splt <- strsplit(value_split$html, split = "\n", fixed = TRUE)
if (length(splt[[1]]) > 1) {
remain_value <- trimws(sub(splt[[1]][1], "", value), which = "left")
remain_value_split <- split_string_html(remain_value, width, rs$units)
cnt <- cnt + remain_value_split$lines
value_split_txt <- paste0(splt[[1]][1], "\n", remain_value_split$html)
} else {
value_split_txt <- value_split$html
}
}
if (pgby$bold == "label") {
page_by_text <- paste0("<b>", encodeHTML(paste0(label_split$html, " ")), "</b>", encodeHTML(value_split_txt))
} else {
page_by_text <- paste0(encodeHTML(paste0(label_split$html, " ")), "<b>", encodeHTML(value_split_txt), "</b>")
}
}
dev.off()
# Construct HTML for page by
ret[length(ret) + 1] <- paste0("<tr><td style=\"", tb, "\">",
page_by_text, "</td></tr>\n")
if (pgby$blank_row %in% c("below", "both")) {
tb <- get_cell_borders_html(trows, 1, trows, 1, pgby$borders,
border_color = get_style(rs, "border_color"))
ret[length(ret) + 1] <- paste0("<tr><td style=\"", tb,
"\"> </td></tr>\n")
cnt <- cnt + 1
}
ret[length(ret) + 1] <- "</table>"
if ("bottom" %in% get_outer_borders(pgby$borders))
border_flag <- TRUE
}
res <- list(html = paste0(ret, collapse = ""),
lines = cnt,
border_flag = border_flag)
return(res)
}
# Utilities ---------------------------------------------------------------
#' @description Return border code for a particular cell. Idea is
#' you pass in the size of the table and the particular cell position,
#' and this function will return the correct border codes. System works
#' great.
#' @noRd
get_cell_borders_html <- function(row, col, nrow, ncol, brdrs,
flag = "", exclude = NULL,
border_color = "",
stub_flag = FALSE,
cell_border = NULL) {
t <- ""
b <- ""
l <- ""
r <- ""
if (border_color == "")
border_color <- "black"
if ("all" %in% brdrs) {
t <- paste0("border-top:thin solid ", border_color, ";")
b <- paste0("border-bottom:thin solid ", border_color, ";")
l <- paste0("border-left:thin solid ", border_color, ";")
r <- paste0("border-right:thin solid ", border_color, ";")
if (row > 1)
t <- ""
if (col < ncol & stub_flag == FALSE)
r <- ""
} else {
if ("inside" %in% brdrs) {
t <- ""
b <- paste0("border-bottom:thin solid ", border_color, ";")
l <- paste0("border-left:thin solid ", border_color, ";")
r <- ""
if (col == 1)
l <- ""
if (col == ncol)
r <- ""
if (row == nrow)
b <- ""
if (row == 1)
t <- ""
}
if (row == 1 & any(brdrs %in% c("outside", "top")) |
any(cell_border %in% c("outside", "top"))
) {
t <- paste0("border-top:thin solid ", border_color, ";")
}
if (row == nrow & any(brdrs %in% c("bottom", "outside")) |
any(cell_border %in% c("bottom", "outside"))
) {
b <- paste0("border-bottom:thin solid ", border_color, ";")
}
if (col == 1 & any(brdrs %in% c("outside", "left")) |
any(cell_border %in% c("outside", "left"))
) {
l <- paste0("border-left:thin solid ", border_color, ";")
}
if (col == ncol & any(brdrs %in% c("outside", "right")) |
any(cell_border %in% c("outside", "right"))
) {
r <- paste0("border-right:thin solid ", border_color, ";")
}
}
# Deal with flag
# Flag is for special rows like blanks or labels
if (!is.null(flag)) {
if (flag %in% c("L", "B", "A")) {
if (stub_flag == FALSE & col == 1 & any(brdrs %in% c("outside", "all", "right")))
r <- paste0("border-right:thin solid ", border_color, ";")
else if (col != ncol & stub_flag == FALSE)
r <- ""
if (col != 1)
l <- ""
}
}
if (!is.null(exclude)) {
if (any(exclude == "top"))
t <- ""
if (any(exclude == "bottom"))
b <- ""
if (any(exclude == "left"))
l <- ""
if (any(exclude == "right"))
r <- ""
}
ret <- paste0(t, b, l, r)
return(ret)
}
get_page_numbers_html <- function(val, tpg = TRUE) {
ret <- val
ret <- gsub("[pg]", "\\chpgn ", ret, fixed = TRUE)
if (tpg)
ret <- gsub("[tpg]", "{\\field{\\*\\fldinst NUMPAGES }}", ret, fixed = TRUE)
return(ret)
}
Try the reporter package in your browser
Any scripts or data that you put into this service are public.
reporter documentation built on Feb. 7, 2026, 9:07 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 get_page_numbers_html get_cell_borders_html get_page_by_html get_title_header_html get_footnotes_html_back get_footnotes_html get_titles_html_back get_titles_html get_page_footer_html get_page_header_html page_template_html
# The page template is everything except the content: page header/footer,
# titles, footnotes, etc.
# Page Template HTML Functions ---------------------------------------------
#' Create a page template with header, titles, footnotes, and footer.
#' @param rs The report spec
#' @return The page template object
#' @noRd
page_template_html <- function(rs) {
pt <- structure(list(), class = c("page_template_html", "list"))
pt$page_header <- get_page_header_html(rs)
pt$title_hdr <- get_title_header_html(rs$title_hdr, rs$line_size, rs)
pt$titles <- get_titles_html(rs$titles, rs$line_size, rs)
pt$footnotes <- c()
if (!is.null(rs$footnotes)) {
if (!is.null(rs$footnotes[[1]])) {
if (rs$footnotes[[1]]$valign == "bottom")
pt$footnotes <- get_footnotes_html(rs$footnotes, rs$line_size, rs)
}
}
pt$page_footer <- get_page_footer_html(rs)
pt$lines <- sum(pt$page_header$lines, pt$page_footer$lines,
pt$title_hdr$lines, pt$titles$lines, pt$footnotes$lines)
# Page by not here. Messes up line counts.
return(pt)
}
#' @import grDevices
#' @noRd
get_page_header_html <- function(rs) {
ret <- ""
cnt <- 0
# hl <- rs$page_header_left
# hr <- rs$page_header_right
# maxh <- max(length(hl), length(hr))
# # User controlled width of left column
# lwdth <- rs$page_header_width
# if (is.null(lwdth))
# lwdth <- rs$content_size[["width"]]/2
#
# # Calculate right column width
# rwdth <- rs$content_size[["width"]] - lwdth
# lpct <- round(lwdth / rs$content_size[["width"]] * 100)
# rpct <- round(rwdth / rs$content_size[["width"]] * 100)
if ((!is.null(rs$header_image_left) & is.null(rs$page_header_left)) |
(!is.null(rs$header_image_center) & is.null(rs$page_header_center)) |
(!is.null(rs$header_image_right) & is.null(rs$page_header_right))) {
stop("`page_header` must be used when using `header_image`.")
}
# Make sure the length is 3, NA will be imputed later.
width <- c(rs$page_header_width, rep(NA, 3 - length(rs$page_header_width)))
image_left <- FALSE
image_center <- FALSE
image_right <- FALSE
if (!is.null(rs$header_image_left)) {
image_left <- TRUE
hl <- rs$header_image_left
} else{
hl <- rs$page_header_left
}
if (!is.null(rs$header_image_right)) {
image_right <- TRUE
hr <- rs$header_image_right
} else {
hr <- rs$page_header_right
}
if (!is.null(rs$header_image_center)) {
image_center <- TRUE
hc <- rs$header_image_center
# Default center cell is not displayed, open it when picture exists
if (width[2] == 0) {
width[2] <- NA
}
} else {
hc <- rs$page_header_center
}
hl_num <- ifelse(image_left, length(hl$image_path), length(hl))
hc_num <- ifelse(image_center, length(hc$image_path), length(hc))
hr_num <- ifelse(image_right, length(hr$image_path) , length(hr))
maxh <- max(hl_num, hc_num, hr_num)
# Calculate the widths
total_width <- sum(width, na.rm = T)
if (total_width > rs$content_size[["width"]]) {
stop(sprintf("Total width of page footer %s %s cannot be greater than content width %s %s.",
total_width,
rs$units,
rs$content_size[["width"]],
rs$units))
} else {
na_num <- sum(is.na(width))
imputed_width <- (rs$content_size[["width"]] - total_width) / na_num
left_width <- ifelse(is.na(width[1]), imputed_width, width[1])
center_width <- ifelse(is.na(width[2]), imputed_width, width[2])
right_width <- ifelse(is.na(width[3]), imputed_width, width[3])
left_pct <- 100 * left_width/rs$content_size[["width"]]
center_pct <- 100 * center_width/rs$content_size[["width"]]
right_pct <- 100 * right_width/rs$content_size[["width"]]
}
if (maxh > 0) {
# ret <- paste0("<table ",
# "style=\"width:100%\">",
# "<colgroup>\n<col style=\"width:", left_pct, "%\">\n",
# "<col style=\"width:", right_pct,"%\">\n</colgroup>\n")
ret <- paste0("<table ",
"style=\"width:100%\">",
"<colgroup>\n",
ifelse(left_pct > 0, paste0("<col style=\"width:", left_pct, "%\">\n"), ""),
ifelse(center_pct > 0, paste0("<col style=\"width:", center_pct, "%\">\n"), ""),
ifelse(right_pct > 0, paste0("<col style=\"width:", right_pct,"%\">\n"), ""),
"</colgroup>\n")
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
u <- rs$units
if (rs$units == "inches") {
u <- "in"
}
lcnt <- 0
ccnt <- 0
rcnt <- 0
lheight <- 0
cheight <- 0
rheight <- 0
max_height <- 0
for (i in seq(1, maxh)) {
ret <- paste0(ret, "<tr>")
if (left_width > 0) {
if (hl_num >= i) {
if (image_left == FALSE) {
# Split strings if they exceed width
tmp <- split_string_html(hl[[i]], left_width, rs$units)
ret <- paste0(ret, "<td style=\"text-align:left\">", encodeHTML(tmp$html),
"</td>\n")
lcnt <- tmp$lines
} else {
# Get image code
tmp_nm <- tempfile(tmpdir = tempdir(), fileext = ".jpg")
file.copy(hl$image_path[i], tmp_nm, overwrite = TRUE)
hl$width <- min(hl$width, left_width)
img <- get_image_html(tmp_nm, rs$modified_path, hl, rs$units)
ret <- paste0(ret, "<td style=\"text-align:left\">", img, "</td>")
lheight <- hl$height
}
} else {
ret <- paste0(ret, "<td style=\"text-align:left\"> </td>\n")
lcnt <- 1
}
}
if (center_width > 0) {
if (hc_num >= i) {
if (image_center == FALSE) {
# Split strings if they exceed width
tmp3 <- split_string_html(hc[[i]], center_width, rs$units)
ret <- paste0(ret, "<td style=\"text-align:center\">", encodeHTML(tmp3$html),
"</td>\n")
ccnt <- tmp3$lines
} else {
# Get image code
tmp_nm <- tempfile(tmpdir = tempdir(), fileext = ".jpg")
file.copy(hc$image_path[i], tmp_nm, overwrite = TRUE)
hc$width <- min(hc$width, center_width)
img <- get_image_html(tmp_nm, rs$modified_path, hc, rs$units)
ret <- paste0(ret, "<td style=\"text-align:center\">", img, "</td>")
cheight <- hc$height
}
} else {
ret <- paste0(ret, "<td style=\"text-align:center\"> </td>\n")
ccnt <- 1
}
}
if (right_width) {
if (hr_num >= i) {
if (image_right == FALSE) {
# Split strings if they exceed width
tmp2 <- split_string_html(hr[[i]], right_width, rs$units)
ret <- paste0(ret, "<td style=\"text-align:right\">", encodeHTML(tmp2$html),
"</td></tr>\n")
rcnt <- tmp2$lines
} else {
# Get image code
tmp_nm <- tempfile(tmpdir = tempdir(), fileext = ".jpg")
file.copy(hr$image_path[i], tmp_nm, overwrite = TRUE)
hr$width <- min(hr$width, right_width)
img <- get_image_html(tmp_nm, rs$modified_path, hr, rs$units)
ret <- paste0(ret, "<td style=\"text-align:right\">", img, "</td>")
rheight <- hr$height
}
} else {
ret <- paste0(ret, "<td style=\"text-align:right\"> </td></tr>\n")
rcnt <- 1
}
}
# if (lcnt > rcnt)
# cnt <- cnt + lcnt
# else
# cnt <- cnt + rcnt
cnt <- cnt + max(lcnt, ccnt, rcnt)
max_height <- max_height + max(lheight, cheight, rheight)
}
ret <- paste0(ret, "</table>")
dev.off()
if (max_height > 0) {
cnt <- max(cnt, round(max_height/ rs$line_height))
}
if (rs$page_header_blank_row == "below") {
ret <- paste0(ret, "<br>")
cnt <- cnt + 1
}
}
res <- list(html = ret, lines = cnt)
return(res)
}
#' @import grDevices
#' @noRd
get_page_footer_html <- function(rs) {
ret <- ""
cnt <- 1
# fl <- rs$page_footer_left
# fc <- rs$page_footer_center
# fr <- rs$page_footer_right
#
# maxf <- max(length(fl), length(fc), length(fr))
if ((!is.null(rs$footer_image_left) & is.null(rs$page_footer_left)) |
(!is.null(rs$footer_image_right) & is.null(rs$page_footer_right)) |
(!is.null(rs$footer_image_center) & is.null(rs$page_footer_center))) {
stop("`page_footer` must be used when using `footer_image`.")
}
image_left <- FALSE
image_center <- FALSE
image_right <- FALSE
if (!is.null(rs$footer_image_left)) {
fl <- rs$footer_image_left
image_left <- TRUE
} else {
fl <- rs$page_footer_left
}
if (!is.null(rs$footer_image_center)) {
fc <- rs$footer_image_center
image_center <- TRUE
} else {
fc <- rs$page_footer_center
}
if (!is.null(rs$footer_image_right)) {
fr <- rs$footer_image_right
image_right <- TRUE
} else {
fr <- rs$page_footer_right
}
fl_num <- ifelse(image_left, length(fl$image_path), length(fl))
fc_num <- ifelse(image_center, length(fc$image_path), length(fc))
fr_num <- ifelse(image_right, length(fr$image_path) , length(fr))
maxf <- max(fl_num, fc_num, fr_num)
if (maxf > 0) {
width <- rs$page_footer_width
# Make sure the length is 3, NA will be imputed later.
width <- c(width, rep(NA, 3 - length(width)))
total_width <- sum(width, na.rm = T)
if (total_width > rs$content_size[["width"]]) {
stop(sprintf("Total width of page footer %s %s cannot be greater than content width %s %s.",
total_width,
rs$units,
rs$content_size[["width"]],
rs$units))
} else {
na_num <- sum(is.na(width))
imputed_width <- (rs$content_size[["width"]] - total_width) / na_num
left_width <- ifelse(is.na(width[1]), imputed_width, width[1])
center_width <- ifelse(is.na(width[2]), imputed_width, width[2])
right_width <- ifelse(is.na(width[3]), imputed_width, width[3])
left_pct <- 100 * left_width/rs$content_size[["width"]]
center_pct <- 100 * center_width/rs$content_size[["width"]]
right_pct <- 100 * right_width/rs$content_size[["width"]]
}
# ret <- paste0("<br>\n<table ",
# "style=\"width:100%\">\n",
# paste0("<colgroup>\n<col style=\"width:", left_pct,"%\">\n"),
# paste0("<col style=\"width:", center_pct,"%\">\n"),
# paste0("<col style=\"width:", right_pct,"%\">\n</colgroup>\n"))
ret <- paste0("<br>\n<table ",
"style=\"width:100%\">\n",
"<colgroup>\n",
ifelse(left_pct > 0, paste0("<col style=\"width:", left_pct,"%\">\n"), ""),
ifelse(center_pct > 0, paste0("<col style=\"width:", center_pct,"%\">\n"), ""),
ifelse(right_pct > 0, paste0("<col style=\"width:", right_pct,"%\">\n"), ""),
"</colgroup>\n")
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
u <- rs$units
if (u == "inches") {
u <- "in"
}
lcnt <- 0
ccnt <- 0
rcnt <- 0
lheight <- 0
cheight <- 0
rheight <- 0
max_height <- 0
for (i in seq(1, maxf)) {
ret <- paste0(ret, "<tr>")
if (left_width > 0) {
if (fl_num >= i) {
if (image_left == FALSE) {
# Split strings if they exceed width
tmp1 <- split_string_html(fl[[i]], left_width, rs$units)
ret <- paste0(ret, "<td style=\"text-align:left\">", encodeHTML(tmp1$html),
"</td>")
lcnt <- tmp1$lines
} else {
# Get image code
tmp_nm <- tempfile(tmpdir = tempdir(), fileext = ".jpg")
file.copy(fl$image_path[i], tmp_nm, overwrite = TRUE)
fl$width <- min(fl$width, left_width)
img <- get_image_html(tmp_nm, rs$modified_path, fl, rs$units)
ret <- paste0(ret, "<td style=\"text-align:left\">", img, "</td>")
lheight <- fl$height
}
} else {
ret <- paste0(ret, "<td style=\"text-align:left\"> </td>")
lcnt <- 1
}
}
if (center_width > 0) {
if (fc_num >= i) {
if (image_center == FALSE) {
# Split strings if they exceed width
tmp2 <- split_string_html(fc[[i]], center_width, rs$units)
ret <- paste0(ret, "<td style=\"text-align:center\">", encodeHTML(tmp2$html),
"</td>")
ccnt <- tmp2$lines
} else {
# Get image code
tmp_nm <- tempfile(tmpdir = tempdir(), fileext = ".jpg")
file.copy(fc$image_path[i], tmp_nm, overwrite = TRUE)
fc$width <- min(fc$width, center_width)
img <- get_image_html(tmp_nm, rs$modified_path, fc, rs$units)
ret <- paste0(ret, "<td style=\"text-align:center\">", img, "</td>")
cheight <- fc$height
}
} else {
ret <- paste0(ret, "<td style=\"text-align:center\"> </td>")
ccnt <- 1
}
}
if (right_width > 0) {
if (fr_num >= i) {
if (image_right == FALSE) {
tmp3 <- split_string_html(fr[[i]], right_width, rs$units)
ret <- paste0(ret, "<td style=\"text-align:right\">", encodeHTML(tmp3$html),
"</td>")
rcnt <- tmp3$lines
} else {
# Get image code
tmp_nm <- tempfile(tmpdir = tempdir(), fileext = ".jpg")
file.copy(fr$image_path[i], tmp_nm, overwrite = TRUE)
fr$width <- min(fr$width, right_width)
img <- get_image_html(tmp_nm, rs$modified_path, fr, rs$units)
ret <- paste0(ret, "<td style=\"text-align:right\">", img, "</td>")
rheight <- fr$height
}
} else {
ret <- paste0(ret, "<td style=\"text-align:right\"> </td>")
rcnt <- 1
}
}
cnt <- cnt + max(lcnt, ccnt, rcnt)
max_height <- max_height + max(lheight, cheight, rheight)
}
dev.off()
if (max_height > 0) {
cnt <- max(cnt, round(max_height/ rs$line_height))
}
ret <- paste0(ret, "</tr>\n")
}
ret <- paste0(ret, "</table>\n")
res <- list(html = paste0(ret, collapse = ""),
lines = cnt)
return(res)
}
#' @import grDevices
#' @noRd
get_titles_html <- function(ttllst, content_width, rs, talgn = "center") {
ret <- c()
cnt <- 0
border_flag <- FALSE
# ta <- "align=\"left\" "
# if (talgn == "right")
# ta <- "align=\"right\" "
# else if (talgn %in% c("center", "centre"))
# ta <- "align=\"center\" "
sty <- paste0(get_style_html(rs, "title_font_color"),
get_style_html(rs, "title_background"),
get_style_html(rs, "title_font_bold"),
get_style_html(rs, "title_font_size"))
u <- rs$units
if (rs$units == "inches")
u <- "in"
if (length(ttllst) > 0) {
for (ttls in ttllst) {
cols <- ttls$columns
if (ttls$width == "page")
width <- rs$content_size[["width"]]
else if (ttls$width == "content")
width <- content_width
else if (is.numeric(ttls$width))
width <- ttls$width
w <- round(width, 3)
cwidth <- width / cols
cw <- w / cols
if (ttls$align %in% c("centre", "center"))
algn <- "text-align: center;"
else if (ttls$align == "right")
algn <- "text-align: right;"
else
algn <- "text-align: left;"
alcnt <- 0
blcnt <- 0
# Open device context
pdf(NULL)
if (!is.null(ttls$font_size)) {
ttlfs <- ttls$font_size
} else {
ttlfs <- rs$font_size
}
par(family = get_font_family(rs$font), ps = ttlfs)
ret[length(ret) + 1] <- paste0("<table ",
"style=\"width:", w, u, ";",
sty,
"\">\n")
al <- ""
if (any(ttls$blank_row %in% c("above", "both"))) {
alcnt <- 1
tb <- get_cell_borders_html(1, 1, length(ttls$titles) + alcnt,
1, ttls$borders,
border_color = get_style(rs, "border_color"))
if (tb == "")
al <- paste0("<tr><td colspan=\"", cols, "\"> </td></tr>\n")
else
al <- paste0("<tr><td style=\"", tb, "\" colspan=\"", cols,
"\"> </td></tr>\n")
# Can append now, since it is first
ret[length(ret) + 1] <- al
cnt <- cnt + 1
}
bl <- ""
if (any(ttls$blank_row %in% c("below", "both"))) {
blcnt <- 1
tb <- get_cell_borders_html(length(ttls$titles) + alcnt + blcnt, 1,
length(ttls$titles) + alcnt + blcnt,
1, ttls$borders,
border_color = get_style(rs, "border_color"))
if (tb == "")
bl <- paste0("<tr><td colspan=\"", cols, "\"> </td></tr>\n")
else
bl <- paste0("<tr><td style=\"", tb, "\" colspan=\"", cols,
"\"> </td></tr>\n")
# Wait to append until after title rows
cnt <- cnt + 1
}
i <- 1
while (i <= length(ttls$titles)) {
# Calculate current row
rwnum <- ceiling(i / cols)
mxlns <- 0
rw <- "<tr>"
for (j in seq_len(cols)) {
b <- get_cell_borders_html(rwnum + alcnt, j,
length(ttls$titles) + alcnt + blcnt,
cols, ttls$borders,
border_color = get_style(rs, "border_color"))
# Not all cells have titles
if (i > length(ttls$titles))
vl <- ""
else
vl <- ttls$titles[[i]]
# Deal with column alignments
if (cols == 1) {
calgn <- algn
} else if (cols == 2) {
if (j == 1)
calgn <- "text-align: left;"
else
calgn <- "text-align: right;"
} else if (cols == 3) {
if (j == 1)
calgn <- "text-align: left;"
else if (j == 2)
calgn <- "text-align: center;"
else if (j == 3)
calgn <- "text-align: right;"
}
cws <- paste0("width:", cw, u, ";")
valgn <- "vertical-align:text-top;"
# Split title strings if they exceed width
tmp <- split_string_html(vl, cwidth, rs$units)
# Track max lines for counting
if (tmp$lines > mxlns)
mxlns <- tmp$lines
if (ttls$bold)
tstr <- paste0("<b>", encodeHTML(tmp$html), "</b>")
else
tstr <- encodeHTML(tmp$html)
fz <- ""
if (!is.null(ttls$font_size)){
fz <- paste0("font-size:", ttls$font_size, "pt;")
}
# Concatenate title string
rw <- paste0(rw, paste0("<td style=\"", cws, b, fz, calgn, valgn, "\">",
tstr, "</td>\n"))
i <- i + 1
}
ret <- append(ret, paste0(rw, "</tr>\n"))
# Keep track of lines
cnt <- cnt + mxlns
# A flag to indicate that this block has bottom borders.
# Used to eliminate border duplication on subsequent blocks.
if ("bottom" %in% get_outer_borders(ttls$borders))
border_flag <- TRUE
}
# Append blank row at bottom
if (bl != "")
ret <- append(ret, bl)
ret[length(ret) + 1] <- "</table>"
dev.off()
}
}
res <- list(html = paste0(ret, collapse = ""),
lines = cnt,
border_flag = border_flag)
return(res)
}
#' @import grDevices
#' @noRd
get_titles_html_back <- function(ttllst, content_width, rs, talgn = "center") {
ret <- c()
cnt <- 0
border_flag <- FALSE
# ta <- "align=\"left\" "
# if (talgn == "right")
# ta <- "align=\"right\" "
# else if (talgn %in% c("center", "centre"))
# ta <- "align=\"center\" "
sty <- paste0(get_style_html(rs, "title_font_color"),
get_style_html(rs, "title_background"),
get_style_html(rs, "title_font_bold"),
get_style_html(rs, "title_font_size"))
u <- rs$units
if (rs$units == "inches")
u <- "in"
if (length(ttllst) > 0) {
for (ttls in ttllst) {
if (ttls$width == "page")
width <- rs$content_size[["width"]]
else if (ttls$width == "content")
width <- content_width
else if (is.numeric(ttls$width))
width <- ttls$width
w <- round(width, 3)
if (ttls$align %in% c("centre", "center"))
algn <- "text-align: center;"
else if (ttls$align == "right")
algn <- "text-align: right;"
else
algn <- "text-align: left;"
alcnt <- 0
blcnt <- 0
# Open device context
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
ret[length(ret) + 1] <- paste0("<table ",
"style=\"width:", w, u, ";",
algn, sty,
"\">\n")
for (i in seq_along(ttls$titles)) {
al <- ""
if (i == 1) {
if (any(ttls$blank_row %in% c("above", "both"))) {
alcnt <- 1
tb <- get_cell_borders_html(i, 1, length(ttls$titles) + alcnt,
1, ttls$borders,
border_color = get_style(rs, "border_color"))
if (tb == "")
al <- "<tr><td> </td></tr>\n"
else
al <- paste0("<tr><td style=\"", tb, "\"> </td></tr>\n")
cnt <- cnt + 1
}
}
bl <- ""
if (i == length(ttls$titles)) {
if (any(ttls$blank_row %in% c("below", "both"))) {
blcnt <- 1
tb <- get_cell_borders_html(i + alcnt + blcnt, 1,
length(ttls$titles) + alcnt + blcnt,
1, ttls$borders,
border_color = get_style(rs, "border_color"))
if (tb == "")
bl <- "<tr><td> </td></tr>\n"
else
bl <- paste0("<tr><td style=\"", tb, "\"> </td></tr>\n")
cnt <- cnt + 1
}
}
b <- get_cell_borders_html(i + alcnt, 1,
length(ttls$titles) + alcnt + blcnt,
1, ttls$borders,
border_color = get_style(rs, "border_color"))
# Split title strings if they exceed width
tmp <- split_string_html(ttls$titles[[i]], width, rs$units)
if (ttls$bold)
tstr <- paste0("<b>", encodeHTML(tmp$html), "</b>")
else
tstr <- encodeHTML(tmp$html)
fz <- ""
if (!is.null(ttls$font_size)){
fz <- paste0("font-size:", ttls$font_size, "pt;")
}
# Concatenate title string
if (al != "")
ret <- append(ret, al)
if (b == "" & fz == "") {
ret <- append(ret, paste0("<tr><td>", tstr,
"</td></tr>\n"))
} else {
ret <- append(ret, paste0("<tr><td style=\"", b, fz, "\">",
tstr,
"</td></tr>\n"))
}
if (bl != "")
ret <- append(ret, bl)
cnt <- cnt + tmp$lines
# A flag to indicate that this block has bottom borders.
# Used to eliminate border duplication on subsequent blocks.
if ("bottom" %in% get_outer_borders(ttls$borders))
border_flag <- TRUE
}
ret[length(ret) + 1] <- "</table>"
dev.off()
}
}
res <- list(html = paste0(ret, collapse = ""),
lines = cnt,
border_flag = border_flag)
return(res)
}
#' @import grDevices
#' @noRd
get_footnotes_html <- function(ftnlst, content_width, rs, talgn = "center",
ex_brdr = FALSE) {
ret <- c()
cnt <- 0
exclude_top <- NULL
if (ex_brdr)
exclude_top <- "top"
u <- rs$units
if (rs$units == "inches")
u <- "in"
sty <- paste0(get_style_html(rs, "footnote_font_color"),
get_style_html(rs, "footnote_background"),
get_style_html(rs, "footnote_font_bold"))
if (length(ftnlst) > 0) {
for (ftnts in ftnlst) {
cols <- ftnts$columns
if (ftnts$width == "page")
width <- rs$content_size[["width"]]
else if (ftnts$width == "content")
width <- content_width
else if (is.numeric(ftnts$width))
width <- ftnts$width
w <- round(width, 3)
cwidth <- width / cols
cw <- w / cols
if (ftnts$align %in% c("centre", "center"))
algn <- "text-align: center;"
else if (ftnts$align == "right")
algn <- "text-align: right;"
else
algn <- "text-align: left;"
alcnt <- 0
blcnt <- 0
pdf(NULL)
if (!is.null(ftnts$font_size)) {
ftntfs <- ftnts$font_size
} else {
ftntfs <- rs$font_size
}
par(family = get_font_family(rs$font), ps = ftntfs)
ret[length(ret) + 1] <- paste0("<table ",
"style=\"width:", w, u, ";",
algn, sty,
"\">\n")
al <- ""
if (any(ftnts$blank_row %in% c("above", "both"))) {
alcnt <- 1
tb <- get_cell_borders_html(1, 1, length(ftnts$footnotes) + alcnt,
1, ftnts$borders, exclude = exclude_top,
border_color = get_style(rs, "border_color"))
if (tb == "")
al <- paste0("<tr><td colspan=\"", cols, "\"> </td></tr>\n")
else
al <- paste0("<tr><td style=\"", tb, "\" colspan=\"", cols,
"\"> </td></tr>\n")
# Can append now, since it is first
ret[length(ret) + 1] <- al
cnt <- cnt + 1
}
bl <- ""
if (any(ftnts$blank_row %in% c("below", "both"))) {
blcnt <- 1
tb <- get_cell_borders_html(length(ftnts$footnotes) + alcnt + blcnt, 1,
length(ftnts$footnotes) + alcnt + blcnt,
1, ftnts$borders,
border_color = get_style(rs, "border_color"))
if (tb == "")
bl <- paste0("<tr><td colspan=\"", cols, "\"> </td></tr>\n")
else
bl <- paste0("<tr><td style=\"", tb, "\" colspan=\"", cols,
"\"> </td></tr>\n")
cnt <- cnt + 1
}
i <- 1
while (i <= length(ftnts$footnotes)) {
# Calculate current row
rwnum <- ceiling(i / cols)
mxlns <- 0
rw <- "<tr>"
for (j in seq_len(cols)) {
b <- get_cell_borders_html(rwnum + alcnt, j,
length(ftnts$footnotes) + alcnt + blcnt,
cols, ftnts$borders, exclude = exclude_top,
border_color = get_style(rs, "border_color"))
# Not all cells have titles
if (i > length(ftnts$footnotes))
vl <- ""
else
vl <- ftnts$footnotes[[i]]
# Deal with column alignments
if (cols == 1) {
calgn <- algn
} else if (cols == 2) {
if (j == 1)
calgn <- "text-align: left;"
else
calgn <- "text-align: right;"
} else if (cols == 3) {
if (j == 1)
calgn <- "text-align: left;"
else if (j == 2)
calgn <- "text-align: center;"
else if (j == 3)
calgn <- "text-align: right;"
}
cws <- paste0("width:", cw, u, ";")
valgn <- "vertical-align:text-top;"
# Split footnote strings if they exceed width
tmp <- split_string_html(vl, cwidth, rs$units)
# Track max lines for counting
if (tmp$lines > mxlns)
mxlns <- tmp$lines
if (ftnts$italics)
txt <- paste0("<i>", encodeHTML(tmp$html), "</i>")
else
txt <- encodeHTML(tmp$html)
# if (b == "")
# ret <- append(ret, paste0("<tr><td>", txt,
# "</td></tr>\n"))
# else {
# ret <- append(ret, paste0("<tr><td style=\"", b, "\">",
# txt,
# "</td></tr>\n"))
#}
fz <- ""
if (!is.null(ftnts$font_size)){
fz <- paste0("font-size:", ftnts$font_size, "pt;")
}
# Concat tags and footnote content
rw <- paste0(rw, paste0("<td style=\"", cws, b, fz, calgn, valgn, "\">",
txt, "</td>\n"))
i <- i + 1
}
ret <- append(ret, paste0(rw, "</tr>\n"))
# Keep track of lines
cnt <- cnt + mxlns
}
if (bl != "")
ret <- append(ret, bl)
ret[length(ret) + 1] <- "</table>"
dev.off()
}
}
res <- list(html = paste0(ret, collapse = ""),
lines = cnt)
return(res)
}
#' @import grDevices
#' @noRd
get_footnotes_html_back <- function(ftnlst, content_width, rs, talgn = "center",
ex_brdr = FALSE) {
ret <- c()
cnt <- 0
exclude_top <- NULL
if (ex_brdr)
exclude_top <- "top"
u <- rs$units
if (rs$units == "inches")
u <- "in"
sty <- paste0(get_style_html(rs, "footnote_font_color"),
get_style_html(rs, "footnote_background"),
get_style_html(rs, "footnote_font_bold"))
if (length(ftnlst) > 0) {
for (ftnts in ftnlst) {
if (ftnts$width == "page")
width <- rs$content_size[["width"]]
else if (ftnts$width == "content")
width <- content_width
else if (is.numeric(ftnts$width))
width <- ftnts$width
w <- round(width, 3)
if (ftnts$align %in% c("centre", "center"))
algn <- "text-align: center;"
else if (ftnts$align == "right")
algn <- "text-align: right;"
else
algn <- "text-align: left;"
alcnt <- 0
blcnt <- 0
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
ret[length(ret) + 1] <- paste0("<table ",
"style=\"width:", w, u, ";",
algn, sty,
"\">\n")
for (i in seq_along(ftnts$footnotes)) {
al <- ""
if (i == 1) {
if (any(ftnts$blank_row %in% c("above", "both"))) {
alcnt <- 1
tb <- get_cell_borders_html(i, 1, length(ftnts$footnotes) + alcnt,
1, ftnts$borders, exclude = exclude_top,
border_color = get_style(rs, "border_color"))
if (tb == "")
al <- "<tr><td> </td></tr>\n"
else
al <- paste0("<tr><td style=\"", tb, "\"> </td></tr>\n")
cnt <- cnt + 1
}
}
bl <- ""
if (i == length(ftnts$footnotes)) {
if (any(ftnts$blank_row %in% c("below", "both"))) {
blcnt <- 1
tb <- get_cell_borders_html(i + alcnt + blcnt, 1,
length(ftnts$footnotes) + alcnt + blcnt,
1, ftnts$borders,
border_color = get_style(rs, "border_color"))
if (tb == "")
bl <- "<tr><td> </td></tr>\n"
else
bl <- paste0("<tr><td style=\"", tb, "\"> </td></tr>\n")
cnt <- cnt + 1
}
}
b <- get_cell_borders_html(i + alcnt, 1,
length(ftnts$footnotes) + alcnt + blcnt,
1, ftnts$borders, exclude = exclude_top,
border_color = get_style(rs, "border_color"))
# Split footnote strings if they exceed width
tmp <- split_string_html(ftnts$footnotes[[i]], width, rs$units)
if (al != "")
ret <- append(ret, al)
if (ftnts$italics)
txt <- paste0("<i>", encodeHTML(tmp$html), "</i>")
else
txt <- encodeHTML(tmp$html)
if (b == "")
ret <- append(ret, paste0("<tr><td>", txt,
"</td></tr>\n"))
else {
ret <- append(ret, paste0("<tr><td style=\"", b, "\">",
txt,
"</td></tr>\n"))
}
if (bl != "")
ret <- append(ret, bl)
cnt <- cnt + tmp$lines
}
ret[length(ret) + 1] <- "</table>"
dev.off()
}
}
res <- list(html = paste0(ret, collapse = ""),
lines = cnt)
return(res)
}
#' @import grDevices
#' @noRd
get_title_header_html <- function(thdrlst, content_width, rs, talgn = "center") {
ret <- c()
cnt <- 0
border_flag <- FALSE
u <- rs$units
if (rs$units == "inches")
u <- "in"
if (length(thdrlst) > 0) {
for (ttlhdr in thdrlst) {
if (ttlhdr$width == "page")
width <- rs$content_size[["width"]]
else if (ttlhdr$width == "content")
width <- content_width
else if (is.numeric(ttlhdr$width))
width <- ttlhdr$width
w <- round(width, 3)
mx <- max(length(ttlhdr$titles), length(ttlhdr$right))
alcnt <- 0
blcnt <- 0
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
ret[length(ret) + 1] <- paste0("<table ",
"style=\"width:", w, u, ";",
"\">\n",
"<colgroup><col style=\"width:70%;\">\n",
"<col style=\"width:30%;\"></colgroup>\n")
for(i in seq_len(mx)) {
al <- ""
if (i == 1) {
if (any(ttlhdr$blank_row %in% c("above", "both"))) {
alcnt <- 1
tb1 <- get_cell_borders_html(i, 1, mx + alcnt,
2, ttlhdr$borders,
border_color = get_style(rs, "border_color"))
tb2 <- get_cell_borders_html(i, 2, mx + alcnt,
2, ttlhdr$borders,
border_color = get_style(rs, "border_color"))
al <- paste0("<tr><td style=\"text-align:left;", tb1, "\"> </td>",
"<td style=\"text-align:right;", tb2,
"\"> </td></tr>\n")
cnt <- cnt + 1
}
}
bl <- ""
if (i == mx) {
if (any(ttlhdr$blank_row %in% c("below", "both"))) {
blcnt <- 1
tb1 <- get_cell_borders_html(i + alcnt + blcnt, 1,
mx + alcnt + blcnt,
2, ttlhdr$borders,
border_color = get_style(rs, "border_color"))
tb2 <- get_cell_borders_html(i + alcnt + blcnt, 2,
mx + alcnt + blcnt,
2, ttlhdr$borders,
border_color = get_style(rs, "border_color"))
bl <- paste0("<tr><td style=\"text-align:left;", tb1, "\"> </td>",
"<td style=\"text-align:right;", tb2,
"\"> </td></tr>\n")
cnt <- cnt + 1
}
}
if (length(ttlhdr$titles) >= i) {
# Split strings if they exceed width
tmp1 <- split_string_html(ttlhdr$titles[[i]], width * .7, rs$units)
ttl <- tmp1$html
tcnt <- tmp1$lines
} else {
ttl <- ""
tcnt <- 1
}
if (length(ttlhdr$right) >= i) {
tmp2 <- split_string_html(ttlhdr$right[[i]],
width * .3, rs$units)
hdr <- get_page_numbers_html(tmp2$html, FALSE)
hdr <- tmp2$html
hcnt <- tmp2$lines
} else {
hdr <- ""
hcnt <- 1
}
b1 <- get_cell_borders_html(i + alcnt, 1, mx + alcnt + blcnt,
2, ttlhdr$borders,
border_color = get_style(rs, "border_color"))
b2 <- get_cell_borders_html(i + alcnt, 2, mx+ alcnt + blcnt,
2, ttlhdr$borders,
border_color = get_style(rs, "border_color"))
if (al != "")
ret <- append(ret, al)
ret <- append(ret, paste0("<tr><td style=\"text-align:left;", b1, "\">",
encodeHTML(ttl),
"</td><td style=\"text-align:right;", b2, "\">",
encodeHTML(hdr),
"</td></tr>\n"))
if (bl != "")
ret <- append(ret, bl)
if (tcnt > hcnt)
cnt <- cnt + tcnt
else
cnt <- cnt + hcnt
if ("bottom" %in% get_outer_borders(ttlhdr$borders))
border_flag <- TRUE
}
ret[length(ret) + 1] <- "</table>\n"
dev.off()
}
}
res <- list(html = paste0(ret, collapse = ""),
lines = cnt,
border_flag = border_flag)
return(res)
}
#' Get page by text strings suitable for printing
#' @import stringi
#' @return A vector of strings
#' @noRd
get_page_by_html <- function(pgby, width, value, rs, talgn, ex_brdr = FALSE, pgby_cnt = NULL) {
if (is.null(width)) {
stop("width cannot be null.")
}
if (is.null(value))
value <- get_pgby_value(value, pgby_cnt)
ll <- width
ret <- c()
cnt <- 0
border_flag <- FALSE
exclude_top <- NULL
if (ex_brdr)
exclude_top <- "top"
if (!is.null(pgby)) {
if (!any(class(pgby) == "page_by"))
stop("pgby parameter value is not a page_by.")
w <- paste0("width:", round(width, 3), units_html(rs$units), ";")
if (pgby$align %in% c("centre", "center"))
algn <- "text-align: center;"
else if (pgby$align == "right")
algn <- "text-align: right;"
else
algn <- "text-align: left;"
ret[length(ret) + 1] <- paste0("<table style=\"", algn, w, "\">\n")
trows <- 1
brow <- 1
if (pgby$blank_row %in% c("above", "both")) {
trows <- trows + 1
brow <- 2
}
if (pgby$blank_row %in% c("below", "both"))
trows <- trows + 1
if (pgby$blank_row %in% c("above", "both")) {
tb <- get_cell_borders_html(1, 1, trows, 1, pgby$borders,
exclude = exclude_top,
border_color = get_style(rs, "border_color"))
ret[length(ret) + 1] <- paste0("<tr><td style=\"", tb,
"\"> </td></tr>\n")
cnt <- cnt + 1
}
tb <- get_cell_borders_html(brow, 1 , trows, 1, pgby$borders,
exclude = exclude_top,
border_color = get_style(rs, "border_color"))
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
# # Account for multiple pgby lines
# tmp <- split_string_html(value, width, rs$units)
#
# dev.off()
#
# vl <- tmp$html
# cnt <- cnt + tmp$lines
#
# # Construct HTML for page by
# ret[length(ret) + 1] <- paste0("<tr><td style=\"", tb, "\">",
# pgby$label, encodeHTML(vl), "</td></tr>\n")
# #cnt <- cnt + 1
# Add bold
if (pgby$bold %in% c(TRUE, FALSE)) {
if (substr(pgby$label, nchar(pgby$label), nchar(pgby$label)) != " "){
sep <- " "
} else {
sep <- ""
}
tmp <- split_string_html(paste0(pgby$label, sep, value), width, rs$units)
vl <- tmp$html
cnt <- cnt + tmp$lines
if (pgby$bold ) {
page_by_text <- paste0("<b>", encodeHTML(vl), "</b>")
} else {
page_by_text <- encodeHTML(vl)
}
} else if (pgby$bold %in% c("value", "label")) {
# Split label
label_split <- split_string_html(pgby$label, width, rs$units)
cnt <- cnt + label_split$lines
# Use remain width to split value
remain_width <- width - label_split$widths[length(label_split$widths)]
value_split <- split_string_html(value, remain_width, rs$units)
if (value_split$widths[1] > remain_width) {
# If first width is bigger than remaining width, it means value starts a new line
value_split <- split_string_html(value, width, rs$units)
cnt <- cnt + value_split$lines
value_split_txt <- value_split$html
} else {
# Otherwise, split with full width if there is a second line
splt <- strsplit(value_split$html, split = "\n", fixed = TRUE)
if (length(splt[[1]]) > 1) {
remain_value <- trimws(sub(splt[[1]][1], "", value), which = "left")
remain_value_split <- split_string_html(remain_value, width, rs$units)
cnt <- cnt + remain_value_split$lines
value_split_txt <- paste0(splt[[1]][1], "\n", remain_value_split$html)
} else {
value_split_txt <- value_split$html
}
}
if (pgby$bold == "label") {
page_by_text <- paste0("<b>", encodeHTML(paste0(label_split$html, " ")), "</b>", encodeHTML(value_split_txt))
} else {
page_by_text <- paste0(encodeHTML(paste0(label_split$html, " ")), "<b>", encodeHTML(value_split_txt), "</b>")
}
}
dev.off()
# Construct HTML for page by
ret[length(ret) + 1] <- paste0("<tr><td style=\"", tb, "\">",
page_by_text, "</td></tr>\n")
if (pgby$blank_row %in% c("below", "both")) {
tb <- get_cell_borders_html(trows, 1, trows, 1, pgby$borders,
border_color = get_style(rs, "border_color"))
ret[length(ret) + 1] <- paste0("<tr><td style=\"", tb,
"\"> </td></tr>\n")
cnt <- cnt + 1
}
ret[length(ret) + 1] <- "</table>"
if ("bottom" %in% get_outer_borders(pgby$borders))
border_flag <- TRUE
}
res <- list(html = paste0(ret, collapse = ""),
lines = cnt,
border_flag = border_flag)
return(res)
}
# Utilities ---------------------------------------------------------------
#' @description Return border code for a particular cell. Idea is
#' you pass in the size of the table and the particular cell position,
#' and this function will return the correct border codes. System works
#' great.
#' @noRd
get_cell_borders_html <- function(row, col, nrow, ncol, brdrs,
flag = "", exclude = NULL,
border_color = "",
stub_flag = FALSE,
cell_border = NULL) {
t <- ""
b <- ""
l <- ""
r <- ""
if (border_color == "")
border_color <- "black"
if ("all" %in% brdrs) {
t <- paste0("border-top:thin solid ", border_color, ";")
b <- paste0("border-bottom:thin solid ", border_color, ";")
l <- paste0("border-left:thin solid ", border_color, ";")
r <- paste0("border-right:thin solid ", border_color, ";")
if (row > 1)
t <- ""
if (col < ncol & stub_flag == FALSE)
r <- ""
} else {
if ("inside" %in% brdrs) {
t <- ""
b <- paste0("border-bottom:thin solid ", border_color, ";")
l <- paste0("border-left:thin solid ", border_color, ";")
r <- ""
if (col == 1)
l <- ""
if (col == ncol)
r <- ""
if (row == nrow)
b <- ""
if (row == 1)
t <- ""
}
if (row == 1 & any(brdrs %in% c("outside", "top")) |
any(cell_border %in% c("outside", "top"))
) {
t <- paste0("border-top:thin solid ", border_color, ";")
}
if (row == nrow & any(brdrs %in% c("bottom", "outside")) |
any(cell_border %in% c("bottom", "outside"))
) {
b <- paste0("border-bottom:thin solid ", border_color, ";")
}
if (col == 1 & any(brdrs %in% c("outside", "left")) |
any(cell_border %in% c("outside", "left"))
) {
l <- paste0("border-left:thin solid ", border_color, ";")
}
if (col == ncol & any(brdrs %in% c("outside", "right")) |
any(cell_border %in% c("outside", "right"))
) {
r <- paste0("border-right:thin solid ", border_color, ";")
}
}
# Deal with flag
# Flag is for special rows like blanks or labels
if (!is.null(flag)) {
if (flag %in% c("L", "B", "A")) {
if (stub_flag == FALSE & col == 1 & any(brdrs %in% c("outside", "all", "right")))
r <- paste0("border-right:thin solid ", border_color, ";")
else if (col != ncol & stub_flag == FALSE)
r <- ""
if (col != 1)
l <- ""
}
}
if (!is.null(exclude)) {
if (any(exclude == "top"))
t <- ""
if (any(exclude == "bottom"))
b <- ""
if (any(exclude == "left"))
l <- ""
if (any(exclude == "right"))
r <- ""
}
ret <- paste0(t, b, l, r)
return(ret)
}
get_page_numbers_html <- function(val, tpg = TRUE) {
ret <- val
ret <- gsub("[pg]", "\\chpgn ", ret, fixed = TRUE)
if (tpg)
ret <- gsub("[tpg]", "{\\field{\\*\\fldinst NUMPAGES }}", ret, fixed = TRUE)
return(ret)
}
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.