From cce0f7e8832c51814e31f2c41d38287255da37c8 Mon Sep 17 00:00:00 2001 From: Jan Marvin Garbuszus Date: Fri, 20 Sep 2024 19:36:25 +0200 Subject: [PATCH] [clone] fix cloning from worksheet with multiple images --- NEWS.md | 2 + R/class-workbook.R | 170 ++++++++++++++------------- tests/testthat/test-cloneWorksheet.R | 55 ++++++++- 3 files changed, 143 insertions(+), 84 deletions(-) diff --git a/NEWS.md b/NEWS.md index fb6a33cf0..f6068f440 100644 --- a/NEWS.md +++ b/NEWS.md @@ -18,6 +18,8 @@ * Fixed a regression in the previous release, where `wb_dims()` would pass column names passed via `cols` to `col2int()` which could cause overflow errors resulting in a failing check. [1133](https://github.com/JanMarvin/openxlsx2/pull/1133) +* Fix cloning from worksheets with multiple images. + ## Internal changes * The handling of shared hyperlinks has been updated. Previously, when loading a file with shared hyperlinks, they were converted into `wbHyperlink` objects (a legacy from `openxlsx`). With recent internal changes, hyperlinks are no longer automatically transformed into `wbHyperlink` objects. If you still require these objects, you can use the internal function `wb_to_hyperlink(wb, sheet = 1)`. However, please note that this class is not essential for `openxlsx2` and may be further simplified or removed in the future without notice. [1137](https://github.com/JanMarvin/openxlsx2/pull/1137) diff --git a/R/class-workbook.R b/R/class-workbook.R index f1273faa7..582e6ef26 100644 --- a/R/class-workbook.R +++ b/R/class-workbook.R @@ -892,67 +892,67 @@ wbWorkbook <- R6::R6Class( drawing_id <- from$worksheets[[old]]$relships$drawing new_drawing_sheet <- length(self$drawings) + 1L + new_drawing_rels <- length(self$drawings_rels) + 1L - self$append("drawings_rels", from$drawings_rels[[drawing_id]]) + # if drawings_rels is list(), appending will create multiple lists + self$append("drawings_rels", list(from$drawings_rels[[drawing_id]])) + # select the latest addition to drawings_rels + drawings_rels <- self$drawings_rels[[new_drawing_rels]] + + # For charts we have to modify the name of the chart in the xml code # give each chart its own filename (images can re-use the same file, but charts can't) - self$drawings_rels[[new_drawing_sheet]] <- - # TODO Can this be simplified? There's a bit going on here - vapply( - self$drawings_rels[[new_drawing_sheet]], - function(rl) { - # is rl here a length of 1? - stopifnot(length(rl) == 1L) # lets find out... if this fails, just remove it - chartfiles <- reg_match(rl, "(?<=charts/)chart[0-9]+\\.xml") - - for (cf in chartfiles) { - chartid <- NROW(self$charts) + 1L - newname <- stri_join("chart", chartid, ".xml") - old_chart <- as.integer(gsub("\\D+", "", cf)) - self$charts <- rbind(self$charts, from$charts[old_chart, ]) - - # Read the chartfile and adjust all formulas to point to the new - # sheet name instead of the clone source - - chart <- self$charts$chart[chartid] - self$charts$rels[chartid] <- gsub("?drawing[0-9]+.xml", paste0("drawing", chartid, ".xml"), self$charts$rels[chartid]) - - guard_ws <- function(x) { - if (grepl(" ", x)) x <- shQuote(x, type = "sh") - x - } + for (dl in seq_along(drawings_rels)) { + chartfiles <- reg_match(drawings_rels[dl], "(?<=charts/)chart[0-9]+\\.xml") + + for (cf in chartfiles) { + chartid <- NROW(self$charts) + 1L + newname <- stri_join("chart", chartid, ".xml") + old_chart <- as.integer(gsub("\\D+", "", cf)) + self$charts <- rbind(self$charts, from$charts[old_chart, ]) + + # Read the chartfile and adjust all formulas to point to the new + # sheet name instead of the clone source + + chart <- self$charts$chart[chartid] + self$charts$rels[chartid] <- gsub( + "?drawing[0-9]+.xml", + paste0("drawing", chartid, ".xml"), + self$charts$rels[chartid] + ) - old_sheet_name <- guard_ws(from$sheet_names[[old]]) - new_sheet_name <- guard_ws(new) + guard_ws <- function(x) { + if (grepl(" ", x)) x <- shQuote(x, type = "sh") + x + } - ## we need to replace "'oldname'" as well as "oldname" - chart <- gsub( - paste0(">", old_sheet_name, "!"), - paste0(">", new_sheet_name, "!"), - chart, - perl = TRUE - ) + old_sheet_name <- guard_ws(from$sheet_names[[old]]) + new_sheet_name <- guard_ws(new) - self$charts$chart[chartid] <- chart + ## we need to replace "'oldname'" as well as "oldname" + chart <- gsub( + paste0(">", old_sheet_name, "!"), + paste0(">", new_sheet_name, "!"), + chart, + perl = TRUE + ) - # two charts can not point to the same rels - if (self$charts$rels[chartid] != "") { - self$charts$rels[chartid] <- gsub( - stri_join(old_chart, ".xml"), - stri_join(chartid, ".xml"), - self$charts$rels[chartid] - ) - } + self$charts$chart[chartid] <- chart - rl <- gsub(stri_join("(?<=charts/)", cf), newname, rl, perl = TRUE) - } + # two charts can not point to the same rels + if (self$charts$rels[chartid] != "") { + self$charts$rels[chartid] <- gsub( + stri_join(old_chart, ".xml"), + stri_join(chartid, ".xml"), + self$charts$rels[chartid] + ) + } - rl + drawings_rels[dl] <- gsub(stri_join("(?<=charts/)", cf), newname, drawings_rels[dl], perl = TRUE) + } + } - }, - NA_character_, - USE.NAMES = FALSE - ) + self$drawings_rels[[new_drawing_rels]] <- drawings_rels self$append("drawings", from$drawings[[drawing_id]]) } @@ -1180,11 +1180,6 @@ wbWorkbook <- R6::R6Class( if (length(from$media)) { - # TODO there might be other content types like png, wav etc. - if (!any(grepl("Default Extension=\"jpg\"", self$Content_Types))) { - self$append("Content_Types", "") - } - # get old drawing id, must not match new drawing id old_drawing_sheet <- from$worksheets[[old]]$relships$drawing @@ -1198,34 +1193,47 @@ wbWorkbook <- R6::R6Class( # because we might end up with multiple files with similar names, we have to rename # the media file and update the drawing relationship # TODO has every drawing a drawing_rel of the same size? - drels <- rbindlist(xml_attr(self$drawings_rels[[new_drawing_sheet]], "Relationship")) - if (ncol(drels) && any(basename(drels$Type) == "image")) { - sel <- basename(drels$Type) == "image" - targets <- basename2(drels[sel]$Target) - media_names <- from$media[grepl(targets, names(from$media))] - - onams <- names(media_names) - mnams <- vector("character", length(onams)) - next_ids <- length(names(self$media)) + seq_along(mnams) - - # we might have multiple media references on a sheet - for (i in seq_along(onams)) { - media_id <- as.integer(gsub("\\D+", "", onams[i])) - # take filetype + number + file extension - # e.g. "image5.jpg" and return "image2.jpg" - mnams[i] <- gsub("(\\d+)\\.(\\w+)", paste0(next_ids[i], ".\\2"), onams[i]) + if (all(nchar(self$drawings_rels[[new_drawing_rels]]))) { + + drels <- rbindlist(xml_attr(self$drawings_rels[[new_drawing_rels]], "Relationship")) + fe <- unique(tools::file_ext(drels$Target)) + + cte <- sprintf("", fe, fe) + sel <- which(!cte %in% self$Content_Types) + + if (length(sel)) { + self$append("Content_Types", sprintf("", fe, fe)) } - names(media_names) <- mnams - # update relationship - self$drawings_rels[[new_drawing_sheet]] <- gsub( - pattern = onams, - replacement = mnams, - x = self$drawings_rels[[new_drawing_sheet]], - ) + if (ncol(drels) && any(basename(drels$Type) == "image")) { + sel <- basename(drels$Type) == "image" + targets <- basename2(drels$Target)[sel] + media_names <- from$media[targets %in% names(from$media)] + + onams <- names(media_names) + mnams <- vector("character", length(onams)) + next_ids <- length(names(self$media)) + seq_along(mnams) + + # we might have multiple media references on a sheet + for (i in seq_along(onams)) { + media_id <- as.integer(gsub("\\D+", "", onams[i])) + # take filetype + number + file extension + # e.g. "image5.jpg" and return "image2.jpg" + mnams[i] <- gsub("(\\d+)\\.(\\w+)", paste0(next_ids[i], ".\\2"), onams[i]) + } + names(media_names) <- mnams + + # update relationship + self$drawings_rels[[new_drawing_rels]] <- stringi::stri_replace_all_fixed( + self$drawings_rels[[new_drawing_rels]], + pattern = onams, + replacement = mnams, + vectorize_all = FALSE + ) - # append media - self$append("media", media_names) + # append media + self$append("media", media_names) + } } } } diff --git a/tests/testthat/test-cloneWorksheet.R b/tests/testthat/test-cloneWorksheet.R index e2849ea97..83091a69f 100644 --- a/tests/testthat/test-cloneWorksheet.R +++ b/tests/testthat/test-cloneWorksheet.R @@ -325,9 +325,9 @@ test_that("cloning slicers throws warning", { df <- wb_data(wb, sheet = 1) wb$add_pivot_table( - df, dims = "A3", slicer = "vs", rows = "cyl", cols = "gear", data = "disp", - pivot_table = "mtcars" - )$ + df, dims = "A3", slicer = "vs", rows = "cyl", cols = "gear", data = "disp", + pivot_table = "mtcars" + )$ add_slicer(x = df, slicer = "vs", pivot_table = "mtcars") expect_warning( @@ -336,3 +336,52 @@ test_that("cloning slicers throws warning", { ) }) + +test_that("cloning sheets with multiple images works", { + + png1 <- tempfile(fileext = "plot1.png") + png2 <- tempfile(fileext = "plot2.png") + jpg1 <- tempfile(fileext = "plot1.jpg") + jpg2 <- tempfile(fileext = "plot2.jpg") + + png(png1) + plot(1) + dev.off() + + png(png2) + plot(1:2) + dev.off() + + jpeg(jpg1) + plot(1:3) + dev.off() + + jpeg(jpg2) + plot(1:4) + dev.off() + + wb_old <- wb_workbook()$add_worksheet()$ + add_image(dims = "A1:A1", file = png1)$ + add_image(dims = "A2:A2", file = png2)$ + add_image(dims = "A3:A3", file = jpg1)$ + add_image(dims = "A4:A4", file = jpg2) + + wb <- wb_workbook() + wb$clone_worksheet(old = 1, new = "Clone1", from = wb_old) + + exp <- list( + c( + "", + "", + "", + "" + ) + ) + got <- wb$drawings_rels + expect_equal(exp, got) + + exp <- c("", "") + got <- wb$Content_Types[10:11] + expect_equal(exp, got) + +})