diff --git a/NEWS.md b/NEWS.md
index 21c24af..ee2eb9f 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -1,5 +1,8 @@
# colortable (development version)
+### Features
+ - Initial implementation of word (docx) printing
+
# colortable 0.2.1
### Features
diff --git a/R/color_utils.R b/R/color_utils.R
index 43537a0..b9e2dfc 100644
--- a/R/color_utils.R
+++ b/R/color_utils.R
@@ -36,10 +36,17 @@ unify_colors <- function(x, type = print_method()) {
grepl("^#[0-9A-Fa-f]{6}$", x, perl = TRUE)) {
return(toupper(x))
} else {
- type <- match.arg(type, c("latex", "html", "console"))
- method_colors <- valid_colors(type)$`Color Name`
- if (!x %in% method_colors) {
+ if(!is.null(type)){
+ type <- match.arg(type, c("latex", "html", "console"))
+ method_colors <- valid_colors(type)$`Color Name`
+ in_method_colors <-x %in% method_colors
+ }else{
+ in_method_colors = FALSE
+ }
+
+
+ if (!in_method_colors) {
other_colors <- valid_colors(setdiff(c("latex", "html", "console"), type))
idx <- which(other_colors$`Color Name` %in% x)
if (length(idx) > 0) {
diff --git a/R/print_color_vctr.R b/R/print_color_vctr.R
index 8045b97..c7c8356 100644
--- a/R/print_color_vctr.R
+++ b/R/print_color_vctr.R
@@ -25,6 +25,7 @@ format.color_vctr <- function(x, ..., method = print_method()){
"latex" = format.color_vctr.latex,
"html" = format.color_vctr.html,
"gfm" = format.color_vctr.html,
+ "docx" = format.color_vctr.docx,
stop("Method for ", print_method()," not implemented yet.")
)
@@ -69,6 +70,17 @@ format.color_vctr.latex <- function(x,...){
x
}
+format.color_vctr.docx <- function(x,...){
+ x <-
+ style2docxV(
+ format_preserve_na(field(x, "vctr"), ...),
+ field(x, ".style"),
+ field(x, ".text_color"),
+ field(x, ".background")
+ )
+ names(x) <- NULL
+ x
+}
add_colortable_latex_meta <- function(){
meta <- knitr::knit_meta(clean = FALSE)
diff --git a/R/style2.R b/R/style2.R
index 1cc47a7..32234f9 100644
--- a/R/style2.R
+++ b/R/style2.R
@@ -71,3 +71,18 @@ style2tex <- function(x, style = NA, text_color = NA, background = NA, ...){
}
style2texV <- Vectorize(style2tex,vectorize.args = c("x","style","text_color","background"),SIMPLIFY = TRUE)
+
+style2docx <- function(x, style = NA, text_color = NA, background = NA, ...){
+ if (is.na(x)) {
+ return(NA)
+ }else{
+ text_style <- style_wrapper_docx(style, type = "style")
+ text_color <- style_wrapper_docx(text_color, type = "text")
+ text_background <- style_wrapper_docx(background, type = "background")
+
+ style_zipper_docx(x, paste0(text_background,text_style,text_color))
+ }
+}
+
+style2docxV <- Vectorize(style2docx,vectorize.args = c("x","style","text_color","background"),SIMPLIFY = TRUE)
+
diff --git a/R/style_docx.R b/R/style_docx.R
new file mode 100644
index 0000000..c4edf55
--- /dev/null
+++ b/R/style_docx.R
@@ -0,0 +1,114 @@
+#' @importFrom rmarkdown latex_dependency
+style_wrapper_docx <-
+ function(styling,
+ type = c("text", "style", "background")) {
+ if (is.na(styling)) {
+ ""
+ } else{
+ type <- match.arg(type)
+ styling <- tolower(styling)
+ switch(
+ type,
+ "style" = docx_decoration_styling(styling),
+ "text" = docx_text_styling(unify_colors(styling,type = NULL)),
+ "background" = docx_background_styling(styling)
+ )
+ }
+ }
+
+style_zipper_docx <- function(x,styling){
+ paste0("`", styling, "",x,"`{=openxml}")
+}
+
+docx_decoration_styling <- function(styling){
+ if (!styling %in% names(docx_style_codes)) {
+ ""
+ }else{
+ codes <- docx_style_codes[[styling]]
+ paste0("")
+ }
+}
+
+docx_style_codes <- list(
+ bold = list(code = "b"),
+ italic = list(code = "i"),
+ underline = list(code = "u"),
+ strikethrough = list(code = "strike")
+)
+
+docx_text_styling <- function(color){
+ code <- try(as_hex_codes(color), silent = TRUE)
+ if (inherits(code, "try-error")) {
+ ""
+ } else{
+ paste0("")
+ }
+}
+
+docx_background_styling <- function(color){
+ code <- try(as_docx_highlighter(color), silent = TRUE)
+ if(inherits(code, "try-error")){
+ ""
+ }else{
+ paste0("")
+ }
+}
+
+#' @importFrom grDevices col2rgb
+as_hex_codes <- function(x) {
+ if (grepl("^(#)", x) |
+ grepl("^(#)*[0-9A-Fa-f]{6}$", x, perl = TRUE)) {
+ return(toupper(x))
+ } else {
+ colors <- valid_colors()
+ method_colors <- colors$`Color Name`
+ if (x %in% method_colors) {
+ idx <- which(colors$`Color Name` %in% x)
+ if (length(idx) > 0) {
+ return(colors$`Hex Code`[min(idx)])
+ }
+ } else {
+ stop(
+ paste(
+ "Invalid Color Name being used. check for valid color names using `valid_colors()`"
+ )
+ )
+ }
+ }
+}
+
+
+as_docx_highlighter <- function(color){
+ if(color %in% color_key_docx_highlighter$Name){
+ idx <- which(color_key_docx_highlighter$Name == color)
+ }else{
+ rgb_mat <- col2rgb(as_hex_codes(color))[,1, drop = TRUE]
+ rgb_key <- do.call('rbind',color_key_docx_highlighter$RGB)
+ idx <- which_closest_color(rgb_mat, rgb_key)
+ }
+ c(color_key_docx_highlighter[idx,"code", drop = TRUE])
+}
+
+
+color_key_docx_highlighter <- tibble::tribble(
+ ~Name, ~hex, ~code, ~RGB,
+ "yellow","#ffff00","yellow",c(red = 255, blue = 0, green = 255),
+ "lightgreen","#00ff00","green",c(red = 0, blue = 0, green = 255),
+ "cyan","#00ffff","cyan",c(red = 0, blue = 255, green = 255),
+ "pink","#ff00ff","magenta",c(red = 255, blue = 255, green = 0),
+ "blue","#0000ff","blue",c(red = 0, blue = 255, green = 0),
+ "red","#ff0000","red",c(red = 255, blue = 0, green = 0),
+ "darkblue","#000080","darkBlue",c(red = 0, blue = 128, green = 0),
+ "teal","#008080","darkCyan",c(red = 0, blue = 128, green = 128),
+ "green","#008000","darkGreen",c(red = 0, blue = 0, green = 128),
+ "violet","#800080","darkMagenta",c(red = 128, blue = 128, green = 0),
+ "darkred","#800000","darkRed",c(red = 128, blue = 0, green = 0),
+ "darkyellow","#808000","darkYellow",c(red = 128, blue = 0, green = 128),
+ "darkgray","#808080","darkGray",c(red = 128, blue = 128, green = 128),
+ "lightgray","#c0c0c0","lightGray",c(red = 192, blue = 192, green = 192),
+ "black","#000000","black",c(red = 0, blue = 0, green = 0)
+)
+
+
+
+
diff --git a/tests/testthat/test-print_docx.R b/tests/testthat/test-print_docx.R
new file mode 100644
index 0000000..94098a0
--- /dev/null
+++ b/tests/testthat/test-print_docx.R
@@ -0,0 +1,105 @@
+capture_print <- function(x){
+ capture.output(print(x,console_width = 80, method = "docx"))
+}
+
+test_that("vector printing to console - numeric", {
+ styled_vect <-
+ color_vctr(c(1, 2, 0.05, 20),
+ text_color = c("red", "blue", "green", NA),
+ style = c("bold","italic","strikethrough",NA),
+ background = c("teal",NA,"yellow",NA))
+
+ expect_equal(
+ capture_print(styled_vect),
+ c("` 1.00`{=openxml}",
+ "` 2.00`{=openxml}",
+ "` 0.05`{=openxml}",
+ "`20.00`{=openxml}" )
+ )
+
+})
+
+test_that("vector printing to console - integer", {
+ styled_vect <-
+ color_vctr(as.integer(c(1, 2, 3, 20)),
+ text_color = c("red", "blue", "green", NA),
+ style = c("bold","italic","strikethrough",NA),
+ background = c("teal",NA,"yellow",NA))
+
+ expect_equal(
+ capture_print(styled_vect),
+ c("` 1`{=openxml}",
+ "` 2`{=openxml}",
+ "` 3`{=openxml}",
+ "`20`{=openxml}")
+ )
+})
+
+test_that("vector printing to console - character", {
+ styled_vect <-
+ color_vctr(c("A", "B", "C", "Long Character"),
+ text_color = c("red", "blue", "green", NA),
+ style = c("bold","italic","strikethrough",NA),
+ background = c("teal",NA,"yellow",NA))
+
+
+ expect_equal(
+ capture_print(styled_vect),
+ c("`A `{=openxml}",
+ "`B `{=openxml}",
+ "`C `{=openxml}",
+ "`Long Character`{=openxml}")
+ )
+
+})
+
+test_that("vector printing to console - factor", {
+ styled_vect <-
+ color_vctr(factor(c("A", "B", "C", "Long Character")),
+ text_color = c("red", "blue", "green", NA),
+ style = c("bold","italic","strikethrough",NA),
+ background = c("teal",NA,"yellow",NA))
+
+ expect_equal(
+ capture_print(styled_vect),
+ c("`A `{=openxml}",
+ "`B `{=openxml}",
+ "`C `{=openxml}",
+ "`Long Character`{=openxml}" )
+ )
+})
+
+test_that("vector printing to console - character", {
+ styled_vect <-
+ color_vctr(c(TRUE, FALSE, TRUE, TRUE),
+ text_color = c("red", "blue", "green", NA),
+ style = c("bold","italic","strikethrough",NA),
+ background = c("teal",NA,"yellow",NA))
+
+ expect_equal(
+ capture_print(styled_vect),
+ c("` TRUE`{=openxml}",
+ "`FALSE`{=openxml}",
+ "` TRUE`{=openxml}",
+ "` TRUE`{=openxml}")
+ )
+})
+
+test_that("vector printing to console - dates", {
+ styled_vect <-
+ color_vctr(as.Date(c("1970-01-01","1970-01-02","1970-01-03","1970-01-04")),
+ text_color = c("red", "blue", "green", NA),
+ style = c("bold","italic","strikethrough",NA),
+ background = c("teal",NA,"yellow",NA))
+
+ expect_equal(
+ capture_print(styled_vect),
+ c("`1970-01-01`{=openxml}",
+ "`1970-01-02`{=openxml}",
+ "`1970-01-03`{=openxml}",
+ "`1970-01-04`{=openxml}")
+ )
+
+})
+
+