Skip to content

Commit

Permalink
[clone] fix cloning from worksheet with multiple images
Browse files Browse the repository at this point in the history
  • Loading branch information
@JanMarvin
JanMarvin committed Sep 20, 2024
1 parent e11df88 commit cce0f7e
Show file tree
Hide file tree
Showing 3 changed files with 143 additions and 84 deletions.
2 changes: 2 additions & 0 deletions NEWS.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
170 changes: 89 additions & 81 deletions R/class-workbook.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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]])
}
Expand Down Expand Up @@ -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", "<Default Extension=\"jpg\" ContentType=\"image/jpg\"/>")
}

# get old drawing id, must not match new drawing id
old_drawing_sheet <- from$worksheets[[old]]$relships$drawing

Expand All @@ -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("<Default Extension=\"%s\" ContentType=\"image/%s\"/>", fe, fe)
sel <- which(!cte %in% self$Content_Types)

if (length(sel)) {
self$append("Content_Types", sprintf("<Default Extension=\"%s\" ContentType=\"image/%s\"/>", 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)
}
}
}
}
Expand Down
55 changes: 52 additions & 3 deletions tests/testthat/test-cloneWorksheet.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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(
Expand All @@ -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(
"<Relationship Id=\"rId1\" Type=\"http://schemas.openxmlformats.org/officeDocument/2006/relationships/image\" Target=\"../media/image1.png\"/>",
"<Relationship Id=\"rId2\" Type=\"http://schemas.openxmlformats.org/officeDocument/2006/relationships/image\" Target=\"../media/image2.png\"/>",
"<Relationship Id=\"rId3\" Type=\"http://schemas.openxmlformats.org/officeDocument/2006/relationships/image\" Target=\"../media/image3.jpg\"/>",
"<Relationship Id=\"rId4\" Type=\"http://schemas.openxmlformats.org/officeDocument/2006/relationships/image\" Target=\"../media/image4.jpg\"/>"
)
)
got <- wb$drawings_rels
expect_equal(exp, got)

exp <- c("<Default Extension=\"png\" ContentType=\"image/png\"/>", "<Default Extension=\"jpg\" ContentType=\"image/jpg\"/>")
got <- wb$Content_Types[10:11]
expect_equal(exp, got)

})

0 comments on commit cce0f7e

Please sign in to comment.