diff --git a/.DS_Store b/.DS_Store
deleted file mode 100644
index 7b9d3374..00000000
Binary files a/.DS_Store and /dev/null differ
diff --git a/.Rbuildignore b/.Rbuildignore
index e22ba84b..b040f0c7 100644
--- a/.Rbuildignore
+++ b/.Rbuildignore
@@ -1,11 +1,22 @@
+..Rcheck
^docs$
^_pkgdown\.yml$
^r2rtf\.Rproj$
^\.Rproj\.user$
^pkgdown$
^pipelines-definition.groovy$
-^\vignettes\figure$
-^README.Rmd$
+^README\.Rmd$
^LICENSES_THIRD_PARTY$
^LICENSE$
+^inst\Rbadges$
+^\.gitignore$
+^\.DS_Store$
+^\.git\$
+^\vignettes\rtf$
+^\vignettes\fig$
+^\vignettes\example-figure.Rmd$
+^\vignettes\example-pipeline.Rmd$
+^\vignettes\rtf-row.Rmd$
+^\vignettes\rtf-text.Rmd$
^\.github$
+
diff --git a/.github/workflows/check-standard.yaml b/.github/workflows/check-standard.yaml
index 39b78666..f3855a35 100644
--- a/.github/workflows/check-standard.yaml
+++ b/.github/workflows/check-standard.yaml
@@ -20,7 +20,6 @@ jobs:
config:
- {os: windows-latest, r: '3.6'}
- {os: macOS-latest, r: '3.6'}
- - {os: macOS-latest, r: 'devel'}
- {os: ubuntu-16.04, r: '3.6', rspm: "https://demo.rstudiopm.com/all/__linux__/xenial/latest"}
env:
diff --git a/.gitignore b/.gitignore
index 0036c2f1..5941e122 100644
--- a/.gitignore
+++ b/.gitignore
@@ -3,3 +3,5 @@ docs
.Rproj.user
.Rhistory
.RData
+doc
+Meta
diff --git a/DESCRIPTION b/DESCRIPTION
index 4dbb9993..863bd786 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,17 +1,18 @@
Package: r2rtf
-Title: Easily Create Presentation-Ready RTF Table and Figure
-Version: 0.1.0
+Title: Easily Create Presentation-Ready Rich Text Format (RTF) Table and Figure
+Version: 0.1.1
Authors@R: c(
person("Yilong", "Zhang", email = "yilong.zhang@merck.com", role = c("aut", "cre")),
- person("Siruo", "Wang", email = "swang171@jhu.edu", role = c("aut")),
- person("Simiao", "Ye", email = "simiao.ye1@merck.com", role = c("aut"))
+ person("Siruo", "Wang", email = "swang171@jhu.edu", role = "aut"),
+ person("Simiao", "Ye", email = "simiao.ye1@merck.com", role = "aut"),
+ person("Merck Sharp & Dohme Corp", role = "cph")
)
-Description: Create RTF table and figure with flexible format.
-Depends: R (>= 3.4.0)
+Description: Create presentation-ready Rich Text Format (RTF) table and figure with flexible and customized format.
+Depends: R (>= 3.5.0)
License: GPL-3
Encoding: UTF-8
LazyData: true
-RoxygenNote: 6.1.1
+RoxygenNote: 7.0.2
VignetteBuilder: knitr
Roxygen: list(markdown = TRUE)
Suggests:
diff --git a/NEWS.md b/NEWS.md
new file mode 100644
index 00000000..e6db40cd
--- /dev/null
+++ b/NEWS.md
@@ -0,0 +1,9 @@
+# r2rtf 0.1.1
+
+* standardize input from `gt_tbl` to `tbl`
+* resolving UTF-8 encoding
+
+# r2rtf 0.1.0
+
+* Added a `NEWS.md` file to track changes to the package.
+* Initial Version
diff --git a/R/add_attributes.R b/R/add_attributes.R
index b541ff87..661517fa 100644
--- a/R/add_attributes.R
+++ b/R/add_attributes.R
@@ -21,7 +21,7 @@
#'
#' @description
#' add title, subtitle, and other attributes to the object
-#' @param gt_tbl a data frame
+#' @param tbl a data frame
#' @param title title string
#' @param subtitle subtitle string
#' @param font text font type
@@ -39,8 +39,16 @@
#' @param new_page boolean value to indicate whether to start a new page
#' @param hyphenation boolean value to indicate whether to use hyphenation
#'
+#' @return the same data frame \code{tbl} with additional attributes for table title
+#'
+#' @examples
+#' library(dplyr) # required to run examples
+#' data(tbl_1)
+#' tbl_1 %>% rtf_title(title = "ANCOVA of Change from Baseline at Week 8") %>%
+#' attr("rtf_heading")
+#'
#' @export
-rtf_title <- function(gt_tbl,
+rtf_title <- function(tbl,
title = NULL,
subtitle = NULL,
@@ -53,7 +61,7 @@ rtf_title <- function(gt_tbl,
justification = "c",
indent_first = 0,
- indent_left = 0,
+ indent_left = 0,
indent_right = 0,
space = 1,
@@ -61,41 +69,33 @@ rtf_title <- function(gt_tbl,
space_after = 180,
new_page = FALSE,
- hyphenation = TRUE){
-
-
- if ("rtf_heading" %in% names(attributes(gt_tbl))) {
-
- attr(gt_tbl, "rtf_heading")$title <- c(attr(gt_tbl, "rtf_heading")$title, title)
- attr(gt_tbl, "rtf_heading")$subtitle <- c(attr(gt_tbl, "rtf_heading")$subtitle, subtitle)
-
-
+ hyphenation = TRUE) {
+ if ("rtf_heading" %in% names(attributes(tbl))) {
+ attr(tbl, "rtf_heading")$title <- c(attr(tbl, "rtf_heading")$title, title)
+ attr(tbl, "rtf_heading")$subtitle <- c(attr(tbl, "rtf_heading")$subtitle, subtitle)
} else {
-
- attr(gt_tbl, "rtf_heading") <- list(title = title, subtitle = subtitle)
-
+ attr(tbl, "rtf_heading") <- list(title = title, subtitle = subtitle)
}
- attr(gt_tbl, "rtf_heading")$font <- font
- attr(gt_tbl, "rtf_heading")$format <- format
- attr(gt_tbl, "rtf_heading")$font_size <- font_size
- attr(gt_tbl, "rtf_heading")$color <- color
- attr(gt_tbl, "rtf_heading")$background_color <- background_color
- attr(gt_tbl, "rtf_heading")$justification <- justification
- attr(gt_tbl, "rtf_heading")$indent_first <- indent_first
- attr(gt_tbl, "rtf_heading")$indent_left <- indent_left
- attr(gt_tbl, "rtf_heading")$indent_right <- indent_right
- attr(gt_tbl, "rtf_heading")$space <- space
- attr(gt_tbl, "rtf_heading")$space_before <- space_before
- attr(gt_tbl, "rtf_heading")$space_after <- space_after
- attr(gt_tbl, "rtf_heading")$new_page <- new_page
- attr(gt_tbl, "rtf_heading")$hyphenation <- hyphenation
+ attr(tbl, "rtf_heading")$font <- font
+ attr(tbl, "rtf_heading")$format <- format
+ attr(tbl, "rtf_heading")$font_size <- font_size
+ attr(tbl, "rtf_heading")$color <- color
+ attr(tbl, "rtf_heading")$background_color <- background_color
+ attr(tbl, "rtf_heading")$justification <- justification
+ attr(tbl, "rtf_heading")$indent_first <- indent_first
+ attr(tbl, "rtf_heading")$indent_left <- indent_left
+ attr(tbl, "rtf_heading")$indent_right <- indent_right
+ attr(tbl, "rtf_heading")$space <- space
+ attr(tbl, "rtf_heading")$space_before <- space_before
+ attr(tbl, "rtf_heading")$space_after <- space_after
+ attr(tbl, "rtf_heading")$new_page <- new_page
+ attr(tbl, "rtf_heading")$hyphenation <- hyphenation
- gt_tbl
-
+ tbl
}
@@ -103,7 +103,7 @@ rtf_title <- function(gt_tbl,
#' @title Add footnote attributes to the table
#'
-#' @param gt_tbl a data frame
+#' @param tbl a data frame
#' @param footnote footnote text
#' @param font text font type
#' @param font_size text font size
@@ -120,8 +120,16 @@ rtf_title <- function(gt_tbl,
#' @param new_page boolean value to indicate whether to start a new page
#' @param hyphenation boolean value to indicate whether to use hyphenation
#'
+#' @return the same data frame \code{tbl} with additional attributes for table footnote
+#'
+#' @examples
+#' library(dplyr) # required to run examples
+#' data(tbl_1)
+#' tbl_1 %>% rtf_footnote("\\dagger Based on an ANCOVA model.") %>%
+#' attr("rtf_footnote")
+#'
#' @export
-rtf_footnote <- function(gt_tbl,
+rtf_footnote <- function(tbl,
footnote = NULL,
@@ -133,7 +141,7 @@ rtf_footnote <- function(gt_tbl,
justification = "c",
indent_first = 0,
- indent_left = 0,
+ indent_left = 0,
indent_right = 0,
space = 1,
@@ -141,44 +149,39 @@ rtf_footnote <- function(gt_tbl,
space_after = 0,
new_page = FALSE,
- hyphenation = TRUE){
-
-
- if ("rtf_footnote" %in% names(attributes(gt_tbl))) {
-
- attr(gt_tbl, "rtf_footnote")$footnote <- c(attr(gt_tbl, "rtf_footnote")$footnote, footnote)
-
+ hyphenation = TRUE) {
+ if ("rtf_footnote" %in% names(attributes(tbl))) {
+ attr(tbl, "rtf_footnote")$footnote <- c(attr(tbl, "rtf_footnote")$footnote, footnote)
} else {
-
- attr(gt_tbl, "rtf_footnote") <- list(footnote = footnote)
+ attr(tbl, "rtf_footnote") <- list(footnote = footnote)
}
if (justification == "l") {
- indent_left <- .footnote_source_space(gt_tbl)
+ indent_left <- .footnote_source_space(tbl)
} else if (justification == "r") {
- indent_right <- .footnote_source_space(gt_tbl)
+ indent_right <- .footnote_source_space(tbl)
}
- attr(gt_tbl, "rtf_footnote")$font <- font
- attr(gt_tbl, "rtf_footnote")$format <- format
- attr(gt_tbl, "rtf_footnote")$font_size <- font_size
- attr(gt_tbl, "rtf_footnote")$color <- color
- attr(gt_tbl, "rtf_footnote")$background_color <- background_color
- attr(gt_tbl, "rtf_footnote")$justification <- justification
- attr(gt_tbl, "rtf_footnote")$indent_first <- indent_first
- attr(gt_tbl, "rtf_footnote")$indent_left <- indent_left
- attr(gt_tbl, "rtf_footnote")$indent_right <- indent_right
- attr(gt_tbl, "rtf_footnote")$space <- space
- attr(gt_tbl, "rtf_footnote")$space_before <- space_before
- attr(gt_tbl, "rtf_footnote")$space_after <- space_after
- attr(gt_tbl, "rtf_footnote")$new_page <- new_page
- attr(gt_tbl, "rtf_footnote")$hyphenation <- hyphenation
+ attr(tbl, "rtf_footnote")$font <- font
+ attr(tbl, "rtf_footnote")$format <- format
+ attr(tbl, "rtf_footnote")$font_size <- font_size
+ attr(tbl, "rtf_footnote")$color <- color
+ attr(tbl, "rtf_footnote")$background_color <- background_color
+ attr(tbl, "rtf_footnote")$justification <- justification
+ attr(tbl, "rtf_footnote")$indent_first <- indent_first
+ attr(tbl, "rtf_footnote")$indent_left <- indent_left
+ attr(tbl, "rtf_footnote")$indent_right <- indent_right
+ attr(tbl, "rtf_footnote")$space <- space
+ attr(tbl, "rtf_footnote")$space_before <- space_before
+ attr(tbl, "rtf_footnote")$space_after <- space_after
+ attr(tbl, "rtf_footnote")$new_page <- new_page
+ attr(tbl, "rtf_footnote")$hyphenation <- hyphenation
- gt_tbl
+ tbl
}
@@ -187,7 +190,7 @@ rtf_footnote <- function(gt_tbl,
#' @title Add data source attributes to the table
#'
-#' @param gt_tbl A data frame
+#' @param tbl A data frame
#' @param source data source text
#' @param font text font type
#' @param font_size text font size
@@ -204,8 +207,16 @@ rtf_footnote <- function(gt_tbl,
#' @param new_page boolean value to indicate whether to start a new page
#' @param hyphenation boolean value to indicate whether to use hyphenation
#'
+#' @return the same data frame \code{tbl} with additional attributes for data source of a table
+#'
+#' @examples
+#' library(dplyr) # required to run examples
+#' data(tbl_1)
+#' tbl_1 %>% rtf_source("Source: [study999:adam-adeff]") %>%
+#' attr("rtf_source")
+#'
#' @export
-rtf_source <- function(gt_tbl,
+rtf_source <- function(tbl,
source = NULL,
@@ -217,7 +228,7 @@ rtf_source <- function(gt_tbl,
justification = "c",
indent_first = 0,
- indent_left = 0,
+ indent_left = 0,
indent_right = 0,
space = 1,
@@ -225,58 +236,51 @@ rtf_source <- function(gt_tbl,
space_after = 0,
new_page = FALSE,
- hyphenation = TRUE){
-
-
- if ("rtf_source" %in% names(attributes(gt_tbl))) {
-
- attr(gt_tbl, "rtf_source")$source <- c(attr(gt_tbl, "rtf_source")$source, source)
-
+ hyphenation = TRUE) {
+ if ("rtf_source" %in% names(attributes(tbl))) {
+ attr(tbl, "rtf_source")$source <- c(attr(tbl, "rtf_source")$source, source)
} else {
-
- attr(gt_tbl, "rtf_source") <- list(source = source)
+ attr(tbl, "rtf_source") <- list(source = source)
}
if (justification == "l") {
- indent_left <- .footnote_source_space(gt_tbl)
+ indent_left <- .footnote_source_space(tbl)
} else if (justification == "r") {
- indent_right <- .footnote_source_space(gt_tbl)
+ indent_right <- .footnote_source_space(tbl)
}
- attr(gt_tbl, "rtf_source")$font <- font
- attr(gt_tbl, "rtf_source")$format <- format
- attr(gt_tbl, "rtf_source")$font_size <- font_size
- attr(gt_tbl, "rtf_source")$color <- color
- attr(gt_tbl, "rtf_source")$background_color <- background_color
- attr(gt_tbl, "rtf_source")$justification <- justification
- attr(gt_tbl, "rtf_source")$indent_first <- indent_first
- attr(gt_tbl, "rtf_source")$indent_left <- indent_left
- attr(gt_tbl, "rtf_source")$indent_right <- indent_right
- attr(gt_tbl, "rtf_source")$space <- space
- attr(gt_tbl, "rtf_source")$space_before <- space_before
- attr(gt_tbl, "rtf_source")$space_after <- space_after
- attr(gt_tbl, "rtf_source")$new_page <- new_page
- attr(gt_tbl, "rtf_source")$hyphenation <- hyphenation
-
-
- gt_tbl
-
+ attr(tbl, "rtf_source")$font <- font
+ attr(tbl, "rtf_source")$format <- format
+ attr(tbl, "rtf_source")$font_size <- font_size
+ attr(tbl, "rtf_source")$color <- color
+ attr(tbl, "rtf_source")$background_color <- background_color
+ attr(tbl, "rtf_source")$justification <- justification
+ attr(tbl, "rtf_source")$indent_first <- indent_first
+ attr(tbl, "rtf_source")$indent_left <- indent_left
+ attr(tbl, "rtf_source")$indent_right <- indent_right
+ attr(tbl, "rtf_source")$space <- space
+ attr(tbl, "rtf_source")$space_before <- space_before
+ attr(tbl, "rtf_source")$space_after <- space_after
+ attr(tbl, "rtf_source")$new_page <- new_page
+ attr(tbl, "rtf_source")$hyphenation <- hyphenation
+
+
+ tbl
}
#' Add page attributes to the table
#'
-#' @param gt_tbl A data frame
+#' @param tbl A data frame
#' @param page_width A numeric number to indicate page width.
#' @param page_height A numeric number to indicate page height.
#' @param orientation Orientation in 'portrait' or 'landscape'.
#'
#' @noRd
-.rtf_page_size <- function(gt_tbl,
+.rtf_page_size <- function(tbl,
page_width,
page_height,
orientation) {
-
if (!is.numeric(page_width)) {
stop("input page_width must be a numeric number")
}
@@ -286,43 +290,42 @@ rtf_source <- function(gt_tbl,
}
- if (!orientation %in% c("portrait","landscape")){
+ if (!orientation %in% c("portrait", "landscape")) {
stop("input orientation must be 'portrait' or 'landscape' ")
}
- attr(gt_tbl, "page_width") <- page_width
- attr(gt_tbl, "page_height") <- page_height
- attr(gt_tbl, "orientation") <- orientation
+ attr(tbl, "page_width") <- page_width
+ attr(tbl, "page_height") <- page_height
+ attr(tbl, "orientation") <- orientation
- gt_tbl
+ tbl
}
#' Add margin attributes to the table
#'
-#' @param gt_tbl A data frame
+#' @param tbl A data frame
#' @param doctype doctype in 'csr', 'wma', 'wmm' or 'narrow'
#' @param orientation Orientation in 'portrait' or 'landscape'.
#'
#' @noRd
-.rtf_page_margin <- function(gt_tbl,
+.rtf_page_margin <- function(tbl,
doctype,
orientation) {
-
- if (!doctype %in% c("csr", "wma", "wmm", "narrow")){
+ if (!doctype %in% c("csr", "wma", "wmm", "narrow")) {
stop("input doctype must be 'csr', 'wma', 'wmm' or 'narrow' ")
}
- if (!orientation %in% c("portrait","landscape")){
+ if (!orientation %in% c("portrait", "landscape")) {
stop("input orientation must be 'portrait' or 'landscape' ")
}
- attr(gt_tbl, "doctype") <- doctype
+ attr(tbl, "doctype") <- doctype
- gt_tbl
+ tbl
}
@@ -331,7 +334,7 @@ rtf_source <- function(gt_tbl,
#' @title Add column header to the table
#'
-#' @param gt_tbl A data frame
+#' @param tbl A data frame
#' @param colheader A string that uses " | " to separate column names.
#' @param border_left left border type
#' @param border_right right border type
@@ -341,7 +344,7 @@ rtf_source <- function(gt_tbl,
#' @param border_color_right right border color
#' @param border_color_top top border color
#' @param border_color_bottom bottom border color
-#' @param border_width worder width in twips
+#' @param border_width border width in twips
#' @param cell_justification justification for cell
#' @param col_rel_width column relative width in a vector eg. c(2,1,1) refers to 2:1;1
#' @param page_width page width in inches
@@ -357,148 +360,146 @@ rtf_source <- function(gt_tbl,
#' @param text_space_after line space after text
#' @param first_row boolean value to indicate whether column header is the first row of the table
#'
+#' @return the same data frame \code{tbl} with additional attributes for table column header
+#'
+#' @examples
+#' library(dplyr) # required to run examples
+#' data(tbl_1)
+#' tbl_1 %>%
+#' rtf_colheader(colheader = "Treatment | N | Mean (SD) | N | Mean (SD) | N |
+#' Mean (SD) | LS Mean (95% CI)\\dagger") %>%
+#' attr("rtf_colheader")
+#'
#' @export
-rtf_colheader <- function(gt_tbl,
+rtf_colheader <- function(tbl,
- colheader = NULL,
+ colheader = NULL,
- border_left = "single",
- border_right = "single",
- border_top = NULL,
- border_bottom = "",
+ border_left = "single",
+ border_right = "single",
+ border_top = NULL,
+ border_bottom = "",
- border_color_left = NULL,
- border_color_right = NULL,
- border_color_top = NULL,
- border_color_bottom = NULL,
+ border_color_left = NULL,
+ border_color_right = NULL,
+ border_color_top = NULL,
+ border_color_bottom = NULL,
- border_width = 15,
- cell_justification = "c",
+ border_width = 15,
+ cell_justification = "c",
- col_rel_width = NULL,
- page_width = 8.5,
- col_total_width = page_width/1.4,
- cell_height = 0.15,
+ col_rel_width = NULL,
+ page_width = 8.5,
+ col_total_width = page_width / 1.4,
+ cell_height = 0.15,
- text_justification = "c",
- text_font = 1,
- text_format = NULL,
- text_color = NULL,
+ text_justification = "c",
+ text_font = 1,
+ text_format = NULL,
+ text_color = NULL,
text_background_color = NULL,
- text_font_size = 9,
- text_space_before = 15,
- text_space_after = 15,
-
- first_row = FALSE
-
-
-) {
+ text_font_size = 9,
+ text_space_before = 15,
+ text_space_after = 15,
+ first_row = FALSE) {
if (colheader == "") {
+ attr(tbl, "rtf_colheader")$colheader <- NULL
+ attr(tbl, "rtf_colheader")$first_row <- first_row
+ } else if (!is.null(colheader)) {
+ colheader <- data.frame(t(trimws(unlist(strsplit(colheader, "|", fixed = TRUE)))))
- attr(gt_tbl, "rtf_colheader")$colheader <- NULL
- attr(gt_tbl, "rtf_colheader")$first_row <- first_row
-
- } else if (!is.null(colheader)){
-
- colheader <- data.frame( t(trimws(unlist(strsplit(colheader, "|", fixed = TRUE)))))
-
- n_row = nrow(colheader)
- n_col = ncol(colheader)
+ n_row <- nrow(colheader)
+ n_col <- ncol(colheader)
# Set default value for column width
- if (is.null(col_rel_width)){
+ if (is.null(col_rel_width)) {
col_rel_width <- NA
}
## Border top post processing for new page
- if(is.null(border_top)){
- border_top = ""
- border_post = TRUE
- }else{
- border_post = FALSE
+ if (is.null(border_top)) {
+ border_top <- ""
+ border_post <- TRUE
+ } else {
+ border_post <- FALSE
}
# Set default value for text color if background color presented
- if(is.null(text_color) & ! is.null(text_background_color)){
+ if (is.null(text_color) & !is.null(text_background_color)) {
text_color <- "black"
}
# Transer vector to matrix by row
- foo <- function(x){
- if( (is.null(dim(x))) & (! is.null(x) ) ){
+ foo <- function(x) {
+ if ((is.null(dim(x))) & (!is.null(x))) {
x <- matrix(x, nrow = n_row, ncol = n_col, byrow = TRUE)
}
x
}
- border_top <- foo(border_top)
- border_left <- foo(border_left)
- border_right <- foo(border_right)
- border_bottom <- foo(border_bottom)
+ border_top <- foo(border_top)
+ border_left <- foo(border_left)
+ border_right <- foo(border_right)
+ border_bottom <- foo(border_bottom)
- border_color_left <- foo(border_color_left)
- border_color_right <- foo(border_color_right)
- border_color_top <- foo(border_color_top)
- border_color_bottom <- foo(border_color_bottom)
+ border_color_left <- foo(border_color_left)
+ border_color_right <- foo(border_color_right)
+ border_color_top <- foo(border_color_top)
+ border_color_bottom <- foo(border_color_bottom)
- text_font <- foo(text_font)
- text_format <- foo(text_format)
- text_color <- foo(text_color)
+ text_font <- foo(text_font)
+ text_format <- foo(text_format)
+ text_color <- foo(text_color)
text_background_color <- foo(text_background_color)
- text_justification <- foo(text_justification)
- text_font_size <- foo(text_font_size)
+ text_justification <- foo(text_justification)
+ text_font_size <- foo(text_font_size)
# Update to matrix format
if (border_post) {
-
- if (length(.get_colheader(gt_tbl)) == 0 && first_row == TRUE) {
- border_top[1,] <- rep("double", n_col)
+ if (length(.get_colheader(tbl)) == 0 && first_row == TRUE) {
+ border_top[1, ] <- rep("double", n_col)
} else {
- border_top[1,] <- rep("single", n_col)
+ border_top[1, ] <- rep("single", n_col)
}
-
}
- attr(gt_tbl, "rtf_colheader")$col_rel_width <- c(attr(gt_tbl, "rtf_colheader")$col_rel_width, list(col_rel_width))
- attr(gt_tbl, "rtf_colheader")$colheader <- c(attr(gt_tbl, "rtf_colheader")$colheader, list(colheader))
- attr(gt_tbl, "rtf_colheader")$border_left <- c(attr(gt_tbl, "rtf_colheader")$border_left, list(border_left))
- attr(gt_tbl, "rtf_colheader")$border_right <- c(attr(gt_tbl, "rtf_colheader")$border_right, list(border_right))
- attr(gt_tbl, "rtf_colheader")$border_top <- c(attr(gt_tbl, "rtf_colheader")$border_top, list(border_top))
- attr(gt_tbl, "rtf_colheader")$border_bottom <- c(attr(gt_tbl, "rtf_colheader")$border_bottom, list(border_bottom))
- attr(gt_tbl, "rtf_colheader")$border_color_left <- c(attr(gt_tbl, "rtf_colheader")$border_color_left, list(border_color_left))
- attr(gt_tbl, "rtf_colheader")$border_color_right <- c(attr(gt_tbl, "rtf_colheader")$border_color_right, list(border_color_right))
- attr(gt_tbl, "rtf_colheader")$border_color_bottom <- c(attr(gt_tbl, "rtf_colheader")$border_color_bottom, list(border_color_bottom))
- attr(gt_tbl, "rtf_colheader")$border_width <- c(attr(gt_tbl, "rtf_colheader")$border_width, list(border_width))
- attr(gt_tbl, "rtf_colheader")$cell_justification <- c(attr(gt_tbl, "rtf_colheader")$cell_justification, list(cell_justification))
- attr(gt_tbl, "rtf_colheader")$page_width <- c(attr(gt_tbl, "rtf_colheader")$page_width, list(page_width))
- attr(gt_tbl, "rtf_colheader")$col_total_width <- c(attr(gt_tbl, "rtf_colheader")$col_total_width, list(col_total_width))
- attr(gt_tbl, "rtf_colheader")$cell_height <- c(attr(gt_tbl, "rtf_colheader")$cell_height, list(cell_height))
- attr(gt_tbl, "rtf_colheader")$text_justification <- c(attr(gt_tbl, "rtf_colheader")$text_justification, list(text_justification))
- attr(gt_tbl, "rtf_colheader")$text_font <- c(attr(gt_tbl, "rtf_colheader")$text_font, list(text_font))
- attr(gt_tbl, "rtf_colheader")$text_format <- c(attr(gt_tbl, "rtf_colheader")$text_format, list(text_format))
- attr(gt_tbl, "rtf_colheader")$text_color <- c(attr(gt_tbl, "rtf_colheader")$text_color, list(text_color))
- attr(gt_tbl, "rtf_colheader")$text_background_color <- c(attr(gt_tbl, "rtf_colheader")$text_background_color, list(text_background_color))
- attr(gt_tbl, "rtf_colheader")$text_font_size <- c(attr(gt_tbl, "rtf_colheader")$text_font_size, list(text_font_size))
- attr(gt_tbl, "rtf_colheader")$text_space_before <- c(attr(gt_tbl, "rtf_colheader")$text_space_before, list(text_space_before))
- attr(gt_tbl, "rtf_colheader")$text_space_after <- c(attr(gt_tbl, "rtf_colheader")$text_space_after, list(text_space_after))
- attr(gt_tbl, "rtf_colheader")$first_row <- c(attr(gt_tbl, "rtf_colheader")$first_row, list(first_row))
-
-
-
- }else{
- attr(gt_tbl, "rtf_colheader")$colheader <- NULL
+ attr(tbl, "rtf_colheader")$col_rel_width <- c(attr(tbl, "rtf_colheader")$col_rel_width, list(col_rel_width))
+ attr(tbl, "rtf_colheader")$colheader <- c(attr(tbl, "rtf_colheader")$colheader, list(colheader))
+ attr(tbl, "rtf_colheader")$border_left <- c(attr(tbl, "rtf_colheader")$border_left, list(border_left))
+ attr(tbl, "rtf_colheader")$border_right <- c(attr(tbl, "rtf_colheader")$border_right, list(border_right))
+ attr(tbl, "rtf_colheader")$border_top <- c(attr(tbl, "rtf_colheader")$border_top, list(border_top))
+ attr(tbl, "rtf_colheader")$border_bottom <- c(attr(tbl, "rtf_colheader")$border_bottom, list(border_bottom))
+ attr(tbl, "rtf_colheader")$border_color_left <- c(attr(tbl, "rtf_colheader")$border_color_left, list(border_color_left))
+ attr(tbl, "rtf_colheader")$border_color_right <- c(attr(tbl, "rtf_colheader")$border_color_right, list(border_color_right))
+ attr(tbl, "rtf_colheader")$border_color_bottom <- c(attr(tbl, "rtf_colheader")$border_color_bottom, list(border_color_bottom))
+ attr(tbl, "rtf_colheader")$border_width <- c(attr(tbl, "rtf_colheader")$border_width, list(border_width))
+ attr(tbl, "rtf_colheader")$cell_justification <- c(attr(tbl, "rtf_colheader")$cell_justification, list(cell_justification))
+ attr(tbl, "rtf_colheader")$page_width <- c(attr(tbl, "rtf_colheader")$page_width, list(page_width))
+ attr(tbl, "rtf_colheader")$col_total_width <- c(attr(tbl, "rtf_colheader")$col_total_width, list(col_total_width))
+ attr(tbl, "rtf_colheader")$cell_height <- c(attr(tbl, "rtf_colheader")$cell_height, list(cell_height))
+ attr(tbl, "rtf_colheader")$text_justification <- c(attr(tbl, "rtf_colheader")$text_justification, list(text_justification))
+ attr(tbl, "rtf_colheader")$text_font <- c(attr(tbl, "rtf_colheader")$text_font, list(text_font))
+ attr(tbl, "rtf_colheader")$text_format <- c(attr(tbl, "rtf_colheader")$text_format, list(text_format))
+ attr(tbl, "rtf_colheader")$text_color <- c(attr(tbl, "rtf_colheader")$text_color, list(text_color))
+ attr(tbl, "rtf_colheader")$text_background_color <- c(attr(tbl, "rtf_colheader")$text_background_color, list(text_background_color))
+ attr(tbl, "rtf_colheader")$text_font_size <- c(attr(tbl, "rtf_colheader")$text_font_size, list(text_font_size))
+ attr(tbl, "rtf_colheader")$text_space_before <- c(attr(tbl, "rtf_colheader")$text_space_before, list(text_space_before))
+ attr(tbl, "rtf_colheader")$text_space_after <- c(attr(tbl, "rtf_colheader")$text_space_after, list(text_space_after))
+ attr(tbl, "rtf_colheader")$first_row <- c(attr(tbl, "rtf_colheader")$first_row, list(first_row))
+ } else {
+ attr(tbl, "rtf_colheader")$colheader <- NULL
}
- gt_tbl
+ tbl
}
#' @title add table body attributes to the table
#'
-#' @param gt_tbl A data frame
+#' @param tbl A data frame
#' @param colheader A boolean value to indicate whether to add default column header to the table
#' @param page_width page width in inches
#' @param page_height page height in inches
@@ -512,7 +513,7 @@ rtf_colheader <- function(gt_tbl,
#' @param border_color_right right border color
#' @param border_color_top top border color
#' @param border_color_bottom bottom border color
-#' @param border_width worder width in twips
+#' @param border_width border width in twips
#' @param cell_justification justification for cell
#' @param col_rel_width column relative width in a vector eg. c(2,1,1) refers to 2:1;1
#' @param col_total_width column total width for the table
@@ -530,183 +531,178 @@ rtf_colheader <- function(gt_tbl,
#' @param new_page a boolean value to indicate whether to separate grouped table into pages by sections
#' @param last_row a boolean value to indicate whether the table contains the last row of the final table
#'
+#' @return the same data frame \code{tbl} with additional attributes for table body
+#'
+#' @examples
+#' library(dplyr) # required to run examples
+#' data(tbl_1)
+#' tbl_1 %>%
+#' rtf_body(col_rel_width = c(3,1,3,1,3,1,3,5),
+#' text_justification = c("l",rep("c",7)),
+#' last_row = FALSE) %>%
+#' attributes()
+#'
#' @export
-rtf_body <- function(gt_tbl,
-
- colheader = TRUE,
-
- page_width = 8.5,
- page_height = 11,
- orientation = "portrait",
- doctype = "wma",
-
- border_left = "single",
- border_right = "single",
- border_top = NULL,
- border_bottom = "double",
-
- border_color_left = NULL,
- border_color_right = NULL,
- border_color_top = NULL,
- border_color_bottom = NULL,
-
- border_width = 15,
- col_rel_width = NULL,
- col_total_width = page_width/1.4,
- cell_height = 0.15,
- cell_justification = "c",
-
- text_font = 1,
- text_format = NULL,
- text_color = NULL,
+rtf_body <- function(tbl,
+
+ colheader = TRUE,
+
+ page_width = 8.5,
+ page_height = 11,
+ orientation = "portrait",
+ doctype = "wma",
+
+ border_left = "single",
+ border_right = "single",
+ border_top = NULL,
+ border_bottom = "double",
+
+ border_color_left = NULL,
+ border_color_right = NULL,
+ border_color_top = NULL,
+ border_color_bottom = NULL,
+
+ border_width = 15,
+ col_rel_width = NULL,
+ col_total_width = page_width / 1.4,
+ cell_height = 0.15,
+ cell_justification = "c",
+
+ text_font = 1,
+ text_format = NULL,
+ text_color = NULL,
text_background_color = NULL,
- text_justification = "c",
- text_font_size = 9,
- text_space_before = 15,
- text_space_after = 15,
-
- page_num = NULL,
+ text_justification = "c",
+ text_font_size = 9,
+ text_space_before = 15,
+ text_space_after = 15,
- page_by = NULL,
- new_page = FALSE,
+ page_num = NULL,
- last_row = TRUE){
+ page_by = NULL,
+ new_page = FALSE,
-
- gt_tbl <- .rtf_page_size(gt_tbl,
- page_width = page_width,
- page_height = page_height,
- orientation = orientation
+ last_row = TRUE) {
+ tbl <- .rtf_page_size(tbl,
+ page_width = page_width,
+ page_height = page_height,
+ orientation = orientation
)
- gt_tbl <- .rtf_page_margin(gt_tbl,
- doctype = doctype,
- orientation = orientation
+ tbl <- .rtf_page_margin(tbl,
+ doctype = doctype,
+ orientation = orientation
)
## check whether to add column header or not
- if (colheader == TRUE){
-
- if ( is.null(.get_colheader(gt_tbl)$colheader)){
- gt_tbl <- rtf_colheader(gt_tbl,
- colheader = paste(attr(gt_tbl, "names"), collapse = " | " ))
-
+ if (colheader == TRUE) {
+ if (is.null(.get_colheader(tbl)$colheader)) {
+ tbl <- rtf_colheader(tbl,
+ colheader = paste(attr(tbl, "names"), collapse = " | ")
+ )
}
-
- }else{
-
- attr(gt_tbl, "rtf_colheader")$colheader <- NULL
- attr(gt_tbl, "rtf_colheader")$first_row <- FALSE
+ } else {
+ attr(tbl, "rtf_colheader")$colheader <- NULL
+ attr(tbl, "rtf_colheader")$first_row <- FALSE
}
## Border top post processing for new page
- if(is.null(border_top)){
- border_top = ""
- border_post = TRUE
- }else{
- border_post = FALSE
+ if (is.null(border_top)) {
+ border_top <- ""
+ border_post <- TRUE
+ } else {
+ border_post <- FALSE
}
- if ( !is.null(page_by)) {
-
- if (all(page_by %in% attr(gt_tbl, "names"))) {
-
- id <- which(attr(gt_tbl, "names") %in% page_by)
+ if (!is.null(page_by)) {
+ if (all(page_by %in% attr(tbl, "names"))) {
+ id <- which(attr(tbl, "names") %in% page_by)
- page_by_vars <- gt_tbl[,id]
-
- if (is.null(ncol(page_by_vars))){
-
- pageby_condition = page_by_vars
-
- }else{
+ page_by_vars <- tbl[, id]
+ if (is.null(ncol(page_by_vars))) {
+ pageby_condition <- page_by_vars
+ } else {
pageby_condition <- do.call(paste, c(page_by_vars, sep = "-"))
}
- temp <- lapply(unique(pageby_condition), function(x){
-
- gt_tbl[which(pageby_condition %in% x), -id]
-
- })
+ temp <- lapply(unique(pageby_condition), function(x) {
+ tbl[which(pageby_condition %in% x), -id]
+ })
pageby_db <- do.call(rbind, temp)
pageby_colheader <- unique(pageby_condition)
-
-
} else {
-
- stop(paste0("page_by must be one of the following: ", paste(attr(gt_tbl, "names"), collapse = ", ")))
+ stop(paste0("page_by must be one of the following: ", paste(attr(tbl, "names"), collapse = ", ")))
}
-
} else {
- pageby_db <- data.frame(gt_tbl)
+ pageby_db <- data.frame(tbl)
pageby_condition <- NULL
pageby_colheader <- NULL
}
- n_row = nrow(pageby_db)
- n_col = ncol(pageby_db)
+ n_row <- nrow(pageby_db)
+ n_col <- ncol(pageby_db)
# Set default value for column width
- if(is.null(col_rel_width)){
+ if (is.null(col_rel_width)) {
col_rel_width <- rep(1, n_col)
}
# Set default value for text color if background color presented
- if(is.null(text_color) & ! is.null(text_background_color)){
+ if (is.null(text_color) & !is.null(text_background_color)) {
text_color <- "black"
}
# Transer vector to matrix by row
- foo <- function(x){
- if( (is.null(dim(x))) & (! is.null(x) ) ){
+ foo <- function(x) {
+ if ((is.null(dim(x))) & (!is.null(x))) {
x <- matrix(x, nrow = n_row, ncol = n_col, byrow = TRUE)
}
x
}
- border_top <- foo(border_top)
- border_left <- foo(border_left)
- border_right <- foo(border_right)
- border_bottom <- foo(border_bottom)
+ border_top <- foo(border_top)
+ border_left <- foo(border_left)
+ border_right <- foo(border_right)
+ border_bottom <- foo(border_bottom)
- border_color_left <- foo(border_color_left)
- border_color_right <- foo(border_color_right)
- border_color_top <- foo(border_color_top)
- border_color_bottom <- foo(border_color_bottom)
+ border_color_left <- foo(border_color_left)
+ border_color_right <- foo(border_color_right)
+ border_color_top <- foo(border_color_top)
+ border_color_bottom <- foo(border_color_bottom)
- text_font <- foo(text_font)
- text_format <- foo(text_format)
- text_color <- foo(text_color)
+ text_font <- foo(text_font)
+ text_format <- foo(text_format)
+ text_color <- foo(text_color)
text_background_color <- foo(text_background_color)
- text_justification <- foo(text_justification)
- text_font_size <- foo(text_font_size)
-
- page_num <- .set_page_num(page_num, orientation)
-
- index_list <- .pageby_db_index(pageby_db,
- pageby_colheader,
- pageby_condition,
- page_num,
- page_by,
- new_page)
+ text_justification <- foo(text_justification)
+ text_font_size <- foo(text_font_size)
+
+ page_num <- .set_page_num(page_num, orientation)
+
+ index_list <- .pageby_db_index(
+ pageby_db,
+ pageby_colheader,
+ pageby_condition,
+ page_num,
+ page_by,
+ new_page
+ )
index_newpage <- index_list$index_newpage
index_endpage <- index_list$index_endpage
- for (x in index_newpage){
-
+ for (x in index_newpage) {
if (border_post) {
-
- if (is.null(.get_colheader(gt_tbl)$colheader) && .get_colheader(gt_tbl)$first_row == TRUE) {
- border_top[x,] <- rep("double", n_col)
+ if (is.null(.get_colheader(tbl)$colheader) && .get_colheader(tbl)$first_row == TRUE) {
+ border_top[x, ] <- rep("double", n_col)
} else {
- border_top[x,] <- rep("single", n_col)
+ border_top[x, ] <- rep("single", n_col)
}
}
}
@@ -714,48 +710,46 @@ rtf_body <- function(gt_tbl,
- attr(gt_tbl, "border_top") <- border_top
- attr(gt_tbl, "border_left") <- border_left
- attr(gt_tbl, "border_right") <- border_right
- attr(gt_tbl, "border_bottom") <- border_bottom
+ attr(tbl, "border_top") <- border_top
+ attr(tbl, "border_left") <- border_left
+ attr(tbl, "border_right") <- border_right
+ attr(tbl, "border_bottom") <- border_bottom
- attr(gt_tbl, "border_color_left") <- border_color_left
- attr(gt_tbl, "border_color_right") <- border_color_right
- attr(gt_tbl, "border_color_top") <- border_color_top
- attr(gt_tbl, "border_color_bottom") <- border_color_bottom
+ attr(tbl, "border_color_left") <- border_color_left
+ attr(tbl, "border_color_right") <- border_color_right
+ attr(tbl, "border_color_top") <- border_color_top
+ attr(tbl, "border_color_bottom") <- border_color_bottom
- attr(gt_tbl, "border_width") <- border_width
- attr(gt_tbl, "page_width") <- page_width
- attr(gt_tbl, "col_total_width") <- col_total_width
- attr(gt_tbl, "cell_height") <- cell_height
- attr(gt_tbl, "cell_justification") <- cell_justification
- attr(gt_tbl, "col_rel_width") <- col_rel_width
+ attr(tbl, "border_width") <- border_width
+ attr(tbl, "page_width") <- page_width
+ attr(tbl, "col_total_width") <- col_total_width
+ attr(tbl, "cell_height") <- cell_height
+ attr(tbl, "cell_justification") <- cell_justification
+ attr(tbl, "col_rel_width") <- col_rel_width
- attr(gt_tbl, "text_font") <- text_font
- attr(gt_tbl, "text_format") <- text_format
- attr(gt_tbl, "text_font_size") <- text_font_size
- attr(gt_tbl, "text_color") <- text_color
- attr(gt_tbl, "text_background_color") <- text_background_color
- attr(gt_tbl, "text_justification") <- text_justification
+ attr(tbl, "text_font") <- text_font
+ attr(tbl, "text_format") <- text_format
+ attr(tbl, "text_font_size") <- text_font_size
+ attr(tbl, "text_color") <- text_color
+ attr(tbl, "text_background_color") <- text_background_color
+ attr(tbl, "text_justification") <- text_justification
- attr(gt_tbl, "text_space_before") <- text_space_before
- attr(gt_tbl, "text_space_after") <- text_space_after
+ attr(tbl, "text_space_before") <- text_space_before
+ attr(tbl, "text_space_after") <- text_space_after
- attr(gt_tbl, "page_num") <- page_num
- attr(gt_tbl, "page_by") <- page_by
- attr(gt_tbl, "new_page") <- new_page
- attr(gt_tbl, "pageby_db") <- pageby_db
- attr(gt_tbl, "pageby_condition") <- pageby_condition
- attr(gt_tbl, "pageby_colheader") <- pageby_colheader
- attr(gt_tbl, "pageby_newpage_index") <- index_newpage
- attr(gt_tbl, "pageby_endpage_index") <- index_endpage
+ attr(tbl, "page_num") <- page_num
+ attr(tbl, "page_by") <- page_by
+ attr(tbl, "new_page") <- new_page
+ attr(tbl, "pageby_db") <- pageby_db
+ attr(tbl, "pageby_condition") <- pageby_condition
+ attr(tbl, "pageby_colheader") <- pageby_colheader
+ attr(tbl, "pageby_newpage_index") <- index_newpage
+ attr(tbl, "pageby_endpage_index") <- index_endpage
- attr(gt_tbl, "last_row") <- last_row
+ attr(tbl, "last_row") <- last_row
- gt_tbl
+ tbl
}
-
-
diff --git a/R/add_features.R b/R/add_features.R
index 5b883281..bfb9166f 100644
--- a/R/add_features.R
+++ b/R/add_features.R
@@ -22,25 +22,24 @@
.as_rtf_init <- function() {
# The number 1033 is U.S. English
- paste("{", "\\rtf1\\ansi\n\\deff0\\deflang1033", sep="")
-
- }
+ paste("{", "\\rtf1\\ansi\n\\deff0\\deflang1033", sep = "")
+}
#' rtf code to initiate an rtf table
#'
#' @noRd
-.as_rtf_font<-function() {
-
- font_type <- .font_type()
- font_rtf <- factor(c(1,2,3), levels = font_type$type, labels = font_type$rtf_code)
- font_style <- factor(c(1,2,3), levels = font_type$type, labels = font_type$style)
- font_name <- factor(c(1,2,3), levels = font_type$type, labels = font_type$name)
-
-
- font_table <- paste0("{\\fonttbl",
- paste(paste0("{", font_rtf, font_style, "\\fcharset161\\fprq2 ", font_name, ";}\n"), collapse = ""),
- "}\n")
+.as_rtf_font <- function() {
+ font_type <- .font_type()
+ font_rtf <- factor(c(1, 2, 3), levels = font_type$type, labels = font_type$rtf_code)
+ font_style <- factor(c(1, 2, 3), levels = font_type$type, labels = font_type$style)
+ font_name <- factor(c(1, 2, 3), levels = font_type$type, labels = font_type$name)
+
+ font_table <- paste0(
+ "{\\fonttbl",
+ paste(paste0("{", font_rtf, font_style, "\\fcharset161\\fprq2 ", font_name, ";}\n"), collapse = ""),
+ "}\n"
+ )
font_table
}
@@ -51,52 +50,48 @@
#'
#' @noRd
.inch_to_twip <- function(inch) {
- round(inch*1440, 0)
+ round(inch * 1440, 0)
}
#' create rtf color table
-#' @param gt_tbl a data frame
+#' @param tbl a data frame
#'
#' @noRd
-.as_rtf_color <- function(gt_tbl) {
-
+.as_rtf_color <- function(tbl) {
rtf_color <- NULL
- color_used <- .color_used(gt_tbl)
+ color_used <- .color_used(tbl)
if (color_used == TRUE) {
- col_tb <- .color_table()
- rtf_color <- paste(c( "{\\colortbl; ", col_tb$rtf_code, "}"), collapse = "\n")
+ col_tb <- .color_table()
+ rtf_color <- paste(c("{\\colortbl; ", col_tb$rtf_code, "}"), collapse = "\n")
}
rtf_color
-
}
#' create rtf page size
-#' @param gt_tbl a data frame
+#' @param tbl a data frame
#' @noRd
-.as_rtf_page <- function(gt_tbl){
-
- page_width <- attr(gt_tbl, "page_width")
- page_height <- attr(gt_tbl, "page_height")
- orientation <- attr(gt_tbl, "orientation")
+.as_rtf_page <- function(tbl) {
+ page_width <- attr(tbl, "page_width")
+ page_height <- attr(tbl, "page_height")
+ orientation <- attr(tbl, "orientation")
.page.size <- c("\\paperw", "\\paperh")
- .page.size <- paste( paste0(.page.size, .inch_to_twip(c(page_width, page_height))), collapse = "")
+ .page.size <- paste(paste0(.page.size, .inch_to_twip(c(page_width, page_height))), collapse = "")
- if(orientation == "landscape"){
-
+ if (orientation == "landscape") {
.page.size <- paste0(.page.size, "\\landscape\n")
}
- if(orientation == "portrait"){
+ if (orientation == "portrait") {
.page.size <- paste0(.page.size, "\n")
}
@@ -114,32 +109,29 @@
#'
#' @noRd
.set_omi <- function(doctype, orientation) {
-
-
- if (!doctype %in% c("csr", "wma", "wmm","narrow")){
+ if (!doctype %in% c("csr", "wma", "wmm", "narrow")) {
stop("input doctype must be 'csr', 'wma', 'wmm' or 'narrow' ")
}
- if (!orientation %in% c("portrait","landscape")){
+ if (!orientation %in% c("portrait", "landscape")) {
stop("input orientation must be 'portrait' or 'landscape' ")
}
.omi <- list(
-
csr = list(
- portrait = c(1.25, 1, 1.5, 1, 0.5, 0.5),
+ portrait = c(1.25, 1, 1.5, 1, 0.5, 0.5),
landscape = c(0.5, 0.5, 1.27986111111111, 1.25, 1.25, 1)
),
wma = list(
- portrait = c(1.25, 1, 1.75, 1.25, 1.75, 1.00625),
+ portrait = c(1.25, 1, 1.75, 1.25, 1.75, 1.00625),
landscape = c(0.5, 0.5, 2, 1.25, 1.25, 1.25)
),
wmm = list(
- portrait = c(1.25, 1, 1, 1, 1.75, 1.00625),
+ portrait = c(1.25, 1, 1, 1, 1.75, 1.00625),
landscape = c(0.5, 0.5, 1.25, 1, 1.25, 1.25)
),
@@ -147,36 +139,31 @@
portrait = rep(0.5, 6),
landscape = rep(0.5, 6)
)
-
)
- .omi[[doctype]][[orientation ]]
-
+ .omi[[doctype]][[orientation]]
}
#' rtf code to set up margins in twips
-#' @param gt_tbl a data frame
+#' @param tbl a data frame
#' @noRd
-.as_rtf_margin <- function(gt_tbl){
-
- doctype <- attr(gt_tbl, "doctype")
- orientation <- attr(gt_tbl, "orientation")
+.as_rtf_margin <- function(tbl) {
+ doctype <- attr(tbl, "doctype")
+ orientation <- attr(tbl, "orientation")
- .omi <- .set_omi(doctype, orientation)
- .margin <- c("\\margl", "\\margr", "\\margt", "\\margb", "\\headery","\\footery")
- .margin <- paste( paste0(.margin, .inch_to_twip(.omi)), collapse = "")
+ .omi <- .set_omi(doctype, orientation)
+ .margin <- c("\\margl", "\\margr", "\\margt", "\\margb", "\\headery", "\\footery")
+ .margin <- paste(paste0(.margin, .inch_to_twip(.omi)), collapse = "")
.margin <- paste0(.margin, "\n")
.margin
-
}
#' rtf code to set up margins in twips
#'
#' @noRd
-.as_rtf_newpage <- function(){
-
+.as_rtf_newpage <- function() {
paste("\\intbl\\row\\pard\\page\\par\\pard")
}
@@ -187,9 +174,7 @@
#' @param orientation Orientation in 'portrait' or 'landscape'.
#' @noRd
.set_page_num <- function(page_num, orientation) {
-
- if (is.null(page_num)){
-
+ if (is.null(page_num)) {
if (orientation == "portrait") page_num <- 42
if (orientation == "landscape") page_num <- 26
}
@@ -199,12 +184,11 @@
#' extract the heading attribute from a \pkg{gt} object
#'
-#' @param gt_tbl A data frame
+#' @param tbl A data frame
#'
#' @noRd
-.get_heading <- function(gt_tbl) {
-
- gt_attr <- attributes(gt_tbl)
+.get_heading <- function(tbl) {
+ gt_attr <- attributes(tbl)
rtf_heading <- gt_attr$rtf_heading
rtf_heading
@@ -212,26 +196,24 @@
#' extract the heading attribute from a \pkg{gt} object
#'
-#' @param gt_tbl A data frame
+#' @param tbl A data frame
#'
#' @noRd
-.footnote_source_space <- function(gt_tbl) {
-
+.footnote_source_space <- function(tbl) {
+ table_width <- attr(tbl, "col_total_width")
+ page_width <- attr(tbl, "page_width")
+ text_space_before <- attr(tbl, "text_space_before")
+ border_width <- attr(tbl, "border_width")
+ doctype <- attr(tbl, "doctype")
+ orientation <- attr(tbl, "orientation")
- table_width <- attr(gt_tbl, "col_total_width")
- page_width <- attr(gt_tbl, "page_width")
- text_space_before <- attr(gt_tbl, "text_space_before")
- border_width <- attr(gt_tbl, "border_width")
- doctype <- attr(gt_tbl, "doctype")
- orientation <- attr(gt_tbl, "orientation")
-
- page_width <- .inch_to_twip(page_width )
- left_margin <- .inch_to_twip(.set_omi(doctype, orientation)[1])
+ page_width <- .inch_to_twip(page_width)
+ left_margin <- .inch_to_twip(.set_omi(doctype, orientation)[1])
right_margin <- .inch_to_twip(.set_omi(doctype, orientation)[2])
- table_width <- .inch_to_twip(table_width)
+ table_width <- .inch_to_twip(table_width)
- space_adjust <- round((page_width - left_margin - right_margin - table_width) / 2 )
+ space_adjust <- round((page_width - left_margin - right_margin - table_width) / 2)
space_adjust
@@ -241,29 +223,28 @@
#' check whether color is used in a data frame
#'
-#' @param gt_tbl A data frame
+#' @param tbl A data frame
#'
#' @noRd
-.color_used <- function(gt_tbl){
-
+.color_used <- function(tbl) {
color_used <- FALSE
- heading_color <- attr(gt_tbl,"rtf_heading")$color
- heading_background_color <- attr(gt_tbl,"rtf_heading")$background_color
+ heading_color <- attr(tbl, "rtf_heading")$color
+ heading_background_color <- attr(tbl, "rtf_heading")$background_color
- border_color_left <- attr(gt_tbl,"border_color_left")
- border_color_right <- attr(gt_tbl,"border_color_right")
- border_color_top <- attr(gt_tbl,"border_color_top")
- border_color_bottom <- attr(gt_tbl,"border_color_bottom")
+ border_color_left <- attr(tbl, "border_color_left")
+ border_color_right <- attr(tbl, "border_color_right")
+ border_color_top <- attr(tbl, "border_color_top")
+ border_color_bottom <- attr(tbl, "border_color_bottom")
- text_color <- attr(gt_tbl,"text_color")
- text_background_color <- attr(gt_tbl,"text_background_color")
+ text_color <- attr(tbl, "text_color")
+ text_background_color <- attr(tbl, "text_background_color")
- footnote_color <- attr(gt_tbl,"rtf_footnote")$color
- footnote_background_color <- attr(gt_tbl,"rtf_footnote")$background_color
+ footnote_color <- attr(tbl, "rtf_footnote")$color
+ footnote_background_color <- attr(tbl, "rtf_footnote")$background_color
- source_color <- attr(gt_tbl,"rtf_source")$color
- source_background_color <- attr(gt_tbl,"rtf_source")$background_color
+ source_color <- attr(tbl, "rtf_source")$color
+ source_background_color <- attr(tbl, "rtf_source")$background_color
no_color <- is.null(heading_color) &&
is.null(heading_background_color) &&
@@ -296,18 +277,17 @@
pageby_colheader,
pageby_condition,
table_rtftext,
- new_page){
-
+ new_page) {
category_index <- NULL
if (!is.null(page_by)) {
-
rtf_pageby_colheader <- lapply(pageby_colheader, function(x) {
.as_rtf_table(rtf_body(data.frame(x),
- colheader = FALSE,
- border_bottom = "single",
- text_justification = "l"))
+ colheader = FALSE,
+ border_bottom = "single",
+ text_justification = "l"
+ ))
})
rtf_pageby_index <- sapply(pageby_colheader, function(x) {
@@ -316,15 +296,16 @@
new_table_rtftext <- matrix("",
- nrow = nrow(table_rtftext),
- ncol = ncol(table_rtftext) + length(pageby_colheader))
+ nrow = nrow(table_rtftext),
+ ncol = ncol(table_rtftext) + length(pageby_colheader)
+ )
- split_index <- c(0, cumsum(rtf_pageby_index)[-length(rtf_pageby_index)]) + 1
+ split_index <- c(0, cumsum(rtf_pageby_index)[-length(rtf_pageby_index)]) + 1
pageby_index <- c(0, cumsum(rtf_pageby_index)[-length(rtf_pageby_index)]) + c(1:length(rtf_pageby_index))
- for ( i in c(1:length(pageby_index)) ) {
+ for (i in c(1:length(pageby_index))) {
## add pageby column header
row_idx <- c(1:length(rtf_pageby_colheader[[1]]))
@@ -335,26 +316,25 @@
## split table_rtftext based on pageby feature
new_start <- pageby_index[i] + 1
- new_end <- new_start + rtf_pageby_index[i] - 1
+ new_end <- new_start + rtf_pageby_index[i] - 1
old_start <- split_index[i]
- old_end <- old_start + rtf_pageby_index[i] - 1
-
- new_table_rtftext[, new_start:new_end] <- table_rtftext[,old_start:old_end]
+ old_end <- old_start + rtf_pageby_index[i] - 1
+ new_table_rtftext[, new_start:new_end] <- table_rtftext[, old_start:old_end]
}
- table_rtftext <- new_table_rtftext
+ table_rtftext <- new_table_rtftext
- if (new_page == TRUE){
+ if (new_page == TRUE) {
category_index <- pageby_index[-1] - 1
}
-
}
- newtable_list <- list(table_rtftext = table_rtftext,
- category_index = category_index)
-
+ newtable_list <- list(
+ table_rtftext = table_rtftext,
+ category_index = category_index
+ )
}
#' calculate index to insert new page rtf code
@@ -367,31 +347,21 @@
.table_rtftext_index <- function(new_page,
category_index,
page_num,
- n_row){
-
-
- if (page_num <= n_row){
-
+ n_row) {
+ if (page_num <= n_row) {
if (new_page == TRUE) {
-
pages <- c(0, category_index, n_row)
- pages_cut <- lapply( 2:length(pages), function (x){
-
- ( 0 : floor ((pages[x] - pages[x-1]) / page_num) ) * page_num + pages[x-1]
-
+ pages_cut <- lapply(2:length(pages), function(x) {
+ (0:floor((pages[x] - pages[x - 1]) / page_num)) * page_num + pages[x - 1]
})
pages <- unique(sort(c(pages, unlist(pages_cut))))
-
-
} else {
## if new_page == FALSE
- pages <- c(0, c(1 : floor(n_row / page_num)) * page_num)
+ pages <- c(0, c(1:floor(n_row / page_num)) * page_num)
}
-
-
} else {
## if (page_num > n_row)
@@ -421,18 +391,15 @@
pageby_condition,
page_num,
page_by,
- new_page){
-
- index_newpage = 1
- index_endpage = NULL
-
- n_row <- nrow(pageby_db) + length(pageby_colheader)
+ new_page) {
+ index_newpage <- 1
+ index_endpage <- NULL
- if ((!is.null(page_num)) && (n_row !=1)) {
+ n_row <- nrow(pageby_db) + length(pageby_colheader)
- if (page_num < n_row){
-
- index_newpage <- c(1 : floor(n_row / page_num)) * page_num
+ if ((!is.null(page_num)) && (n_row != 1)) {
+ if (page_num < n_row) {
+ index_newpage <- c(1:floor(n_row / page_num)) * page_num
if (index_newpage[length(index_newpage)] > n_row) index_newpage <- index_newpage[-length(index_newpage)]
index_newpage <- c(0, index_newpage) + 1
@@ -440,14 +407,13 @@
## if page_by feature is turned on
- if ((!is.null(page_by))){
-
+ if ((!is.null(page_by))) {
rtf_pageby_index <- sapply(pageby_colheader, function(x) {
length(which(pageby_condition %in% x))
})
- if (new_page == TRUE){
+ if (new_page == TRUE) {
## if new_page == TRUE, break by new_page
@@ -455,17 +421,15 @@
first_interval <- page_num - 1
- index_newpage_cut <- lapply( 2:length(index_newpage), function (x){
-
- item_1 <- index_newpage[x-1] + first_interval
+ index_newpage_cut <- lapply(2:length(index_newpage), function(x) {
+ item_1 <- index_newpage[x - 1] + first_interval
- if (index_newpage[x] > item_1){
+ if (index_newpage[x] > item_1) {
+ item_2 <- (0:floor((index_newpage[x] - item_1) / page_num)) * page_num + item_1
- item_2 <- ( 0 : floor ((index_newpage[x] - item_1) / page_num) ) * page_num + item_1
-
- cut = c(item_1, item_2)
- }else{
- cut = NULL
+ cut <- c(item_1, item_2)
+ } else {
+ cut <- NULL
}
cut
@@ -473,28 +437,27 @@
index_newpage <- unique(sort(c(index_newpage, unlist(index_newpage_cut))))
-
} else {
## if new_page == FALSE, only break by page_num
- split_index <- c(0, cumsum(rtf_pageby_index)[-length(rtf_pageby_index)]) + 1
- pageby_index <- c(0, cumsum(rtf_pageby_index)[-length(rtf_pageby_index)]) + c(1:length(rtf_pageby_index))
+ split_index <- c(0, cumsum(rtf_pageby_index)[-length(rtf_pageby_index)]) + 1
+ pageby_index <- c(0, cumsum(rtf_pageby_index)[-length(rtf_pageby_index)]) + c(1:length(rtf_pageby_index))
- temp_idx <- sapply(index_newpage, function(x) { min(which(pageby_index >= x)) - 1 })
+ temp_idx <- sapply(index_newpage, function(x) {
+ min(which(pageby_index >= x)) - 1
+ })
index_newpage <- c(1, split_index[temp_idx] + (index_newpage - pageby_index[temp_idx]))
}
-
-
}
-
-
}
if (length(index_newpage) > 1) index_endpage <- index_newpage[-1] - 1
- index_list <- list(index_newpage = index_newpage,
- index_endpage = index_endpage)
+ index_list <- list(
+ index_newpage = index_newpage,
+ index_endpage = index_endpage
+ )
index_list
@@ -508,10 +471,8 @@
#' @param heading Heading attribute from a data frame
#'
#' @noRd
-.is_title <- function(heading){
-
+.is_title <- function(heading) {
length(heading) > 0 && !is.null(heading$title)
-
}
@@ -523,17 +484,17 @@
.is_subtitle <- function(heading) {
length(heading) > 0 & !is.null(heading$subtitle) & all(heading$subtitle != "")
+
}
#' extract the footnote_df attribute from a data frame
#'
-#' @param gt_tbl A data frame
+#' @param tbl A data frame
#'
#' @noRd
-.get_footnote <- function(gt_tbl) {
-
- gt_attr <- attributes(gt_tbl)
+.get_footnote <- function(tbl) {
+ gt_attr <- attributes(tbl)
footnote <- gt_attr$rtf_footnote
footnote
@@ -548,17 +509,17 @@
.is_footnote <- function(footnote){
length(footnote) > 0 & !is.null(footnote$footnote) & all(footnote$footnote != "")
+
}
#' extract the data source attribute from a \pkg{gt} object
#'
-#' @param gt_tbl A data frame
+#' @param tbl A data frame
#'
#' @noRd
-.get_source <- function(gt_tbl) {
-
- gt_attr <- attributes(gt_tbl)
+.get_source <- function(tbl) {
+ gt_attr <- attributes(tbl)
source <- gt_attr$rtf_source
source
@@ -566,13 +527,11 @@
#' extract the column header attribute from a data frame
#'
-#' @param gt_tbl A data frame
+#' @param tbl A data frame
#'
#' @noRd
-.get_colheader <- function(gt_tbl) {
-
- attr(gt_tbl, "rtf_colheader")
-
+.get_colheader <- function(tbl) {
+ attr(tbl, "rtf_colheader")
}
@@ -582,8 +541,7 @@
#' @param source source attribute from a data frame
#'
#' @noRd
-.is_source <- function(source){
-
+.is_source <- function(source) {
length(source) > 0 && !is.null(source$source) && source$source != ""
}
@@ -595,23 +553,24 @@
#'
#' @noRd
.convert <- function(x) {
-
-
- char_rtf <- c( "^" = "\\super ",
- "_" = "\\sub ",
- ">=" = "\\geq ",
- "<=" = "\\leq ",
- "\n" = "\\line ")
+ char_rtf <- c(
+ "^" = "\\super ",
+ "_" = "\\sub ",
+ ">=" = "\\geq ",
+ "<=" = "\\leq ",
+ "\n" = "\\line "
+ )
# Define Pattern for latex code
- # char_latex <- unicode_latex$chr
- # names(char_latex) <- unicode_latex$latex
- unicode_latex$int <- as.integer(as.hexmode(unicode_latex$unicode))
+ unicode_latex$int <- as.integer(as.hexmode(unicode_latex$unicode))
char_latex <- ifelse(unicode_latex$int <= 255, unicode_latex$chr,
- ifelse(unicode_latex$int > 255 & unicode_latex$int < 32768,
- paste0("\\uc1\\u", unicode_latex$int, "*"),
- paste0("\\uc1\\u-", unicode_latex$int, "*") ))
+ ifelse(unicode_latex$int > 255 & unicode_latex$int < 32768,
+ paste0("\\uc1\\u", unicode_latex$int, "*"),
+ paste0("\\uc1\\u-", unicode_latex$int, "*")
+ )
+ )
+
names(char_latex) <- unicode_latex$latex
# Declare fixed string in the pattern (no regular expression)
@@ -622,9 +581,6 @@
x <- stringr::str_replace_all(x, char_latex)
x
-
-
-
}
@@ -640,110 +596,105 @@
#' @references Burke, S. M. (2003). RTF Pocket Guide. " O'Reilly Media, Inc.".
#' @noRd
utf8Tortf <- function(x) {
-
- stopifnot(length(x) == 1 & "character" %in% class(x) )
+ stopifnot(length(x) == 1 & "character" %in% class(x))
x_char <- unlist(strsplit(x, ""))
- x_int <- utf8ToInt(x)
- x_rtf <- ifelse(x_int <= 255, x_char,
- ifelse(x_int <= 32768, paste0("\\uc1\\u", x_int,"?"),
- paste0("\\uc1\\u-", x_int - 65536, "?") )
- )
+ x_int <- utf8ToInt(x)
+ x_rtf <- ifelse(x_int <= 255, x_char,
+ ifelse(x_int <= 32768, paste0("\\uc1\\u", x_int, "?"),
+ paste0("\\uc1\\u-", x_int - 65536, "?")
+ )
+ )
paste0(x_rtf, collapse = "")
-
}
#' rtf code to set up column header for the rtf table
#'
-#' @param gt_tbl A data frame
+#' @param tbl A data frame
#'
#' @noRd
-.as_rtf_colheader <- function(gt_tbl){
-
- rtf_colheader <- .get_colheader(gt_tbl)
+.as_rtf_colheader <- function(tbl) {
+ rtf_colheader <- .get_colheader(tbl)
colheader_tbl_list <- NULL
if (!is.null(rtf_colheader$colheader)) {
+ colheader_tbl_list <- lapply(c(1:length(rtf_colheader$colheader)), function(i) {
+ colheader_db <- rtf_colheader$colheader[[i]]
+
+ border_left <- rtf_colheader$border_left[[i]]
+ border_right <- rtf_colheader$border_right[[i]]
+ border_top <- rtf_colheader$border_top[[i]]
+ border_bottom <- rtf_colheader$border_bottom[[i]]
+
+ border_color_left <- rtf_colheader$border_color_left[[i]]
+ border_color_right <- rtf_colheader$border_color_right[[i]]
+ border_color_top <- rtf_colheader$border_color_top[[i]]
+ border_color_bottom <- rtf_colheader$border_color_bottom[[i]]
+
+ border_width <- rtf_colheader$border_width[[i]]
+ page_width <- rtf_colheader$page_width[[i]]
+ col_rel_width <- rtf_colheader$col_rel_width[[i]]
+
+ ## if column header relative width under "rtf_colheader" attribute is NA,
+ ## use the global column relative width
+ if (all(is.na(col_rel_width))) {
+ col_rel_width <- attr(tbl, "col_rel_width")
+ }
- colheader_tbl_list <- lapply (c(1:length(rtf_colheader$colheader)), function(i){
-
-
- colheader_db <- rtf_colheader$colheader[[i]]
-
- border_left <- rtf_colheader$border_left[[i]]
- border_right <- rtf_colheader$border_right[[i]]
- border_top <- rtf_colheader$border_top[[i]]
- border_bottom <- rtf_colheader$border_bottom[[i]]
-
- border_color_left <- rtf_colheader$border_color_left[[i]]
- border_color_right <- rtf_colheader$border_color_right[[i]]
- border_color_top <- rtf_colheader$border_color_top[[i]]
- border_color_bottom <- rtf_colheader$border_color_bottom[[i]]
-
- border_width <- rtf_colheader$border_width[[i]]
- page_width <- rtf_colheader$page_width[[i]]
- col_rel_width <- rtf_colheader$col_rel_width[[i]]
-
- ## if column header relative width under "rtf_colheader" attribute is NA,
- ## use the global column relative width
- if(all(is.na(col_rel_width))){
- col_rel_width <- attr(gt_tbl, "col_rel_width")}
-
- col_total_width <- rtf_colheader$col_total_width[[i]]
- cell_height <- rtf_colheader$cell_height[[i]]
- cell_justification <- rtf_colheader$cell_justification[[i]]
-
- text_font <- rtf_colheader$text_font[[i]]
- text_format <- rtf_colheader$text_format[[i]]
- text_color <- rtf_colheader$text_color[[i]]
- text_background_color <- rtf_colheader$text_background_color[[i]]
- text_justification <- rtf_colheader$text_justification[[i]]
- text_font_size <- rtf_colheader$text_font_size[[i]]
- text_space_before <- rtf_colheader$text_space_before[[i]]
- text_space_after <- rtf_colheader$text_space_after[[i]]
-
+ col_total_width <- rtf_colheader$col_total_width[[i]]
+ cell_height <- rtf_colheader$cell_height[[i]]
+ cell_justification <- rtf_colheader$cell_justification[[i]]
+ text_font <- rtf_colheader$text_font[[i]]
+ text_format <- rtf_colheader$text_format[[i]]
+ text_color <- rtf_colheader$text_color[[i]]
+ text_background_color <- rtf_colheader$text_background_color[[i]]
+ text_justification <- rtf_colheader$text_justification[[i]]
+ text_font_size <- rtf_colheader$text_font_size[[i]]
+ text_space_before <- rtf_colheader$text_space_before[[i]]
+ text_space_after <- rtf_colheader$text_space_after[[i]]
- colheader_table <- .rtf_table_content(
- colheader_db,
- border_left = border_left,
- border_right = border_right,
- border_top = border_top,
- border_bottom = border_bottom,
- border_color_left = border_color_left,
- border_color_right = border_color_right,
- border_color_top = border_color_top,
- border_color_bottom = border_color_bottom,
+ colheader_table <- .rtf_table_content(
+ colheader_db,
+ border_left = border_left,
+ border_right = border_right,
+ border_top = border_top,
+ border_bottom = border_bottom,
- border_width = border_width,
- page_width = page_width,
- col_rel_width = col_rel_width,
- col_total_width = col_total_width,
- cell_height = cell_height,
- cell_justification = cell_justification,
+ border_color_left = border_color_left,
+ border_color_right = border_color_right,
+ border_color_top = border_color_top,
+ border_color_bottom = border_color_bottom,
- text_font = text_font,
- text_format = text_format,
- text_color = text_color,
- text_background_color = text_background_color,
- text_justification = text_justification,
- text_font_size = text_font_size,
- text_space_before = text_space_before,
- text_space_after = text_space_after,
+ border_width = border_width,
+ page_width = page_width,
+ col_rel_width = col_rel_width,
+ col_total_width = col_total_width,
+ cell_height = cell_height,
+ cell_justification = cell_justification,
- page_num = NULL,
+ text_font = text_font,
+ text_format = text_format,
+ text_color = text_color,
+ text_background_color = text_background_color,
+ text_justification = text_justification,
+ text_font_size = text_font_size,
+ text_space_before = text_space_before,
+ text_space_after = text_space_after,
- last_row = FALSE )
+ page_num = NULL,
- colheader_table
+ last_row = FALSE
+ )
- })
+ colheader_table
+ })
}
colheader_tbl_list
@@ -752,66 +703,62 @@ utf8Tortf <- function(x) {
#' rtf code to set up header for the rtf table
#'
-#' @param gt_tbl A data frame
+#' @param tbl A data frame
#'
#' @noRd
-.as_rtf_header <- function(gt_tbl) {
-
+.as_rtf_header <- function(tbl) {
header <- list()
- heading <- .get_heading(gt_tbl)
-
- if(.is_title(heading)){
+ heading <- .get_heading(tbl)
+ if (.is_title(heading)) {
text_title <- paste(heading$title, collapse = " \n ")
header[[1]] <- .rtf_text(.convert(text_title),
- font = heading$font,
- font_size = heading$font_size,
- format = heading$format,
- color = heading$color,
- background_color = heading$background_color)
-
- if(.is_subtitle(heading)) {
+ font = heading$font,
+ font_size = heading$font_size,
+ format = heading$format,
+ color = heading$color,
+ background_color = heading$background_color
+ )
+ if (.is_subtitle(heading)) {
text_subtitle <- paste0("\n ", paste(heading$subtitle, collapse = " \n "))
header[[2]] <- .rtf_text(.convert(text_subtitle),
- font = heading$font,
- font_size = heading$font_size,
- format = heading$format,
- color = heading$color,
- background_color = heading$background_color)
-
-
+ font = heading$font,
+ font_size = heading$font_size,
+ format = heading$format,
+ color = heading$color,
+ background_color = heading$background_color
+ )
}
}
## if there is no title and subtitle, set header to NULL, no need to print anything
- if (length(header) == 0){
+ if (length(header) == 0) {
header <- NULL
- }else{
- header <- paste(unlist(header),collapse = "\n")
+ } else {
+ header <- paste(unlist(header), collapse = "\n")
}
- if (!is.null(header)){
-
+ if (!is.null(header)) {
paragraph <- .rtf_paragraph(header,
+ justification = heading$justification,
- justification = heading$justification,
+ indent_first = heading$indent_first,
+ indent_left = heading$indent_left,
+ indent_right = heading$indent_right,
- indent_first = heading$indent_first,
- indent_left = heading$indent_left,
- indent_right = heading$indent_right,
+ space = heading$space,
+ space_before = heading$space_before,
+ space_after = heading$space_after,
- space = heading$space,
- space_before = heading$space_before,
- space_after = heading$space_after,
-
- new_page = heading$new_page,
- hyphenation = heading$hyphenation)
- }else{
+ new_page = heading$new_page,
+ hyphenation = heading$hyphenation
+ )
+ } else {
paragraph <- NULL
}
@@ -819,105 +766,92 @@ utf8Tortf <- function(x) {
}
#' rtf code to set up footnote for the rtf table
-#' @param gt_tbl a data frame
+#' @param tbl a data frame
#' @noRd
-.as_rtf_footnote <- function(gt_tbl){
-
-
-
- footnote_df <- .get_footnote(gt_tbl)
-
- if(.is_footnote(footnote_df)){
+.as_rtf_footnote <- function(tbl) {
+ footnote_df <- .get_footnote(tbl)
+ if (.is_footnote(footnote_df)) {
text_footnote <- paste(footnote_df$footnote, collapse = " \n ")
text_footnote <- .rtf_text(.convert(text_footnote),
- font = footnote_df$font,
- font_size = footnote_df$font_size,
- format = footnote_df$format,
- color = footnote_df$color,
- background_color = footnote_df$background_color)
-
- }else{
+ font = footnote_df$font,
+ font_size = footnote_df$font_size,
+ format = footnote_df$format,
+ color = footnote_df$color,
+ background_color = footnote_df$background_color
+ )
+ } else {
text_footnote <- NULL
}
- if (!is.null(text_footnote)){
-
+ if (!is.null(text_footnote)) {
paragraph <- .rtf_paragraph(text_footnote,
+ justification = footnote_df$justification,
- justification = footnote_df$justification,
-
- indent_first = footnote_df$indent_first,
- indent_left = footnote_df$indent_left,
- indent_right = footnote_df$indent_right,
+ indent_first = footnote_df$indent_first,
+ indent_left = footnote_df$indent_left,
+ indent_right = footnote_df$indent_right,
- space = footnote_df$space,
- space_before = footnote_df$space_before,
- space_after = footnote_df$space_after,
+ space = footnote_df$space,
+ space_before = footnote_df$space_before,
+ space_after = footnote_df$space_after,
- new_page = footnote_df$new_page,
- hyphenation = footnote_df$hyphenation)
- }else{
+ new_page = footnote_df$new_page,
+ hyphenation = footnote_df$hyphenation
+ )
+ } else {
paragraph <- NULL
}
paragraph
-
-
}
#' rtf code to set up footnote for the rtf table
-#' @param gt_tbl a data frame
+#' @param tbl a data frame
#'
#' @noRd
-.as_rtf_source <- function(gt_tbl){
-
-
-
- source <- .get_source(gt_tbl)
-
- if(.is_source(source)){
+.as_rtf_source <- function(tbl) {
+ source <- .get_source(tbl)
+ if (.is_source(source)) {
text_source <- paste(source$source, collapse = " \n ")
text_source <- .rtf_text(.convert(text_source),
- font = source$font,
- font_size = source$font_size,
- format = source$format,
- color = source$color,
- background_color = source$background_color)
-
- }else{
+ font = source$font,
+ font_size = source$font_size,
+ format = source$format,
+ color = source$color,
+ background_color = source$background_color
+ )
+ } else {
text_source <- NULL
}
- if (!is.null(text_source)){
-
+ if (!is.null(text_source)) {
paragraph <- .rtf_paragraph(text_source,
+ justification = source$justification,
- justification = source$justification,
+ indent_first = source$indent_first,
+ indent_left = source$indent_left,
+ indent_right = source$indent_right,
- indent_first = source$indent_first,
- indent_left = source$indent_left,
- indent_right = source$indent_right,
+ space = source$space,
+ space_before = source$space_before,
+ space_after = source$space_after,
- space = source$space,
- space_before = source$space_before,
- space_after = source$space_after,
-
- new_page = source$new_page,
- hyphenation = source$hyphenation)
- }else{
+ new_page = source$new_page,
+ hyphenation = source$hyphenation
+ )
+ } else {
paragraph <- NULL
}
paragraph
-
}
@@ -929,95 +863,92 @@ utf8Tortf <- function(x) {
#'
#' @noRd
.cell_size <- function(col_rel_width, col_total_width) {
-
total.width.twip <- .inch_to_twip(col_total_width)
- round(total.width.twip/sum(col_rel_width) * col_rel_width,0)
-
+ round(total.width.twip / sum(col_rel_width) * col_rel_width, 0)
}
#' get attributes and write rtf table row by row
-#' @param gt_tbl a data frame
+#' @param tbl a data frame
#'
#'
#' @noRd
-.as_rtf_table <- function(gt_tbl) {
-
-
- ## get attributes from gt_tbl
- border_left <- attributes(gt_tbl)$border_left
- border_right <- attributes(gt_tbl)$border_right
- border_top <- attributes(gt_tbl)$border_top
- border_bottom <- attributes(gt_tbl)$border_bottom
-
- border_color_left <- attributes(gt_tbl)$border_color_left
- border_color_right <- attributes(gt_tbl)$border_color_right
- border_color_top <- attributes(gt_tbl)$border_color_top
- border_color_bottom <- attributes(gt_tbl)$border_color_bottom
-
- border_width <- attributes(gt_tbl)$border_width
- page_width <- attributes(gt_tbl)$page_width
- col_rel_width <- attributes(gt_tbl)$col_rel_width
- col_total_width <- attributes(gt_tbl)$col_total_width
- cell_height <- attributes(gt_tbl)$cell_height
- cell_justification <- attributes(gt_tbl)$cell_justification
-
- text_font <- attributes(gt_tbl)$text_font
- text_format <- attributes(gt_tbl)$text_format
- text_color <- attributes(gt_tbl)$text_color
- text_background_color <- attributes(gt_tbl)$text_background_color
- text_justification <- attributes(gt_tbl)$text_justification
- text_font_size <- attributes(gt_tbl)$text_font_size
- text_space_before <- attributes(gt_tbl)$text_space_before
- text_space_after <- attributes(gt_tbl)$text_space_after
-
- page_num <- attributes(gt_tbl)$page_num
- new_page <- attributes(gt_tbl)$new_page
- pageby_db <- attributes(gt_tbl)$pageby_db
- pageby_endpage_index <- attributes(gt_tbl)$pageby_endpage_index
-
-
- last_row <- attributes(gt_tbl)$last_row
-
-
- table <- .rtf_table_content(pageby_db,
-
- border_left = border_left,
- border_right = border_right,
- border_top = border_top,
- border_bottom = border_bottom,
-
- border_color_left = border_color_left,
- border_color_right = border_color_right,
- border_color_top = border_color_top,
- border_color_bottom = border_color_bottom,
-
- border_width = border_width,
- page_width = page_width,
- col_rel_width = col_rel_width,
- col_total_width = col_total_width,
- cell_height = cell_height,
- cell_justification = cell_justification,
-
- text_font = text_font,
- text_format = text_format,
- text_color = text_color,
- text_background_color= text_background_color,
- text_justification = text_justification,
- text_font_size = text_font_size,
- text_space_before = text_space_before,
- text_space_after = text_space_after,
-
- page_num = page_num,
- pageby_endpage_index = pageby_endpage_index,
- new_page = new_page,
-
- last_row = last_row)
-
- table
+.as_rtf_table <- function(tbl) {
+
+
+ ## get attributes from tbl
+ border_left <- attributes(tbl)$border_left
+ border_right <- attributes(tbl)$border_right
+ border_top <- attributes(tbl)$border_top
+ border_bottom <- attributes(tbl)$border_bottom
+
+ border_color_left <- attributes(tbl)$border_color_left
+ border_color_right <- attributes(tbl)$border_color_right
+ border_color_top <- attributes(tbl)$border_color_top
+ border_color_bottom <- attributes(tbl)$border_color_bottom
+
+ border_width <- attributes(tbl)$border_width
+ page_width <- attributes(tbl)$page_width
+ col_rel_width <- attributes(tbl)$col_rel_width
+ col_total_width <- attributes(tbl)$col_total_width
+ cell_height <- attributes(tbl)$cell_height
+ cell_justification <- attributes(tbl)$cell_justification
+
+ text_font <- attributes(tbl)$text_font
+ text_format <- attributes(tbl)$text_format
+ text_color <- attributes(tbl)$text_color
+ text_background_color <- attributes(tbl)$text_background_color
+ text_justification <- attributes(tbl)$text_justification
+ text_font_size <- attributes(tbl)$text_font_size
+ text_space_before <- attributes(tbl)$text_space_before
+ text_space_after <- attributes(tbl)$text_space_after
+
+ page_num <- attributes(tbl)$page_num
+ new_page <- attributes(tbl)$new_page
+ pageby_db <- attributes(tbl)$pageby_db
+ pageby_endpage_index <- attributes(tbl)$pageby_endpage_index
+
+
+ last_row <- attributes(tbl)$last_row
+
+
+ table <- .rtf_table_content(pageby_db,
+ border_left = border_left,
+ border_right = border_right,
+ border_top = border_top,
+ border_bottom = border_bottom,
+
+ border_color_left = border_color_left,
+ border_color_right = border_color_right,
+ border_color_top = border_color_top,
+ border_color_bottom = border_color_bottom,
+
+ border_width = border_width,
+ page_width = page_width,
+ col_rel_width = col_rel_width,
+ col_total_width = col_total_width,
+ cell_height = cell_height,
+ cell_justification = cell_justification,
+
+ text_font = text_font,
+ text_format = text_format,
+ text_color = text_color,
+ text_background_color = text_background_color,
+ text_justification = text_justification,
+ text_font_size = text_font_size,
+ text_space_before = text_space_before,
+ text_space_after = text_space_after,
+
+ page_num = page_num,
+ pageby_endpage_index = pageby_endpage_index,
+ new_page = new_page,
+
+ last_row = last_row
+ )
+ table
}
@@ -1085,18 +1016,18 @@ utf8Tortf <- function(x) {
pageby_endpage_index,
new_page,
- last_row){
+ last_row) {
## get dimension of db
- n_row = nrow(db)
- n_col = ncol(db)
+ n_row <- nrow(db)
+ n_col <- ncol(db)
## Transer vector to matrix by row
- foo <- function(x){
- if( (is.null(dim(x))) & (! is.null(x) ) ){
+ foo <- function(x) {
+ if ((is.null(dim(x))) & (!is.null(x))) {
x <- matrix(x, nrow = n_row, ncol = n_col, byrow = TRUE)
}
x
@@ -1104,63 +1035,65 @@ utf8Tortf <- function(x) {
## cell justification
- justification <- .justification()
- cell_justification_rtf <- factor(cell_justification, levels = justification$type, labels = justification$rtf_code_row)
- cell_height <- round(.inch_to_twip(cell_height)/2,0)
+ justification <- .justification()
+ cell_justification_rtf <- factor(cell_justification, levels = justification$type, labels = justification$rtf_code_row)
+ cell_height <- round(.inch_to_twip(cell_height) / 2, 0)
## rtf code for table begin and end
- row_begin <- paste0("\\trowd\\trgaph", cell_height, "\\trleft0", cell_justification_rtf)
- row_end <- "\\intbl\\row\\pard"
+ row_begin <- paste0("\\trowd\\trgaph", cell_height, "\\trleft0", cell_justification_rtf)
+ row_end <- "\\intbl\\row\\pard"
# Encoding RTF Cell Border
- border_lrtb <- c("\\clbrdrl", "\\clbrdrr", "\\clbrdrt", "\\clbrdrb")
+ border_lrtb <- c("\\clbrdrl", "\\clbrdrr", "\\clbrdrt", "\\clbrdrb")
names(border_lrtb) <- c("left", "right", "top", "bottom")
- border_wid <- paste0("\\brdrw", border_width)
+ border_wid <- paste0("\\brdrw", border_width)
## cell border
- border_type <- .border_type()
- border_left_rtf <- factor(border_left, levels = border_type$name, labels = border_type$rtf_code)
- border_right_rtf <- factor(border_right, levels = border_type$name, labels = border_type$rtf_code)
- border_top_rtf <- factor(border_top, levels = border_type$name, labels = border_type$rtf_code)
- border_bottom_rtf <- factor(border_bottom, levels = border_type$name, labels = border_type$rtf_code)
+ border_type <- .border_type()
+ border_left_rtf <- factor(border_left, levels = border_type$name, labels = border_type$rtf_code)
+ border_right_rtf <- factor(border_right, levels = border_type$name, labels = border_type$rtf_code)
+ border_top_rtf <- factor(border_top, levels = border_type$name, labels = border_type$rtf_code)
+ border_bottom_rtf <- factor(border_bottom, levels = border_type$name, labels = border_type$rtf_code)
- border_left_rtf <- paste0(border_lrtb["left"] , border_left_rtf, border_wid)
- border_right_rtf <- paste0(border_lrtb["right"] , border_right_rtf, border_wid)
- border_top_rtf <- paste0(border_lrtb["top"] , border_top_rtf, border_wid)
- border_bottom_rtf <- paste0(border_lrtb["bottom"], border_bottom_rtf, border_wid)
+ border_left_rtf <- paste0(border_lrtb["left"], border_left_rtf, border_wid)
+ border_right_rtf <- paste0(border_lrtb["right"], border_right_rtf, border_wid)
+ border_top_rtf <- paste0(border_lrtb["top"], border_top_rtf, border_wid)
+ border_bottom_rtf <- paste0(border_lrtb["bottom"], border_bottom_rtf, border_wid)
## border color
col_tb <- .color_table()
if (!is.null(border_color_left)) {
- border_color_left_rtf <- factor(border_color_left, levels = col_tb$color, labels = col_tb$type)
- border_color_left_rtf <- paste0("\\brdrcf", border_color_left_rtf)
- border_left_rtf <- paste0(border_left_rtf, border_color_left_rtf)
+ border_color_left_rtf <- factor(border_color_left, levels = col_tb$color, labels = col_tb$type)
+ border_color_left_rtf <- paste0("\\brdrcf", border_color_left_rtf)
+ border_left_rtf <- paste0(border_left_rtf, border_color_left_rtf)
}
if (!is.null(border_color_right)) {
- border_color_right_rtf <- factor(border_color_right, levels = col_tb$color, labels = col_tb$type)
- border_color_right_rtf <- paste0("\\brdrcf", border_color_right_rtf)
- border_right_rtf <- paste0(border_right_rtf, border_color_right_rtf)
+ border_color_right_rtf <- factor(border_color_right, levels = col_tb$color, labels = col_tb$type)
+ border_color_right_rtf <- paste0("\\brdrcf", border_color_right_rtf)
+ border_right_rtf <- paste0(border_right_rtf, border_color_right_rtf)
}
if (!is.null(border_color_top)) {
- border_color_top_rtf <- factor(border_color_top, levels = col_tb$color, labels = col_tb$type)
- border_color_top_rtf <- paste0("\\brdrcf", border_color_top_rtf)
- border_top_rtf <- paste0(border_top_rtf, border_color_top_rtf)
+ border_color_top_rtf <- factor(border_color_top, levels = col_tb$color, labels = col_tb$type)
+ border_color_top_rtf <- paste0("\\brdrcf", border_color_top_rtf)
+ border_top_rtf <- paste0(border_top_rtf, border_color_top_rtf)
}
if (!is.null(border_color_bottom)) {
- border_color_bottom_rtf <- factor(border_color_bottom, levels = col_tb$color, labels = col_tb$type)
+ border_color_bottom_rtf <- factor(border_color_bottom, levels = col_tb$color)
+ levels(border_color_bottom_rtf) <- col_tb$type
border_color_bottom_rtf <- paste0("\\brdrcf", border_color_bottom_rtf)
- border_bottom_rtf <- paste0(border_bottom_rtf, border_color_bottom_rtf)
+ border_bottom_rtf <- paste0(border_bottom_rtf, border_color_bottom_rtf)
}
## Cell Background Color
if (!is.null(text_background_color)) {
- text_background_color_rtf <- factor(text_background_color, levels = col_tb$color, labels = col_tb$type)
+ text_background_color_rtf <- factor(text_background_color, levels = col_tb$color)
+ levels(text_background_color_rtf) <- col_tb$type
text_background_color_rtf <- paste0("\\clcbpat", text_background_color_rtf)
} else {
text_background_color_rtf <- NULL
@@ -1169,32 +1102,32 @@ utf8Tortf <- function(x) {
# Cell Size
cell_width <- .cell_size(col_rel_width, col_total_width)
- cell_size <- cumsum(cell_width)
- cell_size <- foo(cell_size)
+ cell_size <- cumsum(cell_width)
+ cell_size <- foo(cell_size)
# Cell Border
- border_top_left <- matrix(paste0(border_left_rtf, border_top_rtf, text_background_color_rtf, "\\cellx", cell_size), nrow = n_row, ncol = n_col)
- border_top_left_right <- matrix(paste0(border_left_rtf, border_top_rtf, border_right_rtf, text_background_color_rtf, "\\cellx", cell_size), nrow = n_row, ncol = n_col)
+ border_top_left <- matrix(paste0(border_left_rtf, border_top_rtf, text_background_color_rtf, "\\cellx", cell_size), nrow = n_row, ncol = n_col)
+ border_top_left_right <- matrix(paste0(border_left_rtf, border_top_rtf, border_right_rtf, text_background_color_rtf, "\\cellx", cell_size), nrow = n_row, ncol = n_col)
border_top_left_bottom <- matrix(paste0(border_left_rtf, border_top_rtf, border_bottom_rtf, text_background_color_rtf, "\\cellx", cell_size), nrow = n_row, ncol = n_col)
- border_all <- matrix(paste0(border_left_rtf, border_top_rtf, border_right_rtf, border_bottom_rtf, text_background_color_rtf, "\\cellx", cell_size), nrow = n_row, ncol = n_col)
+ border_all <- matrix(paste0(border_left_rtf, border_top_rtf, border_right_rtf, border_bottom_rtf, text_background_color_rtf, "\\cellx", cell_size), nrow = n_row, ncol = n_col)
- border_rtf <- border_top_left
- border_rtf[, n_col] <- border_top_left_right[, n_col]
+ border_rtf <- border_top_left
+ border_rtf[, n_col] <- border_top_left_right[, n_col]
## check page_num
if (!is.null(page_num) && !is.null(pageby_endpage_index)) {
- #if (!is.null(page_num) && (new_page == TRUE)) {
- #if (!is.null(page_num) && page_num <= n_row){
+ # if (!is.null(page_num) && (new_page == TRUE)) {
+ # if (!is.null(page_num) && page_num <= n_row){
- border_rtf[pageby_endpage_index, ] <- border_top_left_bottom[pageby_endpage_index,]
+ border_rtf[pageby_endpage_index, ] <- border_top_left_bottom[pageby_endpage_index, ]
border_rtf[pageby_endpage_index, n_col] <- border_all[pageby_endpage_index, n_col]
}
## check last_row
if (last_row) {
- border_rtf[n_row, ] <- border_top_left_bottom[n_row ,]
+ border_rtf[n_row, ] <- border_top_left_bottom[n_row, ]
border_rtf[n_row, n_col] <- border_all[n_row, n_col]
}
@@ -1206,14 +1139,15 @@ utf8Tortf <- function(x) {
cell <- paste0("\\pard\\intbl\\sb", text_space_before, "\\sa", text_space_after)
## text justificaton
- text_justification_rtf <- factor(text_justification, levels = justification$type, labels = justification$rtf_code_text)
+ text_justification_rtf <- factor(text_justification, levels = justification$type, labels = justification$rtf_code_text)
+
# if align in decimal always justified at center.
- text_justification_rtf <- ifelse( text_justification == "d", paste0(text_justification_rtf, "\\tqdec\\tx", round(foo(cell_width)/2, 0) ), as.character(text_justification_rtf))
+ text_justification_rtf <- ifelse(text_justification == "d", paste0(text_justification_rtf, "\\tqdec\\tx", round(foo(cell_width) / 2, 0)), as.character(text_justification_rtf))
## text font and font size
- font_type <- .font_type()
- text_font_rtf <- factor(text_font, levels = font_type$type, labels = font_type$rtf_code)
- text_font_size_rtf <- paste0("\\fs", round(text_font_size * 2, 0) )
+ font_type <- .font_type()
+ text_font_rtf <- factor(text_font, levels = font_type$type, labels = font_type$rtf_code)
+ text_font_size_rtf <- paste0("\\fs", round(text_font_size * 2, 0))
## text format
## The combination of type should is valid.
@@ -1221,27 +1155,31 @@ utf8Tortf <- function(x) {
font_format <- .font_format()
if (!is.null(text_format)) {
- text_format_rtf <- lapply(strsplit(text_format, ""), function(x){
+ text_format_rtf <- lapply(strsplit(text_format, ""), function(x) {
paste0(factor(x, levels = font_format$type, labels = font_format$rtf_code),
- collapse = "")} )
- text_format_rtf <- unlist(text_format_rtf)
+ collapse = ""
+ )
+ })
+ text_format_rtf <- unlist(text_format_rtf)
} else {
text_format_rtf <- NULL
}
## cell text color
- if ( !is.null(text_color) ) {
- text_color_rtf <- factor(text_color, levels = col_tb$color, labels = col_tb$type)
- text_color_rtf <- paste0("\\cf", text_color_rtf)
+ if (!is.null(text_color)) {
+ text_color_rtf <- factor(text_color, levels = col_tb$color, labels = col_tb$type)
+ text_color_rtf <- paste0("\\cf", text_color_rtf)
} else {
text_color_rtf <- NULL
}
- content_matrix <- as.matrix( sapply( db,function(x) .convert(x)))
+ content_matrix <- as.matrix(sapply(db, function(x) .convert(x)))
- cell_rtf <- paste0(cell, text_justification_rtf,
- "{", text_font_rtf, text_font_size_rtf, text_color_rtf, text_format_rtf,
- " " , content_matrix , "}", "\\cell")
+ cell_rtf <- paste0(
+ cell, text_justification_rtf,
+ "{", text_font_rtf, text_font_size_rtf, text_color_rtf, text_format_rtf,
+ " ", content_matrix, "}", "\\cell"
+ )
cell_rtf <- t(matrix(cell_rtf, nrow = n_row, ncol = n_col))
@@ -1255,13 +1193,6 @@ utf8Tortf <- function(x) {
#' end rtf table
#'
#' @noRd
-.end_rtf<-function() {
- paste("}", sep= "")
+.end_rtf <- function() {
+ paste("}", sep = "")
}
-
-
-
-
-
-
-
diff --git a/R/add_figure.R b/R/add_figure.R
index 2a5be75f..3458b334 100644
--- a/R/add_figure.R
+++ b/R/add_figure.R
@@ -19,20 +19,44 @@
#'
#' @param file a vector of PNG file path
#'
+#' @return a list of binary data vector returned by \code{readBin}
+#'
+#' @examples
+#' file <- file.path(tempdir(), "figure1.png")
+#' png(file)
+#' plot(1:10)
+#' dev.off()
+#'
+#' # Read in PNG file in binary format
+#' rtf_read_png(file)
+#'
#' @export
-rtf_read_png <- function(file){
- lapply(file, readBin, what="raw", size=1, signed=TRUE, endian="little", n = 1e8)
+rtf_read_png <- function(file) {
+ lapply(file, readBin, what = "raw", size = 1, signed = TRUE, endian = "little", n = 1e8)
}
-#' Add Figure Attrbuties
+#' Add Figure Attributes
#'
#' @inheritParams rtf_body
#'
#' @param fig_width the width of figures in inch
#' @param fig_height the height of figures in inch
#'
+#' @return the same data frame \code{tbl} with additional attributes for figure body
+#'
+#' @examples
+#' library(dplyr) # required to run examples
+#' file <- file.path(tempdir(), "figure1.png")
+#' png(file)
+#' plot(1:10)
+#' dev.off()
+#'
+#' # Read in PNG file in binary format
+#' rtf_read_png(file) %>% rtf_figure() %>%
+#' attributes()
+#'
#' @export
-rtf_figure <- function(gt_tbl,
+rtf_figure <- function(tbl,
page_width = 8.5,
page_height = 11,
@@ -40,22 +64,20 @@ rtf_figure <- function(gt_tbl,
doctype = "wma",
fig_width = 5,
- fig_height = 5){
-
- gt_tbl <- .rtf_page_size(gt_tbl,
- page_width = page_width,
- page_height = page_height,
- orientation = orientation
+ fig_height = 5) {
+ tbl <- .rtf_page_size(tbl,
+ page_width = page_width,
+ page_height = page_height,
+ orientation = orientation
)
- gt_tbl <- .rtf_page_margin(gt_tbl,
- doctype = doctype,
- orientation = orientation
+ tbl <- .rtf_page_margin(tbl,
+ doctype = doctype,
+ orientation = orientation
)
- attr(gt_tbl, "fig_width") <- matrix(fig_width, nrow = length(gt_tbl), ncol = 1, byrow = TRUE)
- attr(gt_tbl, "fig_height") <- matrix(fig_height, nrow = length(gt_tbl), ncol = 1, byrow = TRUE)
-
- gt_tbl
+ attr(tbl, "fig_width") <- matrix(fig_width, nrow = length(tbl), ncol = 1, byrow = TRUE)
+ attr(tbl, "fig_height") <- matrix(fig_height, nrow = length(tbl), ncol = 1, byrow = TRUE)
+ tbl
}
diff --git a/R/add_paragraph.R b/R/add_paragraph.R
index 7b31e9e8..3a5ca778 100644
--- a/R/add_paragraph.R
+++ b/R/add_paragraph.R
@@ -31,10 +31,12 @@
font_size = 12,
format = NULL,
color = NULL,
- background_color = NULL){
+ background_color = NULL) {
## Set defalut value
- if( (! is.null(background_color)) & is.null(color)){color <- "black"}
+ if ((!is.null(background_color)) & is.null(color)) {
+ color <- "black"
+ }
## Define dictionary
font_type <- .font_type()
@@ -42,15 +44,14 @@
col_tb <- .color_table()
- if(! is.null(format)){
+ if (!is.null(format)) {
format_check <- unlist(strsplit(format, ""))
- }else{
+ } else {
format_check <- NULL
}
## check whether input arguments are valid
stopifnot(
-
font %in% font_type$type,
as.vector(format_check) %in% font_format$type,
@@ -60,8 +61,6 @@
color %in% col_tb$color,
background_color %in% col_tb$color
-
-
)
@@ -71,26 +70,29 @@
### Font
font <- factor(font, levels = font_type$type, labels = font_type$rtf_code)
- font_size <- paste0("\\fs", round(font_size * 2, 0) )
-
+ font_size <- paste0("\\fs", round(font_size * 2, 0))
## The combination of text format should be valid.
## e.g. type = "bi" or "ib" should be bold and italics.
- if(! is.null(format)){
- format <- lapply(strsplit(format, ""), function(x){
+ if (!is.null(format)) {
+ format <- lapply(strsplit(format, ""), function(x) {
paste0(factor(x, levels = font_format$type, labels = font_format$rtf_code),
- collapse = "")} )
- format <- unlist(format)
- }else{format <- NULL}
+ collapse = ""
+ )
+ })
+ format <- unlist(format)
+ } else {
+ format <- NULL
+ }
### Color
text_color <- NULL
- if(! is.null(color)){
+ if (!is.null(color)) {
fg_color <- factor(color, levels = col_tb$color, labels = col_tb$type)
text_color <- paste0("\\cf", fg_color)
}
- if(! is.null(background_color)){
+ if (!is.null(background_color)) {
bg_color <- factor(background_color, levels = col_tb$color, labels = col_tb$type)
text_color <- paste0(text_color, "\\chshdng0", "\\chcbpat", bg_color, "\\cb", bg_color)
}
@@ -104,13 +106,14 @@
end <- "}"
- paste0(begin,
- font, font_size,
- format,
- text_color, " ",
- text,
- end)
-
+ paste0(
+ begin,
+ font, font_size,
+ format,
+ text_color, " ",
+ text,
+ end
+ )
}
#' rtf code to add text to paragraph
@@ -130,20 +133,20 @@
#'
#' @noRd
.rtf_paragraph <- function(
- text,
+ text,
- justification = "c",
+ justification = "c",
- indent_first = 0,
- indent_left = 0,
- indent_right = 0,
+ indent_first = 0,
+ indent_left = 0,
+ indent_right = 0,
- space = 1,
- space_before = 180,
- space_after = 180,
+ space = 1,
+ space_before = 180,
+ space_after = 180,
- new_page = FALSE,
- hyphenation = TRUE){
+ new_page = FALSE,
+ hyphenation = TRUE) {
## Define dictionary
para_justification <- .justification()
@@ -151,7 +154,6 @@
## check whether input arguments are valid
stopifnot(
-
as.vector(justification) %in% para_justification$type,
is.numeric(indent_first),
@@ -165,30 +167,29 @@
is.numeric(space_before),
is.numeric(space_after)
-
-
-
)
begin <- "{\\pard"
### line space
space_before <- paste0("\\sb", space_before)
- space_after <- paste0("\\sa", space_after)
+ space_after <- paste0("\\sa", space_after)
### paragraph space
- space <- factor(space, levels = spacing$type, labels = spacing$rtf_code)
+ space <- factor(space, levels = spacing$type)
+ levels(space) <- spacing$rtf_code
### Start new page for this paragraph
page_break <- ifelse(new_page, "\\pagebb", "")
### Indent
indent_first <- paste0("\\fi", indent_first)
- indent_left <- paste0("\\li", indent_left)
+ indent_left <- paste0("\\li", indent_left)
indent_right <- paste0("\\ri", indent_right)
### Alignment
- alignment <- factor(justification, levels = para_justification$type, labels = para_justification$rtf_code_text)
+ alignment <- factor(justification, levels = para_justification$type)
+ levels(alignment) <- para_justification$rtf_code_text
### Hyphenation
hyphenation <- ifelse(hyphenation, "\\hyphpar", "hyphpar0")
@@ -197,11 +198,12 @@
## Paragraph RTF Encode
- paste0(begin, page_break, hyphenation, "\n",
- space, space_before, space_after, indent_first, indent_left, indent_right, alignment, "\n",
- text, "\n",
- end)
-
+ paste0(
+ begin, page_break, hyphenation, "\n",
+ space, space_before, space_after, indent_first, indent_left, indent_right, alignment, "\n",
+ text, "\n",
+ end
+ )
}
#' rtf code to add picture
@@ -209,11 +211,12 @@
#' @param path path for rtf figure
#'
#' @noRd
-.rtf_figure <- function(path){
+.rtf_figure <- function(path) {
# ToDo
# refer rtf:::.add.png and rtf::addPng.RTF
- paste0( "{\\field\\fldedit{\\*\\fldinst { INCLUDEPICTURE \\\\d",
+ paste0(
+ "{\\field\\fldedit{\\*\\fldinst { INCLUDEPICTURE \\\\d",
path,
"\\\\* MERGEFORMATINET }}{\\fldrslt { }}}"
)
@@ -226,18 +229,17 @@
#' @param file file name to save rtf text paragraph, eg. filename.rtf
#'
#' @noRd
-write_rtf_para <- function(rtf_body, file){
-
- col_tb <- .color_table()
- rtf_color <- paste(c( "{\\colortbl; ", col_tb$rtf_code, "}"), collapse = "\n")
+write_rtf_para <- function(rtf_body, file) {
+ col_tb <- .color_table()
+ rtf_color <- paste(c("{\\colortbl; ", col_tb$rtf_code, "}"), collapse = "\n")
start_rtf <- paste(
.as_rtf_init(),
.as_rtf_font(),
rtf_color,
- sep="\n"
+ sep = "\n"
)
- rtf <- paste(start_rtf, "{\\pard \\par}", paste(rtf_body, collapse = ""), .end_rtf(), sep="\n")
+ rtf <- paste(start_rtf, "{\\pard \\par}", paste(rtf_body, collapse = ""), .end_rtf(), sep = "\n")
write(rtf, file)
}
diff --git a/R/data.R b/R/data.R
index a382f8ad..dca09b10 100644
--- a/R/data.R
+++ b/R/data.R
@@ -15,27 +15,76 @@
# You should have received a copy of the GNU General Public License
# along with this program. If not, see .
-#' ADAE
+#' An Adverse Event Dataset
+#'
+#' A dataset containing the adverse event information of a clinical trial following
+#' CDISC ADaM standard.
+#'
+#' Definition of each variable can be found in
+#' \url{https://www.cdisc.org/pilot-project-submission-package}
+#'
+#' @format A data frame with 1191 rows and 55 variables.
+#'
+#' @source \url{https://www.cdisc.org/pilot-project-submission-package}
+#'
"adae"
-#' ADSL
+#' A Subject Level Demographic Dataset
+#'
+#' A dataset containing the demographic information of a clinical trial following
+#' CDISC ADaM standard.
+#'
+#' Definition of each variable can be found in
+#' \url{https://www.cdisc.org/pilot-project-submission-package}
+#'
+#' @format A data frame with 254 rows and 51 variables.
+#'
+#' @source \url{https://www.cdisc.org/pilot-project-submission-package}
"adsl"
-#' ADTTE
-"adtte"
-
-#' HAMD17
+#' An Efficacy Clinical Trial Data to Evaluate a Drug to Reduce Lower Back Pain
+#'
+#' A dataset prepared by the Drug Information Association scientific working group
+#' to investigate a drug to reduce lower back pain.
+#'
+#' Definition of each variable can be found in \url{https://missingdata.lshtm.ac.uk/dia-working-group/}
+#'
+#' @format A data frame with 831 rows and 6 variables.
+#'
+#' @source \url{https://missingdata.lshtm.ac.uk/dia-working-group/}
"HAMD17"
-#' t1_gt
-"t1_gt"
+#' Within Group Results from an ANCOVA Model
+#'
+#' A dataset containing within group results from an ANCOVA model.
+#'
+#' @format A data frame with 2 rows and 8 variables.
+"tbl_1"
-#' t2_gt
-"t2_gt"
+#' Between Group Results from an ANCOVA Model
+#'
+#' A dataset containing between group results from an ANCOVA model.
+#'
+#' @format A data frame with 1 row and 3 variables.
+"tbl_2"
-#' t3_gt
-"t3_gt"
+#' Root Mean Square Error from an ANCOVA model
+#'
+#' A dataset containing root mean square error from an ANCOVA model.
+#'
+#' @format A data frame with 1 row and 1 variable.
+"tbl_3"
-#' unicode_latex
+#' Dictionary of Unicode and Latex Code
+#'
+#' A dataset containing the mapping between unicode and latex code.
+#'
+#' @format A data frame with 681 rows and 3 variables.
+#' \describe{
+#' \item{unicode}{unicode, UTF-8 code}
+#' \item{latex}{latex, latex code}
+#' \item{int}{int, Converted integer of the UTF-8 code}
+#' }
+#'
+#' @source \url{http://milde.users.sourceforge.net/LUCR/Math/data/unimathsymbols.txt}
"unicode_latex"
-
diff --git a/R/dictionary.R b/R/dictionary.R
index ed6dac63..753a662f 100644
--- a/R/dictionary.R
+++ b/R/dictionary.R
@@ -20,15 +20,12 @@
#'
#' @noRd
.font_type <- function() {
-
data.frame(
-
type = 1:3,
name = c("Times New Roman", "Times New Roman Greek", "Arial Greek"),
- style = c("\\froman","\\froman","\\fswiss"),
- rtf_code = c("\\f0", "\\f166","\\f266"),
+ style = c("\\froman", "\\froman", "\\fswiss"),
+ rtf_code = c("\\f0", "\\f166", "\\f266"),
stringsAsFactors = FALSE
-
)
}
@@ -37,12 +34,11 @@
#'
#' @noRd
.color_table <- function() {
-
.tb <- data.frame(color = grDevices::colors())
.tb$type <- 1:nrow(.tb) + 1
- .tb <- cbind( .tb, t(grDevices::col2rgb(.tb$color)) )
- .tb$rtf_code <- paste0("\\red",.tb$red, "\\green", .tb$green, "\\blue", .tb$blue,";")
+ .tb <- cbind(.tb, t(grDevices::col2rgb(.tb$color)))
+ .tb$rtf_code <- paste0("\\red", .tb$red, "\\green", .tb$green, "\\blue", .tb$blue, ";")
.tb
}
@@ -53,14 +49,11 @@
#'
#' @noRd
.font_format <- function() {
-
data.frame(
-
- type = c("","b", "i", "u","s","^","_"),
- name = c("normal","bold", "italics","underline","strike","superscript","subscript"),
- rtf_code = c("","\\b", "\\i", "\\ul", "\\strike", "\\super", "\\sub"),
+ type = c("", "b", "i", "u", "s", "^", "_"),
+ name = c("normal", "bold", "italics", "underline", "strike", "superscript", "subscript"),
+ rtf_code = c("", "\\b", "\\i", "\\ul", "\\strike", "\\super", "\\sub"),
stringsAsFactors = FALSE
-
)
}
@@ -68,39 +61,37 @@
#'
#' @noRd
.justification <- function() {
-
data.frame(
-
type = c("l", "c", "r", "d", "j"),
name = c("left", "center", "right", "decimal", "justified"),
rtf_code_text = c("\\ql", "\\qc", "\\qr", "\\qj", "\\qj"),
- rtf_code_row = c("\\trql", "\\trqc", "\\trqr", "", ""),
+ rtf_code_row = c("\\trql", "\\trqc", "\\trqr", "", ""),
stringsAsFactors = FALSE
-
)
-
}
#' create a data frame as dictionary to look up for rtf table border type
#'
#' @noRd
.border_type <- function() {
-
data.frame(
-
- name = c("", "single","double thick","shadowed","double","dot", "dash", "hairline","small dash","dot dash", "dot dot", "triple",
- "thick thin small" , "thin thick small" , "thin thick thin small",
- "thick thin medium", "thin thick medium", "thin thick thin medium",
- "thick thin large" , "thin thick large" , "thin thick thin large",
- "wavy", "double wavy", "stripe", "emboss", "engrave"),
-
- rtf_code = c("", "\\brdrs", "\\brdrth", "\\brdrsh", "\\brdrdb", "\\brdrdot","\\brdrdash",
- "\\brdrhair","\\brdrdashsm","\\brdrdashd","\\brdrdashdd","\\brdrtriple",
- "\\brdrtnthsg", "\\brdrthtnsg", "\\brdrtnthtnsg",
- "\\brdrtnthmg", "\\brdrthtnmg", "\\brdrtnthtnmg",
- "\\brdrtnthlg", "\\brdrthtnlg", "\\brdrtnthtnlg",
- "\\brdrwavy", "\\brdrwavydb", "\\brdrdashdotstr",
- "\\brdremboss", "\\brdrengrave"),
+ name = c(
+ "", "single", "double thick", "shadowed", "double", "dot", "dash", "hairline", "small dash", "dot dash", "dot dot", "triple",
+ "thick thin small", "thin thick small", "thin thick thin small",
+ "thick thin medium", "thin thick medium", "thin thick thin medium",
+ "thick thin large", "thin thick large", "thin thick thin large",
+ "wavy", "double wavy", "stripe", "emboss", "engrave"
+ ),
+
+ rtf_code = c(
+ "", "\\brdrs", "\\brdrth", "\\brdrsh", "\\brdrdb", "\\brdrdot", "\\brdrdash",
+ "\\brdrhair", "\\brdrdashsm", "\\brdrdashd", "\\brdrdashdd", "\\brdrtriple",
+ "\\brdrtnthsg", "\\brdrthtnsg", "\\brdrtnthtnsg",
+ "\\brdrtnthmg", "\\brdrthtnmg", "\\brdrtnthtnmg",
+ "\\brdrtnthlg", "\\brdrthtnlg", "\\brdrtnthtnlg",
+ "\\brdrwavy", "\\brdrwavydb", "\\brdrdashdotstr",
+ "\\brdremboss", "\\brdrengrave"
+ ),
stringsAsFactors = FALSE
)
}
@@ -108,10 +99,8 @@
#' create a data frame as dictionary to look up for rtf paragraph spacing
#'
#' @noRd
-.spacing <- function(){
-
+.spacing <- function() {
data.frame(
-
type = c(1, 2, 1.5),
name = c("single-space", "double-space", "1.5-space"),
rtf_code = c("", "\\sl480\\slmult1", "\\sl360\\slmult1"),
diff --git a/R/internal_datasets.R b/R/internal_datasets.R
deleted file mode 100644
index 0b1369c5..00000000
--- a/R/internal_datasets.R
+++ /dev/null
@@ -1,30 +0,0 @@
-# Copyright (c) 2020 Merck Sharp & Dohme Corp. a subsidiary of Merck & Co., Inc., Kenilworth, NJ, USA.
-#
-# This file is part of the r2rtf program.
-#
-# r2rtf is free software: you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation, either version 3 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program. If not, see .
-
-#' Unicode characters and corresponding LaTeX math mode commands
-#'
-#' A dataset containing the unicode, character and latex command.
-#'
-#'
-#' @format A data frame with 2757 rows and 3 variables:
-#' \describe{
-#' \item{unicode}{Unicode character number}
-#' \item{chr}{literal character (UTF-8 encoded)}
-#' \item{latex}{Latex command}
-#' }
-#' @source \url{http://milde.users.sourceforge.net/LUCR/Math/data/unimathsymbols.txt}
-"unicode_latex"
diff --git a/R/write_rtf.R b/R/write_rtf.R
index 43924a8a..10a7982d 100644
--- a/R/write_rtf.R
+++ b/R/write_rtf.R
@@ -21,62 +21,106 @@
#' to an RTF file.
#'
#' @name rtf_encode
-#' @param gt_tbl a data frame for table or a list of binary string for figure
+#' @param tbl a data frame for table or a list of binary string for figure
#' @param type the type of input, default is table.
#'
+#' @return
+#' For \code{rtf_encode}, a vector of RTF code.
+#' For \code{write_rtf}, no return value.
+#'
+#' @examples
+#'
+#' library(dplyr) # required to run examples
+#'
+#' # Example 1
+#' head(iris) %>%
+#' rtf_body() %>%
+#' rtf_encode() %>%
+#' write_rtf(file = file.path(tempdir(), "table1.rtf"))
+#'
+#' # Example 2
+#' library(dplyr) # required to run examples
+#' file <- file.path(tempdir(), "figure1.png")
+#' png(file)
+#' plot(1:10)
+#' dev.off()
+#'
+#' # Read in PNG file in binary format
+#' rtf_read_png(file) %>% rtf_figure() %>%
+#' rtf_encode(type = "figure") %>%
+#' write_rtf(file = file.path(tempdir(), "figure1.rtf"))
+#'
+#' # Example 3
+#'
+#' ## convert tbl_1 to the table body. Add title, subtitle, two table
+#' ## headers, and footnotes to the table body.
+#' data(tbl_1)
+#' data(tbl_2)
+#' data(tbl_3)
+#' ## convert tbl_2 to the table body. Add a table column header to table body.
+#' t2 <- tbl_2 %>%
+#' rtf_colheader(colheader = "Pairwise Comparison |
+#' Difference in LS Mean(95% CI)\\dagger | p-Value",
+#' text_justification = c("l","c","c")) %>%
+#' rtf_body(col_rel_width = c(8,7,5),
+#' text_justification = c("l","c","c"),
+#' last_row = FALSE);
+#'
+#' # concatenate a list of table and save to an RTF file
+#' t2 %>% rtf_encode() %>% write_rtf(file.path(tempdir(), "table2.rtf"))
+#'
#' @rdname rtf_encode
#' @export
-rtf_encode <- function(gt_tbl, type = "table"){
-
+rtf_encode <- function(tbl, type = "table") {
match.arg(type, c("table", "figure"))
- if(type == "table"){
- return(.rtf_encode_table(gt_tbl))
+ if (type == "table") {
+ return(.rtf_encode_table(tbl))
}
- if(type == "figure"){
- return(.rtf_encode_figure(gt_tbl))
+ if (type == "figure") {
+ return(.rtf_encode_figure(tbl))
}
-
}
#' @rdname rtf_encode
#' @export
-as_rtf <- function(gt_tbl, type = "table"){
-
+as_rtf <- function(tbl, type = "table") {
message("`as_rtf()` is deprecated, use `rtf_encode`.")
- rtf_encode(gt_tbl, type)
+ rtf_encode(tbl, type)
}
#' Render Table to RTF encoding
#'
#' @noRd
-.rtf_encode_figure <- function(gt_tbl){
+.rtf_encode_figure <- function(tbl) {
## get rtf code for page, margin, header, footnote, source, newpage
- page_rtftext <- .as_rtf_page(gt_tbl)
- margin_rtftext <- .as_rtf_margin(gt_tbl)
- header_rtftext <- .as_rtf_header(gt_tbl)
- footnote_rtftext <- .as_rtf_footnote(gt_tbl)
- source_rtftext <- .as_rtf_source(gt_tbl)
- newpage_rtftext <- .as_rtf_newpage()
+ page_rtftext <- .as_rtf_page(tbl)
+ margin_rtftext <- .as_rtf_margin(tbl)
+ header_rtftext <- .as_rtf_header(tbl)
+ footnote_rtftext <- .as_rtf_footnote(tbl)
+ source_rtftext <- .as_rtf_source(tbl)
+ newpage_rtftext <- .as_rtf_newpage()
## get rtf code for figure width and height
- fig_width <- attr(gt_tbl, "fig_width")
- fig_height <- attr(gt_tbl, "fig_height")
+ fig_width <- attr(tbl, "fig_width")
+ fig_height <- attr(tbl, "fig_height")
- rtf_fig <- paste0("{\\pict\\pngblip\\picwgoal",
- round(fig_width*1440),"\\pichgoal",
- round(fig_height*1440)," ", lapply(gt_tbl, paste, collapse = ""),"}")
+ rtf_fig <- paste0(
+ "{\\pict\\pngblip\\picwgoal",
+ round(fig_width * 1440), "\\pichgoal",
+ round(fig_height * 1440), " ", lapply(tbl, paste, collapse = ""), "}"
+ )
start_rtf <- paste(
.as_rtf_init(),
.as_rtf_font(),
- sep="\n"
+ sep = "\n"
)
rtf_feature <- paste(
@@ -87,7 +131,7 @@ as_rtf <- function(gt_tbl, type = "table"){
.rtf_paragraph(""), # new line after figure
footnote_rtftext,
source_rtftext,
- c(rep(newpage_rtftext, length(rtf_fig) -1), ""),
+ c(rep(newpage_rtftext, length(rtf_fig) - 1), ""),
sep = "\n"
)
rtf_feature <- paste(rtf_feature, collapse = "\n")
@@ -95,126 +139,119 @@ as_rtf <- function(gt_tbl, type = "table"){
end_rtf <- .end_rtf()
- paste(start_rtf, rtf_feature, end_rtf, end_rtf, sep="\n")
-
+ paste(start_rtf, rtf_feature, end_rtf, end_rtf, sep = "\n")
}
#' Render Table to RTF encoding
#'
#' @noRd
-.rtf_encode_table <- function(gt_tbl){
+.rtf_encode_table <- function(tbl) {
start_rtf <- paste(
.as_rtf_init(),
.as_rtf_font(),
- .as_rtf_color(gt_tbl),
- sep="\n"
+ .as_rtf_color(tbl),
+ sep = "\n"
)
- if ( "data.frame" %in% class(gt_tbl) ) {
+ if ("data.frame" %in% class(tbl)) {
## get rtf code for page, margin, header, footnote, source, newpage
- page_rtftext <- .as_rtf_page(gt_tbl)
- margin_rtftext <- .as_rtf_margin(gt_tbl)
- header_rtftext <- .as_rtf_header(gt_tbl)
- footnote_rtftext <- .as_rtf_footnote(gt_tbl)
- source_rtftext <- .as_rtf_source(gt_tbl)
- newpage_rtftext <- .as_rtf_newpage()
+ page_rtftext <- .as_rtf_page(tbl)
+ margin_rtftext <- .as_rtf_margin(tbl)
+ header_rtftext <- .as_rtf_header(tbl)
+ footnote_rtftext <- .as_rtf_footnote(tbl)
+ source_rtftext <- .as_rtf_source(tbl)
+ newpage_rtftext <- .as_rtf_newpage()
## get rtf code for colheader and table
- colheader_rtftext <- .as_rtf_colheader(gt_tbl)
- table_rtftext <- .as_rtf_table(gt_tbl)
+ colheader_rtftext <- .as_rtf_colheader(tbl)
+ table_rtftext <- .as_rtf_table(tbl)
## combine table_rtftext with pageby_colheader
- page_by <- attr(gt_tbl, "page_by")
- pageby_db <- attr(gt_tbl, "pageby_db")
- pageby_condition <- attr(gt_tbl, "pageby_condition")
- pageby_colheader <- attr(gt_tbl, "pageby_colheader")
- new_page <- attr(gt_tbl, "new_page")
- page_num <- attr(gt_tbl, "page_num")
-
-
- newtable_list <- .page_by_newtable_rtf(page_by,
- pageby_colheader,
- pageby_condition,
- table_rtftext,
- new_page)
+ page_by <- attr(tbl, "page_by")
+ pageby_db <- attr(tbl, "pageby_db")
+ pageby_condition <- attr(tbl, "pageby_condition")
+ pageby_colheader <- attr(tbl, "pageby_colheader")
+ new_page <- attr(tbl, "new_page")
+ page_num <- attr(tbl, "page_num")
+
+
+ newtable_list <- .page_by_newtable_rtf(
+ page_by,
+ pageby_colheader,
+ pageby_condition,
+ table_rtftext,
+ new_page
+ )
- table_rtftext <- newtable_list$table_rtftext
+ table_rtftext <- newtable_list$table_rtftext
category_index <- newtable_list$category_index
n_row <- ncol(table_rtftext)
- pages <- .table_rtftext_index(new_page, category_index, page_num, n_row)
-
- if (length(pages) > 1){
-
- #if (!is.null(page_num) && !is.null(category_index)) {
-
- #pages <- .table_rtftext_index(new_page, category_index, page_num, n_row)
-
- rtf_feature <- lapply( 1:(length(pages)-1), function(x){
-
- paste(
-
- page_rtftext,
-
- margin_rtftext,
+ pages <- .table_rtftext_index(new_page, category_index, page_num, n_row)
- paste("{\\pard \\par}", header_rtftext, sep = "\n"),
+ if (length(pages) > 1) {
- paste(unlist(colheader_rtftext), collapse = "\n"),
+ # if (!is.null(page_num) && !is.null(category_index)) {
- paste(table_rtftext[, c( (pages[x] + 1) : pages[x+1])],
- collapse = "\n"),
+ # pages <- .table_rtftext_index(new_page, category_index, page_num, n_row)
- footnote_rtftext,
+ rtf_feature <- lapply(1:(length(pages) - 1), function(x) {
+ paste(
- source_rtftext,
+ page_rtftext,
- newpage_rtftext,
+ margin_rtftext,
- sep="\n"
+ paste("{\\pard \\par}", header_rtftext, sep = "\n"),
- )
+ paste(unlist(colheader_rtftext), collapse = "\n"),
- })
+ paste(table_rtftext[, c((pages[x] + 1):pages[x + 1])],
+ collapse = "\n"
+ ),
- if (pages[length(pages)] < n_row) {
+ footnote_rtftext,
- rtf_feature <- c(rtf_feature,
+ source_rtftext,
- paste(
+ newpage_rtftext,
+ sep = "\n"
+ )
+ })
- page_rtftext,
+ if (pages[length(pages)] < n_row) {
+ rtf_feature <- c(
+ rtf_feature,
- margin_rtftext,
+ paste(
- paste("{\\pard \\par}", header_rtftext, sep = "\n"),
+ page_rtftext,
- paste(unlist(colheader_rtftext), collapse = "\n"),
+ margin_rtftext,
- paste(table_rtftext[, c( (pages[length(pages)] + 1) : n_row )],
- collapse = "\n"),
+ paste("{\\pard \\par}", header_rtftext, sep = "\n"),
- footnote_rtftext,
+ paste(unlist(colheader_rtftext), collapse = "\n"),
- source_rtftext,
+ paste(table_rtftext[, c((pages[length(pages)] + 1):n_row)],
+ collapse = "\n"
+ ),
- sep="\n")
+ footnote_rtftext,
+ source_rtftext,
+ sep = "\n"
)
- }
-
- rtf_feature <- paste(unlist(rtf_feature), collapse = "\n")
-
-
-
+ )
+ }
+ rtf_feature <- paste(unlist(rtf_feature), collapse = "\n")
} else {
-
rtf_feature <- paste(
page_rtftext,
@@ -230,54 +267,43 @@ as_rtf <- function(gt_tbl, type = "table"){
footnote_rtftext,
source_rtftext,
-
- sep="\n"
+ sep = "\n"
)
-
}
-
-
-
- }else if (class(gt_tbl) == "list") {
-
-
+ } else if (class(tbl) == "list") {
rtf_feature <- paste(
- .as_rtf_page(gt_tbl[[1]]),
-
- .as_rtf_margin(gt_tbl[[1]]),
+ .as_rtf_page(tbl[[1]]),
- paste("{\\pard \\par}", unlist(lapply(gt_tbl, function (x) .as_rtf_header(x))), sep = "\n"),
+ .as_rtf_margin(tbl[[1]]),
- paste(unlist(lapply(gt_tbl, function(x) {
- paste(
- paste(unlist(.as_rtf_colheader(x)), collapse = "\n"),
- paste(.as_rtf_table(x), collapse = "\n"),
- sep = "\n"
- )
- })),
- collapse = "\n"),
+ paste("{\\pard \\par}", unlist(lapply(tbl, function(x) .as_rtf_header(x))), sep = "\n"),
+ paste(unlist(lapply(tbl, function(x) {
+ paste(
+ paste(unlist(.as_rtf_colheader(x)), collapse = "\n"),
+ paste(.as_rtf_table(x), collapse = "\n"),
+ sep = "\n"
+ )
+ })),
+ collapse = "\n"
+ ),
- paste(unlist(lapply(gt_tbl, function (x) .as_rtf_footnote(x))), sep = ""),
- paste(unlist(lapply(gt_tbl, function (x) .as_rtf_source(x))), sep = ""),
+ paste(unlist(lapply(tbl, function(x) .as_rtf_footnote(x))), sep = ""),
- sep="\n"
+ paste(unlist(lapply(tbl, function(x) .as_rtf_source(x))), sep = ""),
+ sep = "\n"
)
-
} else {
-
stop("Input must be a data frame or a list of data frame to render an rtf table")
-
}
- rtf <- paste(start_rtf, rtf_feature, .end_rtf(), sep="\n")
+ rtf <- paste(start_rtf, rtf_feature, .end_rtf(), sep = "\n")
rtf
-
}
@@ -287,16 +313,10 @@ as_rtf <- function(gt_tbl, type = "table"){
#' @description
#' The write_rtf function writes rtf encoding string to an .rtf file
#'
-#' @param rtf rtf encoing string rendered by `as_rtf()`
+#' @param rtf rtf encoding string rendered by `as_rtf()`
#' @param file File name to write the output RTF table.
#'
#' @export
-write_rtf <- function(rtf, file){
-
+write_rtf <- function(rtf, file) {
write(rtf, file)
-
}
-
-
-
-
diff --git a/README.Rmd b/README.Rmd
index a6855c61..ebd93815 100644
--- a/README.Rmd
+++ b/README.Rmd
@@ -7,7 +7,7 @@ knitr::opts_chunk$set(echo = TRUE)
```
```{r, echo = FALSE}
-pkgname = "r2rtf"
+pkgname <- "r2rtf"
```
# Overview
diff --git a/data/adtte.rda b/data/adtte.rda
deleted file mode 100644
index 63acb27f..00000000
Binary files a/data/adtte.rda and /dev/null differ
diff --git a/data/t1_gt.rda b/data/t1_gt.rda
deleted file mode 100644
index 142b4aff..00000000
Binary files a/data/t1_gt.rda and /dev/null differ
diff --git a/data/t2_gt.rda b/data/t2_gt.rda
deleted file mode 100644
index c92b547a..00000000
Binary files a/data/t2_gt.rda and /dev/null differ
diff --git a/data/t3_gt.rda b/data/t3_gt.rda
deleted file mode 100644
index db66f5e5..00000000
Binary files a/data/t3_gt.rda and /dev/null differ
diff --git a/data/tbl_1.rda b/data/tbl_1.rda
new file mode 100644
index 00000000..61430895
Binary files /dev/null and b/data/tbl_1.rda differ
diff --git a/data/tbl_2.rda b/data/tbl_2.rda
new file mode 100644
index 00000000..7bb66a78
Binary files /dev/null and b/data/tbl_2.rda differ
diff --git a/data/tbl_3.rda b/data/tbl_3.rda
new file mode 100644
index 00000000..254e51f0
Binary files /dev/null and b/data/tbl_3.rda differ
diff --git a/data/unicode_latex.rda b/data/unicode_latex.rda
index b498b036..01298b40 100644
Binary files a/data/unicode_latex.rda and b/data/unicode_latex.rda differ
diff --git a/man/HAMD17.Rd b/man/HAMD17.Rd
index 88922823..d580cd22 100644
--- a/man/HAMD17.Rd
+++ b/man/HAMD17.Rd
@@ -3,12 +3,19 @@
\docType{data}
\name{HAMD17}
\alias{HAMD17}
-\title{HAMD17}
-\format{An object of class \code{tbl_df} (inherits from \code{tbl}, \code{data.frame}) with 831 rows and 6 columns.}
+\title{An Efficacy Clinical Trial Data to Evaluate a Drug to Reduce Lower Back Pain}
+\format{A data frame with 831 rows and 6 variables.}
+\source{
+\url{https://missingdata.lshtm.ac.uk/dia-working-group/}
+}
\usage{
HAMD17
}
\description{
-HAMD17
+A dataset prepared by the Drug Information Association scientific working group
+to investigate a drug to reduce lower back pain.
+}
+\details{
+Definition of each variable can be found in \url{https://missingdata.lshtm.ac.uk/dia-working-group/}
}
\keyword{datasets}
diff --git a/man/adae.Rd b/man/adae.Rd
index e43bd331..dd720d17 100644
--- a/man/adae.Rd
+++ b/man/adae.Rd
@@ -3,12 +3,20 @@
\docType{data}
\name{adae}
\alias{adae}
-\title{ADAE}
-\format{An object of class \code{data.frame} with 1191 rows and 55 columns.}
+\title{An Adverse Event Dataset}
+\format{A data frame with 1191 rows and 55 variables.}
+\source{
+\url{https://www.cdisc.org/pilot-project-submission-package}
+}
\usage{
adae
}
\description{
-ADAE
+A dataset containing the adverse event information of a clinical trial following
+CDISC ADaM standard.
+}
+\details{
+Definition of each variable can be found in
+\url{https://www.cdisc.org/pilot-project-submission-package}
}
\keyword{datasets}
diff --git a/man/adsl.Rd b/man/adsl.Rd
index 19cabf57..d98949f8 100644
--- a/man/adsl.Rd
+++ b/man/adsl.Rd
@@ -3,12 +3,20 @@
\docType{data}
\name{adsl}
\alias{adsl}
-\title{ADSL}
-\format{An object of class \code{data.frame} with 254 rows and 51 columns.}
+\title{A Subject Level Demographic Dataset}
+\format{A data frame with 254 rows and 51 variables.}
+\source{
+\url{https://www.cdisc.org/pilot-project-submission-package}
+}
\usage{
adsl
}
\description{
-ADSL
+A dataset containing the demographic information of a clinical trial following
+CDISC ADaM standard.
+}
+\details{
+Definition of each variable can be found in
+\url{https://www.cdisc.org/pilot-project-submission-package}
}
\keyword{datasets}
diff --git a/man/adtte.Rd b/man/adtte.Rd
deleted file mode 100644
index 846372a2..00000000
--- a/man/adtte.Rd
+++ /dev/null
@@ -1,14 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/data.R
-\docType{data}
-\name{adtte}
-\alias{adtte}
-\title{ADTTE}
-\format{An object of class \code{data.frame} with 254 rows and 24 columns.}
-\usage{
-adtte
-}
-\description{
-ADTTE
-}
-\keyword{datasets}
diff --git a/man/rtf_body.Rd b/man/rtf_body.Rd
index 6a1a9e9d..307eacc9 100644
--- a/man/rtf_body.Rd
+++ b/man/rtf_body.Rd
@@ -4,22 +4,42 @@
\alias{rtf_body}
\title{add table body attributes to the table}
\usage{
-rtf_body(gt_tbl, colheader = TRUE, page_width = 8.5,
- page_height = 11, orientation = "portrait", doctype = "wma",
- border_left = "single", border_right = "single", border_top = NULL,
- border_bottom = "double", border_color_left = NULL,
- border_color_right = NULL, border_color_top = NULL,
- border_color_bottom = NULL, border_width = 15,
- col_rel_width = NULL, col_total_width = page_width/1.4,
- cell_height = 0.15, cell_justification = "c", text_font = 1,
- text_format = NULL, text_color = NULL,
- text_background_color = NULL, text_justification = "c",
- text_font_size = 9, text_space_before = 15, text_space_after = 15,
- page_num = NULL, page_by = NULL, new_page = FALSE,
- last_row = TRUE)
+rtf_body(
+ tbl,
+ colheader = TRUE,
+ page_width = 8.5,
+ page_height = 11,
+ orientation = "portrait",
+ doctype = "wma",
+ border_left = "single",
+ border_right = "single",
+ border_top = NULL,
+ border_bottom = "double",
+ border_color_left = NULL,
+ border_color_right = NULL,
+ border_color_top = NULL,
+ border_color_bottom = NULL,
+ border_width = 15,
+ col_rel_width = NULL,
+ col_total_width = page_width/1.4,
+ cell_height = 0.15,
+ cell_justification = "c",
+ text_font = 1,
+ text_format = NULL,
+ text_color = NULL,
+ text_background_color = NULL,
+ text_justification = "c",
+ text_font_size = 9,
+ text_space_before = 15,
+ text_space_after = 15,
+ page_num = NULL,
+ page_by = NULL,
+ new_page = FALSE,
+ last_row = TRUE
+)
}
\arguments{
-\item{gt_tbl}{A data frame}
+\item{tbl}{A data frame}
\item{colheader}{A boolean value to indicate whether to add default column header to the table}
@@ -47,7 +67,7 @@ rtf_body(gt_tbl, colheader = TRUE, page_width = 8.5,
\item{border_color_bottom}{bottom border color}
-\item{border_width}{worder width in twips}
+\item{border_width}{border width in twips}
\item{col_rel_width}{column relative width in a vector eg. c(2,1,1) refers to 2:1;1}
@@ -81,6 +101,19 @@ rtf_body(gt_tbl, colheader = TRUE, page_width = 8.5,
\item{last_row}{a boolean value to indicate whether the table contains the last row of the final table}
}
+\value{
+the same data frame \code{tbl} with additional attributes for table body
+}
\description{
add table body attributes to the table
}
+\examples{
+library(dplyr) # required to run examples
+data(tbl_1)
+tbl_1 \%>\%
+ rtf_body(col_rel_width = c(3,1,3,1,3,1,3,5),
+ text_justification = c("l",rep("c",7)),
+ last_row = FALSE) \%>\%
+ attributes()
+
+}
diff --git a/man/rtf_colheader.Rd b/man/rtf_colheader.Rd
index 21f63bbe..d22a00ff 100644
--- a/man/rtf_colheader.Rd
+++ b/man/rtf_colheader.Rd
@@ -4,19 +4,36 @@
\alias{rtf_colheader}
\title{Add column header to the table}
\usage{
-rtf_colheader(gt_tbl, colheader = NULL, border_left = "single",
- border_right = "single", border_top = NULL, border_bottom = "",
- border_color_left = NULL, border_color_right = NULL,
- border_color_top = NULL, border_color_bottom = NULL,
- border_width = 15, cell_justification = "c", col_rel_width = NULL,
- page_width = 8.5, col_total_width = page_width/1.4,
- cell_height = 0.15, text_justification = "c", text_font = 1,
- text_format = NULL, text_color = NULL,
- text_background_color = NULL, text_font_size = 9,
- text_space_before = 15, text_space_after = 15, first_row = FALSE)
+rtf_colheader(
+ tbl,
+ colheader = NULL,
+ border_left = "single",
+ border_right = "single",
+ border_top = NULL,
+ border_bottom = "",
+ border_color_left = NULL,
+ border_color_right = NULL,
+ border_color_top = NULL,
+ border_color_bottom = NULL,
+ border_width = 15,
+ cell_justification = "c",
+ col_rel_width = NULL,
+ page_width = 8.5,
+ col_total_width = page_width/1.4,
+ cell_height = 0.15,
+ text_justification = "c",
+ text_font = 1,
+ text_format = NULL,
+ text_color = NULL,
+ text_background_color = NULL,
+ text_font_size = 9,
+ text_space_before = 15,
+ text_space_after = 15,
+ first_row = FALSE
+)
}
\arguments{
-\item{gt_tbl}{A data frame}
+\item{tbl}{A data frame}
\item{colheader}{A string that uses " | " to separate column names.}
@@ -36,7 +53,7 @@ rtf_colheader(gt_tbl, colheader = NULL, border_left = "single",
\item{border_color_bottom}{bottom border color}
-\item{border_width}{worder width in twips}
+\item{border_width}{border width in twips}
\item{cell_justification}{justification for cell}
@@ -66,6 +83,18 @@ rtf_colheader(gt_tbl, colheader = NULL, border_left = "single",
\item{first_row}{boolean value to indicate whether column header is the first row of the table}
}
+\value{
+the same data frame \code{tbl} with additional attributes for table column header
+}
\description{
Add column header to the table
}
+\examples{
+library(dplyr) # required to run examples
+data(tbl_1)
+tbl_1 \%>\%
+ rtf_colheader(colheader = "Treatment | N | Mean (SD) | N | Mean (SD) | N |
+ Mean (SD) | LS Mean (95\% CI)\\\\dagger") \%>\%
+ attr("rtf_colheader")
+
+}
diff --git a/man/rtf_encode.Rd b/man/rtf_encode.Rd
index 88951fe1..59c18716 100644
--- a/man/rtf_encode.Rd
+++ b/man/rtf_encode.Rd
@@ -5,16 +5,63 @@
\alias{as_rtf}
\title{Render to RTF Encoding}
\usage{
-rtf_encode(gt_tbl, type = "table")
+rtf_encode(tbl, type = "table")
-as_rtf(gt_tbl, type = "table")
+as_rtf(tbl, type = "table")
}
\arguments{
-\item{gt_tbl}{a data frame for table or a list of binary string for figure}
+\item{tbl}{a data frame for table or a list of binary string for figure}
\item{type}{the type of input, default is table.}
}
+\value{
+\preformatted{For \code{rtf_encode}, a vector of RTF code.
+For \code{write_rtf}, no return value.
+}
+}
\description{
This function extracts table/figure attributes and render to RTF encoding that is ready to save
to an RTF file.
}
+\examples{
+
+library(dplyr) # required to run examples
+
+# Example 1
+ head(iris) \%>\%
+ rtf_body() \%>\%
+ rtf_encode() \%>\%
+ write_rtf(file = file.path(tempdir(), "table1.rtf"))
+
+# Example 2
+ library(dplyr) # required to run examples
+ file <- file.path(tempdir(), "figure1.png")
+ png(file)
+ plot(1:10)
+ dev.off()
+
+ # Read in PNG file in binary format
+ rtf_read_png(file) \%>\% rtf_figure() \%>\%
+ rtf_encode(type = "figure") \%>\%
+ write_rtf(file = file.path(tempdir(), "figure1.rtf"))
+
+# Example 3
+
+## convert tbl_1 to the table body. Add title, subtitle, two table
+## headers, and footnotes to the table body.
+ data(tbl_1)
+ data(tbl_2)
+ data(tbl_3)
+ ## convert tbl_2 to the table body. Add a table column header to table body.
+ t2 <- tbl_2 \%>\%
+ rtf_colheader(colheader = "Pairwise Comparison |
+ Difference in LS Mean(95\% CI)\\\\dagger | p-Value",
+ text_justification = c("l","c","c")) \%>\%
+ rtf_body(col_rel_width = c(8,7,5),
+ text_justification = c("l","c","c"),
+ last_row = FALSE);
+
+ # concatenate a list of table and save to an RTF file
+ t2 \%>\% rtf_encode() \%>\% write_rtf(file.path(tempdir(), "table2.rtf"))
+
+}
diff --git a/man/rtf_figure.Rd b/man/rtf_figure.Rd
index a814fa49..21bec330 100644
--- a/man/rtf_figure.Rd
+++ b/man/rtf_figure.Rd
@@ -2,14 +2,20 @@
% Please edit documentation in R/add_figure.R
\name{rtf_figure}
\alias{rtf_figure}
-\title{Add Figure Attrbuties}
+\title{Add Figure Attributes}
\usage{
-rtf_figure(gt_tbl, page_width = 8.5, page_height = 11,
- orientation = "portrait", doctype = "wma", fig_width = 5,
- fig_height = 5)
+rtf_figure(
+ tbl,
+ page_width = 8.5,
+ page_height = 11,
+ orientation = "portrait",
+ doctype = "wma",
+ fig_width = 5,
+ fig_height = 5
+)
}
\arguments{
-\item{gt_tbl}{A data frame}
+\item{tbl}{A data frame}
\item{page_width}{page width in inches}
@@ -23,6 +29,21 @@ rtf_figure(gt_tbl, page_width = 8.5, page_height = 11,
\item{fig_height}{the height of figures in inch}
}
+\value{
+the same data frame \code{tbl} with additional attributes for figure body
+}
\description{
-Add Figure Attrbuties
+Add Figure Attributes
+}
+\examples{
+ library(dplyr) # required to run examples
+ file <- file.path(tempdir(), "figure1.png")
+ png(file)
+ plot(1:10)
+ dev.off()
+
+ # Read in PNG file in binary format
+ rtf_read_png(file) \%>\% rtf_figure() \%>\%
+ attributes()
+
}
diff --git a/man/rtf_footnote.Rd b/man/rtf_footnote.Rd
index bcfea62e..9a9daa51 100644
--- a/man/rtf_footnote.Rd
+++ b/man/rtf_footnote.Rd
@@ -4,14 +4,27 @@
\alias{rtf_footnote}
\title{Add footnote attributes to the table}
\usage{
-rtf_footnote(gt_tbl, footnote = NULL, font = 1, format = NULL,
- font_size = 9, color = NULL, background_color = NULL,
- justification = "c", indent_first = 0, indent_left = 0,
- indent_right = 0, space = 1, space_before = 0, space_after = 0,
- new_page = FALSE, hyphenation = TRUE)
+rtf_footnote(
+ tbl,
+ footnote = NULL,
+ font = 1,
+ format = NULL,
+ font_size = 9,
+ color = NULL,
+ background_color = NULL,
+ justification = "c",
+ indent_first = 0,
+ indent_left = 0,
+ indent_right = 0,
+ space = 1,
+ space_before = 0,
+ space_after = 0,
+ new_page = FALSE,
+ hyphenation = TRUE
+)
}
\arguments{
-\item{gt_tbl}{a data frame}
+\item{tbl}{a data frame}
\item{footnote}{footnote text}
@@ -43,6 +56,16 @@ rtf_footnote(gt_tbl, footnote = NULL, font = 1, format = NULL,
\item{hyphenation}{boolean value to indicate whether to use hyphenation}
}
+\value{
+the same data frame \code{tbl} with additional attributes for table footnote
+}
\description{
Add footnote attributes to the table
}
+\examples{
+library(dplyr) # required to run examples
+data(tbl_1)
+tbl_1 \%>\% rtf_footnote("\\\\dagger Based on an ANCOVA model.") \%>\%
+ attr("rtf_footnote")
+
+}
diff --git a/man/rtf_read_png.Rd b/man/rtf_read_png.Rd
index 53f9ae01..fd861b6b 100644
--- a/man/rtf_read_png.Rd
+++ b/man/rtf_read_png.Rd
@@ -9,6 +9,19 @@ rtf_read_png(file)
\arguments{
\item{file}{a vector of PNG file path}
}
+\value{
+a list of binary data vector returned by \code{readBin}
+}
\description{
Read PNG figures into Binary Files
}
+\examples{
+ file <- file.path(tempdir(), "figure1.png")
+ png(file)
+ plot(1:10)
+ dev.off()
+
+ # Read in PNG file in binary format
+ rtf_read_png(file)
+
+}
diff --git a/man/rtf_source.Rd b/man/rtf_source.Rd
index efebf247..2f22e3f8 100644
--- a/man/rtf_source.Rd
+++ b/man/rtf_source.Rd
@@ -4,14 +4,27 @@
\alias{rtf_source}
\title{Add data source attributes to the table}
\usage{
-rtf_source(gt_tbl, source = NULL, font = 1, format = NULL,
- font_size = 9, color = NULL, background_color = NULL,
- justification = "c", indent_first = 0, indent_left = 0,
- indent_right = 0, space = 1, space_before = 0, space_after = 0,
- new_page = FALSE, hyphenation = TRUE)
+rtf_source(
+ tbl,
+ source = NULL,
+ font = 1,
+ format = NULL,
+ font_size = 9,
+ color = NULL,
+ background_color = NULL,
+ justification = "c",
+ indent_first = 0,
+ indent_left = 0,
+ indent_right = 0,
+ space = 1,
+ space_before = 0,
+ space_after = 0,
+ new_page = FALSE,
+ hyphenation = TRUE
+)
}
\arguments{
-\item{gt_tbl}{A data frame}
+\item{tbl}{A data frame}
\item{source}{data source text}
@@ -43,6 +56,16 @@ rtf_source(gt_tbl, source = NULL, font = 1, format = NULL,
\item{hyphenation}{boolean value to indicate whether to use hyphenation}
}
+\value{
+the same data frame \code{tbl} with additional attributes for data source of a table
+}
\description{
Add data source attributes to the table
}
+\examples{
+library(dplyr) # required to run examples
+data(tbl_1)
+tbl_1 \%>\% rtf_source("Source: [study999:adam-adeff]") \%>\%
+ attr("rtf_source")
+
+}
diff --git a/man/rtf_title.Rd b/man/rtf_title.Rd
index 238619fa..3c3f86ee 100644
--- a/man/rtf_title.Rd
+++ b/man/rtf_title.Rd
@@ -4,14 +4,28 @@
\alias{rtf_title}
\title{Add title attributes to the table}
\usage{
-rtf_title(gt_tbl, title = NULL, subtitle = NULL, font = 1,
- format = NULL, font_size = 12, color = NULL,
- background_color = NULL, justification = "c", indent_first = 0,
- indent_left = 0, indent_right = 0, space = 1, space_before = 180,
- space_after = 180, new_page = FALSE, hyphenation = TRUE)
+rtf_title(
+ tbl,
+ title = NULL,
+ subtitle = NULL,
+ font = 1,
+ format = NULL,
+ font_size = 12,
+ color = NULL,
+ background_color = NULL,
+ justification = "c",
+ indent_first = 0,
+ indent_left = 0,
+ indent_right = 0,
+ space = 1,
+ space_before = 180,
+ space_after = 180,
+ new_page = FALSE,
+ hyphenation = TRUE
+)
}
\arguments{
-\item{gt_tbl}{a data frame}
+\item{tbl}{a data frame}
\item{title}{title string}
@@ -45,6 +59,16 @@ rtf_title(gt_tbl, title = NULL, subtitle = NULL, font = 1,
\item{hyphenation}{boolean value to indicate whether to use hyphenation}
}
+\value{
+the same data frame \code{tbl} with additional attributes for table title
+}
\description{
add title, subtitle, and other attributes to the object
}
+\examples{
+library(dplyr) # required to run examples
+data(tbl_1)
+tbl_1 \%>\% rtf_title(title = "ANCOVA of Change from Baseline at Week 8") \%>\%
+ attr("rtf_heading")
+
+}
diff --git a/man/t1_gt.Rd b/man/t1_gt.Rd
deleted file mode 100644
index 9b424da4..00000000
--- a/man/t1_gt.Rd
+++ /dev/null
@@ -1,14 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/data.R
-\docType{data}
-\name{t1_gt}
-\alias{t1_gt}
-\title{t1_gt}
-\format{An object of class \code{gt_tbl} (inherits from \code{data.frame}) with 2 rows and 8 columns.}
-\usage{
-t1_gt
-}
-\description{
-t1_gt
-}
-\keyword{datasets}
diff --git a/man/t2_gt.Rd b/man/t2_gt.Rd
deleted file mode 100644
index a2cad82c..00000000
--- a/man/t2_gt.Rd
+++ /dev/null
@@ -1,14 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/data.R
-\docType{data}
-\name{t2_gt}
-\alias{t2_gt}
-\title{t2_gt}
-\format{An object of class \code{gt_tbl} (inherits from \code{data.frame}) with 1 rows and 3 columns.}
-\usage{
-t2_gt
-}
-\description{
-t2_gt
-}
-\keyword{datasets}
diff --git a/man/t3_gt.Rd b/man/t3_gt.Rd
deleted file mode 100644
index 6b6904a2..00000000
--- a/man/t3_gt.Rd
+++ /dev/null
@@ -1,14 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/data.R
-\docType{data}
-\name{t3_gt}
-\alias{t3_gt}
-\title{t3_gt}
-\format{An object of class \code{gt_tbl} (inherits from \code{data.frame}) with 1 rows and 1 columns.}
-\usage{
-t3_gt
-}
-\description{
-t3_gt
-}
-\keyword{datasets}
diff --git a/man/tbl_1.Rd b/man/tbl_1.Rd
new file mode 100644
index 00000000..714f5c4d
--- /dev/null
+++ b/man/tbl_1.Rd
@@ -0,0 +1,14 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/data.R
+\docType{data}
+\name{tbl_1}
+\alias{tbl_1}
+\title{Within Group Results from an ANCOVA Model}
+\format{A data frame with 2 rows and 8 variables.}
+\usage{
+tbl_1
+}
+\description{
+A dataset containing within group results from an ANCOVA model.
+}
+\keyword{datasets}
diff --git a/man/tbl_2.Rd b/man/tbl_2.Rd
new file mode 100644
index 00000000..9819ab6e
--- /dev/null
+++ b/man/tbl_2.Rd
@@ -0,0 +1,14 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/data.R
+\docType{data}
+\name{tbl_2}
+\alias{tbl_2}
+\title{Between Group Results from an ANCOVA Model}
+\format{A data frame with 1 row and 3 variables.}
+\usage{
+tbl_2
+}
+\description{
+A dataset containing between group results from an ANCOVA model.
+}
+\keyword{datasets}
diff --git a/man/tbl_3.Rd b/man/tbl_3.Rd
new file mode 100644
index 00000000..fe544487
--- /dev/null
+++ b/man/tbl_3.Rd
@@ -0,0 +1,14 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/data.R
+\docType{data}
+\name{tbl_3}
+\alias{tbl_3}
+\title{Root Mean Square Error from an ANCOVA model}
+\format{A data frame with 1 row and 1 variable.}
+\usage{
+tbl_3
+}
+\description{
+A dataset containing root mean square error from an ANCOVA model.
+}
+\keyword{datasets}
diff --git a/man/unicode_latex.Rd b/man/unicode_latex.Rd
index acc576bd..6b2547b3 100644
--- a/man/unicode_latex.Rd
+++ b/man/unicode_latex.Rd
@@ -1,19 +1,22 @@
% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/data.R, R/internal_datasets.R
+% Please edit documentation in R/data.R
\docType{data}
\name{unicode_latex}
\alias{unicode_latex}
-\title{unicode_latex}
-\format{An object of class \code{data.frame} with 704 rows and 3 columns.}
+\title{Dictionary of Unicode and Latex Code}
+\format{A data frame with 681 rows and 3 variables.
+\describe{
+\item{unicode}{unicode, UTF-8 code}
+\item{latex}{latex, latex code}
+\item{int}{int, Converted integer of the UTF-8 code}
+}}
\source{
\url{http://milde.users.sourceforge.net/LUCR/Math/data/unimathsymbols.txt}
}
\usage{
-unicode_latex
-
unicode_latex
}
\description{
-A dataset containing the unicode, character and latex command.
+A dataset containing the mapping between unicode and latex code.
}
\keyword{datasets}
diff --git a/man/write_rtf.Rd b/man/write_rtf.Rd
index 295a9e0b..26efbfc8 100644
--- a/man/write_rtf.Rd
+++ b/man/write_rtf.Rd
@@ -7,7 +7,7 @@
write_rtf(rtf, file)
}
\arguments{
-\item{rtf}{rtf encoing string rendered by \code{as_rtf()}}
+\item{rtf}{rtf encoding string rendered by \code{as_rtf()}}
\item{file}{File name to write the output RTF table.}
}
diff --git a/tests/testthat/test-convert_latex.R b/tests/testthat/test-convert_latex.R
index 2d748ef9..68e3a850 100644
--- a/tests/testthat/test-convert_latex.R
+++ b/tests/testthat/test-convert_latex.R
@@ -1,20 +1,23 @@
context("test-convert_latex")
test_that("multiplication works", {
+ .x <- c(
+ "Greek: \\alpha\\beta\\gamma",
+ "Symbole: \\dagger\\ddagger",
+ "superscript: LS Mean^\\dagger",
+ "superscript: LS Mean ^{\\dagger\\dagger}",
+ "subscript:, HAMD_{17}",
+ "superscript and subscript:, x_2^5"
+ )
- .x <- c("Greek: \\alpha\\beta\\gamma",
- "Symbole: \\dagger\\ddagger",
- "superscript: LS Mean^\\dagger",
- "superscript: LS Mean ^{\\dagger\\dagger}",
- "subscript:, HAMD_{17}",
- "superscript and subscript:, x_2^5")
-
- .x_utf8 <- c("Greek: \\uc1\\u945*\\uc1\\u946*\\uc1\\u947*",
- "Symbole: \\uc1\\u8224*\\uc1\\u8225*",
- "superscript: LS Mean\\super \\uc1\\u8224*",
- "superscript: LS Mean \\super {\\uc1\\u8224*\\uc1\\u8224*}",
- "subscript:, HAMD\\sub {17}",
- "superscript and subscript:, x\\sub 2\\super 5")
+ .x_utf8 <- c(
+ "Greek: \\uc1\\u945*\\uc1\\u946*\\uc1\\u947*",
+ "Symbole: \\uc1\\u8224*\\uc1\\u8225*",
+ "superscript: LS Mean\\super \\uc1\\u8224*",
+ "superscript: LS Mean \\super {\\uc1\\u8224*\\uc1\\u8224*}",
+ "subscript:, HAMD\\sub {17}",
+ "superscript and subscript:, x\\sub 2\\super 5"
+ )
expect_equal(.convert(.x), .x_utf8)
diff --git a/vignettes/example-figure.Rmd b/vignettes/example-figure.Rmd
index ccec9a1e..87573dc8 100644
--- a/vignettes/example-figure.Rmd
+++ b/vignettes/example-figure.Rmd
@@ -30,17 +30,17 @@ The package allow user to embed multiple figures into one RTF document. The work
A quick example to illustrate the workflow:
```{r, eval = FALSE}
-# Define the path of figure
+# Define the path of figure
filename <- c("fig/fig1.png", "fig/fig2.png", "fig/fig3.png")
-filename %>%
- rtf_read_png() %>% # read PNG files from the file path
- rtf_title("title", "subtitle") %>% # add title or subtitle
- rtf_footnote("footnote") %>% # add footnote
- rtf_source("[datasource: mk0999]") %>% # add data source
- rtf_figure() %>% # default seting of page and figure
- rtf_encode(type = "figure") %>% # encode rtf as figure
- write_rtf(file = "rtf/fig-simple.rtf") # write RTF to a file
+filename %>%
+ rtf_read_png() %>% # read PNG files from the file path
+ rtf_title("title", "subtitle") %>% # add title or subtitle
+ rtf_footnote("footnote") %>% # add footnote
+ rtf_source("[datasource: mk0999]") %>% # add data source
+ rtf_figure() %>% # default seting of page and figure
+ rtf_encode(type = "figure") %>% # encode rtf as figure
+ write_rtf(file = "rtf/fig-simple.rtf") # write RTF to a file
```
In `rtf_figure`, the features of page and figure can be set up:
@@ -52,18 +52,20 @@ In `rtf_figure`, the features of page and figure can be set up:
The figure height and width can be set up for each figure in a vector. The code below provides an example for these features.
```{r, eval = FALSE}
-filename %>%
- rtf_read_png() %>% # read PNG files from the file path
- rtf_title("title", "subtitle") %>% # add title or subtitle
- rtf_footnote("footnote") %>% # add footnote
- rtf_source("[datasource: mk0999]") %>% # add data source
- rtf_figure(page_height = 8.5, # page height
- page_width = 11, # page width
- orientation = "landscape", # page direction
- doctype = "narrow", # set page margin as narrow i.e. 0.5 inch at each side
- fig_height = 5, # set figure height
- fig_width = c(6,7,8) ) %>% # set figure width individually.
- rtf_encode(type = "figure") %>% # encode rtf as figure
- write_rtf(file = "rtf/fig-landscape.rtf") # write RTF to a file
+filename %>%
+ rtf_read_png() %>% # read PNG files from the file path
+ rtf_title("title", "subtitle") %>% # add title or subtitle
+ rtf_footnote("footnote") %>% # add footnote
+ rtf_source("[datasource: mk0999]") %>% # add data source
+ rtf_figure(
+ page_height = 8.5, # page height
+ page_width = 11, # page width
+ orientation = "landscape", # page direction
+ doctype = "narrow", # set page margin as narrow i.e. 0.5 inch at each side
+ fig_height = 5, # set figure height
+ fig_width = c(6, 7, 8)
+ ) %>% # set figure width individually.
+ rtf_encode(type = "figure") %>% # encode rtf as figure
+ write_rtf(file = "rtf/fig-landscape.rtf") # write RTF to a file
```
diff --git a/vignettes/example-pipeline.Rmd b/vignettes/example-pipeline.Rmd
new file mode 100644
index 00000000..7f6e6fdc
--- /dev/null
+++ b/vignettes/example-pipeline.Rmd
@@ -0,0 +1,576 @@
+---
+title: "RTF Examples for Tables"
+output: rmarkdown::html_vignette
+vignette: >
+ %\VignetteIndexEntry{example-table}
+ %\VignetteEngine{knitr::rmarkdown}
+ %\VignetteEncoding{UTF-8}
+---
+
+```{r setup, include=FALSE}
+knitr::opts_chunk$set(echo = TRUE)
+devtools::load_all() # need to be updated after the package mature
+
+library(tidyverse)
+library(emmeans)
+library(stringr)
+```
+
+Define some utility functions
+```{r}
+#' Format Model Estimator
+#'
+#' The function assume 1 or 2 column.
+#' If there is only 1 column, only represent mean
+#' If there are 2 column, represent mean (sd) or mean(se)
+#' Decimals will understand the number will be formated as x.x(x.xx)
+#' @noRd
+fmt_est <- function(data, columns = c("mean", "sd"), decimals = c(1, 2)) {
+ .mean <- formatC(data[[columns[[1]]]], digits = decimals[1], format = "f", flag = "0")
+ if (length(columns) > 1) {
+ .sd <- formatC(data[[columns[[2]]]], digits = decimals[2], format = "f", flag = "0")
+ paste0(.mean, " (", .sd, ")")
+ } else {
+ .mean
+ }
+}
+
+#' Format Confidence Interval
+#' @noRd
+fmt_ci <- function(data, columns = c("lower.CL", "upper.CL"), decimals = 2) {
+ .lower <- formatC(data[[columns[[1]]]], digits = decimals, format = "f", flag = "0")
+ .upper <- formatC(data[[columns[[2]]]], digits = decimals, format = "f", flag = "0")
+ paste0("(", .lower, ", ", .upper, ")")
+}
+
+#' Format P-Value
+#' @noRd
+fmt_pval <- function(data, columns = "p.value", decimals = 3) {
+ scale <- 10^(-1 * decimals)
+ p_scale <- paste0("<", scale)
+ if_else(data[[columns[[1]]]] < scale, p_scale,
+ formatC(data[[columns[[1]]]], digits = decimals, format = "f", flag = "0")
+ )
+}
+```
+
+# Examples
+## Example 1: ANCOVA analysis for HOMA data
+
+
+* The data is available at [https://missingdata.lshtm.ac.uk/dia-working-group/example-data-sets/](https://missingdata.lshtm.ac.uk/dia-working-group/example-data-sets/)
+
+* For example, we want to summary the analysis results using ANCOVA model
+
+```{r}
+data("HAMD17")
+ana_week <- 8 # Analysis Week
+
+HAMD17_lmfit <- HAMD17 %>%
+ filter(week == ana_week) %>%
+ lm(change ~ basval + TRT, data = .)
+```
+
+### Raw summary
+```{r}
+t11 <- HAMD17 %>%
+ filter(week == ana_week) %>%
+ group_by(TRT) %>%
+ summarise(
+ N = n(),
+ mean_bl = mean(basval),
+ sd_bl = sd(basval),
+ mean = mean(change),
+ sd = sd(change)
+ )
+```
+
+### LS mean
+```{r}
+t12 <- emmeans(HAMD17_lmfit, "TRT")
+t1 <- merge(t11, t12) %>%
+ mutate(emmean_sd = SE * sqrt(df)) %>%
+ mutate(
+ Trt = c("Study Drug", "Placebo"),
+ N1 = N,
+ Mean1 = fmt_est(., c("mean_bl", "sd_bl")),
+ N2 = N,
+ Mean2 = fmt_est(., c("mean", "sd")),
+ N3 = N,
+ Mean3 = fmt_est(., c("emmean", "emmean_sd")),
+ CI = paste(fmt_est(., "emmean"), fmt_ci(., c("lower.CL", "upper.CL")))
+ ) %>%
+ select(Trt:CI)
+```
+
+### Treatment Comparison
+```{r}
+t2 <- data.frame(pairs(t12))
+
+t2 <- t2 %>%
+ mutate(
+ lower = estimate - 1.96 * SE,
+ upper = estimate + 1.96 * SE
+ ) %>%
+ mutate(
+ comp = "Study Drug vs. Placebo",
+ mean = paste(fmt_est(., "estimate"), fmt_ci(., c("lower", "upper"))),
+ p = fmt_pval(., "p.value")
+ ) %>%
+ select(comp:p)
+```
+
+### RMSE
+```{r}
+t3 <- data.frame(rmse = paste0(
+ "Root Mean Squared Error of Change = ",
+ formatC(sd(HAMD17_lmfit$residuals), digits = 2, format = "f", flag = "0")
+))
+```
+
+The purpose of this exercise is to create a table as in `rtf_example1.rtf` by using the three datasets `t1`, `t2` and `t3`
+
+```{r}
+t1
+```
+
+```{r}
+t2
+```
+
+```{r}
+t3
+```
+
+
+For multiple tables like the efficacy example, we have a flow in the following to print an rtf table
+```{r}
+
+tbl_1 <- t1 %>%
+ rtf_title(
+ title = "ANCOVA of Change from Baseline at Week 8",
+ subtitle = c(
+ "Missing Data Approach",
+ "Analysis Population"
+ )
+ ) %>%
+ rtf_colheader(
+ colheader = " | Baseline | Week 20 | Change from Baseline",
+ col_rel_width = c(3, 4, 4, 9),
+ first_row = TRUE
+ ) %>%
+ rtf_colheader(colheader = "Treatment | N | Mean (SD) | N | Mean (SD) | N | Mean (SD) | LS Mean (95% CI)\\dagger") %>%
+ rtf_body(
+ col_rel_width = c(3, 1, 3, 1, 3, 1, 3, 5),
+ text_justification = c("l", rep("c", 7)),
+ last_row = FALSE
+ ) %>%
+ rtf_footnote(
+ footnote = "\\daggerBased on an ANCOVA model.\n ANCOVA = Analysis of Covariance, CI = Confidence Interval, LS = Least Squares, SD = Standard Deviation",
+ justification = "l"
+ )
+
+
+tbl_2 <- t2 %>%
+ rtf_colheader(
+ colheader = "Pairwise Comparison | Difference in LS Mean (95% CI)\\dagger | p-Value",
+ text_justification = c("l", "c", "c")
+ ) %>%
+ rtf_body(
+ col_rel_width = c(8, 7, 5),
+ text_justification = c("l", "c", "c"),
+ last_row = FALSE
+ )
+
+
+tbl_3 <- t3 %>%
+ rtf_body(
+ colheader = FALSE,
+ col_rel_width = c(1),
+ text_justification = "l"
+ ) %>%
+ rtf_source(
+ source = "Source: [study999: adam-adeff]",
+ justification = "l"
+ )
+
+
+tbl <- list(tbl_1, tbl_2, tbl_3)
+
+tbl %>%
+ rtf_encode() %>%
+ write_rtf("rtf/efficacy_example.rtf")
+```
+
+
+## Example 2: a simplified adverse events summary table
+
+
+# get raw summary
+```{r}
+# Step 1: Get raw summary
+data(adae)
+ae_t1 <- adae %>%
+ group_by(TRTP) %>%
+ mutate(n_subj = n_distinct(SUBJID)) %>%
+ group_by(TRTP, AEDECOD) %>%
+ summarise(
+ n_ae = n_distinct(SUBJID),
+ pct = round(n_ae / unique(n_subj) * 100, 2)
+ ) %>%
+ dplyr::filter(n_ae > 4) %>% # only show AE terms with at least 10 subjects in one treatment group.
+ gather(key = "var", value = "value", n_ae, pct) %>%
+ unite(temp, TRTP, var) %>%
+ spread(temp, value, fill = 0)
+ae_t1
+```
+
+# write to an rtf table
+```{r}
+ae_tbl <- ae_t1 %>%
+ rtf_title(
+ "Analysis of Subjects With Specific Adverse Events",
+ c(
+ "(Incidence > 10 Subjects in One or More Treatment Groups)",
+ "ASaT"
+ )
+ ) %>%
+ rtf_colheader(" | Placebo | Drug High Dose | Drug Low Dose",
+ col_rel_width = c(4, rep(2, 3)),
+ first_row = TRUE
+ ) %>%
+ rtf_colheader(" | n | (%) | n | (%) | n | (%)",
+ border_top = c("", rep("single", 6)),
+ border_left = c("single", rep(c("single", ""), 3))
+ ) %>%
+ rtf_body(
+ col_rel_width = c(4, rep(1, 6)),
+ text_justification = c("l", rep("c", 6)),
+ border_left = c("single", rep(c("single", ""), 3))
+ ) %>%
+ rtf_footnote(c("\\daggerThis is footnote 1", "This is footnote 2"),
+ justification = "l"
+ ) %>%
+ rtf_source("Source: xxx",
+ justification = "l"
+ )
+
+
+ae_tbl %>%
+ rtf_encode() %>%
+ write_rtf("rtf/ae_example.rtf")
+```
+
+# Example 3: adverse events example page_by option
+
+# write to an rtf table
+```{r}
+ae_tbl <- ae_t1 %>%
+ rtf_title(
+ "Analysis of Subjects With Specific Adverse Events",
+ c(
+ "(Incidence > 10 Subjects in One or More Treatment Groups)",
+ "ASaT"
+ )
+ ) %>%
+ rtf_colheader(" | Placebo | Drug High Dose | Drug Low Dose",
+ col_rel_width = c(4, rep(2, 3)),
+ first_row = TRUE
+ ) %>%
+ rtf_colheader(" | n | (%) | n | (%) | n | (%)",
+ border_top = c("", rep("single", 6)),
+ border_left = c("single", rep(c("single", ""), 3))
+ ) %>%
+ rtf_body(
+ col_rel_width = c(4, rep(1, 6)),
+ text_justification = c("l", rep("c", 6)),
+ border_left = c("single", rep(c("single", ""), 3)),
+ page_num = 10
+ ) %>%
+ rtf_footnote("This is a footnote") %>%
+ rtf_source("Source: xxx")
+
+
+ae_tbl %>%
+ rtf_encode() %>%
+ write_rtf("rtf/ae_example_page_num_10.rtf")
+```
+
+
+# Example 4: group_by feature
+
+```{r}
+data(iris)
+
+iris <- cbind(iris, new_cat = rep(c("A", "B", "C", "D", "E"), 30))
+
+iris_tbl <- iris %>%
+ rtf_title("IRIS DATA") %>%
+ rtf_colheader("Sepal Length | Sepal Width | Petal Length | PetalWidth",
+ first_row = TRUE
+ ) %>%
+ rtf_body(
+ page_by = c("Species", "new_cat"),
+ new_page = TRUE,
+ page_num = 30
+ ) %>%
+ rtf_footnote("This is a footnote") %>%
+ rtf_source("Source: xxx")
+
+iris_tbl %>%
+ rtf_encode() %>%
+ write_rtf("rtf/iris_example.rtf")
+```
+
+## Example 5: A very simple example
+```{r}
+data(iris)
+
+iris_tbl <- iris[1:20, ] %>% rtf_body()
+
+iris_tbl %>%
+ rtf_encode() %>%
+ write_rtf("rtf/iris_very_simple.rtf")
+```
+
+## Example 6: A simple example
+```{r}
+data(iris)
+
+iris_tbl <- iris[1:20, ] %>%
+ rtf_title("IRIS DATA") %>%
+ rtf_colheader("Sepal Length | Sepal Width | Petal Length | PetalWidth | Species",
+ first_row = TRUE
+ ) %>%
+ rtf_body() %>%
+ rtf_footnote("This is a footnote") %>%
+ rtf_source("Source: xxx")
+
+iris_tbl %>%
+ rtf_encode() %>%
+ write_rtf("rtf/iris_simple.rtf")
+```
+
+## Example 7: baseline characteristics example feature
+```{r}
+bs_count <- function(data, grp, var,
+ var_label = var,
+ decimal = 1,
+ total = TRUE) {
+ data <- data %>% rename(grp = !!grp, var = !!var)
+ coding <- levels(factor(data$grp))
+ data <- data %>% mutate(grp = as.numeric(factor(grp)))
+
+ # res <- data %>% count(grp, var, .drop = FALSE)
+ res <- with(data, table(var, grp)) %>%
+ as.data.frame() %>%
+ mutate(grp = as.numeric(grp))
+
+ if (total) {
+ res_tot <- with(data, table(var)) %>%
+ as.data.frame() %>%
+ mutate(grp = 9999)
+ res <- bind_rows(res, res_tot)
+ }
+
+ res <- res %>% rename(n = Freq)
+
+ res <- res %>% mutate(pct = formatC(n / sum(n) * 100, digits = decimal, format = "f", flag = "0"))
+
+ res <- res %>%
+ gather("key", "value", n, pct) %>%
+ unite(keys, grp, key) %>%
+ spread(keys, value) %>%
+ mutate(var_label = var_label) %>%
+ mutate(var = as.character(var))
+
+ names(res) <- gsub("_n", "", names(res), fixed = TRUE)
+ attr(res, "coding") <- coding
+
+ res
+}
+
+bs_continous <- function(data, grp, var,
+ var_label = var,
+ decimal = 1,
+ total = TRUE,
+ blank_row = FALSE) {
+ data <- data %>% rename(grp = !!grp, var = !!var)
+ coding <- levels(factor(data$grp))
+ data <- data %>% mutate(grp = as.numeric(factor(grp)))
+
+ res <- data %>%
+ select(grp, var) %>%
+ na.omit() %>%
+ group_by(grp) %>%
+ summarise(
+ `Subjects with data` = n(),
+ Mean = formatC(mean(var), digits = decimal, format = "f", flag = "0"),
+ SD = formatC(sd(var), digits = decimal, format = "f", flag = "0"),
+ Median = formatC(median(var), digits = decimal, format = "f", flag = "0"),
+ Range = paste(range(var), collapse = " to ")
+ )
+
+ if (total) {
+ res_tot <- data %>%
+ select(grp, var) %>%
+ na.omit() %>%
+ summarise(
+ `Subjects with data` = n(),
+ Mean = formatC(mean(var), digits = decimal, format = "f", flag = "0"),
+ SD = formatC(sd(var), digits = decimal, format = "f", flag = "0"),
+ Median = formatC(median(var), digits = decimal, format = "f", flag = "0"),
+ Range = paste(range(var), collapse = " to ")
+ ) %>%
+ mutate(grp = 9999)
+ res <- bind_rows(res, res_tot)
+ }
+
+
+ res <- res %>%
+ gather("key", "value", -grp) %>%
+ mutate(key = factor(key, levels = c("Subjects with data", "Mean", "SD", "Median", "Range"))) %>%
+ spread(grp, value) %>%
+ mutate(var_label = var_label) %>%
+ mutate(key = as.character(key)) %>%
+ rename(var = key)
+
+ if (blank_row) {
+ res <- bind_rows(tibble(var_label = var_label), res)
+ }
+
+ res
+}
+
+# The code above define two utility function for baseline characterstic tables.
+
+
+
+# Analaysis Set
+data(adsl)
+ana <- adsl %>% subset(ITT == "Y")
+ana <- ana %>% mutate(
+ RACE = factor(
+ RACE,
+ toupper(c(
+ "African Descent (Negro, Black)", "Caucasian", "Hispanic (Mexican - American, Mexico, Central And South America)",
+ "Other (Mixed - Racial Heritage, American Indian, Eskimo)"
+ )),
+ c("Black", "Caucasian", "Hispanic", "Other")
+ ),
+ SEX = factor(SEX, c("F", "M"), c("Female", "Male"))
+)
+
+# Build Data for r2rtf
+bs_tb <- bind_rows(
+ bs_count(ana, "TRTPN", "SEX", "Gender"),
+ bs_count(ana, "TRTPN", "AGEGRP", "Age (Years)"),
+ bs_continous(ana, "TRTPN", "AGE", "Age (Years)", blank_row = TRUE),
+ bs_count(ana, "TRTPN", "RACE", "Race")
+)
+
+bs_tb[is.na(bs_tb)] <- ""
+```
+
+
+```{r}
+bs_rtf <- bs_tb %>%
+ rtf_title("Demographic and Anthropometric Characteristics", "ITT Subjects") %>%
+ rtf_colheader(" | Placebo | Drug Low Dose | Drug High Dose | Total | label",
+ col_rel_width = c(3, rep(2, 4), 3),
+ page_width = 9.5,
+ first_row = TRUE
+ ) %>%
+ rtf_colheader(" | n | (%) | n | (%) | n | (%) | n | (%) | label",
+ page_width = 9.5,
+ border_top = c("", rep("single", 9)),
+ border_left = c("single", rep(c("single", ""), 4), "single")
+ ) %>%
+ rtf_body(
+ page_width = 9.5,
+ col_rel_width = c(3, rep(c(1.2, 0.8), 4), 3),
+ text_justification = c("l", rep("d", 8), "c"),
+ border_left = c("single", rep(c("single", ""), 4), "single")
+ ) %>%
+ rtf_footnote("This is a footnote") %>%
+ rtf_source("Source: xxx")
+
+
+# Output
+
+bs_rtf %>%
+ rtf_encode() %>%
+ write_rtf("rtf/bs_example.rtf")
+```
+
+
+## Example 8: baseline characteristics example page_by feature
+
+```{r}
+## r2rtf rtf table createion pipeline
+bs_rtf <- bs_tb %>%
+ rtf_title("Demographic and Anthropometric Characteristics", "ITT Subjects") %>%
+ rtf_colheader(" | Placebo | Drug Low Dose | Drug High Dose | Total",
+ col_rel_width = c(3, rep(2, 4)),
+ first_row = TRUE
+ ) %>%
+ rtf_colheader(" | n | (%) | n | (%) | n | (%) | n | (%)",
+ border_top = c("", rep("single", 8)),
+ border_left = c("single", rep(c("single", ""), 4))
+ ) %>%
+ rtf_body(
+ page_by = "var_label", # this option show the label in one row.
+ col_rel_width = c(3, rep(c(1.2, 0.8), 4)),
+ text_justification = c("l", rep("d", 8)),
+ border_left = c("single", rep(c("single", ""), 4))
+ ) %>%
+ rtf_footnote("This is a footnote") %>%
+ rtf_source("Source: xxx")
+
+
+# Output
+
+bs_rtf %>%
+ rtf_encode() %>%
+ write_rtf("rtf/bs_pageby_example.rtf")
+```
+
+
+
+## Example 9: baseline characteristics example page_by and new_page feature
+```{r}
+## r2rtf rtf table createion pipeline
+bs_rtf <- bs_tb %>%
+ rtf_title("Demographic and Anthropometric Characteristics", "ITT Subjects") %>%
+ rtf_colheader(" | Placebo | Drug Low Dose | Drug High Dose | Total",
+ col_rel_width = c(3, rep(2, 4)),
+ first_row = TRUE
+ ) %>%
+ rtf_colheader(" | n | (%) | n | (%) | n | (%) | n | (%)",
+ border_top = c("", rep("single", 8)),
+ border_left = c("single", rep(c("single", ""), 4))
+ ) %>%
+ rtf_body(
+ page_by = "var_label", # this option show the label in one row.
+ new_page = TRUE,
+ col_rel_width = c(3, rep(c(1.2, 0.8), 4)),
+ text_justification = c("l", rep("d", 8)),
+ border_left = c("single", rep(c("single", ""), 4))
+ ) %>%
+ rtf_footnote("This is a footnote",
+ justification = "l"
+ ) %>%
+ rtf_source("Source: xxx",
+ justification = "l"
+ )
+
+
+# Output
+
+bs_rtf %>%
+ rtf_encode() %>%
+ write_rtf("rtf/bs_pageby_newpage_example.rtf")
+```
+
+
+
diff --git a/vignettes/example_pipeline.Rmd b/vignettes/example_pipeline.Rmd
deleted file mode 100644
index 58c946b3..00000000
--- a/vignettes/example_pipeline.Rmd
+++ /dev/null
@@ -1,505 +0,0 @@
----
-title: "RTF Examples for Tables"
-output: rmarkdown::html_vignette
-vignette: >
- %\VignetteIndexEntry{example-table}
- %\VignetteEngine{knitr::rmarkdown}
- %\VignetteEncoding{UTF-8}
----
-
-```{r setup, include=FALSE}
-knitr::opts_chunk$set(echo = TRUE)
-devtools::load_all() # need to be updated after the package mature
-
-library(tidyverse)
-library(emmeans)
-library(stringr)
-
-```
-
-Define some utility functions
-```{r}
-#' Format Model Estimator
-#'
-#' The function assume 1 or 2 column.
-#' If there is only 1 column, only represent mean
-#' If there are 2 column, represent mean (sd) or mean(se)
-#' Decimals will understand the number will be formated as x.x(x.xx)
-#' @noRd
-fmt_est <- function(data, columns = c("mean", "sd"), decimals = c(1,2)){
- .mean = formatC(data[[columns[[1]]]], digits = decimals[1], format = "f", flag = "0")
- if(length(columns) > 1){
- .sd = formatC(data[[columns[[2]]]], digits = decimals[2], format = "f", flag = "0")
- paste0(.mean, " (", .sd, ")")
- }else{
- .mean
- }
-
-}
-
-#' Format Confidence Interval
-#' @noRd
-fmt_ci <- function(data, columns = c("lower.CL", "upper.CL"), decimals = 2){
- .lower = formatC(data[[columns[[1]]]], digits = decimals, format = "f", flag = "0")
- .upper = formatC(data[[columns[[2]]]], digits = decimals, format = "f", flag = "0")
- paste0("(", .lower, ", " , .upper, ")")
-}
-
-#' Format P-Value
-#' @noRd
-fmt_pval <- function(data, columns = "p.value", decimals = 3){
- scale <- 10 ^ (-1 * decimals)
- p_scale <- paste0("<",scale)
- if_else(data[[columns[[1]]]] < scale, p_scale,
- formatC(data[[columns[[1]]]], digits = decimals, format = "f", flag = "0") )
-}
-```
-
-# Examples
-## Example 1: ANCOVA analysis for HOMA data
-
-
-* The data is avaliable at [https://missingdata.lshtm.ac.uk/dia-working-group/example-data-sets/](https://missingdata.lshtm.ac.uk/dia-working-group/example-data-sets/)
-
-* For example, we want to summary the analysis results using ANCOVA model
-
-```{r}
-data("HAMD17")
-ana_week = 8 # Analysis Week
-
-HAMD17_lmfit <- HAMD17 %>% filter(week == ana_week) %>%
- lm(change ~ basval + TRT, data = .)
-
-```
-
-### Raw summary
-```{r}
-t11 <- HAMD17 %>% filter(week == ana_week) %>%
- group_by(TRT) %>%
- summarise( N = n(),
- mean_bl = mean(basval),
- sd_bl = sd(basval),
- mean = mean(change),
- sd = sd(change))
-```
-
-### LS mean
-```{r}
-t12 <- emmeans(HAMD17_lmfit, "TRT")
-t1 <- merge(t11, t12) %>%
- mutate(emmean_sd = SE * sqrt(df)) %>%
- mutate( Trt = c("Study Drug", "Placebo"),
- N1 = N,
- Mean1 = fmt_est(., c("mean_bl", "sd_bl") ),
- N2 = N,
- Mean2 = fmt_est(., c("mean", "sd")),
- N3 = N,
- Mean3 = fmt_est(., c("emmean", "emmean_sd")),
- CI = paste(fmt_est(., "emmean"), fmt_ci(., c("lower.CL", "upper.CL")))
- ) %>%
- select(Trt:CI)
-```
-
-### Treatment Comparision
-```{r}
-t2 <- data.frame(pairs(t12))
-
-t2 <- t2 %>% mutate(
- lower = estimate - 1.96 * SE,
- upper = estimate + 1.96 * SE) %>%
- mutate(
- comp = "Study Drug vs. Placebo",
- mean = paste(fmt_est(., "estimate"), fmt_ci(., c("lower", "upper"))),
- p = fmt_pval(., "p.value")
- ) %>%
- select(comp:p)
-
-```
-
-### RMSE
-```{r}
-t3 <- data.frame(rmse = paste0("Root Mean Squared Error of Change = ",
- formatC(sd(HAMD17_lmfit$residuals), digits = 2, format = "f", flag = "0")))
-```
-
-The prupose of this exercise is to create a table as in `rtf_example1.rtf` by using the three datasets `t1`, `t2` and `t3`
-
-```{r}
-t1
-```
-
-```{r}
-t2
-```
-
-```{r}
-t3
-```
-
-
-For multiple tables like the efficacy example, we have a flow in the following to print an rtf table
-```{r}
-
-tbl_1 <- t1 %>%
- rtf_title(title = "ANCOVA of Change from Baseline at Week 8",
- subtitle = c("Missing Data Approach",
- "Analysis Population")) %>%
- rtf_colheader(colheader = " | Baseline | Week 20 | Change from Baseline",
- col_rel_width = c(3, 4, 4, 9),
- first_row = TRUE) %>%
- rtf_colheader(colheader = "Treatment | N | Mean (SD) | N | Mean (SD) | N | Mean (SD) | LS Mean (95% CI)\\dagger") %>%
- rtf_body(col_rel_width = c(3,1,3,1,3,1,3,5),
- text_justification = c("l",rep("c",7)),
- last_row = FALSE) %>%
- rtf_footnote(footnote = "\\daggerBased on an ANCOVA model.\n ANCOVA = Analysis of Covariance, CI = Confidence Interval, LS = Least Squares, SD = Standard Deviation",
- justification = "l")
-
-
-tbl_2 <- t2 %>%
- rtf_colheader(colheader = "Pairwise Comparison | Difference in LS Mean (95% CI)\\dagger | p-Value",
- text_justification = c("l","c","c")) %>%
- rtf_body(col_rel_width = c(8,7,5),
- text_justification = c("l","c","c"),
- last_row = FALSE)
-
-
-tbl_3 <- t3 %>%
- rtf_body(colheader = FALSE,
- col_rel_width = c(1),
- text_justification = "l") %>%
- rtf_source(source = "Source: [study999: adam-adeff]",
- justification = "l")
-
-
-tbl <- list(tbl_1, tbl_2, tbl_3)
-
-tbl %>% rtf_encode() %>% write_rtf("rtf/efficacy_example.rtf")
-
-```
-
-
-## Example 2: a simplified adverse events summary table
-
-
-# get raw summary
-```{r}
-# Step 1: Get raw summary
-data(adae)
-ae_t1 <- adae %>%
- group_by(TRTP) %>%
- mutate(n_subj = n_distinct(SUBJID)) %>%
- group_by(TRTP, AEDECOD) %>%
- summarise(n_ae = n_distinct(SUBJID),
- pct = round(n_ae/unique(n_subj) * 100, 2) ) %>%
- dplyr::filter(n_ae > 4) %>% # only show AE terms with at least 10 subjects in one treatment group.
- gather( key = "var", value = "value", n_ae, pct) %>%
- unite(temp, TRTP, var) %>%
- spread( temp, value, fill = 0)
-ae_t1
-```
-
-# write to an rtf table
-```{r}
-ae_tbl <- ae_t1 %>%
- rtf_title( "Analysis of Subjects With Specific Adverse Events",
- c("(Incidence > 10 Subjects in One or More Treatment Groups)",
- "ASaT") ) %>%
- rtf_colheader(" | Placebo | Drug High Dose | Drug Low Dose",
- col_rel_width = c(4, rep(2,3)),
- first_row = TRUE) %>%
- rtf_colheader(" | n | (%) | n | (%) | n | (%)",
- border_top = c("", rep("single", 6)),
- border_left = c("single", rep(c("single",""), 3))) %>%
- rtf_body(col_rel_width = c(4, rep(1,6)) ,
- text_justification = c("l", rep("c",6)),
- border_left = c("single", rep(c("single",""), 3) )) %>%
- rtf_footnote(c("\\daggerThis is footnote 1", "This is footnote 2"),
- justification = "l") %>%
- rtf_source("Source: xxx",
- justification = "l")
-
-
-ae_tbl %>% rtf_encode() %>% write_rtf("rtf/ae_example.rtf")
-```
-
-# Example 3: adverse events example page_by option
-
-# write to an rtf table
-```{r}
-ae_tbl <- ae_t1 %>%
- rtf_title( "Analysis of Subjects With Specific Adverse Events",
- c("(Incidence > 10 Subjects in One or More Treatment Groups)",
- "ASaT") ) %>%
- rtf_colheader(" | Placebo | Drug High Dose | Drug Low Dose",
- col_rel_width = c(4, rep(2,3)),
- first_row = TRUE) %>%
- rtf_colheader(" | n | (%) | n | (%) | n | (%)",
- border_top = c("", rep("single", 6)),
- border_left = c("single", rep(c("single",""), 3))) %>%
- rtf_body(col_rel_width = c(4, rep(1,6)) ,
- text_justification = c("l", rep("c",6)),
- border_left = c("single", rep(c("single",""), 3) ),
- page_num = 10) %>%
- rtf_footnote("This is a footnote") %>%
- rtf_source("Source: xxx")
-
-
-ae_tbl %>% rtf_encode() %>% write_rtf("rtf/ae_example_page_num_10.rtf")
-```
-
-
-# Example 4: group_by feature
-
-```{r}
-data(iris)
-
-iris <- cbind(iris, new_cat = rep(c("A","B","C","D","E"), 30))
-
-iris_tbl <- iris %>%
- rtf_title("IRIS DATA") %>%
- rtf_colheader("Sepal Length | Sepal Width | Petal Length | PetalWidth",
- first_row = TRUE) %>%
- rtf_body(
- page_by = c("Species", "new_cat"),
- new_page = TRUE,
- page_num = 30) %>%
- rtf_footnote("This is a footnote") %>%
- rtf_source("Source: xxx")
-
-iris_tbl %>% rtf_encode() %>% write_rtf("rtf/iris_example.rtf")
-
-
-```
-
-## Example 5: A very simple example
-```{r}
-data(iris)
-
-iris_tbl <- iris[1:20,] %>% rtf_body()
-
-iris_tbl %>% rtf_encode() %>% write_rtf("rtf/iris_very_simple.rtf")
-```
-
-## Example 6: A simple example
-```{r}
-data(iris)
-
-iris_tbl <- iris[1:20,] %>%
- rtf_title("IRIS DATA") %>%
- rtf_colheader("Sepal Length | Sepal Width | Petal Length | PetalWidth | Species",
- first_row = TRUE) %>%
- rtf_body() %>%
- rtf_footnote("This is a footnote") %>%
- rtf_source("Source: xxx")
-
-iris_tbl %>% rtf_encode() %>% write_rtf("rtf/iris_simple.rtf")
-```
-
-## Example 7: baseline characteristics example feature
-```{r}
-bs_count <- function(data, grp, var,
- var_label = var,
- decimal = 1,
- total = TRUE){
-
-
- data <- data %>% rename(grp = !! grp, var = !! var)
- coding <- levels( factor(data$grp) )
- data <- data %>% mutate(grp = as.numeric(factor(grp)))
-
- # res <- data %>% count(grp, var, .drop = FALSE)
- res <- with(data, table(var, grp)) %>% as.data.frame() %>%
- mutate(grp = as.numeric(grp))
-
- if(total){
- res_tot <- with(data, table(var)) %>% as.data.frame() %>% mutate(grp = 9999)
- res <- bind_rows(res, res_tot)
- }
-
- res <- res %>% rename(n = Freq)
-
- res <- res %>% mutate(pct = formatC( n / sum(n) * 100, digits = decimal, format = "f", flag = "0") )
-
- res <- res %>% gather("key", "value", n, pct) %>%
- unite(keys, grp, key) %>%
- spread(keys, value) %>%
- mutate(var_label = var_label) %>%
- mutate(var = as.character(var))
-
- names(res) <- gsub("_n", "", names(res), fixed = TRUE)
- attr(res, "coding") <- coding
-
- res
-}
-
-bs_continous <- function(data, grp, var,
- var_label = var,
- decimal = 1,
- total = TRUE,
- blank_row = FALSE){
-
- data <- data %>% rename(grp = !! grp, var = !! var)
- coding <- levels( factor(data$grp) )
- data <- data %>% mutate(grp = as.numeric(factor(grp)))
-
- res <- data %>% select(grp, var) %>% na.omit() %>%
- group_by(grp) %>%
- summarise(`Subjects with data` = n(),
- Mean = formatC( mean(var), digits = decimal, format = "f", flag = "0"),
- SD = formatC( sd(var) , digits = decimal, format = "f", flag = "0"),
- Median = formatC( median(var), digits = decimal, format = "f", flag = "0"),
- Range = paste( range(var), collapse = " to ") )
-
- if(total){
-
- res_tot <- data %>% select(grp, var) %>% na.omit() %>%
- summarise(`Subjects with data` = n(),
- Mean = formatC( mean(var), digits = decimal, format = "f", flag = "0"),
- SD = formatC( sd(var) , digits = decimal, format = "f", flag = "0"),
- Median = formatC( median(var), digits = decimal, format = "f", flag = "0"),
- Range = paste( range(var), collapse = " to ") ) %>%
- mutate(grp = 9999)
- res <- bind_rows(res, res_tot)
- }
-
-
- res <- res %>% gather("key", "value", - grp) %>%
- mutate(key = factor(key, levels = c("Subjects with data", "Mean", "SD", "Median", "Range")) ) %>%
- spread(grp, value) %>%
- mutate(var_label = var_label) %>%
- mutate(key = as.character(key)) %>%
- rename(var = key)
-
- if(blank_row){
- res <- bind_rows(tibble(var_label = var_label), res)
- }
-
- res
-}
-
-# The code above define two utility function for baseline characterstic tables.
-
-
-
-# Analaysis Set
-data(adsl)
-ana <- adsl %>% subset(ITT == "Y")
-ana <- ana %>% mutate(
- RACE = factor(RACE,
- toupper( c("African Descent (Negro, Black)", "Caucasian", "Hispanic (Mexican - American, Mexico, Central And South America)",
- "Other (Mixed - Racial Heritage, American Indian, Eskimo)")),
- c("Black", "Caucasian", "Hispanic", "Other")),
- SEX = factor(SEX, c("F", "M"), c("Female", "Male"))
-)
-
-# Build Data for r2rtf
-bs_tb <- bind_rows(
- bs_count(ana, "TRTPN", "SEX", "Gender"),
- bs_count(ana, "TRTPN", "AGEGRP", "Age (Years)"),
- bs_continous(ana, "TRTPN", "AGE", "Age (Years)", blank_row = TRUE),
- bs_count(ana, "TRTPN", "RACE", "Race")
-)
-
-bs_tb[ is.na(bs_tb) ] <- ""
-```
-
-
-```{r}
-bs_rtf <- bs_tb %>%
-
- rtf_title("Demographic and Anthropometric Characteristics","ITT Subjects") %>%
-
- rtf_colheader(" | Placebo | Drug Low Dose | Drug High Dose | Total | label",
- col_rel_width = c(3, rep(2,4),3),
- page_width = 9.5,
- first_row = TRUE) %>%
-
- rtf_colheader(" | n | (%) | n | (%) | n | (%) | n | (%) | label",
- page_width = 9.5,
- border_top = c("", rep("single", 9)),
- border_left = c("single", rep(c("single",""), 4),"single")) %>%
-
- rtf_body(page_width = 9.5,
- col_rel_width = c(3, rep(c(1.2, 0.8), 4),3) ,
- text_justification = c("l", rep("d",8),"c"),
- border_left = c("single", rep(c("single",""), 4),"single" )) %>%
-
- rtf_footnote("This is a footnote") %>%
-
- rtf_source("Source: xxx")
-
-
-# Output
-
-bs_rtf %>% rtf_encode() %>% write_rtf("rtf/bs_example.rtf")
-```
-
-
-## Example 8: baseline characteristics example page_by feature
-
-```{r}
-## r2rtf rtf table createion pipeline
-bs_rtf <- bs_tb %>%
-
- rtf_title("Demographic and Anthropometric Characteristics","ITT Subjects") %>%
-
- rtf_colheader(" | Placebo | Drug Low Dose | Drug High Dose | Total",
- col_rel_width = c(3, rep(2,4)),
- first_row = TRUE) %>%
-
- rtf_colheader(" | n | (%) | n | (%) | n | (%) | n | (%)",
- border_top = c("", rep("single", 8)),
- border_left = c("single", rep(c("single",""), 4))) %>%
-
- rtf_body(page_by = "var_label", # this option show the label in one row.
- col_rel_width = c(3, rep(c(1.2, 0.8), 4)) ,
- text_justification = c("l", rep("d",8)),
- border_left = c("single", rep(c("single",""), 4) )) %>%
-
- rtf_footnote("This is a footnote") %>%
-
- rtf_source("Source: xxx")
-
-
-# Output
-
-bs_rtf %>% rtf_encode() %>% write_rtf("rtf/bs_pageby_example.rtf")
-```
-
-
-
-## Example 9: baseline characteristics example page_by and new_page feature
-```{r}
-## r2rtf rtf table createion pipeline
-bs_rtf <- bs_tb %>%
-
- rtf_title("Demographic and Anthropometric Characteristics","ITT Subjects") %>%
-
- rtf_colheader(" | Placebo | Drug Low Dose | Drug High Dose | Total",
- col_rel_width = c(3, rep(2,4)),
- first_row = TRUE) %>%
-
- rtf_colheader(" | n | (%) | n | (%) | n | (%) | n | (%)",
- border_top = c("", rep("single", 8)),
- border_left = c("single", rep(c("single",""), 4))) %>%
-
- rtf_body(page_by = "var_label", # this option show the label in one row.
- new_page = TRUE,
- col_rel_width = c(3, rep(c(1.2, 0.8), 4)) ,
- text_justification = c("l", rep("d",8)),
- border_left = c("single", rep(c("single",""), 4) )) %>%
-
- rtf_footnote("This is a footnote",
- justification = "l") %>%
-
- rtf_source("Source: xxx",
- justification = "l")
-
-
-# Output
-
-bs_rtf %>% rtf_encode() %>% write_rtf("rtf/bs_pageby_newpage_example.rtf")
-```
-
-
-
diff --git a/vignettes/rtf-row.Rmd b/vignettes/rtf-row.Rmd
index 64ac2b76..dde26b9b 100644
--- a/vignettes/rtf-row.Rmd
+++ b/vignettes/rtf-row.Rmd
@@ -1,5 +1,5 @@
---
-title: "RTF Examples for Controling Table Details"
+title: "RTF Examples for Controlling Table Details"
date: "`r Sys.Date()`"
output: rmarkdown::html_vignette
vignette: >
@@ -27,7 +27,7 @@ This vignette documents how to use `.rtf_row` to customize table in details. All
`.rtf_row` supports `r length(.border_type()$name)` different types of border as listed below.
```{r}
-.border_type()$name
+.border_type()$name
```
The border type can be used to define the top, left, right and bottom border types.
@@ -35,12 +35,13 @@ The border type can be used to define the top, left, right and bottom border typ
This example define different top border line.
```{r}
.n <- length(.border_type()$name)
-db <- data.frame( border_type = .border_type()$name ) %>%
- rtf_title("Summary of Border Type Using Top Border") %>%
- rtf_body(border_top = .border_type()$name)
-
-db %>% rtf_encode() %>%
- write_rtf("rtf/border-type.rtf")
+db <- data.frame(border_type = .border_type()$name) %>%
+ rtf_title("Summary of Border Type Using Top Border") %>%
+ rtf_body(border_top = .border_type()$name)
+
+db %>%
+ rtf_encode() %>%
+ write_rtf("rtf/border-type.rtf")
```
@@ -49,27 +50,32 @@ The bottom border only defined in last row. This example show that top border an
cell border as single. Only last column use right border as double. Only last row use bottom border as dash line.
```{r}
-iris %>% head() %>%
- rtf_body(border_top = "single",
- border_left = "single",
- border_right = "double",
- border_bottom = "dash") %>%
- rtf_encode() %>%
- write_rtf("rtf/border-order.rtf")
+iris %>%
+ head() %>%
+ rtf_body(
+ border_top = "single",
+ border_left = "single",
+ border_right = "double",
+ border_bottom = "dash"
+ ) %>%
+ rtf_encode() %>%
+ write_rtf("rtf/border-order.rtf")
```
-This example display table with specific border type (i.e. double line at the frist and last line and blank at the middle)
+This example display table with specific border type (i.e. double line at the first and last line and blank at the middle)
```{r}
-rtf_db <- iris %>%
- head() %>%
- rtf_title("Border Using Double Line at First/Last Line") %>%
- rtf_colheader("Sepal Length | Sepal Width | Petal Length | Petal Width | Species",
- first_row = TRUE) %>%
- rtf_body()
-
+rtf_db <- iris %>%
+ head() %>%
+ rtf_title("Border Using Double Line at First/Last Line") %>%
+ rtf_colheader("Sepal Length | Sepal Width | Petal Length | Petal Width | Species",
+ first_row = TRUE
+ ) %>%
+ rtf_body()
+
-rtf_db %>% rtf_encode() %>%
- write_rtf("rtf/border-example.rtf")
+rtf_db %>%
+ rtf_encode() %>%
+ write_rtf("rtf/border-example.rtf")
```
Internally, the border type will be saved as a matrix to define the border type of each cell. For example, the top border type in the last example is saved as
@@ -80,22 +86,24 @@ rtf_db %>% attr("border_top")
the bottom border type in the last example is saved as below. Based on the rule, all cells use top border. cells at last row use bottom border at last row.
```{r}
-rtf_db %>% attr("border_bottom")
+rtf_db %>% attr("border_bottom")
```
-User can use single value, vector, and matrix to control the border type. Specifically, a verctor is transfered to a matrix by row. Therefore, it is useful to set columns type by using vector.
+User can use single value, vector, and matrix to control the border type. Specifically, a vector is transferred to a matrix by row. Therefore, it is useful to set columns type by using vector.
```{r}
-matrix( .border_type()$name[1:5], nrow = 6, ncol = 5, byrow = TRUE)
+matrix(.border_type()$name[1:5], nrow = 6, ncol = 5, byrow = TRUE)
```
```{r}
-rtf_db <- iris %>%
- head() %>%
- rtf_title("Left Border Defined by a Vector") %>%
- rtf_body(border_left = .border_type()$name[2:6])
+rtf_db <- iris %>%
+ head() %>%
+ rtf_title("Left Border Defined by a Vector") %>%
+ rtf_body(border_left = .border_type()$name[2:6])
-rtf_db %>% rtf_encode() %>% write_rtf("rtf/border-vector.rtf")
+rtf_db %>%
+ rtf_encode() %>%
+ write_rtf("rtf/border-vector.rtf")
```
@@ -107,7 +115,7 @@ The table cell allow to be left, center or right justified. the cell is also all
```
```{r}
-.justification()[, 1:2] %>%
+.justification()[, 1:2] %>%
rtf_body(text_justification = rep(.justification()$type, each = 2)) %>%
rtf_encode() %>%
write_rtf("rtf/justification-type.rtf")
@@ -115,11 +123,11 @@ The table cell allow to be left, center or right justified. the cell is also all
```{r}
-db <- iris %>% mutate(Sepal.Length = formatC(Sepal.Length * 2, digits = 1, format = "f") )
+db <- iris %>% mutate(Sepal.Length = formatC(Sepal.Length * 2, digits = 1, format = "f"))
-db[, rep(1,4)] %>%
+db[, rep(1, 4)] %>%
head() %>%
- rtf_body(text_justification = c("d", "l", "c", "r") ) %>%
+ rtf_body(text_justification = c("d", "l", "c", "r")) %>%
rtf_encode() %>%
write_rtf("rtf/justification-number.rtf")
```
@@ -127,26 +135,28 @@ db[, rep(1,4)] %>%
## Column Width
-Column width is determined by width ratio between the row using `col_rel_width`. The default is to have the same width for each column. The actual width is calcuate with actual width `col_total_width`. The default value of `col_total_width` is page_width divided by 1.4.
+Column width is determined by width ratio between the row using `col_rel_width`. The default is to have the same width for each column. The actual width is calculate with actual width `col_total_width`. The default value of `col_total_width` is page_width divided by 1.4.
This example shows the default setting
```{r}
-iris %>% head() %>%
- rtf_body() %>%
- rtf_encode() %>%
- write_rtf("rtf/column-width-default.rtf")
+iris %>%
+ head() %>%
+ rtf_body() %>%
+ rtf_encode() %>%
+ write_rtf("rtf/column-width-default.rtf")
```
This example customizes the column width
```{r}
-iris %>% head() %>%
- rtf_body(col_rel_width = 1:ncol(iris)) %>%
- rtf_encode() %>%
- write_rtf("rtf/column-width-ratio.rtf")
+iris %>%
+ head() %>%
+ rtf_body(col_rel_width = 1:ncol(iris)) %>%
+ rtf_encode() %>%
+ write_rtf("rtf/column-width-ratio.rtf")
```
-## Text Apperance
+## Text Appearance
The `.rtf_row` function allow **bold**, *italics*, ~~strikethrough~~, underline and any combinations of them.
@@ -157,14 +167,14 @@ The `.rtf_row` function allow **bold**, *italics*, ~~strikethrough~~, underline
This example considers the text format defined below
```{r}
-fmt <- matrix( c(.font_format()$type, paste0(.font_format()$type, "b") ), ncol = 2 )
+fmt <- matrix(c(.font_format()$type, paste0(.font_format()$type, "b")), ncol = 2)
fmt
```
```{r}
-.font_format()[, 1:2] %>%
- rtf_body(text_format = fmt) %>%
+.font_format()[, 1:2] %>%
+ rtf_body(text_format = fmt) %>%
rtf_encode() %>%
write_rtf("rtf/text-format.rtf")
```
@@ -174,42 +184,48 @@ fmt
Font size can be defined for each cell.
```{r}
-iris %>% head() %>%
- rtf_body(text_font_size = c(7:11) ) %>%
- rtf_encode() %>%
- write_rtf("rtf/text-font-size.rtf")
+iris %>%
+ head() %>%
+ rtf_body(text_font_size = c(7:11)) %>%
+ rtf_encode() %>%
+ write_rtf("rtf/text-font-size.rtf")
```
## Color
-The text, border and background color can be set seperately for each cell. It is important to note that the cell can be defined condition by the data. For example, one can highlight p-value < 0.05 in gold.
+The text, border and background color can be set separately for each cell. It is important to note that the cell can be defined condition by the data. For example, one can highlight p-value < 0.05 in gold.
This example define text color for each column
```{r}
-iris %>% head()%>%
- rtf_body(text_color = c("black", "red", "gold", "blue", "grey") ) %>%
- rtf_encode() %>%
- write_rtf("rtf/color-text.rtf")
+iris %>%
+ head() %>%
+ rtf_body(text_color = c("black", "red", "gold", "blue", "grey")) %>%
+ rtf_encode() %>%
+ write_rtf("rtf/color-text.rtf")
```
This example define left border color for each column
```{r}
-iris %>% head() %>%
- rtf_body(border_color_left = c("black", "red", "gold", "blue", "grey") ) %>%
- rtf_encode() %>%
- write_rtf("rtf/color-border.rtf")
+iris %>%
+ head() %>%
+ rtf_body(border_color_left = c("black", "red", "gold", "blue", "grey")) %>%
+ rtf_encode() %>%
+ write_rtf("rtf/color-border.rtf")
```
This example define background color for each column
```{r}
-iris %>% head() %>%
- rtf_body(text_background_color = c("white", "red", "gold", "blue", "grey"),
- text_color = "black") %>%
- rtf_encode() %>%
- write_rtf("rtf/color-background.rtf")
+iris %>%
+ head() %>%
+ rtf_body(
+ text_background_color = c("white", "red", "gold", "blue", "grey"),
+ text_color = "black"
+ ) %>%
+ rtf_encode() %>%
+ write_rtf("rtf/color-background.rtf")
```
diff --git a/vignettes/rtf-text.Rmd b/vignettes/rtf-text.Rmd
index 72fb952c..a85188eb 100644
--- a/vignettes/rtf-text.Rmd
+++ b/vignettes/rtf-text.Rmd
@@ -1,5 +1,5 @@
---
-title: "RTF Examples for Controling Text and Paragraph Details"
+title: "RTF Examples for Controlling Text and Paragraph Details"
date: "`r Sys.Date()`"
output: rmarkdown::html_vignette
vignette: >
@@ -23,7 +23,7 @@ This vignette documents how to use `.rtf_text` and `.rtf_paragraph` to customize
```{r}
-text <- paste( rep("Sample Text", 20), collapse = " ")
+text <- paste(rep("Sample Text", 20), collapse = " ")
```
```{r}
@@ -37,20 +37,21 @@ text <- rep(text, 5)
Paragraph alignment supports four types.
```{r}
-.justification() %>% subset(type %in% c("l","c","r","j") )
+.justification() %>% subset(type %in% c("l", "c", "r", "j"))
```
This example display text in different alignment methods.
```{r}
-res <- .rtf_paragraph(.rtf_text(text),
- justification = c("l","c","r","j"))
+res <- .rtf_paragraph(.rtf_text(text),
+ justification = c("l", "c", "r", "j")
+)
write_rtf_para(res, "rtf/para-justification.rtf")
```
### Indent
-First line, left, and right indent can be controle. One can also use a negative number to have the text "outdent".
+First line, left, and right indent can be control. One can also use a negative number to have the text "outdent".
```{r}
res <- .rtf_paragraph(.rtf_text(text), indent_first = c(1000, 0, -1000), indent_left = c(500, -500), indent_right = 500)
@@ -63,23 +64,25 @@ write_rtf_para(res, "rtf/para-indent.rtf")
Different types of line space can be controlled.
```{r}
-.spacing()[,1:2]
+.spacing()[, 1:2]
```
This example show different line spaces in paragraph.
```{r}
-res <- .rtf_paragraph(.rtf_text(text),
- space = c(1,2,1.5))
+res <- .rtf_paragraph(.rtf_text(text),
+ space = c(1, 2, 1.5)
+)
write_rtf_para(res, "rtf/para-line-space.rtf")
```
### Paragraph Space
```{r}
-res <- .rtf_paragraph(.rtf_text(text),
- space_before = c(50, 180),
- space_after = c(180,50))
+res <- .rtf_paragraph(.rtf_text(text),
+ space_before = c(50, 180),
+ space_after = c(180, 50)
+)
write_rtf_para(res, "rtf/para-space.rtf")
```
@@ -88,8 +91,9 @@ write_rtf_para(res, "rtf/para-space.rtf")
This example add page break before paragraphs.
```{r}
-res <- .rtf_paragraph(.rtf_text(text)[1:2],
- new_page = TRUE)
+res <- .rtf_paragraph(.rtf_text(text)[1:2],
+ new_page = TRUE
+)
write_rtf_para(res, "rtf/para-page.rtf")
```
@@ -97,29 +101,34 @@ write_rtf_para(res, "rtf/para-page.rtf")
### Font Size
```{r}
-res <- .rtf_paragraph(.rtf_text(text,
- font_size = 8:12))
+res <- .rtf_paragraph(.rtf_text(text,
+ font_size = 8:12
+))
write_rtf_para(res, "rtf/text-font-size.rtf")
```
### Text Format
```{r}
-res <- .rtf_paragraph(.rtf_text(text,
- format = c("b","i","bi","^", "_", "u", "s")))
+res <- .rtf_paragraph(.rtf_text(text,
+ format = c("b", "i", "bi", "^", "_", "u", "s")
+))
write_rtf_para(res, "rtf/text-format.rtf")
```
### Text Color
```{r}
-res <- .rtf_paragraph(.rtf_text(text,
- color = c("red","gold","black","orange","blue")))
+res <- .rtf_paragraph(.rtf_text(text,
+ color = c("red", "gold", "black", "orange", "blue")
+))
write_rtf_para(res, "rtf/text-color.rtf")
```
### Text Background Color
```{r}
-res <- .rtf_paragraph(.rtf_text(text, color = "white",
- background_color = c("red","gold","black","orange","blue")))
+res <- .rtf_paragraph(.rtf_text(text,
+ color = "white",
+ background_color = c("red", "gold", "black", "orange", "blue")
+))
write_rtf_para(res, "rtf/text-background-color.rtf")
```
@@ -130,10 +139,10 @@ This example call `rtf_text` multiple times to combine a text.
```{r}
res <- .rtf_paragraph(paste0(
.rtf_text("3.5"),
- .rtf_text("\\dagger", format = "^"),
- .rtf_text("\\line red ", color = "red"),
- .rtf_text("highlight", background_color = "yellow") )
-)
+ .rtf_text("\\dagger", format = "^"),
+ .rtf_text("\\line red ", color = "red"),
+ .rtf_text("highlight", background_color = "yellow")
+))
write_rtf_para(res, "rtf/text-combine1.rtf")
```
@@ -141,15 +150,15 @@ This example call `rtf_text` one time to combine a text.
```{r}
text <- c(3.5, "\\dagger", "\\line red ", "highlight")
format <- c("", "^", "", "")
-color <- c("black","black","red","black")
-background_color <- c("white","white","white","yellow")
+color <- c("black", "black", "red", "black")
+background_color <- c("white", "white", "white", "yellow")
res <- .rtf_paragraph(paste(.rtf_text(text, format = format, color = color, background_color = background_color), collapse = ""))
write_rtf_para(res, "rtf/text-combine2.rtf")
```
-### Inline Formating
-This example provide an inline formating options with superscript and subscript. It is important to note the location of `{}` is before the special character.
+### Inline Formatting
+This example provide an inline formatting options with superscript and subscript. It is important to note the location of `{}` is before the special character.
```{r}
text <- c("X{_1} = \\alpha{^2} + \\beta{^\\dagger}")