[wb_comment] modify the background color. closes #869 (#870)

* [wb_comment] modify the background color * return only one next_relship entry * [add_image] move add_media() to own function * [comment] allow background images * [comments] extend lists to the needed range * update roxygen * [add_media] move to private * [tests] add basic test * update NEWS
JanMarvin · Dec 12, 2023 · 86a167f · 86a167f
1 parent f77f351
commit 86a167f
Show file tree

Hide file tree

Showing 10 changed files with 194 additions and 44 deletions.
diff --git a/NEWS.md b/NEWS.md
@@ -1,5 +1,9 @@
 # openxlsx2 (development version)
 
+## New features
+
+* Allow further modifications of comments. The background can now be filled with a color or an image. [870](https://github.com/JanMarvin/openxlsx2/pull/870)
+
 ## Fixes
 
 * `wb_add_ignore_error()` now returns a `wbWorkbook`

diff --git a/R/baseXML.R b/R/baseXML.R
@@ -13,23 +13,28 @@ genBaseContent_Type <- function() {
   )
 }
 
-genBaseShapeVML <- function(clientData, id) {
+genBaseShapeVML <- function(clientData, id, fillcolor, rID) {
   if (grepl("visible", clientData, ignore.case = TRUE)) {
     visible <- "visible"
   } else {
     visible <- "hidden"
   }
 
+  if (is.null(rID))
+    fill <- '<v:fill color2="#ffffe1"/>'
+  else
+    fill <- sprintf('<v:fill type="frame" on="t" color2="#FFFFFF" focussize="0,0" recolor="t" o:relid="%s"/>', rID)
+
   paste0(
     sprintf('<v:shape id="_x0000_s%s" type="#_x0000_t202" style=\'position:absolute;', id),
     sprintf('margin-left:107.25pt;margin-top:172.5pt;width:147pt;height:96pt;z-index:1;
-          visibility:%s;mso-wrap-style:tight\' fillcolor="#ffffe1" o:insetmode="auto">', visible),
-    '<v:fill color2="#ffffe1"/>
-            <v:shadow color="black" obscured="t"/>
-            <v:path o:connecttype="none"/>
-            <v:textbox style=\'mso-direction-alt:auto\'>
-            <div style=\'text-align:left\'/>
-            </v:textbox>', clientData, "</v:shape>"
+          visibility:%s;mso-wrap-style:tight\' fillcolor="%s" o:insetmode="auto">', visible, fillcolor),
+    fill,
+    '<v:shadow color="black" obscured="t"/>
+    <v:path o:connecttype="none"/>
+    <v:textbox style=\'mso-direction-alt:auto\'>
+    <div style=\'text-align:left\'/>
+    </v:textbox>', clientData, "</v:shape>"
   )
 }
 

diff --git a/R/class-comment.R b/R/class-comment.R
@@ -198,6 +198,8 @@ NULL
 #' @inheritParams wb_add_comment
 #' @param comment An object created by [create_comment()]
 #' @param row,col Row and column of the cell
+#' @param color optional background color
+#' @param file optional background image (file extension must be png or jpeg)
 #' @keywords internal
 #' @export
 #' @inherit wb_add_comment examples
