Feature/word outputs

NEWS.md

@@ -1,5 +1,8 @@
 # colortable (development version)
 
+### Features
+  - Initial implementation of word (docx) printing
+
 # colortable 0.2.1
 
 ### Features

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) {

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)

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)
+

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("`<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}")
+}
+
+docx_decoration_styling <- function(styling){
+  if (!styling %in% names(docx_style_codes)) {
+    ""
+  }else{
+    codes <- docx_style_codes[[styling]]
+    paste0("<w:",codes$code,"/>")
+  }
+}
+
+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("<w:color w:val=\"",code,"\"/>")
+  }
+}
+
+docx_background_styling <- function(color){
+  code <- try(as_docx_highlighter(color), silent = TRUE)
+  if(inherits(code, "try-error")){
+    ""
+  }else{
+    paste0("<w:highlight w:val=\"",code,"\"/>")
+  }
+}
+
+#' @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)
+)
+
+
+
+

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("`<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}",
+      "`<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}",
+      "`<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}",
+      "`<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}"  )
+  )
+
+})
+
+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("`<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}",
+      "`<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}",
+      "`<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}",
+      "`<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}")
+  )
+})
+
+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("`<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}",
+      "`<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}",
+      "`<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}",
+      "`<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}")
+  )
+
+})
+
+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("`<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}",
+      "`<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}",
+      "`<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}",
+      "`<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}" )
+  )
+})
+
+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("`<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}",
+      "`<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}",
+      "`<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}",
+      "`<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}")
+  )
+})
+
+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("`<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}",
+      "`<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}",
+      "`<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}",
+      "`<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}")
+  )
+
+})
+
+