Skip to content

Commit 93cf576

Browse files
thebioengineerthebioengineer
authored
Merge pull request #18 from thebioengineer/feature/word_outputs
Feature/word outputs
2 parents a6600f8 + ee01206 commit 93cf576

File tree

6 files changed

+259
-3
lines changed

6 files changed

+259
-3
lines changed

‎NEWS.md

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,8 @@
11
# colortable (development version)
22

3+
### Features
4+
- Initial implementation of word (docx) printing
5+
36
# colortable 0.2.1
47

58
### Features

‎R/color_utils.R

Lines changed: 10 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -36,10 +36,17 @@ unify_colors <- function(x, type = print_method()) {
3636
grepl("^#[0-9A-Fa-f]{6}$", x, perl = TRUE)) {
3737
return(toupper(x))
3838
} else {
39-
type <- match.arg(type, c("latex", "html", "console"))
40-
method_colors <- valid_colors(type)$`Color Name`
4139

42-
if (!x %in% method_colors) {
40+
if(!is.null(type)){
41+
type <- match.arg(type, c("latex", "html", "console"))
42+
method_colors <- valid_colors(type)$`Color Name`
43+
in_method_colors <-x %in% method_colors
44+
}else{
45+
in_method_colors = FALSE
46+
}
47+
48+
49+
if (!in_method_colors) {
4350
other_colors <- valid_colors(setdiff(c("latex", "html", "console"), type))
4451
idx <- which(other_colors$`Color Name` %in% x)
4552
if (length(idx) > 0) {

‎R/print_color_vctr.R

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,7 @@ format.color_vctr <- function(x, ..., method = print_method()){
2525
"latex" = format.color_vctr.latex,
2626
"html" = format.color_vctr.html,
2727
"gfm" = format.color_vctr.html,
28+
"docx" = format.color_vctr.docx,
2829
stop("Method for ", print_method()," not implemented yet.")
2930
)
3031

@@ -69,6 +70,17 @@ format.color_vctr.latex <- function(x,...){
6970
x
7071
}
7172

73+
format.color_vctr.docx <- function(x,...){
74+
x <-
75+
style2docxV(
76+
format_preserve_na(field(x, "vctr"), ...),
77+
field(x, ".style"),
78+
field(x, ".text_color"),
79+
field(x, ".background")
80+
)
81+
names(x) <- NULL
82+
x
83+
}
7284

7385
add_colortable_latex_meta <- function(){
7486
meta <- knitr::knit_meta(clean = FALSE)

‎R/style2.R

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -71,3 +71,18 @@ style2tex <- function(x, style = NA, text_color = NA, background = NA, ...){
7171
}
7272

7373
style2texV <- Vectorize(style2tex,vectorize.args = c("x","style","text_color","background"),SIMPLIFY = TRUE)
74+
75+
style2docx <- function(x, style = NA, text_color = NA, background = NA, ...){
76+
if (is.na(x)) {
77+
return(NA)
78+
}else{
79+
text_style <- style_wrapper_docx(style, type = "style")
80+
text_color <- style_wrapper_docx(text_color, type = "text")
81+
text_background <- style_wrapper_docx(background, type = "background")
82+
83+
style_zipper_docx(x, paste0(text_background,text_style,text_color))
84+
}
85+
}
86+
87+
style2docxV <- Vectorize(style2docx,vectorize.args = c("x","style","text_color","background"),SIMPLIFY = TRUE)
88+

‎R/style_docx.R

Lines changed: 114 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,114 @@
1+
#' @importFrom rmarkdown latex_dependency
2+
style_wrapper_docx <-
3+
function(styling,
4+
type = c("text", "style", "background")) {
5+
if (is.na(styling)) {
6+
""
7+
} else{
8+
type <- match.arg(type)
9+
styling <- tolower(styling)
10+
switch(
11+
type,
12+
"style" = docx_decoration_styling(styling),
13+
"text" = docx_text_styling(unify_colors(styling,type = NULL)),
14+
"background" = docx_background_styling(styling)
15+
)
16+
}
17+
}
18+
19+
style_zipper_docx <- function(x,styling){
20+
paste0("`<w:r><w:rPr xmlns:w14=\"http://schemas.microsoft.com/office/word/2010/wordml\">", styling, "</w:rPr><w:t xml:space=\"preserve\">",x,"</w:t></w:r>`{=openxml}")
21+
}
22+
23+
docx_decoration_styling <- function(styling){
24+
if (!styling %in% names(docx_style_codes)) {
25+
""
26+
}else{
27+
codes <- docx_style_codes[[styling]]
28+
paste0("<w:",codes$code,"/>")
29+
}
30+
}
31+
32+
docx_style_codes <- list(
33+
bold = list(code = "b"),
34+
italic = list(code = "i"),
35+
underline = list(code = "u"),
36+
strikethrough = list(code = "strike")
37+
)
38+
39+
docx_text_styling <- function(color){
40+
code <- try(as_hex_codes(color), silent = TRUE)
41+
if (inherits(code, "try-error")) {
42+
""
43+
} else{
44+
paste0("<w:color w:val=\"",code,"\"/>")
45+
}
46+
}
47+
48+
docx_background_styling <- function(color){
49+
code <- try(as_docx_highlighter(color), silent = TRUE)
50+
if(inherits(code, "try-error")){
51+
""
52+
}else{
53+
paste0("<w:highlight w:val=\"",code,"\"/>")
54+
}
55+
}
56+
57+
#' @importFrom grDevices col2rgb
58+
as_hex_codes <- function(x) {
59+
if (grepl("^(#)", x) |
60+
grepl("^(#)*[0-9A-Fa-f]{6}$", x, perl = TRUE)) {
61+
return(toupper(x))
62+
} else {
63+
colors <- valid_colors()
64+
method_colors <- colors$`Color Name`
65+
if (x %in% method_colors) {
66+
idx <- which(colors$`Color Name` %in% x)
67+
if (length(idx) > 0) {
68+
return(colors$`Hex Code`[min(idx)])
69+
}
70+
} else {
71+
stop(
72+
paste(
73+
"Invalid Color Name being used. check for valid color names using `valid_colors()`"
74+
)
75+
)
76+
}
77+
}
78+
}
79+
80+
81+
as_docx_highlighter <- function(color){
82+
if(color %in% color_key_docx_highlighter$Name){
83+
idx <- which(color_key_docx_highlighter$Name == color)
84+
}else{
85+
rgb_mat <- col2rgb(as_hex_codes(color))[,1, drop = TRUE]
86+
rgb_key <- do.call('rbind',color_key_docx_highlighter$RGB)
87+
idx <- which_closest_color(rgb_mat, rgb_key)
88+
}
89+
c(color_key_docx_highlighter[idx,"code", drop = TRUE])
90+
}
91+
92+
93+
color_key_docx_highlighter <- tibble::tribble(
94+
~Name, ~hex, ~code, ~RGB,
95+
"yellow","#ffff00","yellow",c(red = 255, blue = 0, green = 255),
96+
"lightgreen","#00ff00","green",c(red = 0, blue = 0, green = 255),
97+
"cyan","#00ffff","cyan",c(red = 0, blue = 255, green = 255),
98+
"pink","#ff00ff","magenta",c(red = 255, blue = 255, green = 0),
99+
"blue","#0000ff","blue",c(red = 0, blue = 255, green = 0),
100+
"red","#ff0000","red",c(red = 255, blue = 0, green = 0),
101+
"darkblue","#000080","darkBlue",c(red = 0, blue = 128, green = 0),
102+
"teal","#008080","darkCyan",c(red = 0, blue = 128, green = 128),
103+
"green","#008000","darkGreen",c(red = 0, blue = 0, green = 128),
104+
"violet","#800080","darkMagenta",c(red = 128, blue = 128, green = 0),
105+
"darkred","#800000","darkRed",c(red = 128, blue = 0, green = 0),
106+
"darkyellow","#808000","darkYellow",c(red = 128, blue = 0, green = 128),
107+
"darkgray","#808080","darkGray",c(red = 128, blue = 128, green = 128),
108+
"lightgray","#c0c0c0","lightGray",c(red = 192, blue = 192, green = 192),
109+
"black","#000000","black",c(red = 0, blue = 0, green = 0)
110+
)
111+
112+
113+
114+

‎tests/testthat/test-print_docx.R

Lines changed: 105 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,105 @@
1+
capture_print <- function(x){
2+
capture.output(print(x,console_width = 80, method = "docx"))
3+
}
4+
5+
test_that("vector printing to console - numeric", {
6+
styled_vect <-
7+
color_vctr(c(1, 2, 0.05, 20),
8+
text_color = c("red", "blue", "green", NA),
9+
style = c("bold","italic","strikethrough",NA),
10+
background = c("teal",NA,"yellow",NA))
11+
12+
expect_equal(
13+
capture_print(styled_vect),
14+
c("`<w:r><w:rPr xmlns:w14=\"http://schemas.microsoft.com/office/word/2010/wordml\"><w:highlight w:val=\"darkCyan\"/><w:b/><w:color w:val=\"#FF0000\"/></w:rPr><w:t xml:space=\"preserve\"> 1.00</w:t></w:r>`{=openxml}",
15+
"`<w:r><w:rPr xmlns:w14=\"http://schemas.microsoft.com/office/word/2010/wordml\"><w:i/><w:color w:val=\"#0000FF\"/></w:rPr><w:t xml:space=\"preserve\"> 2.00</w:t></w:r>`{=openxml}",
16+
"`<w:r><w:rPr xmlns:w14=\"http://schemas.microsoft.com/office/word/2010/wordml\"><w:highlight w:val=\"yellow\"/><w:strike/><w:color w:val=\"#00FF00\"/></w:rPr><w:t xml:space=\"preserve\"> 0.05</w:t></w:r>`{=openxml}",
17+
"`<w:r><w:rPr xmlns:w14=\"http://schemas.microsoft.com/office/word/2010/wordml\"></w:rPr><w:t xml:space=\"preserve\">20.00</w:t></w:r>`{=openxml}" )
18+
)
19+
20+
})
21+
22+
test_that("vector printing to console - integer", {
23+
styled_vect <-
24+
color_vctr(as.integer(c(1, 2, 3, 20)),
25+
text_color = c("red", "blue", "green", NA),
26+
style = c("bold","italic","strikethrough",NA),
27+
background = c("teal",NA,"yellow",NA))
28+
29+
expect_equal(
30+
capture_print(styled_vect),
31+
c("`<w:r><w:rPr xmlns:w14=\"http://schemas.microsoft.com/office/word/2010/wordml\"><w:highlight w:val=\"darkCyan\"/><w:b/><w:color w:val=\"#FF0000\"/></w:rPr><w:t xml:space=\"preserve\"> 1</w:t></w:r>`{=openxml}",
32+
"`<w:r><w:rPr xmlns:w14=\"http://schemas.microsoft.com/office/word/2010/wordml\"><w:i/><w:color w:val=\"#0000FF\"/></w:rPr><w:t xml:space=\"preserve\"> 2</w:t></w:r>`{=openxml}",
33+
"`<w:r><w:rPr xmlns:w14=\"http://schemas.microsoft.com/office/word/2010/wordml\"><w:highlight w:val=\"yellow\"/><w:strike/><w:color w:val=\"#00FF00\"/></w:rPr><w:t xml:space=\"preserve\"> 3</w:t></w:r>`{=openxml}",
34+
"`<w:r><w:rPr xmlns:w14=\"http://schemas.microsoft.com/office/word/2010/wordml\"></w:rPr><w:t xml:space=\"preserve\">20</w:t></w:r>`{=openxml}")
35+
)
36+
})
37+
38+
test_that("vector printing to console - character", {
39+
styled_vect <-
40+
color_vctr(c("A", "B", "C", "Long Character"),
41+
text_color = c("red", "blue", "green", NA),
42+
style = c("bold","italic","strikethrough",NA),
43+
background = c("teal",NA,"yellow",NA))
44+
45+
46+
expect_equal(
47+
capture_print(styled_vect),
48+
c("`<w:r><w:rPr xmlns:w14=\"http://schemas.microsoft.com/office/word/2010/wordml\"><w:highlight w:val=\"darkCyan\"/><w:b/><w:color w:val=\"#FF0000\"/></w:rPr><w:t xml:space=\"preserve\">A </w:t></w:r>`{=openxml}",
49+
"`<w:r><w:rPr xmlns:w14=\"http://schemas.microsoft.com/office/word/2010/wordml\"><w:i/><w:color w:val=\"#0000FF\"/></w:rPr><w:t xml:space=\"preserve\">B </w:t></w:r>`{=openxml}",
50+
"`<w:r><w:rPr xmlns:w14=\"http://schemas.microsoft.com/office/word/2010/wordml\"><w:highlight w:val=\"yellow\"/><w:strike/><w:color w:val=\"#00FF00\"/></w:rPr><w:t xml:space=\"preserve\">C </w:t></w:r>`{=openxml}",
51+
"`<w:r><w:rPr xmlns:w14=\"http://schemas.microsoft.com/office/word/2010/wordml\"></w:rPr><w:t xml:space=\"preserve\">Long Character</w:t></w:r>`{=openxml}")
52+
)
53+
54+
})
55+
56+
test_that("vector printing to console - factor", {
57+
styled_vect <-
58+
color_vctr(factor(c("A", "B", "C", "Long Character")),
59+
text_color = c("red", "blue", "green", NA),
60+
style = c("bold","italic","strikethrough",NA),
61+
background = c("teal",NA,"yellow",NA))
62+
63+
expect_equal(
64+
capture_print(styled_vect),
65+
c("`<w:r><w:rPr xmlns:w14=\"http://schemas.microsoft.com/office/word/2010/wordml\"><w:highlight w:val=\"darkCyan\"/><w:b/><w:color w:val=\"#FF0000\"/></w:rPr><w:t xml:space=\"preserve\">A </w:t></w:r>`{=openxml}",
66+
"`<w:r><w:rPr xmlns:w14=\"http://schemas.microsoft.com/office/word/2010/wordml\"><w:i/><w:color w:val=\"#0000FF\"/></w:rPr><w:t xml:space=\"preserve\">B </w:t></w:r>`{=openxml}",
67+
"`<w:r><w:rPr xmlns:w14=\"http://schemas.microsoft.com/office/word/2010/wordml\"><w:highlight w:val=\"yellow\"/><w:strike/><w:color w:val=\"#00FF00\"/></w:rPr><w:t xml:space=\"preserve\">C </w:t></w:r>`{=openxml}",
68+
"`<w:r><w:rPr xmlns:w14=\"http://schemas.microsoft.com/office/word/2010/wordml\"></w:rPr><w:t xml:space=\"preserve\">Long Character</w:t></w:r>`{=openxml}" )
69+
)
70+
})
71+
72+
test_that("vector printing to console - character", {
73+
styled_vect <-
74+
color_vctr(c(TRUE, FALSE, TRUE, TRUE),
75+
text_color = c("red", "blue", "green", NA),
76+
style = c("bold","italic","strikethrough",NA),
77+
background = c("teal",NA,"yellow",NA))
78+
79+
expect_equal(
80+
capture_print(styled_vect),
81+
c("`<w:r><w:rPr xmlns:w14=\"http://schemas.microsoft.com/office/word/2010/wordml\"><w:highlight w:val=\"darkCyan\"/><w:b/><w:color w:val=\"#FF0000\"/></w:rPr><w:t xml:space=\"preserve\"> TRUE</w:t></w:r>`{=openxml}",
82+
"`<w:r><w:rPr xmlns:w14=\"http://schemas.microsoft.com/office/word/2010/wordml\"><w:i/><w:color w:val=\"#0000FF\"/></w:rPr><w:t xml:space=\"preserve\">FALSE</w:t></w:r>`{=openxml}",
83+
"`<w:r><w:rPr xmlns:w14=\"http://schemas.microsoft.com/office/word/2010/wordml\"><w:highlight w:val=\"yellow\"/><w:strike/><w:color w:val=\"#00FF00\"/></w:rPr><w:t xml:space=\"preserve\"> TRUE</w:t></w:r>`{=openxml}",
84+
"`<w:r><w:rPr xmlns:w14=\"http://schemas.microsoft.com/office/word/2010/wordml\"></w:rPr><w:t xml:space=\"preserve\"> TRUE</w:t></w:r>`{=openxml}")
85+
)
86+
})
87+
88+
test_that("vector printing to console - dates", {
89+
styled_vect <-
90+
color_vctr(as.Date(c("1970-01-01","1970-01-02","1970-01-03","1970-01-04")),
91+
text_color = c("red", "blue", "green", NA),
92+
style = c("bold","italic","strikethrough",NA),
93+
background = c("teal",NA,"yellow",NA))
94+
95+
expect_equal(
96+
capture_print(styled_vect),
97+
c("`<w:r><w:rPr xmlns:w14=\"http://schemas.microsoft.com/office/word/2010/wordml\"><w:highlight w:val=\"darkCyan\"/><w:b/><w:color w:val=\"#FF0000\"/></w:rPr><w:t xml:space=\"preserve\">1970-01-01</w:t></w:r>`{=openxml}",
98+
"`<w:r><w:rPr xmlns:w14=\"http://schemas.microsoft.com/office/word/2010/wordml\"><w:i/><w:color w:val=\"#0000FF\"/></w:rPr><w:t xml:space=\"preserve\">1970-01-02</w:t></w:r>`{=openxml}",
99+
"`<w:r><w:rPr xmlns:w14=\"http://schemas.microsoft.com/office/word/2010/wordml\"><w:highlight w:val=\"yellow\"/><w:strike/><w:color w:val=\"#00FF00\"/></w:rPr><w:t xml:space=\"preserve\">1970-01-03</w:t></w:r>`{=openxml}",
100+
"`<w:r><w:rPr xmlns:w14=\"http://schemas.microsoft.com/office/word/2010/wordml\"></w:rPr><w:t xml:space=\"preserve\">1970-01-04</w:t></w:r>`{=openxml}")
101+
)
102+
103+
})
104+
105+

0 commit comments

Comments
 (0)