@@ -207,7 +209,9 @@ write_comment <- function(
     col     = NULL,
     row     = NULL,
     comment,
-    dims    = rowcol_to_dim(row, col)
+    dims    = rowcol_to_dim(row, col),
+    color   = NULL,
+    file    = NULL
   ) {
 
   # TODO add as method: wbWorkbook$addComment(); add param for replace?
@@ -264,9 +268,36 @@ write_comment <- function(
 
   id <- 1025 + sum(lengths(wb$comments))
 
+  fillcolor <- color %||% "#ffffe1"
+  # looks like vml accepts only "#RGB" and not "ARGB"
+  if (is_wbColour(fillcolor)) {
+    if (names(fillcolor) != "rgb") {
+      # actually there are more colors like: "lime [11]" and
+      # "infoBackground [80]" (the default). But no clue how
+      # these are created.
+      stop("fillcolor needs to be an RGB color")
+    }
+
+    fillcolor <- paste0("#", substr(fillcolor, 3, 8))
+  }
+
+  rID <- NULL
+  if (!is.null(file)) {
+    wb$.__enclos_env__$private$add_media(file = file)
+    file <- names(wb$media)[length(wb$media)]
+    rID <- paste0("rId", length(wb$vml_rels) + 1L)
+
+    vml_relship <- sprintf(
+      '<Relationship Id="%s" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/image" Target="../media/%s"/>',
+      rID,
+      file
+    )
+  }
+
+
   # create new commment vml
   cd <- unapply(comment_list, "[[", "clientData")
-  vml_xml <- read_xml(genBaseShapeVML(cd, id), pointer = FALSE)
+  vml_xml <- read_xml(genBaseShapeVML(cd, id, fillcolor, rID), pointer = FALSE)
   vml_comment <- '<o:shapelayout v:ext="edit"><o:idmap v:ext="edit" data="1"/></o:shapelayout><v:shapetype id="_x0000_t202" coordsize="21600,21600" o:spt="202" path="m,l,21600r21600,l21600,xe"><v:stroke joinstyle="miter"/><v:path gradientshapeok="t" o:connecttype="rect"/></v:shapetype>'
   vml_xml <- paste0(vml_xml, vml_comment)
 
@@ -310,17 +341,38 @@ write_comment <- function(
         ),
         xml_children = vml_xml
       )
+      if (length(wb$vml) == 0) {
+        wb$vml <- list()
+      }
       wb$vml <- c(wb$vml, vml_xml)
 
       wb$worksheets[[sheet]]$relships$vmlDrawing <- next_id
-
+      if (!is.null(rID)) {
+        if (length(wb$vml_rels) == 0) {
+          wb$vml_rels <- list()
+        }
+        if (length(wb$vml_rels) < next_id) {
+          wb$vml_rels <- wb$vml_rels[seq_len(next_id)]
+        }
+
+        wb$vml_rels[[next_id]] <- append(
+          wb$vml_rels[[next_id]],
+          vml_relship
+        )
+      }
       # TODO hardcoded 2. Marvin fears that this is not good enough
       wb$worksheets[[sheet]]$legacyDrawing <- sprintf('<legacyDrawing r:id="rId%s"/>', next_rid)
 
       next_rid <- next_rid + 1
     } else {
       vml_id <- wb$worksheets[[sheet]]$relships$vmlDrawing
       wb$vml[[vml_id]] <- xml_add_child(wb$vml[[vml_id]], vml_xml)
+      if (!is.null(rID)) {
+        wb$vml_rels[[vml_id]] <- append(
+          wb$vml_rels[[vml_id]],
+          vml_relship
+        )
+      }
     }
 
     wb$worksheets_rels[[sheet]] <- c(
@@ -334,6 +386,12 @@ write_comment <- function(
   } else {
     vml_id <- wb$worksheets[[sheet]]$relships$vmlDrawing
     wb$vml[[vml_id]] <- xml_add_child(wb$vml[[vml_id]], vml_xml)
+      if (!is.null(rID)) {
+        wb$vml_rels[[vml_id]] <- append(
+          wb$vml_rels[[vml_id]],
+          vml_relship
+        )
+      }
   }
 
   cmmnt_id <- wb$worksheets[[sheet]]$relships$comments

diff --git a/R/class-workbook-wrappers.R b/R/class-workbook-wrappers.R
@@ -3162,7 +3162,7 @@ wb_add_dxfs_style <- function(
 #' Add comment to worksheet
 #'
 #' @details
-#' If applying a `comment` with a string, it will use [wb_comment()] default values.
+#' If applying a `comment` with a string, it will use [wb_comment()] default values. If additional background colors are applied, RGB colors should be provided, either as hex code or with builtin R colors. The alpha chanel is ignored.
 #'
 #' @param wb A workbook object
 #' @param sheet A worksheet of the workbook

diff --git a/R/class-workbook.R b/R/class-workbook.R
@@ -4133,8 +4133,10 @@ wbWorkbook <- R6::R6Class(
         ...
     ) {
 
-      col <- list(...)[["col"]]
-      row <- list(...)[["row"]]
+      col   <- list(...)[["col"]]
+      row   <- list(...)[["row"]]
+      color <- list(...)[["color"]] %||% list(...)[["colour"]]
+      file  <- list(...)[["file"]]
 
       if (!is.null(row) && !is.null(col)) {
         .Deprecated(old = "col/row", new = "dims", package = "openxlsx2")
@@ -4145,11 +4147,16 @@ wbWorkbook <- R6::R6Class(
         comment <- wb_comment(text = comment, author = getOption("openxlsx2.creator"))
       }
 
+      if (!is.null(color) && !is_wbColour(color))
+        stop("color needs to be a wb_color()")
+
       write_comment(
         wb      = self,
         sheet   = sheet,
         comment = comment,
-        dims    = dims
+        dims    = dims,
+        color   = color,
+        file    = file
       ) # has no use: xy
 
       invisible(self)
@@ -4723,23 +4730,8 @@ wbWorkbook <- R6::R6Class(
 
       sheet <- private$get_sheet_index(sheet)
 
-      # TODO tools::file_ext() ...
-      imageType <- regmatches(file, gregexpr("\\.[a-zA-Z]*$", file))
-      imageType <- gsub("^\\.", "", imageType)
-      mediaNo <- length(self$media) + 1L
-
-      ## update Content_Types
-      if (!any(grepl(stri_join("image/", imageType), self$Content_Types))) {
-        self$Content_Types <-
-          unique(c(
-            sprintf(
-              '<Default Extension="%s" ContentType="image/%s"/>',
-              imageType,
-              imageType
-            ),
-            self$Content_Types
-          ))
-      }
+      private$add_media(file)
+      file <- names(self$media)[length(self$media)]
 
       if (length(self$worksheets[[sheet]]$relships$drawing)) {
         sheet_drawing <- self$worksheets[[sheet]]$relships$drawing
@@ -4757,11 +4749,6 @@ wbWorkbook <- R6::R6Class(
         next_id <- "rId1"
       }
 
-      ## write file path to media slot to copy across on save
-      tmp <- file
-      names(tmp) <- stri_join("image", mediaNo, ".", imageType)
-      self$append("media", tmp)
-
       pos <- '<xdr:pos x="0" y="0" />'
 
       drawingsXML <- stri_join(
@@ -4802,10 +4789,9 @@ wbWorkbook <- R6::R6Class(
       self$drawings_rels[[sheet_drawing]] <- c(
         old_drawings_rels,
         sprintf(
-          '<Relationship Id="%s" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/image" Target="../media/image%s.%s"/>',
+          '<Relationship Id="%s" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/image" Target="../media/%s"/>',
           next_id,
-          mediaNo,
-          imageType
+          file
         )
       )
 
@@ -5059,7 +5045,7 @@ wbWorkbook <- R6::R6Class(
       } else {
         relship <- rbindlist(xml_attr(self$worksheets_rels[[sheet]], "Relationship"))
         relship$typ <- basename(relship$Type)
-        next_relship <- as.integer(gsub("\\D+", "", relship$Id)) + 1L
+        next_relship <- max(as.integer(gsub("\\D+", "", relship$Id))) + 1L
         has_no_drawing <- !any(relship$typ == "drawing")
       }
 
@@ -7710,6 +7696,36 @@ wbWorkbook <- R6::R6Class(
       invisible(self)
     },
 
+    add_media = function(
+      file
+    ) {
+
+      # TODO tools::file_ext() ...
+      imageType <- regmatches(file, gregexpr("\\.[a-zA-Z]*$", file))
+      imageType <- gsub("^\\.", "", imageType)
+      mediaNo <- length(self$media) + 1L
+
+      ## update Content_Types
+      if (!any(grepl(stri_join("image/", imageType), self$Content_Types))) {
+        self$Content_Types <-
+          unique(c(
+            sprintf(
+              '<Default Extension="%s" ContentType="image/%s"/>',
+              imageType,
+              imageType
+            ),
+            self$Content_Types
+          ))
+      }
+
+      ## write file path to media slot to copy across on save
+      tmp <- file
+      names(tmp) <- stri_join("image", mediaNo, ".", imageType)
+      self$append("media", tmp)
+
+      invisible(self)
+    },
+
     get_drawingsref = function() {
       has_drawing <- which(grepl("drawings", self$worksheets_rels))
 
@@ -7751,7 +7767,7 @@ wbWorkbook <- R6::R6Class(
               fl = file.path(dir, sprintf("vmlDrawing%s.vml", i))
           )
 
-          if (!is.null(unlist(self$vml_rels)) && length(self$vml_rels) >= i && self$vml_rels[[i]] != "") {
+          if (!is.null(unlist(self$vml_rels)) && length(self$vml_rels) >= i && !all(self$vml_rels[[i]] == "")) {
             write_file(
               head = '<Relationships xmlns="http://schemas.openxmlformats.org/package/2006/relationships">',
               body = pxml(self$vml_rels[[i]]),

diff --git a/man/comment_internal.Rd b/man/comment_internal.Rd
diff --git a/man/wb_add_comment.Rd b/man/wb_add_comment.Rd
diff --git a/man/wb_add_pivot_table.Rd b/man/wb_add_pivot_table.Rd
diff --git a/tests/testthat/test-class-comment.R b/tests/testthat/test-class-comment.R
@@ -296,3 +296,43 @@ test_that("thread option works", {
   expect_equal(exp, got)
 
 })
+
+test_that("background images work", {
+
+  wb <- wb_workbook()
+  wb$add_worksheet("Sheet 1")
+
+  # file extension must be png or jpeg, not jpg?
+  tmp <- tempfile(fileext = ".png")
+  png(file = tmp, bg = "transparent")
+  plot(1:10)
+  rect(1, 5, 3, 7, col = "white")
+  dev.off()
+
+  # write comment without author
+  c1 <- wb_comment(text = "this is a comment", author = "", visible = TRUE)
+  wb$add_comment(dims = "B12", comment = c1, file = tmp)
+
+  wb$add_worksheet()
+  wb$add_comment(dims = "B12", comment = c1)
+
+  wb$add_worksheet()
+
+  # file extension must be png or jpeg, not jpg?
+  tmp2 <- tempfile(fileext = ".png")
+  png(file = tmp2, bg = "transparent")
+  barplot(1:10)
+  dev.off()
+
+  # write comment without author
+  c1 <- wb_comment(text = "this is a comment", author = "", visible = TRUE)
+  wb$add_comment(dims = "G12", comment = c1, file = tmp2)
+  wb$add_comment(dims = "G12", sheet = 1, comment = c1, file = tmp2)
+
+  expect_equal(3, length(wb$vml))
+  expect_equal(3, length(wb$vml_rels))
+  expect_equal(2, length(wb$vml_rels[[1]]))
+  expect_true(is.null(wb$vml_rels[[2]]))
+  expect_equal(1, length(wb$vml_rels[[3]]))
+
+})