- ', clientData, ""
+ visibility:%s;mso-wrap-style:tight\' fillcolor="%s" o:insetmode="auto">', visible, fillcolor),
+ fill,
+ '
+
+ ', clientData, ""
)
}
diff --git a/R/class-comment.R b/R/class-comment.R
index 5035a2565..6b369382c 100644
--- 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(
+ '',
+ 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 <- ''
vml_xml <- paste0(vml_xml, vml_comment)
@@ -310,10 +341,25 @@ 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('', next_rid)
@@ -321,6 +367,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
+ )
+ }
}
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
index 7d0324e9f..a1e2bd12c 100644
--- 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
index 788af6f04..c14e4f040 100644
--- 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(
- '',
- 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 <- ''
drawingsXML <- stri_join(
@@ -4802,10 +4789,9 @@ wbWorkbook <- R6::R6Class(
self$drawings_rels[[sheet_drawing]] <- c(
old_drawings_rels,
sprintf(
- '',
+ '',
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(
+ '',
+ 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 = '',
body = pxml(self$vml_rels[[i]]),
diff --git a/man/comment_internal.Rd b/man/comment_internal.Rd
index 8c6963d86..6319049a8 100644
--- a/man/comment_internal.Rd
+++ b/man/comment_internal.Rd
@@ -12,7 +12,9 @@ write_comment(
col = NULL,
row = NULL,
comment,
- dims = rowcol_to_dim(row, col)
+ dims = rowcol_to_dim(row, col),
+ color = NULL,
+ file = NULL
)
remove_comment(
@@ -35,6 +37,10 @@ remove_comment(
\item{dims}{Optional row and column as spreadsheet dimension, e.g. "A1"}
+\item{color}{optional background color}
+
+\item{file}{optional background image (file extension must be png or jpeg)}
+
\item{gridExpand}{If \code{TRUE}, all data in rectangle min(rows):max(rows) X min(cols):max(cols)
will be removed.}
}
diff --git a/man/wb_add_comment.Rd b/man/wb_add_comment.Rd
index 73333dd00..21e68d706 100644
--- a/man/wb_add_comment.Rd
+++ b/man/wb_add_comment.Rd
@@ -27,7 +27,7 @@ The Workbook object, invisibly.
Add comment to worksheet
}
\details{
-If applying a \code{comment} with a string, it will use \code{\link[=wb_comment]{wb_comment()}} default values.
+If applying a \code{comment} with a string, it will use \code{\link[=wb_comment]{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.
}
\examples{
wb <- wb_workbook()
diff --git a/man/wb_add_pivot_table.Rd b/man/wb_add_pivot_table.Rd
index 09034599a..7a09d8394 100644
--- a/man/wb_add_pivot_table.Rd
+++ b/man/wb_add_pivot_table.Rd
@@ -56,6 +56,9 @@ to ensure the function works.
\code{runTotal}, \code{percentOfRow}, \code{percentOfCol}, \code{percentOfTotal}, \code{index}.
The sheet will be empty unless it is opened in spreadsheet software.
+
+Find more details in the \href{https://janmarvin.github.io/ox2-book/chapters/openxlsx2_pivot_tables.html}{section about pivot tables}
+in the openxlsx2 book.
}
\examples{
wb <- wb_workbook() \%>\% wb_add_worksheet() \%>\% wb_add_data(x = mtcars)
diff --git a/tests/testthat/test-class-comment.R b/tests/testthat/test-class-comment.R
index 74266a10b..a665b20e1 100644
--- 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]]))
+
+})
diff --git a/tests/testthat/test-class-workbook.R b/tests/testthat/test-class-workbook.R
index 7e58e2cc5..f408cbdcc 100644
--- a/tests/testthat/test-class-workbook.R
+++ b/tests/testthat/test-class-workbook.R
@@ -736,6 +736,24 @@ test_that("various image functions work as expected", {
})
+test_that("image relships work with comment", {
+
+ wb <- wb_workbook()
+ wb$add_worksheet("Sheet 1")
+
+ c1 <- wb_comment(text = "this is a comment", author = "", visible = TRUE)
+ wb$add_comment(dims = "B12", comment = c1)
+
+ img <- system.file("extdata", "einstein.jpg", package = "openxlsx2")
+
+ wb$add_image("Sheet 1", dims = "C5", file = img, width = 6, height = 5)
+
+ exp <- ""
+ got <- wb$worksheets[[1]]$drawing
+ expect_equal(exp, got)
+
+})
+
test_that("workbook themes work", {
wb <- wb_workbook()$add_worksheet()