[wbWorkbook] Themes

R/class-workbook-wrappers.R

@@ -8,11 +8,19 @@
 #' @param subject Workbook properties subject
 #' @param category Workbook properties category
 #' @param datetimeCreated The time of the workbook is created
+#' @param theme Optional theme identified by string or number
 #' @return A [wbWorkbook] object
 #'
 #' @export
 #' @family workbook wrappers
 #'
+#' @details
+#' "Atlas", "Badge", "Berlin", "Celestial", "Crop", "Depth", "Droplet",
+#' "Facet", "Feathered", "Gallery", "Headlines", "Integral", "Ion",
+#' "Ion Boardroom", "Madison", "Main Event", "Mesh", "Office Theme",
+#' "Old Office Theme", "Organic", "Parallax", "Parcel", "Retrospect",
+#' "Savon", "Slice", "Vapor Trail", "View", "Wisp", "Wood Type"
+#'
 #' @examples
 #' ## Create a new workbook
 #' wb <- wb_workbook()
@@ -29,14 +37,16 @@ wb_workbook <- function(
   title           = NULL,
   subject         = NULL,
   category        = NULL,
-  datetimeCreated = Sys.time()
+  datetimeCreated = Sys.time(),
+  theme           = NULL
 ) {
   wbWorkbook$new(
     creator         = creator,
     title           = title,
     subject         = subject,
     category        = category,
-    datetimeCreated = datetimeCreated
+    datetimeCreated = datetimeCreated,
+    theme           = theme
   )
 }
 

R/class-workbook.R

@@ -177,13 +177,15 @@ wbWorkbook <- R6::R6Class(
     #' @param datetimeCreated The datetime (as `POSIXt`) the workbook is
     #'   created.  Defaults to the current `Sys.time()` when the workbook object
     #'   is created, not when the Excel files are saved.
+    #' @param theme Optional theme identified by string or number
     #' @return a `wbWorkbook` object
     initialize = function(
       creator         = NULL,
       title           = NULL,
       subject         = NULL,
       category        = NULL,
-      datetimeCreated = Sys.time()
+      datetimeCreated = Sys.time(),
+      theme           = NULL
     ) {
       self$app <- genBaseApp()
       self$charts <- list()
@@ -239,8 +241,40 @@ wbWorkbook <- R6::R6Class(
 
       self$tables <- NULL
       self$tables.xml.rels <- NULL
-      self$theme <- NULL
+      if (is.null(theme)) {
+        self$theme <- NULL
+      } else {
+        # read predefined themes
+        thm_rds <- system.file("extdata", "themes.rds", package = "openxlsx2")
+        themes <- readRDS(thm_rds)
 
+        if (is.character(theme)) {
+          sel <- match(theme, names(themes))
+          err <- is.na(sel)
+        } else {
+          sel <- theme
+          err <- sel > length(themes)
+        }
+
+        if (err) {
+          message("theme ", theme, " not found falling back to default theme")
+        } else {
+          self$theme <- stringi::stri_unescape_unicode(themes[[sel]])
+
+          # create the default font for the style
+          font_scheme <- xml_node(self$theme, "a:theme", "a:themeElements", "a:fontScheme")
+          minor_font <- xml_attr(font_scheme, "a:fontScheme", "a:minorFont", "a:latin")[[1]][["typeface"]]
+
+          self$styles_mgr$styles$fonts <- create_font(
+            sz = 11,
+            color = wb_color(theme = 1),
+            name = minor_font,
+            family = "2",
+            scheme = "minor"
+          )
+
+        }
+      }
 
       self$vbaProject <- NULL
       self$vml <- NULL

inst/extdata/themes.R

@@ -0,0 +1,32 @@
+# convert themes from xlsx files to rds file
+
+library(openxlsx2)
+
+# local clone from https://github.com/JanMarvin/openxlsx-data
+fls <- c(
+  dir("../openxlsx-data/styles", full.names = TRUE, pattern = ".xlsx"),
+ "../openxlsx-data/loadExample.xlsx"
+)
+
+themes <- vector("list", length = length(fls))
+nms    <- vector("character", length = length(fls))
+
+for (i in seq_along(fls)) {
+
+  wb <- wb_load(fls[i])
+
+  xml_theme <- wb$theme
+  xml_name <- xml_attr(xml_theme, "a:theme")[[1]][["name"]]
+  message(xml_name, " ", fls[i])
+
+  themes[[i]] <- stringi::stri_escape_unicode(xml_theme)
+  nms[[i]] <- xml_name
+}
+nms[length(nms)] <- "Old Office Theme"
+names(themes) <- nms
+
+themes <- themes[order(names(themes))]
+
+names(themes) %>% dput()
+
+saveRDS(themes, "inst/extdata/themes.rds")

tests/testthat/test-class-workbook.R

@@ -711,3 +711,30 @@ test_that("various image functions work as expected", {
   )
 
 })
+
+test_that("workbook themes work", {
+
+  wb <- wb_workbook()$add_worksheet()
+  exp <- "Calibri"
+  got <- wb$get_base_font()$name$val
+  expect_equal(exp, got)
+
+  wb <- wb_workbook(theme = "Old Office Theme")$add_worksheet()
+  exp <- "Calibri"
+  got <- wb$get_base_font()$name$val
+  expect_equal(exp, got)
+
+  wb <- wb_workbook(theme = 1)$add_worksheet()
+  exp <- "Rockwell"
+  got <- wb$get_base_font()$name$val
+  expect_equal(exp, got)
+
+  expect_message(
+    wb <- wb_workbook(theme = "Foo")$add_worksheet(),
+    "theme Foo not found falling back to default theme"
+  )
+  exp <- "Calibri"
+  got <- wb$get_base_font()$name$val
+  expect_equal(exp, got)
+
+})