diff --git a/R/class-workbook-add-data.R b/R/class-workbook-add-data.R new file mode 100644 index 000000000..af6800fd3 --- /dev/null +++ b/R/class-workbook-add-data.R @@ -0,0 +1,120 @@ +wb_add_data_impl <- function( + self, + private, + sheet = current_sheet(), + x, + startCol = 1, + startRow = 1, + dims = rowcol_to_dims(startRow, startCol), + array = FALSE, + xy = NULL, + colNames = TRUE, + rowNames = FALSE, + withFilter = FALSE, + name = NULL, + sep = ", ", + applyCellStyle = TRUE, + removeCellStyle = FALSE, + na.strings = getOption("openxlsx2.na.strings", "#N/A") +) { + # TODO copy over the actual write_data() + write_data( + wb = self, + sheet = sheet, + x = x, + startCol = startCol, + startRow = startRow, + dims = dims, + array = array, + xy = xy, + colNames = colNames, + rowNames = rowNames, + withFilter = withFilter, + name = name, + sep = sep, + applyCellStyle = applyCellStyle, + removeCellStyle = removeCellStyle, + na.strings = na.strings + ) + + invisible(self) +} + +wb_add_data_table_impl <- function( + self, + private, + sheet = current_sheet(), + x, + startCol = 1, + startRow = 1, + dims = rowcol_to_dims(startRow, startCol), + xy = NULL, + colNames = TRUE, + rowNames = FALSE, + tableStyle = "TableStyleLight9", + tableName = NULL, + withFilter = TRUE, + sep = ", ", + firstColumn = FALSE, + lastColumn = FALSE, + bandedRows = TRUE, + bandedCols = FALSE, + applyCellStyle = TRUE, + removeCellStyle = FALSE, + na.strings = getOption("openxlsx2.na.strings", "#N/A") +) { + write_datatable( + wb = self, + sheet = sheet, + x = x, + startCol = startCol, + startRow = startRow, + dims = dims, + xy = xy, + colNames = colNames, + rowNames = rowNames, + tableStyle = tableStyle, + tableName = tableName, + withFilter = withFilter, + sep = sep, + firstColumn = firstColumn, + lastColumn = lastColumn, + bandedRows = bandedRows, + bandedCols = bandedCols, + applyCellStyle = applyCellStyle, + removeCellStyle = removeCellStyle, + na.strings = na.strings + ) + + invisible(self) +} + + +wb_add_formula_impl <- function( + self, + private, + sheet = current_sheet(), + x, + startCol = 1, + startRow = 1, + dims = rowcol_to_dims(startRow, startCol), + array = FALSE, + xy = NULL, + applyCellStyle = TRUE, + removeCellStyle = FALSE +) { + write_formula( + wb = self, + sheet = sheet, + x = x, + startCol = startCol, + startRow = startRow, + dims = dims, + array = array, + xy = xy, + applyCellStyle = applyCellStyle, + removeCellStyle = removeCellStyle + ) + + invisible(self) +} diff --git a/R/class-workbook-add-worksheet.R b/R/class-workbook-add-worksheet.R new file mode 100644 index 000000000..00a4f71a2 --- /dev/null +++ b/R/class-workbook-add-worksheet.R @@ -0,0 +1,226 @@ +wb_add_worksheet_impl <- function( + self, + private, + sheet = next_sheet(), + gridLines = TRUE, + rowColHeaders = TRUE, + tabColour = NULL, + zoom = 100, + header = NULL, + footer = NULL, + oddHeader = header, + oddFooter = footer, + evenHeader = header, + evenFooter = footer, + firstHeader = header, + firstFooter = footer, + visible = c("true", "false", "hidden", "visible", "veryhidden"), + hasDrawing = FALSE, + paperSize = getOption("openxlsx2.paperSize", default = 9), + orientation = getOption("openxlsx2.orientation", default = "portrait"), + hdpi = getOption("openxlsx2.hdpi", default = getOption("openxlsx2.dpi", default = 300)), + vdpi = getOption("openxlsx2.vdpi", default = getOption("openxlsx2.dpi", default = 300)) +) { + visible <- tolower(as.character(visible)) + visible <- match.arg(visible) + orientation <- match.arg(orientation, c("portrait", "landscape")) + + # set up so that a single error can be reported on fail + fail <- FALSE + msg <- NULL + + private$validate_new_sheet(sheet) + + if (is_waiver(sheet)) { + if (sheet == "current_sheet") { + stop("cannot add worksheet to current sheet") + } + + # TODO openxlsx2.sheet.default_name is undocumented. should incorporate + # a better check for this + sheet <- paste0( + getOption("openxlsx2.sheet.default_name", "Sheet "), + length(self$sheet_names) + 1L + ) + } + + sheet <- as.character(sheet) + sheet_name <- replace_legal_chars(sheet) + private$validate_new_sheet(sheet_name) + + if (!is.logical(gridLines) | length(gridLines) > 1) { + fail <- TRUE + msg <- c(msg, "gridLines must be a logical of length 1.") + } + + if (!is.null(tabColour)) { + tabColour <- validateColour(tabColour, "Invalid tabColour in add_worksheet.") + } + + if (!is.numeric(zoom)) { + fail <- TRUE + msg <- c(msg, "zoom must be numeric") + } + + # nocov start + if (zoom < 10) { + zoom <- 10 + } else if (zoom > 400) { + zoom <- 400 + } + #nocov end + + if (!is.null(oddHeader) & length(oddHeader) != 3) { + fail <- TRUE + msg <- c(msg, lcr("header")) + } + + if (!is.null(oddFooter) & length(oddFooter) != 3) { + fail <- TRUE + msg <- c(msg, lcr("footer")) + } + + if (!is.null(evenHeader) & length(evenHeader) != 3) { + fail <- TRUE + msg <- c(msg, lcr("evenHeader")) + } + + if (!is.null(evenFooter) & length(evenFooter) != 3) { + fail <- TRUE + msg <- c(msg, lcr("evenFooter")) + } + + if (!is.null(firstHeader) & length(firstHeader) != 3) { + fail <- TRUE + msg <- c(msg, lcr("firstHeader")) + } + + if (!is.null(firstFooter) & length(firstFooter) != 3) { + fail <- TRUE + msg <- c(msg, lcr("firstFooter")) + } + + vdpi <- as.integer(vdpi) + hdpi <- as.integer(hdpi) + + if (is.na(vdpi)) { + fail <- TRUE + msg <- c(msg, "vdpi must be numeric") + } + + if (is.na(hdpi)) { + fail <- TRUE + msg <- c(msg, "hdpi must be numeric") + } + + if (fail) { + stop(msg, call. = FALSE) + } + + newSheetIndex <- length(self$worksheets) + 1L + private$set_current_sheet(newSheetIndex) + sheetId <- private$get_sheet_id_max() # checks for self$worksheet length + + # check for errors ---- + + visible <- switch( + visible, + true = "visible", + false = "hidden", + veryhidden = "veryHidden", + visible + ) + + # Order matters: if a sheet is added to a blank workbook, we add a default style. If we already have + # sheets in the workbook, we do not add a new style. This could confuse Excel which will complain. + # This fixes output of the example in wb_load. + if (length(self$sheet_names) == 0) { + # TODO this should live wherever the other default values for an empty worksheet are initialized + empty_cellXfs <- data.frame(numFmtId = "0", fontId = "0", fillId = "0", borderId = "0", xfId = "0", stringsAsFactors = FALSE) + self$styles_mgr$styles$cellXfs <- write_xf(empty_cellXfs) + } + + self$append_sheets( + sprintf( + '', + sheet_name, + sheetId, + visible, + newSheetIndex + ) + ) + + ## append to worksheets list + self$append("worksheets", + wbWorksheet$new( + tabColour = tabColour, + oddHeader = oddHeader, + oddFooter = oddFooter, + evenHeader = evenHeader, + evenFooter = evenFooter, + firstHeader = firstHeader, + firstFooter = firstFooter, + paperSize = paperSize, + orientation = orientation, + hdpi = hdpi, + vdpi = vdpi, + printGridLines = gridLines + ) + ) + + # NULL or TRUE/FALSE + rightToLeft <- getOption("openxlsx2.rightToLeft") + + # set preselected set for sheetview + self$worksheets[[newSheetIndex]]$set_sheetview( + workbookViewId = 0, + zoomScale = zoom, + showGridLines = gridLines, + showRowColHeaders = rowColHeaders, + tabSelected = newSheetIndex == 1, + rightToLeft = rightToLeft + ) + + + ## update content_tyes + ## add a drawing.xml for the worksheet + if (hasDrawing) { + self$append("Content_Types", c( + sprintf('', newSheetIndex), + sprintf('', newSheetIndex) + )) + } else { + self$append("Content_Types", + sprintf( + '', + newSheetIndex + ) + ) + } + + ## Update xl/rels + self$append("workbook.xml.rels", + sprintf( + '', + newSheetIndex + ) + ) + + ## create sheet.rels to simplify id assignment + new_drawings_idx <- length(self$drawings) + 1 + self$drawings[[new_drawings_idx]] <- "" + self$drawings_rels[[new_drawings_idx]] <- "" + + self$worksheets_rels[[newSheetIndex]] <- genBaseSheetRels(newSheetIndex) + self$vml_rels[[newSheetIndex]] <- list() + self$vml[[newSheetIndex]] <- list() + self$isChartSheet[[newSheetIndex]] <- FALSE + self$comments[[newSheetIndex]] <- list() + self$threadComments[[newSheetIndex]] <- list() + + self$append("sheetOrder", as.integer(newSheetIndex)) + private$set_single_sheet_name(newSheetIndex, sheet_name, sheet) + + invisible(self) + +} diff --git a/R/class-workbook-build-table.R b/R/class-workbook-build-table.R new file mode 100644 index 000000000..35013c886 --- /dev/null +++ b/R/class-workbook-build-table.R @@ -0,0 +1,135 @@ +wb_build_table_impl <- function( + self, + private, + sheet = current_sheet(), + colNames, + ref, + showColNames, + tableStyle, + tableName, + withFilter, # TODO set default for withFilter? + totalsRowCount = 0, + showFirstColumn = 0, + showLastColumn = 0, + showRowStripes = 1, + showColumnStripes = 0 +) { + ## id will start at 3 and drawing will always be 1, printer Settings at 2 (printer settings has been removed) + last_table_id <- function() { + z <- 0 + + if (!all(unlist(self$worksheets_rels) == "")) { + relship <- rbindlist(xml_attr(unlist(self$worksheets_rels), "Relationship")) + # assign("relship", relship, globalenv()) + relship$typ <- basename(relship$Type) + relship$tid <- as.numeric(gsub("\\D+", "", relship$Target)) + if (any(relship$typ == "table")) + z <- max(relship$tid[relship$typ == "table"]) + } + + z + } + + id <- as.character(last_table_id() + 1) # otherwise will start at 0 for table 1 length indicates the last known + sheet <- wb_validate_sheet(self, sheet) + # get the next highest rid + rid <- 1 + if (!all(identical(self$worksheets_rels[[sheet]], character()))) { + rid <- max(as.integer(sub("\\D+", "", rbindlist(xml_attr(self$worksheets_rels[[sheet]], "Relationship"))[["Id"]]))) + 1 + } + + if (is.null(self$tables)) { + nms <- NULL + tSheets <- NULL + tNames <- NULL + tActive <- NULL + } else { + nms <- self$tables$tab_ref + tSheets <- self$tables$tab_sheet + tNames <- self$tables$tab_name + tActive <- self$tables$tab_act + } + + + ### autofilter + autofilter <- if (withFilter) { + xml_node_create(xml_name = "autoFilter", xml_attributes = c(ref = ref)) + } + + ### tableColumn + tableColumn <- sapply(colNames, function(x) { + id <- which(colNames %in% x) + xml_node_create("tableColumn", xml_attributes = c(id = id, name = x)) + }) + + tableColumns <- xml_node_create( + xml_name = "tableColumns", + xml_children = tableColumn, + xml_attributes = c(count = as.character(length(colNames))) + ) + + + ### tableStyleInfo + tablestyle_attr <- c( + name = tableStyle, + showFirstColumn = as.integer(showFirstColumn), + showLastColumn = as.integer(showLastColumn), + showRowStripes = as.integer(showRowStripes), + showColumnStripes = as.integer(showColumnStripes) + ) + + tableStyleXML <- xml_node_create(xml_name = "tableStyleInfo", xml_attributes = tablestyle_attr) + + + ### full table + table_attrs <- c( + xmlns = "http://schemas.openxmlformats.org/spreadsheetml/2006/main", + `xmlns:mc` = "http://schemas.openxmlformats.org/markup-compatibility/2006", + id = id, + name = tableName, + displayName = tableName, + ref = ref, + totalsRowCount = totalsRowCount, + totalsRowShown = "0" + #headerRowDxfId="1" + ) + + tab_xml_new <- xml_node_create( + xml_name = "table", + xml_children = c(autofilter, tableColumns, tableStyleXML), + xml_attributes = table_attrs + ) + + self$tables <- data.frame( + tab_name = c(tNames, tableName), + tab_sheet = c(tSheets, sheet), + tab_ref = c(nms, ref), + tab_xml = c(self$tables$tab_xml, tab_xml_new), + tab_act = c(self$tables$tab_act, 1), + stringsAsFactors = FALSE + ) + + self$worksheets[[sheet]]$tableParts <- c( + self$worksheets[[sheet]]$tableParts, + sprintf('', rid) + ) + attr(self$worksheets[[sheet]]$tableParts, "tableName") <- c( + tNames[tSheets == sheet & tActive == 1], + tableName + ) + + ## create a table.xml.rels + self$append("tables.xml.rels", "") + + ## update worksheets_rels + self$worksheets_rels[[sheet]] <- c( + self$worksheets_rels[[sheet]], + sprintf( + '', + rid, + id + ) + ) + + invisible(self) +} diff --git a/R/class-workbook-cells.R b/R/class-workbook-cells.R new file mode 100644 index 000000000..7b7cee1d3 --- /dev/null +++ b/R/class-workbook-cells.R @@ -0,0 +1,290 @@ +workbook_add_data_validations <- function( + self, + private, + sheet = current_sheet(), + cols, + rows, + type, + operator, + value, + allowBlank = TRUE, + showInputMsg = TRUE, + showErrorMsg = TRUE, + errorStyle = NULL, + errorTitle = NULL, + error = NULL, + promptTitle = NULL, + prompt = NULL +) { + sheet <- private$get_sheet_index(sheet) + + ## rows and cols + if (!is.numeric(cols)) { + cols <- col2int(cols) + } + rows <- as.integer(rows) + + assert_class(allowBlank, "logical") + assert_class(showInputMsg, "logical") + assert_class(showErrorMsg, "logical") + + ## check length of value + if (length(value) > 2) { + stop("value argument must be length <= 2") + } + + valid_types <- c( + "custom", + "whole", + "decimal", + "date", + "time", ## need to conv + "textLength", + "list" + ) + + if (!tolower(type) %in% tolower(valid_types)) { + stop("Invalid 'type' argument!") + } + + ## operator == 'between' we leave out + valid_operators <- c( + "between", + "notBetween", + "equal", + "notEqual", + "greaterThan", + "lessThan", + "greaterThanOrEqual", + "lessThanOrEqual" + ) + + if (!tolower(type) %in% c("custom", "list")) { + if (!tolower(operator) %in% tolower(valid_operators)) { + stop("Invalid 'operator' argument!") + } + + operator <- valid_operators[tolower(valid_operators) %in% tolower(operator)][1] + } else if (tolower(type) == "custom") { + operator <- NULL + } else { + operator <- "between" ## ignored + } + + ## All inputs validated + + type <- valid_types[tolower(valid_types) %in% tolower(type)][1] + + ## check input combinations + if ((type == "date") && !inherits(value, "Date")) { + stop("If type == 'date' value argument must be a Date vector.") + } + + if ((type == "time") && !inherits(value, c("POSIXct", "POSIXt"))) { + stop("If type == 'time' value argument must be a POSIXct or POSIXlt vector.") + } + + + value <- head(value, 2) + allowBlank <- as.character(as.integer(allowBlank[1])) + showInputMsg <- as.character(as.integer(showInputMsg[1])) + showErrorMsg <- as.character(as.integer(showErrorMsg[1])) + + # prepare for worksheet + origin <- get_date_origin(self, origin = TRUE) + + sqref <- stri_join( + get_cell_refs(data.frame( + "x" = c(min(rows), max(rows)), + "y" = c(min(cols), max(cols)) + )), + sep = " ", + collapse = ":" + ) + + if (type == "list") { + operator <- NULL + } + + self$worksheets[[sheet]]$.__enclos_env__$private$data_validation( + type = type, + operator = operator, + value = value, + allowBlank = allowBlank, + showInputMsg = showInputMsg, + showErrorMsg = showErrorMsg, + errorStyle = errorStyle, + errorTitle = errorTitle, + error = error, + promptTitle = promptTitle, + prompt = prompt, + origin = origin, + sqref = sqref + ) + + invisible(self) +} + +wb_merge_cells_impl <- function( + self, + private, + sheet = current_sheet(), + rows = NULL, + cols = NULL +) { + sheet <- private$get_sheet_index(sheet) + + # TODO send to wbWorksheet() method + # self$worksheets[[sheet]]$merge_cells(rows = rows, cols = cols) + # invisible(self) + + rows <- range(as.integer(rows)) + cols <- range(as.integer(cols)) + + sqref <- paste0(int2col(cols), rows) + sqref <- stri_join(sqref, collapse = ":", sep = " ") + + current <- rbindlist(xml_attr(xml = self$worksheets[[sheet]]$mergeCells, "mergeCell"))$ref + + # regmatch0 will return character(0) when x is NULL + if (length(current)) { + + new_merge <- unname(unlist(dims_to_dataframe(sqref, fill = TRUE))) + current_cells <- lapply(current, function(x) unname(unlist(dims_to_dataframe(x, fill = TRUE)))) + intersects <- vapply(current_cells, function(x) any(x %in% new_merge), NA) + + # Error if merge intersects + if (any(intersects)) { + msg <- sprintf( + "Merge intersects with existing merged cells: \n\t\t%s.\nRemove existing merge first.", + stri_join(current[intersects], collapse = "\n\t\t") + ) + stop(msg, call. = FALSE) + } + } + + # TODO does this have to be xml? Can we just save the data.frame or + # matrix and then check that? This would also simplify removing the + # merge specifications + private$append_sheet_field(sheet, "mergeCells", sprintf('', sqref)) + invisible(self) +} + +wb_unmerge_cells_impl <- function( + self, + private, + sheet = current_sheet(), + rows = NULL, + cols = NULL +) { + sheet <- private$get_sheet_index(sheet) + + rows <- range(as.integer(rows)) + cols <- range(as.integer(cols)) + + sqref <- paste0(int2col(cols), rows) + sqref <- stri_join(sqref, collapse = ":", sep = " ") + + current <- rbindlist(xml_attr(xml = self$worksheets[[sheet]]$mergeCells, "mergeCell"))$ref + + if (!is.null(current)) { + new_merge <- unname(unlist(dims_to_dataframe(sqref, fill = TRUE))) + current_cells <- lapply(current, function(x) unname(unlist(dims_to_dataframe(x, fill = TRUE)))) + intersects <- vapply(current_cells, function(x) any(x %in% new_merge), NA) + + # Remove intersection + self$worksheets[[sheet]]$mergeCells <- self$worksheets[[sheet]]$mergeCells[!intersects] + } + + invisible(self) +} + +wb_free_panes_impl <- function( + self, + private, + sheet = current_sheet(), + firstActiveRow = NULL, + firstActiveCol = NULL, + firstRow = FALSE, + firstCol = FALSE +) { + # TODO rename to setFreezePanes? + + # fine to do the validation before the actual check to prevent other errors + sheet <- private$get_sheet_index(sheet) + + if (is.null(firstActiveRow) & is.null(firstActiveCol) & !firstRow & !firstCol) { + return(invisible(self)) + } + + # TODO simplify asserts + if (!is.logical(firstRow)) stop("firstRow must be TRUE/FALSE") + if (!is.logical(firstCol)) stop("firstCol must be TRUE/FALSE") + + # make overwrides for arguments + if (firstRow & !firstCol) { + firstActiveCol <- NULL + firstActiveRow <- NULL + firstCol <- FALSE + } else if (firstCol & !firstRow) { + firstActiveRow <- NULL + firstActiveCol <- NULL + firstRow <- FALSE + } else if (firstRow & firstCol) { + firstActiveRow <- 2L + firstActiveCol <- 2L + firstRow <- FALSE + firstCol <- FALSE + } else { + ## else both firstRow and firstCol are FALSE + firstActiveRow <- firstActiveRow %||% 1L + firstActiveCol <- firstActiveCol %||% 1L + + # Convert to numeric if column letter given + # TODO is col2int() safe for non characters? + firstActiveRow <- col2int(firstActiveRow) + firstActiveCol <- col2int(firstActiveCol) + } + + paneNode <- + if (firstRow) { + '' + } else if (firstCol) { + '' + } else { + if (firstActiveRow == 1 & firstActiveCol == 1) { + ## nothing to do + # return(NULL) + return(invisible(self)) + } + + if (firstActiveRow > 1 & firstActiveCol == 1) { + attrs <- sprintf('ySplit="%s"', firstActiveRow - 1L) + activePane <- "bottomLeft" + } + + if (firstActiveRow == 1 & firstActiveCol > 1) { + attrs <- sprintf('xSplit="%s"', firstActiveCol - 1L) + activePane <- "topRight" + } + + if (firstActiveRow > 1 & firstActiveCol > 1) { + attrs <- sprintf('ySplit="%s" xSplit="%s"', + firstActiveRow - 1L, + firstActiveCol - 1L + ) + activePane <- "bottomRight" + } + + sprintf( + '', + stri_join(attrs, collapse = " ", sep = " "), + get_cell_refs(data.frame(firstActiveRow, firstActiveCol)), + activePane, + activePane + ) + } + + self$worksheets[[sheet]]$freezePane <- paneNode + invisible(self) +} diff --git a/R/class-workbook-clone-worksheet.R b/R/class-workbook-clone-worksheet.R new file mode 100644 index 000000000..01137b2f5 --- /dev/null +++ b/R/class-workbook-clone-worksheet.R @@ -0,0 +1,288 @@ +wb_clone_worksheet_impl <- function(self, private, old, new) { + private$validate_new_sheet(new) + old <- private$get_sheet_index(old) + + newSheetIndex <- length(self$worksheets) + 1L + private$set_current_sheet(newSheetIndex) + sheetId <- private$get_sheet_id_max() # checks for length of worksheets + + if (!all(self$charts$chartEx == "")) { + warning( + "The file you have loaded contains chart extensions. At the moment,", + " cloning worksheets can damage the output." + ) + } + + # not the best but a quick fix + new_raw <- new + new <- replace_legal_chars(new) + + ## copy visibility from cloned sheet! + visible <- rbindlist(xml_attr(self$workbook$sheets[[old]], "sheet"))$state + + ## Add sheet to workbook.xml + self$append_sheets( + xml_node_create( + "sheet", + xml_attributes = c( + name = new, + sheetId = sheetId, + state = visible, + `r:id` = paste0("rId", newSheetIndex) + ) + ) + ) + + ## append to worksheets list + self$append("worksheets", self$worksheets[[old]]$clone(deep = TRUE)) + + ## update content_tyes + ## add a drawing.xml for the worksheet + # FIXME only add what is needed. If no previous drawing is found, don't + # add a new one + self$append("Content_Types", c( + if (self$isChartSheet[old]) { + sprintf('', newSheetIndex) + } else { + sprintf('', newSheetIndex) + } + )) + + ## Update xl/rels + self$append( + "workbook.xml.rels", + if (self$isChartSheet[old]) { + sprintf('', newSheetIndex) + } else { + sprintf('', newSheetIndex) + } + ) + + ## create sheet.rels to simplify id assignment + self$worksheets_rels[[newSheetIndex]] <- self$worksheets_rels[[old]] + + old_drawing_sheet <- NULL + + if (length(self$worksheets_rels[[old]])) { + relship <- rbindlist(xml_attr(self$worksheets_rels[[old]], "Relationship")) + relship$typ <- basename(relship$Type) + old_drawing_sheet <- as.integer(gsub("\\D+", "", relship$Target[relship$typ == "drawing"])) + } + + if (length(old_drawing_sheet)) { + + new_drawing_sheet <- length(self$drawings) + 1 + + self$drawings_rels[[new_drawing_sheet]] <- self$drawings_rels[[old_drawing_sheet]] + + # 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, self$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 + } + + old_sheet_name <- guard_ws(self$sheet_names[[old]]) + new_sheet_name <- guard_ws(new) + + ## we need to replace "'oldname'" as well as "oldname" + chart <- gsub( + old_sheet_name, + new_sheet_name, + chart, + perl = TRUE + ) + + self$charts$chart[chartid] <- chart + + # 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 <- gsub(stri_join("(?<=charts/)", cf), newname, rl, perl = TRUE) + } + + rl + + }, + NA_character_, + USE.NAMES = FALSE + ) + + # otherwise an empty drawings relationship is written + if (identical(self$drawings_rels[[new_drawing_sheet]], character())) + self$drawings_rels[[new_drawing_sheet]] <- list() + + + self$drawings[[new_drawing_sheet]] <- self$drawings[[old_drawing_sheet]] + } + + ## TODO Currently it is not possible to clone a sheet with a slicer in a + # safe way. It will always result in a broken xlsx file which is fixable + # but will not contain a slicer. + + # most likely needs to add slicerCache for each slicer with updated names + + ## SLICERS + + rid <- as.integer(sub("\\D+", "", get_relship_id(obj = self$worksheets_rels[[newSheetIndex]], "slicer"))) + if (length(rid)) { + + warning("Cloning slicers is not yet supported. It will not appear on the sheet.") + self$worksheets_rels[[newSheetIndex]] <- relship_no(obj = self$worksheets_rels[[newSheetIndex]], x = "slicer") + + newid <- length(self$slicers) + 1 + + cloned_slicers <- self$slicers[[old]] + slicer_attr <- xml_attr(cloned_slicers, "slicers") + + # Replace name with name_n. This will prevent the slicer from loading, + # but the xlsx file is not broken + slicer_child <- xml_node(cloned_slicers, "slicers", "slicer") + slicer_df <- rbindlist(xml_attr(slicer_child, "slicer"))[c("name", "cache", "caption", "rowHeight")] + slicer_df$name <- paste0(slicer_df$name, "_n") + slicer_child <- df_to_xml("slicer", slicer_df) + + self$slicers[[newid]] <- xml_node_create("slicers", slicer_child, slicer_attr[[1]]) + + self$worksheets_rels[[newSheetIndex]] <- c( + self$worksheets_rels[[newSheetIndex]], + sprintf("", + rid, + newid) + ) + + self$Content_Types <- c( + self$Content_Types, + sprintf("", newid) + ) + + } + + # The IDs in the drawings array are sheet-specific, so within the new + # cloned sheet the same IDs can be used => no need to modify drawings + self$vml_rels[[newSheetIndex]] <- self$vml_rels[[old]] + self$vml[[newSheetIndex]] <- self$vml[[old]] + self$isChartSheet[[newSheetIndex]] <- self$isChartSheet[[old]] + self$comments[[newSheetIndex]] <- self$comments[[old]] + self$threadComments[[newSheetIndex]] <- self$threadComments[[old]] + + self$append("sheetOrder", as.integer(newSheetIndex)) + self$append("sheet_names", new) + private$set_single_sheet_name(pos = newSheetIndex, clean = new, raw = new_raw) + + + ############################ + ## DRAWINGS + + # if we have drawings to clone, remove every table reference from Relationship + + rid <- as.integer(sub("\\D+", "", get_relship_id(obj = self$worksheets_rels[[newSheetIndex]], x = "drawing"))) + + if (length(rid)) { + + self$worksheets_rels[[newSheetIndex]] <- relship_no(obj = self$worksheets_rels[[newSheetIndex]], x = "drawing") + + self$worksheets_rels[[newSheetIndex]] <- c( + self$worksheets_rels[[newSheetIndex]], + sprintf( + '', + rid, + new_drawing_sheet + ) + ) + + } + + ############################ + ## TABLES + ## ... are stored in the $tables list, with the name and sheet as attr + ## and in the worksheets[]$tableParts list. We also need to adjust the + ## worksheets_rels and set the content type for the new table + + # if we have tables to clone, remove every table referece from Relationship + rid <- as.integer(sub("\\D+", "", get_relship_id(obj = self$worksheets_rels[[newSheetIndex]], x = "table"))) + + if (length(rid)) { + + self$worksheets_rels[[newSheetIndex]] <- relship_no(obj = self$worksheets_rels[[newSheetIndex]], x = "table") + + # make this the new sheets object + tbls <- self$tables[self$tables$tab_sheet == old, ] + if (NROW(tbls)) { + + # newid and rid can be different. ids must be unique + newid <- max(as.integer(rbindlist(xml_attr(self$tables$tab_xml, "table"))$id)) + seq_along(rid) + + # add _n to all table names found + tbls$tab_name <- stri_join(tbls$tab_name, "_n") + tbls$tab_sheet <- newSheetIndex + # modify tab_xml with updated name, displayName and id + tbls$tab_xml <- vapply(seq_len(nrow(tbls)), function(x) { + xml_attr_mod(tbls$tab_xml[x], + xml_attributes = c(name = tbls$tab_name[x], + displayName = tbls$tab_name[x], + id = newid[x]) + ) + }, + NA_character_ + ) + + # add new tables to old tables + self$tables <- rbind( + self$tables, + tbls + ) + + self$worksheets[[newSheetIndex]]$tableParts <- sprintf('', rid) + attr(self$worksheets[[newSheetIndex]]$tableParts, "tableName") <- tbls$tab_name + + ## hint: Content_Types will be created once the sheet is written. no need to add tables there + + # increase tables.xml.rels + self$append("tables.xml.rels", rep("", nrow(tbls))) + + # add table.xml to worksheet relationship + self$worksheets_rels[[newSheetIndex]] <- c( + self$worksheets_rels[[newSheetIndex]], + sprintf( + '', + rid, + newid + ) + ) + } + + } + + # TODO: The following items are currently NOT copied/duplicated for the cloned sheet: + # - Comments ??? + # - Slicers + + invisible(self) +} diff --git a/R/class-workbook-cols.R b/R/class-workbook-cols.R new file mode 100644 index 000000000..83ab5b321 --- /dev/null +++ b/R/class-workbook-cols.R @@ -0,0 +1,232 @@ +wb_add_cols_impl <- function( + self, + private, + sheet = current_sheet(), + n, + beg, + end +) { + sheet <- private$get_sheet_index(sheet) + self$worksheets[[sheet]]$cols_attr <- df_to_xml("col", empty_cols_attr(n, beg, end)) + invisible(self) +} + +wb_group_cols_impl <- function( + self, + private, + sheet = current_sheet(), + cols, + collapsed = FALSE, + levels = NULL +) { + sheet <- private$get_sheet_index(sheet) + + if (length(collapsed) > length(cols)) { + stop("Collapses argument is of greater length than number of cols.") + } + + if (!is.logical(collapsed)) { + stop("Collapses should be a logical value (TRUE/FALSE).") + } + + if (any(cols < 1L)) { + stop("Invalid rows entered (<= 0).") + } + + collapsed <- rep(as.character(as.integer(collapsed)), length.out = length(cols)) + levels <- levels %||% rep("1", length(cols)) + + # Remove duplicates + ok <- !duplicated(cols) + collapsed <- collapsed[ok] + levels <- levels[ok] + cols <- cols[ok] + + # fetch the row_attr data.frame + col_attr <- self$worksheets[[sheet]]$unfold_cols() + + if (NROW(col_attr) == 0) { + # TODO should this be a warning? Or an error? + message("worksheet has no columns. please create some with createCols") + } + + # reverse to make it easier to get the fist + cols_rev <- rev(cols) + + # get the selection based on the col_attr frame. + + # the first n -1 cols get outlineLevel + select <- col_attr$min %in% as.character(cols_rev[-1]) + if (length(select)) { + col_attr$outlineLevel[select] <- as.character(levels[-1]) + col_attr$collapsed[select] <- as.character(as.integer(collapsed[-1])) + col_attr$hidden[select] <- as.character(as.integer(collapsed[-1])) + } + + # the n-th row gets only collapsed + select <- col_attr$min %in% as.character(cols_rev[1]) + if (length(select)) { + col_attr$collapsed[select] <- as.character(as.integer(collapsed[1])) + } + + self$worksheets[[sheet]]$fold_cols(col_attr) + + + # check if there are valid outlineLevel in col_attr and assign outlineLevelRow the max outlineLevel (thats in the documentation) + if (any(col_attr$outlineLevel != "")) { + self$worksheets[[sheet]]$sheetFormatPr <- xml_attr_mod(self$worksheets[[sheet]]$sheetFormatPr, xml_attributes = c(outlineLevelCol = as.character(max(as.integer(col_attr$outlineLevel), na.rm = TRUE)))) + } + + invisible(self) +} + +wb_ungroup_cols_impl <- function( + self, + private, + sheet = current_sheet(), + cols +) { + sheet <- private$get_sheet_index(sheet) + + # check if any rows are selected + if (any(cols < 1L)) { + stop("Invalid cols entered (<= 0).") + } + + # fetch the cols_attr data.frame + col_attr <- self$worksheets[[sheet]]$unfold_cols() + + # get the selection based on the col_attr frame. + select <- col_attr$min %in% as.character(cols) + + if (length(select)) { + col_attr$outlineLevel[select] <- "" + col_attr$collapsed[select] <- "" + # TODO only if unhide = TRUE + col_attr$hidden[select] <- "" + self$worksheets[[sheet]]$fold_cols(col_attr) + } + + # If all outlineLevels are missing: remove the outlineLevelCol attribute. Assigning "" will remove the attribute + if (all(col_attr$outlineLevel == "")) { + self$worksheets[[sheet]]$sheetFormatPr <- xml_attr_mod(self$worksheets[[sheet]]$sheetFormatPr, xml_attributes = c(outlineLevelCol = "")) + } else { + self$worksheets[[sheet]]$sheetFormatPr <- xml_attr_mod(self$worksheets[[sheet]]$sheetFormatPr, xml_attributes = c(outlineLevelCol = as.character(max(as.integer(col_attr$outlineLevel))))) + } + + invisible(self) +} + +wb_remove_col_widths_impl <- function( + self, + private, + sheet = current_sheet(), + cols +) { + sheet <- private$get_sheet_index(sheet) + + if (!is.numeric(cols)) { + cols <- col2int(cols) + } + + customCols <- as.integer(names(self$colWidths[[sheet]])) + removeInds <- which(customCols %in% cols) + if (length(removeInds)) { + remainingCols <- customCols[-removeInds] + if (length(remainingCols) == 0) { + self$colWidths[[sheet]] <- list() + } else { + rem_widths <- self$colWidths[[sheet]][-removeInds] + names(rem_widths) <- as.character(remainingCols) + self$colWidths[[sheet]] <- rem_widths + } + } + + invisible(self) +} + +wb_set_col_widths_impl <- function( + self, + private, + sheet = current_sheet(), + cols, + widths = 8.43, + hidden = FALSE +) { + sheet <- private$get_sheet_index(sheet) + + # should do nothing if the cols' length is zero + # TODO why would cols ever be 0? Can we just signal this as an error? + if (length(cols) == 0L) { + return(invisible(self)) + } + + cols <- col2int(cols) + + if (length(widths) > length(cols)) { + stop("More widths than columns supplied.") + } + + if (length(hidden) > length(cols)) { + stop("hidden argument is longer than cols.") + } + + if (length(widths) < length(cols)) { + widths <- rep(widths, length.out = length(cols)) + } + + if (length(hidden) < length(cols)) { + hidden <- rep(hidden, length.out = length(cols)) + } + + # TODO add bestFit option? + bestFit <- rep("1", length.out = length(cols)) + customWidth <- rep("1", length.out = length(cols)) + + ## Remove duplicates + ok <- !duplicated(cols) + col_width <- widths[ok] + hidden <- hidden[ok] + cols <- cols[ok] + + col_df <- self$worksheets[[sheet]]$unfold_cols() + base_font <- self$get_base_font() + + if (any(widths == "auto")) { + df <- wb_to_df(self, sheet = sheet, cols = cols, colNames = FALSE) + # TODO format(x) might not be the way it is formatted in the xlsx file. + col_width <- vapply(df, function(x) max(nchar(format(x))), NA_real_) + } + + # https://docs.microsoft.com/en-us/dotnet/api/documentformat.openxml.spreadsheet.column + widths <- calc_col_width(base_font = base_font, col_width = col_width) + + # create empty cols + if (NROW(col_df) == 0) { + self$createCols(sheet, n = max(cols)) + col_df <- col_to_df(read_xml(self$worksheets[[sheet]]$cols_attr)) + } + + # found a few cols, but not all required cols. create the missing columns + if (any(!cols %in% as.numeric(col_df$min))) { + beg <- max(as.numeric(col_df$min)) + 1 + end <- max(cols) + + # new columns + self$createCols(sheet, beg = beg, end = end) + new_cols <- col_to_df(read_xml(self$worksheets[[sheet]]$cols_attr)) + + # rbind only the missing columns. avoiding dups + sel <- !new_cols$min %in% col_df$min + col_df <- rbind(col_df, new_cols[sel, ]) + col_df <- col_df[order(as.numeric(col_df[, "min"])), ] + } + + select <- as.numeric(col_df$min) %in% cols + col_df$width[select] <- widths + col_df$hidden[select] <- tolower(hidden) + col_df$bestFit[select] <- bestFit + col_df$customWidth[select] <- customWidth + self$worksheets[[sheet]]$fold_cols(col_df) + invisible(self) +} diff --git a/R/class-workbook-comment.R b/R/class-workbook-comment.R new file mode 100644 index 000000000..3afe1537d --- /dev/null +++ b/R/class-workbook-comment.R @@ -0,0 +1,45 @@ +wb_add_comment_impl <- function( + self, + private, + sheet = current_sheet(), + col, + row, + dims = rowcol_to_dims(row, col), + comment +) { + if (!missing(dims)) { + xy <- unlist(dims_to_rowcol(dims)) + col <- xy[[1]] + row <- as.integer(xy[[2]]) + } + + write_comment( + wb = self, + sheet = sheet, + col = col, + row = row, + comment = comment + ) # has no use: xy + + invisible(self) +} + +wb_remove_comment_impl <- function( + self, + private, + sheet = current_sheet(), + col, + row, + dims = rowcol_to_dims(row, col), + gridExpand = TRUE +) { + if (!missing(dims)) { + xy <- unlist(dims_to_rowcol(dims)) + col <- xy[[1]] + row <- as.integer(xy[[2]]) + # with gridExpand this is always true + gridExpand <- TRUE + } + remove_comment(wb = self, sheet = sheet, col = col, row = row, gridExpand = TRUE) + invisible(self) +} diff --git a/R/class-workbook-conditional-formatting.R b/R/class-workbook-conditional-formatting.R new file mode 100644 index 000000000..b5832176c --- /dev/null +++ b/R/class-workbook-conditional-formatting.R @@ -0,0 +1,237 @@ +wb_add_conditional_formatting_impl <- function( + self, + private, + sheet = current_sheet(), + cols, + rows, + rule = NULL, + style = NULL, + # TODO add vector of possible values + type = c("expression", "colorScale", "dataBar", "duplicatedValues", + "containsText", "notContainsText", "beginsWith", "endsWith", + "between", "topN", "bottomN"), + params = list( + showValue = TRUE, + gradient = TRUE, + border = TRUE, + percent = FALSE, + rank = 5L + ) +) { + if (!is.null(style)) assert_class(style, "character") + assert_class(type, "character") + assert_class(params, "list") + + type <- match.arg(type) + + ## rows and cols + if (!is.numeric(cols)) { + cols <- col2int(cols) + } + + rows <- as.integer(rows) + + ## check valid rule + dxfId <- NULL + if (!is.null(style)) dxfId <- self$styles_mgr$get_dxf_id(style) + params <- validate_cf_params(params) + values <- NULL + + sel <- c("expression", "duplicatedValues", "containsText", "notContainsText", "beginsWith", "endsWith", "between", "topN", "bottomN") + if (is.null(style) && type %in% sel) { + smp <- random_string() + style <- create_dxfs_style(font_color = wb_colour(hex = "FF9C0006"), bgFill = wb_colour(hex = "FFFFC7CE")) + self$styles_mgr$add(style, smp) + dxfId <- self$styles_mgr$get_dxf_id(smp) + } + + switch( + type, + + expression = { + # TODO should we bother to do any conversions or require the text + # entered to be exactly as an Excel expression would be written? + msg <- "When type == 'expression', " + + if (!is.character(rule) || length(rule) != 1L) { + stop(msg, "rule must be a single length character vector") + } + + rule <- gsub("!=", "<>", rule) + rule <- gsub("==", "=", rule) + rule <- replace_legal_chars(rule) # replaces <> + + if (!grepl("[A-Z]", substr(rule, 1, 2))) { + ## formula looks like "operatorX" , attach top left cell to rule + rule <- paste0( + get_cell_refs(data.frame(min(rows), min(cols))), + rule + ) + } ## else, there is a letter in the formula and apply as is + + }, + + colorScale = { + # - style is a vector of colours with length 2 or 3 + # - rule specifies the quantiles (numeric vector of length 2 or 3), if NULL min and max are used + msg <- "When type == 'colourScale', " + + if (!is.character(style)) { + stop(msg, "style must be a vector of colours of length 2 or 3.") + } + + if (!length(style) %in% 2:3) { + stop(msg, "style must be a vector of length 2 or 3.") + } + + if (!is.null(rule)) { + if (length(rule) != length(style)) { + stop(msg, "rule and style must have equal lengths.") + } + } + + style <- check_valid_colour(style) + + if (isFALSE(style)) { + stop(msg, "style must be valid colors") + } + + values <- rule + rule <- style + }, + + dataBar = { + # - style is a vector of colours of length 2 or 3 + # - rule specifies the quantiles (numeric vector of length 2 or 3), if NULL min and max are used + msg <- "When type == 'dataBar', " + style <- style %||% "#638EC6" + + # TODO use inherits() not class() + if (!inherits(style, "character")) { + stop(msg, "style must be a vector of colours of length 1 or 2.") + } + + if (!length(style) %in% 1:2) { + stop(msg, "style must be a vector of length 1 or 2.") + } + + if (!is.null(rule)) { + if (length(rule) != length(style)) { + stop(msg, "rule and style must have equal lengths.") + } + } + + ## Additional parameters passed by ... + # showValue, gradient, border + style <- check_valid_colour(style) + + if (isFALSE(style)) { + stop(msg, "style must be valid colors") + } + + values <- rule + rule <- style + }, + + duplicatedValues = { + # type == "duplicatedValues" + # - style is a Style object + # - rule is ignored + + rule <- style + }, + + containsText = { + # - style is Style object + # - rule is text to look for + msg <- "When type == 'contains', " + + if (!inherits(rule, "character")) { + stop(msg, "rule must be a character vector of length 1.") + } + + values <- rule + rule <- style + }, + + notContainsText = { + # - style is Style object + # - rule is text to look for + msg <- "When type == 'notContains', " + + if (!inherits(rule, "character")) { + stop(msg, "rule must be a character vector of length 1.") + } + + values <- rule + rule <- style + }, + + beginsWith = { + # - style is Style object + # - rule is text to look for + msg <- "When type == 'beginsWith', " + + if (!is.character("character")) { + stop(msg, "rule must be a character vector of length 1.") + } + + values <- rule + rule <- style + }, + + endsWith = { + # - style is Style object + # - rule is text to look for + msg <- "When type == 'endsWith', " + + if (!inherits(rule, "character")) { + stop(msg, "rule must be a character vector of length 1.") + } + + values <- rule + rule <- style + }, + + between = { + rule <- range(rule) + }, + + topN = { + # - rule is ignored + # - 'rank' and 'percent' are named params + + ## Additional parameters passed by ... + # percent, rank + + values <- params + rule <- style + }, + + bottomN = { + # - rule is ignored + # - 'rank' and 'percent' are named params + + ## Additional parameters passed by ... + # percent, rank + + values <- params + rule <- style + } + ) + + private$do_conditional_formatting( + sheet = sheet, + startRow = min(rows), + endRow = max(rows), + startCol = min(cols), + endCol = max(cols), + dxfId = dxfId, + formula = rule, + type = type, + values = values, + params = params + ) + + invisible(self) +} diff --git a/R/class-workbook-creators.R b/R/class-workbook-creators.R new file mode 100644 index 000000000..be085262f --- /dev/null +++ b/R/class-workbook-creators.R @@ -0,0 +1,25 @@ +wb_modify_creators_impl <- function( + self, + private, + method = c("add", "set", "remove"), + value +) { + method <- match.arg(method) + assert_class(value, "character") + + if (any(!has_chr(value))) { + stop("all creators must contain characters without NAs", call. = FALSE) + } + + value <- switch( + method, + add = unique(c(self$creator, value)), + set = unique(value), + remove = setdiff(self$creator, value) + ) + + self$creator <- value + # core is made on initialization + private$generate_base_core() + invisible(self) +} diff --git a/R/class-workbook-filters.R b/R/class-workbook-filters.R new file mode 100644 index 000000000..891fd931a --- /dev/null +++ b/R/class-workbook-filters.R @@ -0,0 +1,32 @@ +wb_add_filter_impl <- function( + self, + private, + sheet = current_sheet(), + rows, + cols +) { + sheet <- private$get_sheet_index(sheet) + + if (length(rows) != 1) { + stop("row must be a numeric of length 1.") + } + + if (!is.numeric(cols)) { + cols <- col2int(cols) + } + + self$worksheets[[sheet]]$autoFilter <- sprintf( + '', + paste(get_cell_refs(data.frame("x" = c(rows, rows), "y" = c(min(cols), max(cols)))), collapse = ":") + ) + + invisible(self) +} + +wb_remove_filter_impl <- function(self, private, sheet = current_sheet()) { + for (s in private$get_sheet_index(sheet)) { + self$worksheets[[s]]$autoFilter <- character() + } + + invisible(self) +} diff --git a/R/class-workbook-header-footer.R b/R/class-workbook-header-footer.R new file mode 100644 index 000000000..eb7d82924 --- /dev/null +++ b/R/class-workbook-header-footer.R @@ -0,0 +1,61 @@ +wb_set_header_footer_impl <- function( + self, + private, + sheet = current_sheet(), + header = NULL, + footer = NULL, + evenHeader = NULL, + evenFooter = NULL, + firstHeader = NULL, + firstFooter = NULL +) { + sheet <- private$get_sheet_index(sheet) + + if (!is.null(header) && length(header) != 3) { + stop("header must have length 3 where elements correspond to positions: left, center, right.") + } + + if (!is.null(footer) && length(footer) != 3) { + stop("footer must have length 3 where elements correspond to positions: left, center, right.") + } + + if (!is.null(evenHeader) && length(evenHeader) != 3) { + stop("evenHeader must have length 3 where elements correspond to positions: left, center, right.") + } + + if (!is.null(evenFooter) && length(evenFooter) != 3) { + stop("evenFooter must have length 3 where elements correspond to positions: left, center, right.") + } + + if (!is.null(firstHeader) && length(firstHeader) != 3) { + stop("firstHeader must have length 3 where elements correspond to positions: left, center, right.") + } + + if (!is.null(firstFooter) && length(firstFooter) != 3) { + stop("firstFooter must have length 3 where elements correspond to positions: left, center, right.") + } + + # TODO this could probably be moved to the hf assignment + oddHeader <- headerFooterSub(header) + oddFooter <- headerFooterSub(footer) + evenHeader <- headerFooterSub(evenHeader) + evenFooter <- headerFooterSub(evenFooter) + firstHeader <- headerFooterSub(firstHeader) + firstFooter <- headerFooterSub(firstFooter) + + hf <- list( + oddHeader = naToNULLList(oddHeader), + oddFooter = naToNULLList(oddFooter), + evenHeader = naToNULLList(evenHeader), + evenFooter = naToNULLList(evenFooter), + firstHeader = naToNULLList(firstHeader), + firstFooter = naToNULLList(firstFooter) + ) + + if (all(lengths(hf) == 0)) { + hf <- NULL + } + + self$worksheets[[sheet]]$headerFooter <- hf + invisible(self) +} diff --git a/R/class-workbook-initialize.R b/R/class-workbook-initialize.R new file mode 100644 index 000000000..ced289824 --- /dev/null +++ b/R/class-workbook-initialize.R @@ -0,0 +1,96 @@ +wb_initialize_impl <- function( + self, + private, + creator = NULL, + title = NULL, + subject = NULL, + category = NULL, + datetimeCreated = Sys.time() +) { + self$apps <- character() + self$charts <- list() + self$isChartSheet <- logical() + + self$connections <- NULL + self$Content_Types <- genBaseContent_Type() + self$core <- + genBaseCore( + creator = creator, + title = title, + subject = subject, + category = category + ) + self$comments <- list() + self$threadComments <- list() + + + self$drawings <- list() + self$drawings_rels <- list() + # self$drawings_vml <- list() + + self$embeddings <- NULL + self$externalLinks <- NULL + self$externalLinksRels <- NULL + + self$headFoot <- NULL + + self$media <- list() + self$metadata <- NULL + + self$persons <- NULL + + self$pivotTables <- NULL + self$pivotTables.xml.rels <- NULL + self$pivotDefinitions <- NULL + self$pivotRecords <- NULL + self$pivotDefinitionsRels <- NULL + + self$queryTables <- NULL + + self$slicers <- NULL + self$slicerCaches <- NULL + + self$sheet_names <- character() + self$sheetOrder <- integer() + + self$sharedStrings <- list() + attr(self$sharedStrings, "uniqueCount") <- 0 + + self$styles_mgr <- style_mgr$new(self) + self$styles_mgr$styles <- genBaseStyleSheet() + + self$tables <- NULL + self$tables.xml.rels <- NULL + self$theme <- NULL + + + self$vbaProject <- NULL + self$vml <- list() + self$vml_rels <- list() + + self$creator <- + creator %||% + getOption("openxlsx2.creator") %||% + # USERNAME may only be present for windows + Sys.getenv("USERNAME", Sys.getenv("USER")) + + assert_class(self$creator, "character") + assert_class(title, "character", or_null = TRUE) + assert_class(subject, "character", or_null = TRUE) + assert_class(category, "character", or_null = TRUE) + assert_class(datetimeCreated, "POSIXt") + + stopifnot( + length(title) <= 1L, + length(category) <= 1L, + length(datetimeCreated) == 1L + ) + + self$title <- title + self$subject <- subject + self$category <- category + self$datetimeCreated <- datetimeCreated + private$generate_base_core() + private$current_sheet <- 0L + invisible(self) +} diff --git a/R/class-workbook-methods.R b/R/class-workbook-methods.R new file mode 100644 index 000000000..e01e8514d --- /dev/null +++ b/R/class-workbook-methods.R @@ -0,0 +1,334 @@ + +wb_append_impl <- function(self, private, field, value) { + self[[field]] <- c(self[[field]], value) + invisible(self) +} + +wb_append_sheets_impl <- function(self, private, value) { + self$workbook$sheets <- c(self$workbook$sheets, value) + invisible(self) +} + +wb_add_chartsheet_impl <- function(self, private, sheet, tabColour, zoom) { + # TODO private$new_sheet_index()? + newSheetIndex <- length(self$worksheets) + 1L + sheetId <- private$get_sheet_id_max() # checks for length of worksheets + + ## Add sheet to workbook.xml + self$append_sheets( + sprintf( + '', + sheet, + sheetId, + newSheetIndex + ) + ) + + ## append to worksheets list + self$append("worksheets", + wbChartSheet$new(tabColour = tabColour) + ) + + + # nocov start + if (zoom < 10) { + zoom <- 10 + } else if (zoom > 400) { + zoom <- 400 + } + #nocov end + + self$worksheets[[newSheetIndex]]$set_sheetview( + workbookViewId = 0, + zoomScale = zoom, + tabSelected = newSheetIndex == 1 + ) + + self$append("sheet_names", sheet) + + ## update content_tyes + self$append("Content_Types", + sprintf( + '', + newSheetIndex + ) + ) + + ## Update xl/rels + self$append("workbook.xml.rels", + sprintf( + '', + newSheetIndex + ) + ) + + ## add a drawing.xml for the worksheet + self$append("Content_Types", + sprintf( + '', + newSheetIndex + ) + ) + + ## create sheet.rels to simplify id assignment + new_drawings_idx <- length(self$drawings) + 1 + self$drawings[[new_drawings_idx]] <- "" + self$drawings_rels[[new_drawings_idx]] <- "" + + self$worksheets_rels[[newSheetIndex]] <- genBaseSheetRels(newSheetIndex) + self$isChartSheet[[newSheetIndex]] <- TRUE + self$vml_rels[[newSheetIndex]] <- list() + self$vml[[newSheetIndex]] <- list() + self$append("sheetOrder", newSheetIndex) + + # invisible(newSheetIndex) + invisible(self) +} + +wb_add_style_impl <- function( + self, + private, + style = NULL, + style_name = substitute(style) +) { + style_name <- format(style_name) + assert_class(style, "character") + assert_class(style_name, "character") + self$styles_mgr$add(style, style_name) + invisible(self) +} + +wb_open_impl <- function(self, private, interactive = NA) { + xl_open(self, interactive = interactive) + invisible(self) +} + +wb_get_base_font_impl <- function(self, private) { + baseFont <- self$styles_mgr$styles$fonts[[1]] + + sz <- unlist(xml_attr(baseFont, "font", "sz")) + colour <- unlist(xml_attr(baseFont, "font", "color")) + name <- unlist(xml_attr(baseFont, "font", "name")) + + if (length(sz[[1]]) == 0) { + sz <- list("val" = "11") + } else { + sz <- as.list(sz) + } + + if (length(colour[[1]]) == 0) { + colour <- list("rgb" = "#000000") + } else { + colour <- as.list(colour) + } + + if (length(name[[1]]) == 0) { + name <- list("val" = "Calibri") + } else { + name <- as.list(name) + } + + list( + size = sz, + colour = colour, + name = name + ) +} + +wb_set_base_font_impl <- function( + self, + private, + fontSize = 11, + fontColour = wb_colour(theme = "1"), + fontName = "Calibri" +) { + if (fontSize < 0) { + stop("Invalid fontSize") + } + + if (is.character(fontColour) && is.null(names(fontColour))) { + fontColour <- wb_colour(fontColour) + } + + self$styles_mgr$styles$fonts[[1]] <- create_font( + sz = as.character(fontSize), + color = fontColour, + name = fontName + ) + + invisible(self) +} + +wb_set_bookview_impl <- function( + self, + private, + activeTab = NULL, + autoFilterDateGrouping = NULL, + firstSheet = NULL, + minimized = NULL, + showHorizontalScroll = NULL, + showSheetTabs = NULL, + showVerticalScroll = NULL, + tabRatio = NULL, + visibility = NULL, + windowHeight = NULL, + windowWidth = NULL, + xWindow = NULL, + yWindow = NULL +) { + wbv <- self$workbook$bookViews + + if (is.null(wbv)) { + wbv <- xml_node_create("workbookView") + } else { + wbv <- xml_node(wbv, "bookViews", "workbookView") + } + + wbv <- xml_attr_mod( + wbv, + xml_attributes = c( + activeTab = as_xml_attr(activeTab), + autoFilterDateGrouping = as_xml_attr(autoFilterDateGrouping), + firstSheet = as_xml_attr(firstSheet), + minimized = as_xml_attr(minimized), + showHorizontalScroll = as_xml_attr(showHorizontalScroll), + showSheetTabs = as_xml_attr(showSheetTabs), + showVerticalScroll = as_xml_attr(showVerticalScroll), + tabRatio = as_xml_attr(tabRatio), + visibility = as_xml_attr(visibility), + windowHeight = as_xml_attr(windowHeight), + windowWidth = as_xml_attr(windowWidth), + xWindow = as_xml_attr(xWindow), + yWindow = as_xml_attr(yWindow) + ) + ) + + self$workbook$bookViews <- xml_node_create( + "bookViews", + xml_children = wbv + ) + + invisible(self) +} + +wb_print_impl <- function(self, private) { + exSheets <- self$get_sheet_names() + nSheets <- length(exSheets) + nImages <- length(self$media) + nCharts <- length(self$charts) + + showText <- "A Workbook object.\n" + + ## worksheets + if (nSheets > 0) { + showText <- c(showText, "\nWorksheets:\n") + sheetTxt <- sprintf("Sheets: %s", paste(names(exSheets), collapse = " ")) + + showText <- c(showText, sheetTxt, "\n") + } else { + showText <- + c(showText, "\nWorksheets:\n", "No worksheets attached\n") + } + + if (nSheets > 0) { + showText <- + c(showText, sprintf( + "Write order: %s", + stri_join(self$sheetOrder, sep = " ", collapse = ", ") + )) + } + + cat(unlist(showText)) + invisible(self) +} + +wb_set_last_modified_by_impl <- function(self, private, LastModifiedBy = NULL) { + # TODO rename to wb_set_last_modified_by() ? + if (!is.null(LastModifiedBy)) { + current_LastModifiedBy <- + stri_match(self$core, regex = "(.*?)")[1, 2] + self$core <- + stri_replace_all_fixed( + self$core, + pattern = current_LastModifiedBy, + replacement = LastModifiedBy + ) + } + + invisible(self) +} + +wb_grid_lines_impl <- function( + self, + private, + sheet = current_sheet(), + show = FALSE, + print = show +) { + sheet <- private$get_sheet_index(sheet) + + assert_class(show, "logical") + assert_class(print, "logical") + + ## show + sv <- self$worksheets[[sheet]]$sheetViews + sv <- xml_attr_mod(sv, c(showGridLines = as_xml_attr(show))) + self$worksheets[[sheet]]$sheetViews <- sv + + ## print + if (print) + self$worksheets[[sheet]]$set_print_options(gridLines = print, gridLinesSet = print) + + invisible(self) +} + +wb_set_order_impl <- function(self, private, sheets) { + sheets <- private$get_sheet_index(sheet = sheets) + + if (anyDuplicated(sheets)) { + stop("`sheets` cannot have duplicates") + } + + if (length(sheets) != length(self$worksheets)) { + stop(sprintf("Worksheet order must be same length as number of worksheets [%s]", length(self$worksheets))) + } + + if (any(sheets > length(self$worksheets))) { + stop("Elements of order are greater than the number of worksheets") + } + + self$sheetOrder <- sheets + invisible(self) +} + +wb_add_page_breaks_impl <- function( + self, + private, + sheet = current_sheet(), + row = NULL, + col = NULL +) { + sheet <- private$get_sheet_index(sheet) + self$worksheets[[sheet]]$add_page_break(row = row, col = col) + invisible(self) +} + +wb_clean_sheet_impl <- function( + self, + private, + sheet = current_sheet(), + numbers = TRUE, + characters = TRUE, + styles = TRUE, + merged_cells = TRUE +) { + sheet <- private$get_sheet_index(sheet) + self$worksheets[[sheet]]$clean_sheet( + numbers = numbers, + characters = characters, + styles = styles, + merged_cells = merged_cells + ) + + invisible(self) +} diff --git a/R/class-workbook-named-regions.R b/R/class-workbook-named-regions.R new file mode 100644 index 000000000..7bd2eb927 --- /dev/null +++ b/R/class-workbook-named-regions.R @@ -0,0 +1,129 @@ +wb_add_named_region_impl = function( + self, + private, + sheet = current_sheet(), + cols, + rows, + name, + localSheet = FALSE, + overwrite = FALSE, + comment = NULL, + customMenu = NULL, + description = NULL, + is_function = NULL, + functionGroupId = NULL, + help = NULL, + hidden = NULL, + localName = NULL, + publishToServer = NULL, + statusBar = NULL, + vbProcedure = NULL, + workbookParameter = NULL, + xml = NULL +) { + + sheet <- private$get_sheet_index(sheet) + + if (!is.numeric(rows)) { + stop("rows argument must be a numeric/integer vector") + } + + if (!is.numeric(cols)) { + stop("cols argument must be a numeric/integer vector") + } + + localSheetId <- "" + if (localSheet) localSheetId <- as.character(sheet) + + ## check name doesn't already exist + ## named region + + definedNames <- rbindlist(xml_attr(self$workbook$definedNames, level1 = "definedName")) + sel1 <- tolower(definedNames$name) == tolower(name) + sel2 <- definedNames$localSheetId == localSheetId + if (!is.null(definedNames$localSheetId)) { + sel <- sel1 & sel2 + } else { + sel <- sel1 + } + match_dn <- which(sel) + + if (any(match_dn)) { + if (overwrite) + self$workbook$definedNames <- self$workbook$definedNames[-match_dn] + else + stop(sprintf("Named region with name '%s' already exists! Use overwrite = TRUE if you want to replace it", name)) + } else if (grepl("^[A-Z]{1,3}[0-9]+$", name)) { + stop("name cannot look like a cell reference.") + } + + cols <- round(cols) + rows <- round(rows) + + startCol <- min(cols) + endCol <- max(cols) + + startRow <- min(rows) + endRow <- max(rows) + + ref1 <- paste0("$", int2col(startCol), "$", startRow) + ref2 <- paste0("$", int2col(endCol), "$", endRow) + + if (localSheetId == "") localSheetId <- NULL + + private$create_named_region( + ref1 = ref1, + ref2 = ref2, + name = name, + sheet = self$sheet_names[sheet], + localSheetId = localSheetId, + comment = comment, + customMenu = customMenu, + description = description, + is_function = is_function, + functionGroupId = functionGroupId, + help = help, + hidden = hidden, + localName = localName, + publishToServer = publishToServer, + statusBar = statusBar, + vbProcedure = vbProcedure, + workbookParameter = workbookParameter, + xml = xml + ) + + invisible(self) +} + +wb_remove_named_region_impl = function( + self, + private, + sheet = current_sheet(), + name = NULL +) { + # get all nown defined names + dn <- get_named_regions(self) + + if (is.null(name) && !is.null(sheet)) { + sheet <- private$get_sheet_index(sheet) + del <- dn$id[dn$sheet == sheet] + } else if (!is.null(name) && is.null(sheet)) { + del <- dn$id[dn$name == name] + } else { + sheet <- private$get_sheet_index(sheet) + del <- dn$id[dn$sheet == sheet & dn$name == name] + } + + if (length(del)) { + self$workbook$definedNames <- self$workbook$definedNames[-del] + } else { + if (!is.null(name)) + warning(sprintf("Cannot find named region with name '%s'", name)) + # do not warn if wb and sheet are selected. wb_delete_named_region is + # called with every wb_remove_worksheet and would throw meaningless + # warnings. For now simply assume if no name is defined, that the + # user does not care, as long as no defined name remains on a sheet. + } + + invisible(self) +} diff --git a/R/class-workbook-page.R b/R/class-workbook-page.R new file mode 100644 index 000000000..f186ca463 --- /dev/null +++ b/R/class-workbook-page.R @@ -0,0 +1,151 @@ +wb_page_setup_impl = function( + self, + private, + sheet = current_sheet(), + orientation = NULL, + scale = 100, + left = 0.7, + right = 0.7, + top = 0.75, + bottom = 0.75, + header = 0.3, + footer = 0.3, + fitToWidth = FALSE, + fitToHeight = FALSE, + paperSize = NULL, + printTitleRows = NULL, + printTitleCols = NULL, + summaryRow = NULL, + summaryCol = NULL +) { + + sheet <- private$get_sheet_index(sheet) + xml <- self$worksheets[[sheet]]$pageSetup + + if (!is.null(orientation)) { + orientation <- tolower(orientation) + if (!orientation %in% c("portrait", "landscape")) stop("Invalid page orientation.") + } else { + # if length(xml) == 1 then use if () {} else {} + orientation <- ifelse(grepl("landscape", xml), "landscape", "portrait") ## get existing + } + + if ((scale < 10) || (scale > 400)) { + stop("Scale must be between 10 and 400.") + } + + if (!is.null(paperSize)) { + paperSizes <- 1:68 + paperSizes <- paperSizes[!paperSizes %in% 48:49] + if (!paperSize %in% paperSizes) { + stop("paperSize must be an integer in range [1, 68]. See ?ws_page_setup details.") + } + paperSize <- as.integer(paperSize) + } else { + paperSize <- regmatches(xml, regexpr('(?<=paperSize=")[0-9]+', xml, perl = TRUE)) ## get existing + } + + ## Keep defaults on orientation, hdpi, vdpi, paperSize ---- + hdpi <- regmatches(xml, regexpr('(?<=horizontalDpi=")[0-9]+', xml, perl = TRUE)) + vdpi <- regmatches(xml, regexpr('(?<=verticalDpi=")[0-9]+', xml, perl = TRUE)) + + ## Update ---- + self$worksheets[[sheet]]$pageSetup <- sprintf( + '', + paperSize, orientation, scale, as.integer(fitToWidth), as.integer(fitToHeight), hdpi, vdpi + ) + + if (fitToHeight || fitToWidth) { + self$worksheets[[sheet]]$sheetPr <- unique(c(self$worksheets[[sheet]]$sheetPr, '')) + } + + self$worksheets[[sheet]]$pageMargins <- + sprintf('', left, right, top, bottom, header, footer) + + validRow <- function(summaryRow) { + return(tolower(summaryRow) %in% c("above", "below")) + } + validCol <- function(summaryCol) { + return(tolower(summaryCol) %in% c("left", "right")) + } + + outlinepr <- "" + + if (!is.null(summaryRow)) { + + if (!validRow(summaryRow)) { + stop("Invalid \`summaryRow\` option. Must be one of \"Above\" or \"Below\".") + } else if (tolower(summaryRow) == "above") { + outlinepr <- ' summaryBelow=\"0\"' + } else { + outlinepr <- ' summaryBelow=\"1\"' + } + } + + if (!is.null(summaryCol)) { + + if (!validCol(summaryCol)) { + stop("Invalid \`summaryCol\` option. Must be one of \"Left\" or \"Right\".") + } else if (tolower(summaryCol) == "left") { + outlinepr <- paste0(outlinepr, ' summaryRight=\"0\"') + } else { + outlinepr <- paste0(outlinepr, ' summaryRight=\"1\"') + } + } + + if (!stri_isempty(outlinepr)) { + self$worksheets[[sheet]]$sheetPr <- unique(c(self$worksheets[[sheet]]$sheetPr, paste0(""))) + } + + ## print Titles ---- + if (!is.null(printTitleRows) && is.null(printTitleCols)) { + if (!is.numeric(printTitleRows)) { + stop("printTitleRows must be numeric.") + } + + private$create_named_region( + ref1 = paste0("$", min(printTitleRows)), + ref2 = paste0("$", max(printTitleRows)), + name = "_xlnm.Print_Titles", + sheet = self$get_sheet_names()[[sheet]], + localSheetId = sheet - 1L + ) + } else if (!is.null(printTitleCols) && is.null(printTitleRows)) { + if (!is.numeric(printTitleCols)) { + stop("printTitleCols must be numeric.") + } + + cols <- int2col(range(printTitleCols)) + private$create_named_region( + ref1 = paste0("$", cols[1]), + ref2 = paste0("$", cols[2]), + name = "_xlnm.Print_Titles", + sheet = self$get_sheet_names()[[sheet]], + localSheetId = sheet - 1L + ) + } else if (!is.null(printTitleCols) && !is.null(printTitleRows)) { + if (!is.numeric(printTitleRows)) { + stop("printTitleRows must be numeric.") + } + + if (!is.numeric(printTitleCols)) { + stop("printTitleCols must be numeric.") + } + + cols <- int2col(range(printTitleCols)) + rows <- range(printTitleRows) + + cols <- paste(paste0("$", cols[1]), paste0("$", cols[2]), sep = ":") + rows <- paste(paste0("$", rows[1]), paste0("$", rows[2]), sep = ":") + localSheetId <- sheet - 1L + sheet <- self$get_sheet_names()[[sheet]] + + self$workbook$definedNames <- c( + self$workbook$definedNames, + sprintf('\'%s\'!%s,\'%s\'!%s', localSheetId, sheet, cols, sheet, rows) + ) + + } + + invisible(self) +} diff --git a/R/class-workbook-plots.R b/R/class-workbook-plots.R new file mode 100644 index 000000000..89a5de4c0 --- /dev/null +++ b/R/class-workbook-plots.R @@ -0,0 +1,424 @@ +wb_add_image_impl <- function( + self, + private, + sheet = current_sheet(), + file, + width = 6, + height = 3, + startRow = 1, + startCol = 1, + rowOffset = 0, + colOffset = 0, + units = "in", + dpi = 300 +) { + if (!file.exists(file)) { + stop("File does not exist.") + } + + # TODO require user to pass a valid path + if (!grepl("\\\\|\\/", file)) { + file <- file.path(getwd(), file, fsep = .Platform$file.sep) + } + + units <- tolower(units) + + # TODO use match.arg() + if (!units %in% c("cm", "in", "px")) { + stop("Invalid units.\nunits must be one of: cm, in, px") + } + + startCol <- col2int(startCol) + startRow <- as.integer(startRow) + + ## convert to inches + if (units == "px") { + width <- width / dpi + height <- height / dpi + } else if (units == "cm") { + width <- width / 2.54 + height <- height / 2.54 + } + + ## Convert to EMUs + width <- as.integer(round(width * 914400L, 0)) # (EMUs per inch) + height <- as.integer(round(height * 914400L, 0)) # (EMUs per inch) + + ## within the sheet the drawing node's Id refernce an id in the sheetRels + ## sheet rels reference the drawingi.xml file + ## drawingi.xml refernece drawingRels + ## drawing rels reference an image in the media folder + ## worksheetRels(sheet(i)) references drawings(j) + + sheet <- private$get_sheet_index(sheet) + + # TODO tools::file_ext() ... + imageType <- regmatches(file, gregexpr("\\.[a-zA-Z]*$", file)) + imageType <- gsub("^\\.", "", imageType) + + drawing_sheet <- 1 + if (length(self$worksheets_rels[[sheet]])) { + relship <- rbindlist(xml_attr(self$worksheets_rels[[sheet]], "Relationship")) + relship$typ <- basename(relship$Type) + drawing_sheet <- as.integer(gsub("\\D+", "", relship$Target[relship$typ == "drawing"])) + } + + drawing_len <- 0 + if (!all(self$drawings_rels[[drawing_sheet]] == "")) + drawing_len <- length(xml_node(unlist(self$drawings_rels[[drawing_sheet]]), "Relationship")) + + imageNo <- drawing_len + 1L + mediaNo <- length(self$media) + 1L + + startCol <- col2int(startCol) + + ## update Content_Types + if (!any(grepl(stri_join("image/", imageType), self$Content_Types))) { + self$Content_Types <- + unique(c( + sprintf( + '', + imageType, + imageType + ), + self$Content_Types + )) + } + + # update worksheets_rels + if (length(self$worksheets_rels[[sheet]]) == 0) { + self$worksheets_rels[[sheet]] <- sprintf('', imageNo) ## will always be 1 + } + + # update drawings_rels + old_drawings_rels <- unlist(self$drawings_rels[[drawing_sheet]]) + if (all(old_drawings_rels == "")) old_drawings_rels <- NULL + ## drawings rels (Reference from drawings.xml to image file in media folder) + self$drawings_rels[[drawing_sheet]] <- c( + old_drawings_rels, + sprintf( + '', + imageNo, + mediaNo, + imageType + ) + ) + + ## write file path to media slot to copy across on save + tmp <- file + names(tmp) <- stri_join("image", mediaNo, ".", imageType) + self$append("media", tmp) + + ## create drawing.xml + anchor <- '' + + from <- sprintf( + ' + %s + %s + %s + %s + ', + startCol - 1L, + colOffset, + startRow - 1L, + rowOffset + ) + + drawingsXML <- stri_join( + anchor, + from, + sprintf('', width, height), + genBasePic(imageNo), + "", + "" + ) + + + # If no drawing is found, initiate one. If one is found, append a child to the exisiting node. + # Might look into updating attributes as well. + if (all(self$drawings[[drawing_sheet]] == "")) { + xml_attr <- c( + "xmlns:xdr" = "http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing", + "xmlns:a" = "http://schemas.openxmlformats.org/drawingml/2006/main", + "xmlns:r" = "http://schemas.openxmlformats.org/officeDocument/2006/relationships" + ) + self$drawings[[drawing_sheet]] <- xml_node_create("xdr:wsDr", xml_children = drawingsXML, xml_attributes = xml_attr) + } else { + self$drawings[[drawing_sheet]] <- xml_add_child(self$drawings[[drawing_sheet]], drawingsXML) + } + + # Finally we must assign the drawing to the sheet, if no drawing is assigned. If drawing is not + # empty, we must assume that the rId matches another drawing rId in worksheets_rels + if (identical(self$worksheets[[sheet]]$drawing, character())) + self$worksheets[[sheet]]$drawing <- '' ## will always be 1 + + invisible(self) +} + +wb_add_plot_impl <- function( + self, + private, + sheet = current_sheet(), + width = 6, + height = 4, + xy = NULL, + startRow = 1, + startCol = 1, + rowOffset = 0, + colOffset = 0, + fileType = "png", + units = "in", + dpi = 300 +) { + if (is.null(dev.list()[[1]])) { + warning("No plot to insert.") + return(invisible(self)) + } + + if (!is.null(xy)) { + startCol <- xy[[1]] + startRow <- xy[[2]] + } + + fileType <- tolower(fileType) + units <- tolower(units) + + # TODO just don't allow jpg + if (fileType == "jpg") { + fileType <- "jpeg" + } + + # TODO add match.arg() + if (!fileType %in% c("png", "jpeg", "tiff", "bmp")) { + stop("Invalid file type.\nfileType must be one of: png, jpeg, tiff, bmp") + } + + if (!units %in% c("cm", "in", "px")) { + stop("Invalid units.\nunits must be one of: cm, in, px") + } + + fileName <- tempfile(pattern = "figureImage", fileext = paste0(".", fileType)) + + # TODO use switch() + if (fileType == "bmp") { + dev.copy(bmp, filename = fileName, width = width, height = height, units = units, res = dpi) + } else if (fileType == "jpeg") { + dev.copy(jpeg, filename = fileName, width = width, height = height, units = units, quality = 100, res = dpi) + } else if (fileType == "png") { + dev.copy(png, filename = fileName, width = width, height = height, units = units, res = dpi) + } else if (fileType == "tiff") { + dev.copy(tiff, filename = fileName, width = width, height = height, units = units, compression = "none", res = dpi) + } + + ## write image + invisible(dev.off()) + + self$add_image( + sheet = sheet, + file = fileName, + width = width, + height = height, + startRow = startRow, + startCol = startCol, + rowOffset = rowOffset, + colOffset = colOffset, + units = units, + dpi = dpi + ) +} + +wb_add_drawing_impl <- function( + self, + private, + sheet = current_sheet(), + xml, + dims = "A1:H8" +) { + sheet <- private$get_sheet_index(sheet) + + xml <- read_xml(xml, pointer = FALSE) + + if (!(xml_node_name(xml) == "xdr:wsDr")) { + error("xml needs to be a drawing.") + } + + grpSp <- xml_node(xml, "xdr:wsDr", "xdr:absoluteAnchor", "xdr:grpSp") + ext <- xml_node(xml, "xdr:wsDr", "xdr:absoluteAnchor", "xdr:ext") + + # include rvg graphic from specific position to one or two cell anchor + if (!is.null(dims) && xml_node_name(xml, "xdr:wsDr") == "xdr:absoluteAnchor") { + + twocell <- grepl(":", dims) + + if (twocell) { + + xdr_typ <- "xdr:twoCellAnchor" + ext <- NULL + + dims_list <- strsplit(dims, ":")[[1]] + cols <- col2int(dims_list) + rows <- as.numeric(gsub("\\D+", "", dims_list)) + + anchor <- paste0( + "", + "%s0", + "%s0", + "", + "", + "%s0", + "%s0", + "" + ) + anchor <- sprintf(anchor, cols[1] - 1L, rows[1] - 1L, cols[2], rows[2]) + + } else { + + xdr_typ <- "xdr:oneCellAnchor" + + cols <- col2int(dims) + rows <- as.numeric(gsub("\\D+", "", dims)) + + anchor <- paste0( + "", + "%s0", + "%s0", + "" + ) + anchor <- sprintf(anchor, cols[1] - 1L, rows[1] - 1L) + + } + + xdr_typ_xml <- xml_node_create( + xdr_typ, + xml_children = c( + anchor, + ext, + grpSp, + "" + ) + ) + + xml <- xml_node_create( + "xdr:wsDr", + xml_attributes = c( + "xmlns:a" = "http://schemas.openxmlformats.org/drawingml/2006/main", + "xmlns:r" = "http://schemas.openxmlformats.org/officeDocument/2006/relationships", + "xmlns:pic" = "http://schemas.openxmlformats.org/drawingml/2006/picture", + "xmlns:xdr" = "http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing" + ), + xml_children = xdr_typ_xml + ) + } + + # check if sheet already contains drawing. if yes, try to integrate + # our drawing into this else we only use our drawing. + drawings <- self$drawings[[sheet]] + if (drawings == "") { + drawings <- xml + } else { + drawing_type <- xml_node_name(xml, "xdr:wsDr") + xml_drawing <- xml_node(xml, "xdr:wsDr", drawing_type) + drawings <- xml_add_child(drawings, xml_drawing) + } + self$drawings[[sheet]] <- drawings + + # get the correct next free relship id + if (length(self$worksheets_rels[[sheet]]) == 0) { + next_relship <- 1 + has_no_drawing <- TRUE + } else { + relship <- rbindlist(xml_attr(self$worksheets_rels[[sheet]], "Relationship")) + relship$typ <- basename(relship$Type) + next_relship <- as.integer(gsub("\\D+", "", relship$Id)) + 1L + has_no_drawing <- !any(relship$typ == "drawing") + } + + # if a drawing exisits, we already added ourself to it. Otherwise we + # create a new drawing. + if (has_no_drawing) { + self$worksheets_rels[[sheet]] <- sprintf("", next_relship, sheet) + self$worksheets[[sheet]]$drawing <- sprintf("", next_relship) + } + + invisible(self) +} + +wb_add_chart_xml_impl <- function( + self, + private, + sheet = current_sheet(), + xml, + dims = "A1:H8" +) { + dims_list <- strsplit(dims, ":")[[1]] + cols <- col2int(dims_list) + rows <- as.numeric(gsub("\\D+", "", dims_list)) + + sheet <- private$get_sheet_index(sheet) + + next_chart <- NROW(self$charts) + 1 + + chart <- data.frame( + chart = xml, + colors = colors1_xml, + style = styleplot_xml, + rels = chart1_rels_xml(next_chart), + chartEx = "", + relsEx = "" + ) + + self$charts <- rbind(self$charts, chart) + + len_drawing <- length(xml_node_name(self$drawings[[sheet]], "xdr:wsDr")) + 1L + + from <- c(cols[1] - 1L, rows[1] - 1L) + to <- c(cols[2], rows[2]) + + # create drawing. add it to self$drawings, the worksheet and rels + self$add_drawing( + sheet = sheet, + xml = drawings(len_drawing, from, to), + dims = dims + ) + + self$drawings_rels[[sheet]] <- drawings_rels(self$drawings_rels[[sheet]], next_chart) + invisible(self) +} + +wb_add_mschart_impl <- function( + self, + private, + sheet = current_sheet(), + dims = "B2:H8", + graph +) { + requireNamespace("mschart") + assert_class(graph, "ms_chart") + + sheetname <- private$get_sheet_name(sheet) + + # format.ms_chart is exported in mschart >= 0.4 + out_xml <- read_xml( + format( + graph, + sheetname = sheetname, + id_x = "64451212", + id_y = "64453248" + ), + pointer = FALSE + ) + + # write the chart data to the workbook + if (inherits(graph$data_series, "wb_data")) { + self$add_chart_xml(sheet = sheet, xml = out_xml, dims = dims) + } else { + self$add_data( + x = graph$data_series + )$add_chart_xml( + sheet = sheet, + xml = out_xml, + dims = dims + ) + } +} diff --git a/R/class-workbook-protect.R b/R/class-workbook-protect.R new file mode 100644 index 000000000..18bfdf9ad --- /dev/null +++ b/R/class-workbook-protect.R @@ -0,0 +1,87 @@ +wb_protect_impl <- function( + self, + private, + protect = TRUE, + password = NULL, + lockStructure = FALSE, + lockWindows = FALSE, + type = c("1", "2", "4", "8"), + fileSharing = FALSE, + username = unname(Sys.info()["user"]), + readOnlyRecommended = FALSE +) { + if (!protect) { + self$workbook$workbookProtection <- NULL + return(self) + } + + # match.arg() doesn't handle numbers too well + type <- if (!is.character(type)) as.character(type) + password <- if (is.null(password)) "" else hashPassword(password) + + # TODO: Shall we parse the existing protection settings and preserve all + # unchanged attributes? + + if (fileSharing) { + self$workbook$fileSharing <- xml_node_create( + "fileSharing", + xml_attributes = c( + userName = username, + readOnlyRecommended = if (readOnlyRecommended | type == "2") "1", + reservationPassword = password + ) + ) + } + + self$workbook$workbookProtection <- xml_node_create( + "workbookProtection", + xml_attributes = c( + hashPassword = password, + lockStructure = toString(as.numeric(lockStructure)), + lockWindows = toString(as.numeric(lockWindows)) + ) + ) + + self$workbook$apps <- xml_node_create("DocSecurity", type) + invisible(self) +} + +wb_protect_worksheet_impl <- function( + self, + private, + sheet = current_sheet(), + protect = TRUE, + password = NULL, + properties = NULL +) { + sheet <- wb_validate_sheet(self, sheet) + + if (!protect) { + # initializes as character() + self$worksheets[[sheet]]$sheetProtection <- character() + return(self) + } + + all_props <- worksheet_lock_properties() + + if (!is.null(properties)) { + # ensure only valid properties are listed + properties <- match.arg(properties, all_props, several.ok = TRUE) + } + + properties <- as.character(as.numeric(all_props %in% properties)) + names(properties) <- all_props + + if (!is.null(password)) + properties <- c(properties, password = hashPassword(password)) + + self$worksheets[[sheet]]$sheetProtection <- xml_node_create( + "sheetProtection", + xml_attributes = c( + sheet = "1", + properties[properties != "0"] + ) + ) + + invisible(self) +} diff --git a/R/class-workbook-rows.R b/R/class-workbook-rows.R new file mode 100644 index 000000000..8daddfac6 --- /dev/null +++ b/R/class-workbook-rows.R @@ -0,0 +1,158 @@ +wb_set_row_heights_impl <- function( + self, + private, + sheet = current_sheet(), + rows, + heights +) { + sheet <- private$get_sheet_index(sheet) + + # TODO move to wbWorksheet method + + # create all A columns so that row_attr is available + dims <- rowcol_to_dims(rows, 1) + private$do_cell_init(sheet, dims) + + if (length(rows) > length(heights)) { + heights <- rep(heights, length.out = length(rows)) + } + + if (length(heights) > length(rows)) { + stop("Greater number of height values than rows.") + } + + row_attr <- self$worksheets[[sheet]]$sheet_data$row_attr + + sel <- match(rows, row_attr$r) + row_attr[sel, "ht"] <- as.character(as.numeric(heights)) + row_attr[sel, "customHeight"] <- "1" + + self$worksheets[[sheet]]$sheet_data$row_attr <- row_attr + + invisible(self) +} + +wb_remove_row_heights_impl <- function( + self, + private, + sheet = current_sheet(), + rows + ) { + sheet <- private$get_sheet_index(sheet) + + row_attr <- self$worksheets[[sheet]]$sheet_data$row_attr + + if (is.null(row_attr)) { + warning("There are no initialized rows on this sheet") + return(invisible(self)) + } + + sel <- match(rows, row_attr$r) + row_attr[sel, "ht"] <- "" + row_attr[sel, "customHeight"] <- "" + + self$worksheets[[sheet]]$sheet_data$row_attr <- row_attr + + invisible(self) +} + +wb_group_rows_impl <- function( + self, + private, + sheet = current_sheet(), + rows, + collapsed = FALSE, + levels = NULL +) { + + sheet <- private$get_sheet_index(sheet) + + if (length(collapsed) > length(rows)) { + stop("Collapses argument is of greater length than number of rows.") + } + + if (!is.logical(collapsed)) { + stop("Collapses should be a logical value (TRUE/FALSE).") + } + + if (any(rows <= 0L)) { + stop("Invalid rows entered (<= 0).") + } + + collapsed <- rep(as.character(as.integer(collapsed)), length.out = length(rows)) + + levels <- levels %||% rep("1", length(rows)) + + # Remove duplicates + ok <- !duplicated(rows) + collapsed <- collapsed[ok] + levels <- levels[ok] + rows <- rows[ok] + sheet <- private$get_sheet_index(sheet) + + # fetch the row_attr data.frame + row_attr <- self$worksheets[[sheet]]$sheet_data$row_attr + + rows_rev <- rev(rows) + + # get the selection based on the row_attr frame. + + # the first n -1 rows get outlineLevel + select <- row_attr$r %in% as.character(rows_rev[-1]) + if (length(select)) { + row_attr$outlineLevel[select] <- as.character(levels[-1]) + row_attr$collapsed[select] <- as.character(as.integer(collapsed[-1])) + row_attr$hidden[select] <- as.character(as.integer(collapsed[-1])) + } + + # the n-th row gets only collapsed + select <- row_attr$r %in% as.character(rows_rev[1]) + if (length(select)) { + row_attr$collapsed[select] <- as.character(as.integer(collapsed[1])) + } + + self$worksheets[[sheet]]$sheet_data$row_attr <- row_attr + + # check if there are valid outlineLevel in row_attr and assign outlineLevelRow the max outlineLevel (thats in the documentation) + if (any(row_attr$outlineLevel != "")) { + self$worksheets[[sheet]]$sheetFormatPr <- xml_attr_mod(self$worksheets[[sheet]]$sheetFormatPr, xml_attributes = c(outlineLevelRow = as.character(max(as.integer(row_attr$outlineLevel), na.rm = TRUE)))) + } + + invisible(self) +} + +wb_ungroup_rows_impl <- function( + self, + private, + sheet = current_sheet(), + rows +) { + sheet <- private$get_sheet_index(sheet) + + # check if any rows are selected + if (any(rows < 1L)) { + stop("Invalid rows entered (<= 0).") + } + + # fetch the row_attr data.frame + row_attr <- self$worksheets[[sheet]]$sheet_data$row_attr + + # get the selection based on the row_attr frame. + select <- row_attr$r %in% as.character(rows) + if (length(select)) { + row_attr$outlineLevel[select] <- "" + row_attr$collapsed[select] <- "" + # TODO only if unhide = TRUE + row_attr$hidden[select] <- "" + self$worksheets[[sheet]]$sheet_data$row_attr <- row_attr + } + + # If all outlineLevels are missing: remove the outlineLevelRow attribute. Assigning "" will remove the attribute + if (all(row_attr$outlineLevel == "")) { + self$worksheets[[sheet]]$sheetFormatPr <- xml_attr_mod(self$worksheets[[sheet]]$sheetFormatPr, xml_attributes = c(outlineLevelRow = "")) + } else { + self$worksheets[[sheet]]$sheetFormatPr <- xml_attr_mod(self$worksheets[[sheet]]$sheetFormatPr, xml_attributes = c(outlineLevelRow = as.character(max(as.integer(row_attr$outlineLevel))))) + } + + invisible(self) +} diff --git a/R/class-workbook-save.R b/R/class-workbook-save.R new file mode 100644 index 000000000..56e128d5d --- /dev/null +++ b/R/class-workbook-save.R @@ -0,0 +1,603 @@ +wb_save_impl <- function(self, private, path = self$path, overwrite = TRUE) { + + assert_class(path, "character") + assert_class(overwrite, "logical") + + if (file.exists(path) & !overwrite) { + stop("File already exists!") + } + + ## temp directory to save XML files prior to compressing + tmpDir <- file.path(tempfile(pattern = "workbookTemp_")) + on.exit(unlink(tmpDir, recursive = TRUE), add = TRUE) + + if (file.exists(tmpDir)) { + unlink(tmpDir, recursive = TRUE, force = TRUE) + } + + success <- dir.create(path = tmpDir, recursive = FALSE) + if (!success) { # nocov start + stop(sprintf("Failed to create temporary directory '%s'", tmpDir)) + } # nocov end + + private$preSaveCleanUp() + + nSheets <- length(self$worksheets) + nThemes <- length(self$theme) + nPivots <- length(self$pivotDefinitions) + nSlicers <- length(self$slicers) + nComments <- sum(lengths(self$comments) > 0) + nThreadComments <- sum(lengths(self$threadComments) > 0) + nPersons <- length(self$persons) + nVML <- sum(lengths(self$vml) > 0) + + relsDir <- dir_create(tmpDir, "_rels") + docPropsDir <- dir_create(tmpDir, "docProps") + xlDir <- dir_create(tmpDir, "xl") + xlrelsDir <- dir_create(tmpDir, "xl", "_rels") + xlTablesDir <- dir_create(tmpDir, "xl", "tables") + xlTablesRelsDir <- dir_create(xlTablesDir, "_rels") + + if (length(self$media)) { + xlmediaDir <- dir_create(tmpDir, "xl", "media") + } + + ## will always have a theme + xlthemeDir <- dir_create(tmpDir, "xl", "theme") + + if (is.null(self$theme)) { + con <- file(file.path(xlthemeDir, "theme1.xml"), open = "wb") + writeBin(charToRaw(genBaseTheme()), con) + close(con) + } else { + # TODO replace with seq_len() or seq_along() + lapply(seq_len(nThemes), function(i) { + con <- file(file.path(xlthemeDir, stri_join("theme", i, ".xml")), open = "wb") + writeBin(charToRaw(pxml(self$theme[[i]])), con) + close(con) + }) + } + + + ## Content types has entries of all xml files in the workbook + ct <- self$Content_Types + + + ## will always have drawings + xlworksheetsDir <- dir_create(tmpDir, "xl", "worksheets") + xlworksheetsRelsDir <- dir_create(tmpDir, "xl", "worksheets", "_rels") + xldrawingsDir <- dir_create(tmpDir, "xl", "drawings") + xldrawingsRelsDir <- dir_create(tmpDir, "xl", "drawings", "_rels") + xlchartsDir <- dir_create(tmpDir, "xl", "charts") + xlchartsRelsDir <- dir_create(tmpDir, "xl", "charts", "_rels") + + ## xl/comments.xml + if (nComments > 0 | nVML > 0) { + + cmts <- rbindlist(xml_attr(unlist(self$worksheets_rels), "Relationship")) + cmts$target <- basename(cmts$Target) + cmts$typ <- basename(cmts$Type) + cmts <- cmts[cmts$typ == "comments", ] + cmts$id <- as.integer(gsub("\\D+", "", cmts$target)) + + sel <- vapply(self$comments, function(x) length(x) > 0, NA) + comments <- self$comments[sel] + + if (length(cmts$id) != length(comments)) + warning("comments length != comments ids") + + # TODO use seq_len() or seq_along()? + for (i in seq_along(comments)) { + fn <- sprintf("comments%s.xml", cmts$id[i]) + + write_comment_xml( + comment_list = comments[[i]], + file_name = file.path(tmpDir, "xl", fn) + ) + } + + private$writeDrawingVML(xldrawingsDir, xldrawingsRelsDir) + } + + ## Threaded Comments xl/threadedComments/threadedComment.xml + if (nThreadComments > 0) { + xlThreadComments <- dir_create(tmpDir, "xl", "threadedComments") + + for (i in seq_len(nSheets)) { + if (length(self$threadComments[[i]])) { + fl <- self$threadComments[[i]] + file.copy( + from = fl, + to = file.path(xlThreadComments, basename(fl)), + overwrite = TRUE, + copy.date = TRUE + ) + } + } + } + + ## xl/persons/person.xml + if (nPersons) { + personDir <- dir_create(tmpDir, "xl", "persons") + file.copy(self$persons, personDir, overwrite = TRUE) + } + + + + if (length(self$embeddings)) { + embeddingsDir <- dir_create(tmpDir, "xl", "embeddings") + for (fl in self$embeddings) { + file.copy(fl, embeddingsDir, overwrite = TRUE) + } + } + + + if (nPivots > 0) { + # TODO consider just making a function to create a bunch of directories + # and return as a named list? Easier/cleaner than checking for each + # element if we just go seq_along()? + pivotTablesDir <- dir_create(tmpDir, "xl", "pivotTables") + pivotTablesRelsDir <- dir_create(tmpDir, "xl", "pivotTables", "_rels") + pivotCacheDir <- dir_create(tmpDir, "xl", "pivotCache") + pivotCacheRelsDir <- dir_create(tmpDir, "xl", "pivotCache", "_rels") + + file_copy_wb_save(self$pivotTables, "pivotTable%i.xml", pivotTablesDir) + file_copy_wb_save(self$pivotDefinitions, "pivotCacheDefinition%i.xml", pivotCacheDir) + file_copy_wb_save(self$pivotRecords, "pivotCacheRecords%i.xml", pivotCacheDir) + file_copy_wb_save(self$pivotDefinitionsRels, "pivotCacheDefinition%i.xml.rels", pivotCacheRelsDir) + + for (i in seq_along(self$pivotTables.xml.rels)) { + write_file( + body = self$pivotTables.xml.rels[[i]], + fl = file.path(pivotTablesRelsDir, sprintf("pivotTable%s.xml.rels", i)) + ) + } + } + + ## slicers + if (nSlicers) { + slicersDir <- dir_create(tmpDir, "xl", "slicers") + slicerCachesDir <- dir_create(tmpDir, "xl", "slicerCaches") + + slicer <- self$slicers[self$slicers != ""] + for (i in seq_along(slicer)) { + write_file( + body = slicer[i], + fl = file.path(slicersDir, sprintf("slicer%s.xml", i)) + ) + } + + for (i in seq_along(self$slicerCaches)) { + write_file( + body = self$slicerCaches[[i]], + fl = file.path(slicerCachesDir, sprintf("slicerCache%s.xml", i)) + ) + } + } + + + ## Write content + + # if custom is present, we need 4 relationships, otherwise 3 + + Ids <- c("rId3", "rId2", "rId1") + Types <- c( + "http://schemas.openxmlformats.org/officeDocument/2006/relationships/extended-properties", + "http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties", + "http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument" + ) + Targets <- c("docProps/app.xml", "docProps/core.xml", "xl/workbook.xml") + + if (length(self$custom)) { + Ids <- c(Ids, "rId4") + Types <- c( + Types, + "http://schemas.openxmlformats.org/officeDocument/2006/relationships/custom-properties" + ) + Targets <- c(Targets, "docProps/custom.xml") + } + + relship <- df_to_xml("Relationship", + data.frame(Id = Ids, Type = Types, Target = Targets, stringsAsFactors = FALSE) + ) + + + ## write .rels + write_file( + head = '\n', + body = pxml(relship), + tail = "", + fl = file.path(relsDir, ".rels") + ) + + app <- "Microsoft Excel" + # further protect argument (might be extended with: , , , , , , ) + if (!is.null(self$apps)) app <- paste0(app, self$apps) + + ## write app.xml + if (length(self$app) == 0) { + write_file( + head = '', + body = app, + tail = "", + fl = file.path(docPropsDir, "app.xml") + ) + } else { + write_file( + head = '', + body = pxml(self$app), + tail = '', + fl = file.path(docPropsDir, "app.xml") + ) + } + + ## write core.xml + write_file( + head = "", + body = pxml(self$core), + tail = "", + fl = file.path(docPropsDir, "core.xml") + ) + + + ## write core.xml + if (length(self$custom)) { + write_file( + head = "", + body = pxml(self$custom), + tail = "", + fl = file.path(docPropsDir, "custom.xml") + ) + } + + ## write workbook.xml.rels + write_file( + head = '', + body = pxml(self$workbook.xml.rels), + tail = "", + fl = file.path(xlrelsDir, "workbook.xml.rels") + ) + + ## write tables + + ## update tables in content types (some have been added, some removed, get the final state) + default <- xml_node(ct, "Default") + override <- rbindlist(xml_attr(ct, "Override")) + override$typ <- gsub(".xml$", "", basename(override$PartName)) + override <- override[!grepl("table", override$typ), ] + override$typ <- NULL + + # TODO remove length() check since we have seq_along() + if (any(self$tables$tab_act == 1)) { + + # TODO get table Id from table entry + table_ids <- function() { + z <- 0 + if (!all(identical(unlist(self$worksheets_rels), character()))) { + relship <- rbindlist(xml_attr(unlist(self$worksheets_rels), "Relationship")) + relship$typ <- basename(relship$Type) + relship$tid <- as.numeric(gsub("\\D+", "", relship$Target)) + + z <- sort(relship$tid[relship$typ == "table"]) + } + z + } + + tab_ids <- table_ids() + + for (i in seq_along(tab_ids)) { + + # select only active tabs. in future there should only be active tabs + tabs <- self$tables[self$tables$tab_act == 1, ] + + if (NROW(tabs)) { + write_file( + body = pxml(tabs$tab_xml[i]), + fl = file.path(xlTablesDir, sprintf("table%s.xml", tab_ids[i])) + ) + + ## add entry to content_types as well + override <- rbind( + override, + # new entry for table + c("application/vnd.openxmlformats-officedocument.spreadsheetml.table+xml", + sprintf("/xl/tables/table%s.xml", tab_ids[i])) + ) + + if (self$tables.xml.rels[[i]] != "") { + write_file( + body = self$tables.xml.rels[[i]], + fl = file.path(xlTablesRelsDir, sprintf("table%s.xml.rels", tab_ids[i])) + ) + } + } + } + + } + + ## ct is updated as xml + ct <- c(default, df_to_xml(name = "Override", df_col = override[c("PartName", "ContentType")])) + + + ## write query tables + if (length(self$queryTables)) { + xlqueryTablesDir <- dir_create(tmpDir, "xl", "queryTables") + + for (i in seq_along(self$queryTables)) { + write_file( + body = self$queryTables[[i]], + fl = file.path(xlqueryTablesDir, sprintf("queryTable%s.xml", i)) + ) + } + } + + ## connections + if (length(self$connections)) { + write_file(body = self$connections, fl = file.path(xlDir, "connections.xml")) + } + + ## connections + if (length(self$ctrlProps)) { + ctrlPropsDir <- dir_create(tmpDir, "xl", "ctrlProps") + + for (i in seq_along(self$ctrlProps)) { + write_file(body = self$ctrlProps[i], fl = file.path(ctrlPropsDir, sprintf("ctrlProp%i.xml", i))) + } + } + + if (length(self$customXml)) { + customXmlDir <- dir_create(tmpDir, "customXml") + customXmlRelsDir <- dir_create(tmpDir, "customXml", "_rels") + for (fl in self$customXml[!grepl(".xml.rels$", self$customXml)]) { + file.copy(fl, customXmlDir, overwrite = TRUE) + } + for (fl in self$customXml[grepl(".xml.rels$", self$customXml)]) { + file.copy(fl, customXmlRelsDir, overwrite = TRUE) + } + } + + ## externalLinks + if (length(self$externalLinks)) { + externalLinksDir <- dir_create(tmpDir, "xl", "externalLinks") + + for (i in seq_along(self$externalLinks)) { + write_file( + body = self$externalLinks[[i]], + fl = file.path(externalLinksDir, sprintf("externalLink%s.xml", i)) + ) + } + } + + ## externalLinks rels + if (length(self$externalLinksRels)) { + externalLinksRelsDir <- dir_create(tmpDir, "xl", "externalLinks", "_rels") + + for (i in seq_along(self$externalLinksRels)) { + write_file( + body = self$externalLinksRels[[i]], + fl = file.path( + externalLinksRelsDir, + sprintf("externalLink%s.xml.rels", i) + ) + ) + } + } + + ## media (copy file from origin to destination) + # TODO replace with seq_along() + for (x in self$media) { + file.copy(x, file.path(xlmediaDir, names(self$media)[which(self$media == x)])) + } + + ## VBA Macro + if (!is.null(self$vbaProject)) { + file.copy(self$vbaProject, xlDir) + } + + ## write worksheet, worksheet_rels, drawings, drawing_rels + ct <- private$writeSheetDataXML( + ct, + xldrawingsDir, + xldrawingsRelsDir, + xlchartsDir, + xlchartsRelsDir, + xlworksheetsDir, + xlworksheetsRelsDir + ) + + ## write sharedStrings.xml + if (length(self$sharedStrings)) { + write_file( + head = sprintf( + '', + length(self$sharedStrings), + attr(self$sharedStrings, "uniqueCount") + ), + #body = stri_join(set_sst(attr(self$sharedStrings, "text")), collapse = "", sep = " "), + body = stri_join(self$sharedStrings, collapse = "", sep = ""), + tail = "", + fl = file.path(xlDir, "sharedStrings.xml") + ) + } else { + ## Remove relationship to sharedStrings + ct <- ct[!grepl("sharedStrings", ct)] + } + + if (nComments > 0) { + ct <- c( + ct, + # TODO this default extension is most likely wrong here and should be set when searching for and writing the vml entrys + '', + sprintf('', seq_len(nComments) + ) + ) + } + + ## do not write updated content types to self + # self$Content_Types <- ct + + ## write [Content_type] + write_file( + head = '', + body = pxml(unique(ct)), + tail = "", + fl = file.path(tmpDir, "[Content_Types].xml") + ) + + + styleXML <- self$styles_mgr$styles + if (length(styleXML$numFmts)) { + styleXML$numFmts <- + stri_join( + sprintf('', length(styleXML$numFmts)), + pxml(styleXML$numFmts), + "" + ) + } + styleXML$fonts <- + stri_join( + sprintf('', length(styleXML$fonts)), + pxml(styleXML$fonts), + "" + ) + styleXML$fills <- + stri_join( + sprintf('', length(styleXML$fills)), + pxml(styleXML$fills), + "" + ) + styleXML$borders <- + stri_join( + sprintf('', length(styleXML$borders)), + pxml(styleXML$borders), + "" + ) + styleXML$cellStyleXfs <- + c( + sprintf('', length(styleXML$cellStyleXfs)), + pxml(styleXML$cellStyleXfs), + "" + ) + styleXML$cellXfs <- + stri_join( + sprintf('', length(styleXML$cellXfs)), + paste0(styleXML$cellXfs, collapse = ""), + "" + ) + styleXML$cellStyles <- + stri_join( + sprintf('', length(styleXML$cellStyles)), + pxml(styleXML$cellStyles), + "" + ) + # styleXML$cellStyles <- + # stri_join( + # pxml(self$styles_mgr$tableStyles) + # ) + # TODO + # tableStyles + # extLst + + styleXML$dxfs <- + if (length(styleXML$dxfs)) { + stri_join( + sprintf('', length(styleXML$dxfs)), + stri_join(unlist(styleXML$dxfs), sep = " ", collapse = ""), + "" + ) + } else { + '' + } + + ## write styles.xml + if (length(unlist(self$styles_mgr$styles))) { + write_file( + head = '', + body = pxml(styleXML), + tail = "", + fl = file.path(xlDir, "styles.xml") + ) + } else { + write_file( + head = '', + body = '', + tail = '', + fl = file.path(xlDir, "styles.xml") + ) + } + + if (length(self$calcChain)) { + write_file( + head = '', + body = pxml(self$calcChain), + tail = "", + fl = file.path(xlDir, "calcChain.xml") + ) + } + + # write metadata file. required if cm attribut is set. + if (length(self$metadata)) { + write_file( + head = '', + body = self$metadata, + tail = '', + fl = file.path(xlDir, "metadata.xml") + ) + } + + ## write workbook.xml + workbookXML <- self$workbook + workbookXML$sheets <- stri_join("", pxml(workbookXML$sheets), "") + + if (length(workbookXML$definedNames)) { + workbookXML$definedNames <- stri_join("", pxml(workbookXML$definedNames), "") + } + + # openxml 2.8.1 expects the following order of xml nodes. While we create this per default, it is not + # assured that the order of entries is still valid when we write the file. Functions can change the + # workbook order, therefore we have to make sure that the expected order is written. + # Othterwise spreadsheet software will complain. + workbook_openxml281 <- c( + "fileVersion", "fileSharing", "workbookPr", "alternateContent", "revisionPtr", "absPath", + "workbookProtection", "bookViews", "sheets", "functionGroups", "externalReferences", + "definedNames", "calcPr", "oleSize", "customWorkbookViews", "pivotCaches", "smartTagPr", + "smartTagTypes", "webPublishing", "fileRecoveryPr", "webPublishObjects", "extLst" + ) + + write_file( + head = '', + body = pxml(workbookXML[workbook_openxml281]), + tail = "", + fl = file.path(xlDir, "workbook.xml") + ) + + ## Need to reset sheet order to allow multiple savings + self$workbook$sheets <- self$workbook$sheets[order(self$sheetOrder)] + + ## compress to xlsx + + # TODO make self$vbaProject be TRUE/FALSE + tmpFile <- tempfile(tmpdir = tmpDir, fileext = if (isTRUE(self$vbaProject)) ".xlsm" else ".xlsx") + + ## zip it + zip::zip( + zipfile = tmpFile, + files = list.files(tmpDir, full.names = FALSE), + recurse = TRUE, + compression_level = getOption("openxlsx2.compresssionevel", 6), + include_directories = FALSE, + # change the working directory for this + root = tmpDir, + # change default to match historical zipr + mode = "cherry-pick" + ) + + # Copy file; stop if failed + if (!file.copy(from = tmpFile, to = path, overwrite = overwrite, copy.mode = FALSE)) { + stop("Failed to save workbook") + } + + # (re)assign file path (if successful) + self$path <- path + invisible(self) +} diff --git a/R/class-workbook-sheet-names.R b/R/class-workbook-sheet-names.R new file mode 100644 index 000000000..d4ec9f0fe --- /dev/null +++ b/R/class-workbook-sheet-names.R @@ -0,0 +1,67 @@ +wb_get_sheet_names_impl <- function(self, private) { + res <- self$sheet_names + names(res) <- private$original_sheet_names + res[self$sheetOrder] +} + +wb_set_sheet_names_impl <- function(self, private, old = NULL, new) { + # assume all names. Default values makes the test check for wrappers a + # little weird + old <- old %||% seq_along(self$sheet_names) + + if (identical(old, new)) { + return(self) + } + + if (!length(self$worksheets)) { + stop("workbook does not contain any sheets") + } + + if (length(old) != length(new)) { + stop("`old` and `new` must be the same length") + } + + pos <- private$get_sheet_index(old) + new_raw <- as.character(new) + new_name <- replace_legal_chars(new_raw) + + if (identical(self$sheet_names[pos], new_name)) { + return(self) + } + + bad <- duplicated(tolower(new)) + if (any(bad)) { + stop("Sheet names cannot have duplicates: ", toString(new[bad])) + } + + # should be able to pull this out into a single private function + for (i in seq_along(pos)) { + private$validate_new_sheet(new_name[i]) + private$set_single_sheet_name(pos[i], new_name[i], new_raw[i]) + # TODO move this work into private$set_single_sheet_name() + + ## Rename in workbook + sheetId <- private$get_sheet_id(type = "sheetId", pos[i]) + rId <- private$get_sheet_id(type = 'rId', pos[i]) + self$workbook$sheets[[pos[i]]] <- + sprintf( + '', + new_name[i], + sheetId, + rId + ) + + ## rename defined names + if (length(self$workbook$definedNames)) { + ind <- get_named_regions(self)$sheets == old + if (any(ind)) { + nn <- sprintf("'%s'", new_name[i]) + nn <- stringi::stri_replace_all_fixed(self$workbook$definedName[ind], old, nn) + nn <- stringi::stri_replace_all(nn, "'+", "'") + self$workbook$definedNames[ind] <- nn + } + } + } + + invisible(self) +} diff --git a/R/class-workbook-sheet-styles.R b/R/class-workbook-sheet-styles.R new file mode 100644 index 000000000..e7f508401 --- /dev/null +++ b/R/class-workbook-sheet-styles.R @@ -0,0 +1,759 @@ +wb_add_border_impl <- function( + self, + private, + sheet = current_sheet(), + dims = "A1", + bottom_color = wb_colour(hex = "FF000000"), + left_color = wb_colour(hex = "FF000000"), + right_color = wb_colour(hex = "FF000000"), + top_color = wb_colour(hex = "FF000000"), + bottom_border = "thin", + left_border = "thin", + right_border = "thin", + top_border = "thin", + inner_hgrid = NULL, + inner_hcolor = NULL, + inner_vgrid = NULL, + inner_vcolor = NULL +) { + + # TODO merge styles and if a style is already present, only add the newly + # created border style + + # cc <- wb$worksheets[[sheet]]$sheet_data$cc + # df_s <- as.data.frame(lapply(df, function(x) cc$c_s[cc$r %in% x])) + + df <- dims_to_dataframe(dims, fill = TRUE) + sheet <- private$get_sheet_index(sheet) + + private$do_cell_init(sheet, dims) + + ### beg border creation + full_single <- create_border( + top = top_border, top_color = top_color, + bottom = bottom_border, bottom_color = bottom_color, + left = left_border, left_color = left_color, + right = left_border, right_color = right_color + ) + + top_single <- create_border( + top = top_border, top_color = top_color, + bottom = inner_hgrid, bottom_color = inner_hcolor, + left = left_border, left_color = left_color, + right = left_border, right_color = right_color + ) + + middle_single <- create_border( + top = inner_hgrid, top_color = inner_hcolor, + bottom = inner_hgrid, bottom_color = inner_hcolor, + left = left_border, left_color = left_color, + right = left_border, right_color = right_color + ) + + bottom_single <- create_border( + top = inner_hgrid, top_color = inner_hcolor, + bottom = bottom_border, bottom_color = bottom_color, + left = left_border, left_color = left_color, + right = left_border, right_color = right_color + ) + + left_single <- create_border( + top = top_border, top_color = top_color, + bottom = bottom_border, bottom_color = bottom_color, + left = left_border, left_color = left_color, + right = inner_vgrid, right_color = inner_vcolor + ) + + right_single <- create_border( + top = top_border, top_color = top_color, + bottom = bottom_border, bottom_color = bottom_color, + left = inner_vgrid, left_color = inner_vcolor, + right = right_border, right_color = right_color + ) + + center_single <- create_border( + top = top_border, top_color = top_color, + bottom = bottom_border, bottom_color = bottom_color, + left = inner_vgrid, left_color = inner_vcolor, + right = inner_vgrid, right_color = inner_vcolor + ) + + top_left <- create_border( + top = top_border, top_color = top_color, + bottom = inner_hgrid, bottom_color = inner_hcolor, + left = left_border, left_color = left_color, + right = inner_vgrid, right_color = inner_vcolor + ) + + top_right <- create_border( + top = top_border, top_color = top_color, + bottom = inner_hgrid, bottom_color = inner_hcolor, + left = inner_vgrid, left_color = inner_vcolor, + right = left_border, right_color = right_color + ) + + bottom_left <- create_border( + top = inner_hgrid, top_color = inner_hcolor, + bottom = bottom_border, bottom_color = bottom_color, + left = left_border, left_color = left_color, + right = inner_vgrid, right_color = inner_vcolor + ) + + bottom_right <- create_border( + top = inner_hgrid, top_color = inner_hcolor, + bottom = bottom_border, bottom_color = bottom_color, + left = inner_vgrid, left_color = inner_vcolor, + right = left_border, right_color = right_color + ) + + top_center <- create_border( + top = top_border, top_color = top_color, + bottom = inner_hgrid, bottom_color = inner_hcolor, + left = inner_vgrid, left_color = inner_vcolor, + right = inner_vgrid, right_color = inner_vcolor + ) + + bottom_center <- create_border( + top = inner_hgrid, top_color = inner_hcolor, + bottom = bottom_border, bottom_color = bottom_color, + left = inner_vgrid, left_color = inner_vcolor, + right = inner_vgrid, right_color = inner_vcolor + ) + + middle_left <- create_border( + top = inner_hgrid, top_color = inner_hcolor, + bottom = inner_hgrid, bottom_color = inner_hcolor, + left = left_border, left_color = left_color, + right = inner_vgrid, right_color = inner_vcolor + ) + + middle_right <- create_border( + top = inner_hgrid, top_color = inner_hcolor, + bottom = inner_hgrid, bottom_color = inner_hcolor, + left = inner_vgrid, left_color = inner_vcolor, + right = right_border, right_color = right_color + ) + + inner_cell <- create_border( + top = inner_hgrid, top_color = inner_hcolor, + bottom = inner_hgrid, bottom_color = inner_hcolor, + left = inner_vgrid, left_color = inner_vcolor, + right = inner_vgrid, right_color = inner_vcolor + ) + ### end border creation + + # + # /* top_single */ + # /* middle_single */ + # /* bottom_single */ + # + + # /* left_single --- center_single --- right_single */ + + # + # /* top_left --- top_center --- top_right */ + # /* - - */ + # /* - - */ + # /* - - */ + # /* left_middle right_middle */ + # /* - - */ + # /* - - */ + # /* - - */ + # /* left_bottom - bottom_center - bottom_right */ + # + + ## beg cell references + if (ncol(df) == 1 && nrow(df) == 1) + dim_full_single <- df[1, 1] + + if (ncol(df) == 1 && nrow(df) >= 2) { + dim_top_single <- df[1, 1] + dim_bottom_single <- df[nrow(df), 1] + if (nrow(df) >= 3) { + mid <- df[, 1] + dim_middle_single <- mid[!mid %in% c(dim_top_single, dim_bottom_single)] + } + } + + if (ncol(df) >= 2 && nrow(df) == 1) { + dim_left_single <- df[1, 1] + dim_right_single <- df[1, ncol(df)] + if (ncol(df) >= 3) { + ctr <- df[1, ] + dim_center_single <- ctr[!ctr %in% c(dim_left_single, dim_right_single)] + } + } + + if (ncol(df) >= 2 && nrow(df) >= 2) { + dim_top_left <- df[1, 1] + dim_bottom_left <- df[nrow(df), 1] + dim_top_right <- df[1, ncol(df)] + dim_bottom_right <- df[nrow(df), ncol(df)] + + if (nrow(df) >= 3) { + top_mid <- df[, 1] + bottom_mid <- df[, ncol(df)] + + dim_middle_left <- top_mid[!top_mid %in% c(dim_top_left, dim_bottom_left)] + dim_middle_right <- bottom_mid[!bottom_mid %in% c(dim_top_right, dim_bottom_right)] + } + + if (ncol(df) >= 3) { + top_ctr <- df[1, ] + bottom_ctr <- df[nrow(df), ] + + dim_top_center <- top_ctr[!top_ctr %in% c(dim_top_left, dim_top_right)] + dim_bottom_center <- bottom_ctr[!bottom_ctr %in% c(dim_bottom_left, dim_bottom_right)] + } + + if (ncol(df) > 2 && nrow(df) > 2) { + t_row <- 1 + b_row <- nrow(df) + l_row <- 1 + r_row <- ncol(df) + dim_inner_cell <- as.character(unlist(df[c(-t_row, -b_row), c(-l_row, -r_row)])) + } + } + ### end cell references + + # add some random string to the name. if called multiple times, new + # styles will be created. We do not look for identical styles, therefor + # we might create duplicates, but if a single style changes, the rest of + # the workbook remains valid. + smp <- random_string() + s <- function(x) paste0(smp, "s", deparse(substitute(x)), seq_along(x)) + sfull_single <- paste0(smp, "full_single") + stop_single <- paste0(smp, "full_single") + sbottom_single <- paste0(smp, "bottom_single") + smiddle_single <- paste0(smp, "middle_single") + sleft_single <- paste0(smp, "left_single") + sright_single <- paste0(smp, "right_single") + scenter_single <- paste0(smp, "center_single") + stop_left <- paste0(smp, "top_left") + stop_right <- paste0(smp, "top_right") + sbottom_left <- paste0(smp, "bottom_left") + sbottom_right <- paste0(smp, "bottom_right") + smiddle_left <- paste0(smp, "middle_left") + smiddle_right <- paste0(smp, "middle_right") + stop_center <- paste0(smp, "top_center") + sbottom_center <- paste0(smp, "bottom_center") + sinner_cell <- paste0(smp, "inner_cell") + + # ncol == 1 + if (ncol(df) == 1) { + + # single cell + if (nrow(df) == 1) { + self$styles_mgr$add(full_single, sfull_single) + xf_prev <- get_cell_styles(self, sheet, dims) + xf_full_single <- set_border(xf_prev, self$styles_mgr$get_border_id(sfull_single)) + self$styles_mgr$add(xf_full_single, xf_full_single) + self$set_cell_style(sheet, dims, self$styles_mgr$get_xf_id(xf_full_single)) + } + + # create top & bottom piece + if (nrow(df) >= 2) { + + # top single + self$styles_mgr$add(top_single, stop_single) + xf_prev <- get_cell_styles(self, sheet, dim_top_single) + xf_top_single <- set_border(xf_prev, self$styles_mgr$get_border_id(stop_single)) + self$styles_mgr$add(xf_top_single, xf_top_single) + self$set_cell_style(sheet, dim_top_single, self$styles_mgr$get_xf_id(xf_top_single)) + + # bottom single + self$styles_mgr$add(bottom_single, sbottom_single) + xf_prev <- get_cell_styles(self, sheet, dim_bottom_single) + xf_bottom_single <- set_border(xf_prev, self$styles_mgr$get_border_id(sbottom_single)) + self$styles_mgr$add(xf_bottom_single, xf_bottom_single) + self$set_cell_style(sheet, dim_bottom_single, self$styles_mgr$get_xf_id(xf_bottom_single)) + } + + # create middle piece(s) + if (nrow(df) >= 3) { + + # middle single + self$styles_mgr$add(middle_single, smiddle_single) + xf_prev <- get_cell_styles(self, sheet, dim_middle_single) + xf_middle_single <- set_border(xf_prev, self$styles_mgr$get_border_id(smiddle_single)) + self$styles_mgr$add(xf_middle_single, xf_middle_single) + self$set_cell_style(sheet, dim_middle_single, self$styles_mgr$get_xf_id(xf_middle_single)) + } + + } + + # create left and right single row pieces + if (ncol(df) >= 2 && nrow(df) == 1) { + + # left single + self$styles_mgr$add(left_single, sleft_single) + xf_prev <- get_cell_styles(self, sheet, dim_left_single) + xf_left_single <- set_border(xf_prev, self$styles_mgr$get_border_id(sleft_single)) + self$styles_mgr$add(xf_left_single, xf_left_single) + self$set_cell_style(sheet, dim_left_single, self$styles_mgr$get_xf_id(xf_left_single)) + + # right single + self$styles_mgr$add(right_single, sright_single) + xf_prev <- get_cell_styles(self, sheet, dim_right_single) + xf_right_single <- set_border(xf_prev, self$styles_mgr$get_border_id(sright_single)) + self$styles_mgr$add(xf_right_single, xf_right_single) + self$set_cell_style(sheet, dim_right_single, self$styles_mgr$get_xf_id(xf_right_single)) + + # add single center piece(s) + if (ncol(df) >= 3) { + + # center single + self$styles_mgr$add(center_single, scenter_single) + xf_prev <- get_cell_styles(self, sheet, dim_center_single) + xf_center_single <- set_border(xf_prev, self$styles_mgr$get_border_id(scenter_single)) + self$styles_mgr$add(xf_center_single, xf_center_single) + self$set_cell_style(sheet, dim_center_single, self$styles_mgr$get_xf_id(xf_center_single)) + } + + } + + # create left & right - top & bottom corners pieces + if (ncol(df) >= 2 && nrow(df) >= 2) { + + # top left + self$styles_mgr$add(top_left, stop_left) + xf_prev <- get_cell_styles(self, sheet, dim_top_left) + xf_top_left <- set_border(xf_prev, self$styles_mgr$get_border_id(stop_left)) + self$styles_mgr$add(xf_top_left, xf_top_left) + self$set_cell_style(sheet, dim_top_left, self$styles_mgr$get_xf_id(xf_top_left)) + + # top right + self$styles_mgr$add(top_right, stop_right) + xf_prev <- get_cell_styles(self, sheet, dim_top_right) + xf_top_right <- set_border(xf_prev, self$styles_mgr$get_border_id(stop_right)) + self$styles_mgr$add(xf_top_right, xf_top_right) + self$set_cell_style(sheet, dim_top_right, self$styles_mgr$get_xf_id(xf_top_right)) + + # bottom left + self$styles_mgr$add(bottom_left, sbottom_left) + xf_prev <- get_cell_styles(self, sheet, dim_bottom_left) + xf_bottom_left <- set_border(xf_prev, self$styles_mgr$get_border_id(sbottom_left)) + self$styles_mgr$add(xf_bottom_left, xf_bottom_left) + self$set_cell_style(sheet, dim_bottom_left, self$styles_mgr$get_xf_id(xf_bottom_left)) + + # bottom right + self$styles_mgr$add(bottom_right, sbottom_right) + xf_prev <- get_cell_styles(self, sheet, dim_bottom_right) + xf_bottom_right <- set_border(xf_prev, self$styles_mgr$get_border_id(sbottom_right)) + self$styles_mgr$add(xf_bottom_right, xf_bottom_right) + self$set_cell_style(sheet, dim_bottom_right, self$styles_mgr$get_xf_id(xf_bottom_right)) + } + + # create left and right middle pieces + if (ncol(df) >= 2 && nrow(df) >= 3) { + + # middle left + self$styles_mgr$add(middle_left, smiddle_left) + xf_prev <- get_cell_styles(self, sheet, dim_middle_left) + xf_middle_left <- set_border(xf_prev, self$styles_mgr$get_border_id(smiddle_left)) + self$styles_mgr$add(xf_middle_left, xf_middle_left) + self$set_cell_style(sheet, dim_middle_left, self$styles_mgr$get_xf_id(xf_middle_left)) + + # middle right + self$styles_mgr$add(middle_right, smiddle_right) + xf_prev <- get_cell_styles(self, sheet, dim_middle_right) + xf_middle_right <- set_border(xf_prev, self$styles_mgr$get_border_id(smiddle_right)) + self$styles_mgr$add(xf_middle_right, xf_middle_right) + self$set_cell_style(sheet, dim_middle_right, self$styles_mgr$get_xf_id(xf_middle_right)) + } + + # create top and bottom center pieces + if (ncol(df) >= 3 & nrow(df) >= 2) { + + # top center + self$styles_mgr$add(top_center, stop_center) + xf_prev <- get_cell_styles(self, sheet, dim_top_center) + xf_top_center <- set_border(xf_prev, self$styles_mgr$get_border_id(stop_center)) + self$styles_mgr$add(xf_top_center, xf_top_center) + self$set_cell_style(sheet, dim_top_center, self$styles_mgr$get_xf_id(xf_top_center)) + + # bottom center + self$styles_mgr$add(bottom_center, sbottom_center) + xf_prev <- get_cell_styles(self, sheet, dim_bottom_center) + xf_bottom_center <- set_border(xf_prev, self$styles_mgr$get_border_id(sbottom_center)) + self$styles_mgr$add(xf_bottom_center, xf_bottom_center) + self$set_cell_style(sheet, dim_bottom_center, self$styles_mgr$get_xf_id(xf_bottom_center)) + } + + if (nrow(df) > 2 && ncol(df) > 2) { + + # inner cells + self$styles_mgr$add(inner_cell, sinner_cell) + xf_prev <- get_cell_styles(self, sheet, dim_inner_cell) + xf_inner_cell <- set_border(xf_prev, self$styles_mgr$get_border_id(sinner_cell)) + self$styles_mgr$add(xf_inner_cell, xf_inner_cell) + self$set_cell_style(sheet, dim_inner_cell, self$styles_mgr$get_xf_id(xf_inner_cell)) + } + + invisible(self) +} + +wb_add_fill_impl <- function( + self, + private, + sheet = current_sheet(), + dims = "A1", + color = wb_colour(hex = "FFFFFF00"), + pattern = "solid", + gradient_fill = "", + every_nth_col = 1, + every_nth_row = 1 +) { + sheet <- private$get_sheet_index(sheet) + private$do_cell_init(sheet, dims) + + # dim in dataframe can contain various styles. go cell by cell. + did <- dims_to_dataframe(dims, fill = TRUE) + # select a few cols and rows to fill + cols <- (seq_len(ncol(did)) %% every_nth_col) == 0 + rows <- (seq_len(nrow(did)) %% every_nth_row) == 0 + + dims <- unname(unlist(did[rows, cols, drop = FALSE])) + + cc <- self$worksheets[[sheet]]$sheet_data$cc + cc <- cc[cc$r %in% dims, ] + styles <- unique(cc[["c_s"]]) + + for (style in styles) { + dim <- cc[cc$c_s == style, "r"] + + new_fill <- create_fill( + gradientFill = gradient_fill, + patternType = pattern, + fgColor = color + ) + self$styles_mgr$add(new_fill, new_fill) + + xf_prev <- get_cell_styles(self, sheet, dim[[1]]) + xf_new_fill <- set_fill(xf_prev, self$styles_mgr$get_fill_id(new_fill)) + self$styles_mgr$add(xf_new_fill, xf_new_fill) + s_id <- self$styles_mgr$get_xf_id(xf_new_fill) + self$set_cell_style(sheet, dim, s_id) + } + + invisible(self) +} + +wb_add_font_impl <- function( + self, + private, + sheet = current_sheet(), + dims = "A1", + name = "Calibri", + color = wb_colour(hex = "FF000000"), + size = "11", + bold = "", + italic = "", + outline = "", + strike = "", + underline = "", + # fine tuning + charset = "", + condense = "", + extend = "", + family = "", + scheme = "", + shadow = "", + vertAlign = "" +) { + sheet <- private$get_sheet_index(sheet) + private$do_cell_init(sheet, dims) + + did <- dims_to_dataframe(dims, fill = TRUE) + dims <- unname(unlist(did)) + + cc <- self$worksheets[[sheet]]$sheet_data$cc + cc <- cc[cc$r %in% dims, ] + styles <- unique(cc[["c_s"]]) + + for (style in styles) { + dim <- cc[cc$c_s == style, "r"] + + new_font <- create_font( + b = bold, + charset = charset, + color = color, + condense = condense, + extend = extend, + family = family, + i = italic, + name = name, + outline = outline, + scheme = scheme, + shadow = shadow, + strike = strike, + sz = size, + u = underline, + vertAlign = vertAlign + ) + self$styles_mgr$add(new_font, new_font) + + xf_prev <- get_cell_styles(self, sheet, dim[[1]]) + xf_new_font <- set_font(xf_prev, self$styles_mgr$get_font_id(new_font)) + + self$styles_mgr$add(xf_new_font, xf_new_font) + s_id <- self$styles_mgr$get_xf_id(xf_new_font) + self$set_cell_style(sheet, dim, s_id) + } + + invisible(self) +} + +wb_add_numfmt_impl <- function( + self, + private, + sheet = current_sheet(), + dims = "A1", + numfmt +) { + sheet <- private$get_sheet_index(sheet) + private$do_cell_init(sheet, dims) + + did <- dims_to_dataframe(dims, fill = TRUE) + dims <- unname(unlist(did)) + + cc <- self$worksheets[[sheet]]$sheet_data$cc + cc <- cc[cc$r %in% dims, ] + styles <- unique(cc[["c_s"]]) + + if (inherits(numfmt, "character")) { + + for (style in styles) { + dim <- cc[cc$c_s == style, "r"] + + new_numfmt <- create_numfmt( + numFmtId = self$styles_mgr$next_numfmt_id(), + formatCode = numfmt + ) + self$styles_mgr$add(new_numfmt, new_numfmt) + + xf_prev <- get_cell_styles(self, sheet, dim[[1]]) + xf_new_numfmt <- set_numfmt(xf_prev, self$styles_mgr$get_numfmt_id(new_numfmt)) + self$styles_mgr$add(xf_new_numfmt, xf_new_numfmt) + s_id <- self$styles_mgr$get_xf_id(xf_new_numfmt) + self$set_cell_style(sheet, dim, s_id) + } + + } else { # format is numeric + for (style in styles) { + dim <- cc[cc$c_s == style, "r"] + xf_prev <- get_cell_styles(self, sheet, dim[[1]]) + xf_new_numfmt <- set_numfmt(xf_prev, numfmt) + self$styles_mgr$add(xf_new_numfmt, xf_new_numfmt) + s_id <- self$styles_mgr$get_xf_id(xf_new_numfmt) + self$set_cell_style(sheet, dim, s_id) + } + + } + + invisible(self) +} + +wb_add_cell_style_impl <- function( + self, + private, + sheet = current_sheet(), + dims = "A1", + applyAlignment = NULL, + applyBorder = NULL, + applyFill = NULL, + applyFont = NULL, + applyNumberFormat = NULL, + applyProtection = NULL, + borderId = NULL, + extLst = NULL, + fillId = NULL, + fontId = NULL, + hidden = NULL, + horizontal = NULL, + indent = NULL, + justifyLastLine = NULL, + locked = NULL, + numFmtId = NULL, + pivotButton = NULL, + quotePrefix = NULL, + readingOrder = NULL, + relativeIndent = NULL, + shrinkToFit = NULL, + textRotation = NULL, + vertical = NULL, + wrapText = NULL, + xfId = NULL +) { + sheet <- private$get_sheet_index(sheet) + private$do_cell_init(sheet, dims) + + did <- dims_to_dataframe(dims, fill = TRUE) + dims <- unname(unlist(did)) + + cc <- self$worksheets[[sheet]]$sheet_data$cc + cc <- cc[cc$r %in% dims, ] + styles <- unique(cc[["c_s"]]) + + for (style in styles) { + dim <- cc[cc$c_s == style, "r"] + xf_prev <- get_cell_styles(self, sheet, dim[[1]]) + xf_new_cellstyle <- set_cellstyle( + xf_node = xf_prev, + applyAlignment = applyAlignment, + applyBorder = applyBorder, + applyFill = applyFill, + applyFont = applyFont, + applyNumberFormat = applyNumberFormat, + applyProtection = applyProtection, + borderId = borderId, + extLst = extLst, + fillId = fillId, + fontId = fontId, + hidden = hidden, + horizontal = horizontal, + indent = indent, + justifyLastLine = justifyLastLine, + locked = locked, + numFmtId = numFmtId, + pivotButton = pivotButton, + quotePrefix = quotePrefix, + readingOrder = readingOrder, + relativeIndent = relativeIndent, + shrinkToFit = shrinkToFit, + textRotation = textRotation, + vertical = vertical, + wrapText = wrapText, + xfId = xfId + ) + self$styles_mgr$add(xf_new_cellstyle, xf_new_cellstyle) + s_id <- self$styles_mgr$get_xf_id(xf_new_cellstyle) + self$set_cell_style(sheet, dim, s_id) + } + + invisible(self) +} + +wb_get_cell_style_impl <- function( + self, + private, + sheet = current_sheet(), + dims +) { + if (length(dims) == 1 && grepl(":", dims)) { + dims <- dims_to_dataframe(dims, fill = TRUE) + } + + sheet <- private$get_sheet_index(sheet) + + # This alters the workbook + temp <- self$clone()$.__enclos_env__$private$do_cell_init(sheet, dims) + + # if a range is passed (e.g. "A1:B2") we need to get every cell + dims <- unname(unlist(dims)) + + # TODO check that cc$r is alway valid. not sure atm + sel <- temp$worksheets[[sheet]]$sheet_data$cc$r %in% dims + temp$worksheets[[sheet]]$sheet_data$cc$c_s[sel] +} + +wb_set_cell_style_impl <- function( + self, + private, + sheet = current_sheet(), + dims, + style +) { + if (length(dims) == 1 && grepl(":|;", dims)) + dims <- dims_to_dataframe(dims, fill = TRUE) + + sheet <- private$get_sheet_index(sheet) + private$do_cell_init(sheet, dims) + + # if a range is passed (e.g. "A1:B2") we need to get every cell + dims <- unname(unlist(dims)) + sel <- self$worksheets[[sheet]]$sheet_data$cc$r %in% dims + self$worksheets[[sheet]]$sheet_data$cc$c_s[sel] <- style + invisible(self) +} + +wb_clone_sheet_style_impl = function( + self, + private, + from = current_sheet(), + to +) { + id_org <- private$get_sheet_index(from) + id_new <- private$get_sheet_index(to) + + org_style <- self$worksheets[[id_org]]$sheet_data$cc + wb_style <- self$worksheets[[id_new]]$sheet_data$cc + + # only clone styles from sheets with cc + if (is.null(org_style)) { + message("'from' has no sheet data styles to clone") + } else { + + if (is.null(wb_style)) # if null, create empty dataframe + wb_style <- create_char_dataframe(names(org_style), n = 0) + + # remove all values + org_style <- org_style[c("r", "row_r", "c_r", "c_s")] + + # do not merge c_s and do not create duplicates + merged_style <- merge(org_style, + wb_style[-which(names(wb_style) == "c_s")], + all = TRUE) + merged_style[is.na(merged_style)] <- "" + merged_style <- merged_style[!duplicated(merged_style["r"]), ] + + # will be ordere on save + self$worksheets[[id_new]]$sheet_data$cc <- merged_style + + } + + # copy entire attributes from original sheet to new sheet + org_rows <- self$worksheets[[id_org]]$sheet_data$row_attr + new_rows <- self$worksheets[[id_new]]$sheet_data$row_attr + + if (is.null(org_style)) { + message("'from' has no row styles to clone") + } else { + + if (is.null(new_rows)) + new_rows <- create_char_dataframe(names(org_rows), n = 0) + + # only add the row information, nothing else + merged_rows <- merge(org_rows, + new_rows["r"], + all = TRUE) + merged_rows[is.na(merged_rows)] <- "" + merged_rows <- merged_rows[!duplicated(merged_rows["r"]), ] + ordr <- ordered(order(as.integer(merged_rows$r))) + merged_rows <- merged_rows[ordr, ] + + self$worksheets[[id_new]]$sheet_data$row_attr <- merged_rows + } + + self$worksheets[[id_new]]$cols_attr <- + self$worksheets[[id_org]]$cols_attr + + self$worksheets[[id_new]]$dimension <- + self$worksheets[[id_org]]$dimension + + self$worksheets[[id_new]]$mergeCells <- + self$worksheets[[id_org]]$mergeCells + + invisible(self) +} + +wb_add_sparklines_impl <- function( + self, + private, + sheet = current_sheet(), + sparklines +) { + sheet <- private$get_sheet_index(sheet) + self$worksheets[[sheet]]$add_sparklines(sparklines) + invisible(self) +} diff --git a/R/class-workbook-sheet-visibility.R b/R/class-workbook-sheet-visibility.R new file mode 100644 index 000000000..e816ccc7a --- /dev/null +++ b/R/class-workbook-sheet-visibility.R @@ -0,0 +1,49 @@ +wb_get_sheet_visibility_impl <- function(self, private) { + state <- rep("visible", length(self$workbook$sheets)) + state[grepl("hidden", self$workbook$sheets)] <- "hidden" + state[grepl("veryHidden", self$workbook$sheets, ignore.case = TRUE)] <- "veryHidden" + state +} + +wb_set_sheet_visibility_impl = function( + self, + private, + sheet = current_sheet(), + value +) { + if (length(value) != length(sheet)) { + stop("`value` and `sheet` must be the same length") + } + + sheet <- private$get_sheet_index(sheet) + + value <- tolower(as.character(value)) + value[value %in% "true"] <- "visible" + value[value %in% "false"] <- "hidden" + value[value %in% "veryhidden"] <- "veryHidden" + + exState0 <- reg_match0(self$workbook$sheets[sheet], '(?<=state=")[^"]+') + exState <- tolower(exState0) + exState[exState %in% "true"] <- "visible" + exState[exState %in% "hidden"] <- "hidden" + exState[exState %in% "false"] <- "hidden" + exState[exState %in% "veryhidden"] <- "veryHidden" + + + inds <- which(value != exState) + + if (length(inds) == 0) { + return(invisible(self)) + } + + for (i in seq_along(self$worksheets)) { + self$workbook$sheets[sheet[i]] <- gsub(exState0[i], value[i], self$workbook$sheets[sheet[i]], fixed = TRUE) + } + + if (!any(self$get_sheet_visibility() %in% c("true", "visible"))) { + warning("A workbook must have atleast 1 visible worksheet. Setting first for visible") + self$set_sheet_visibility(1, TRUE) + } + + invisible(self) +} diff --git a/R/class-workbook-tables.R b/R/class-workbook-tables.R new file mode 100644 index 000000000..d3a7edda6 --- /dev/null +++ b/R/class-workbook-tables.R @@ -0,0 +1,78 @@ +wb_get_tables_impl <- function(self, private, sheet = current_sheet()) { + if (length(sheet) != 1) { + stop("sheet argument must be length 1") + } + + if (is.null(self$tables)) { + return(character()) + } + + sheet <- private$get_sheet_index(sheet) + if (is.na(sheet)) stop("No such sheet in workbook") + + sel <- self$tables$tab_sheet == sheet & self$tables$tab_act == 1 + tables <- self$tables$tab_name[sel] + refs <- self$tables$tab_ref[sel] + + if (length(tables)) { + attr(tables, "refs") <- refs + } + + tables +} + +wb_remove_tables_impl <- function( + self, + private, + sheet = current_sheet(), + table +) { + if (length(table) != 1) { + stop("table argument must be length 1") + } + + ## delete table object and all data in it + sheet <- private$get_sheet_index(sheet) + + if (!table %in% self$tables$tab_name) { + stop(sprintf("table '%s' does not exist.", table), call. = FALSE) + } + + ## delete table object (by flagging as deleted) + inds <- self$tables$tab_sheet %in% sheet & self$tables$tab_name %in% table + table_name_original <- self$tables$tab_name[inds] + refs <- self$tables$tab_ref[inds] + + self$tables$tab_name[inds] <- paste0(table_name_original, "_openxlsx_deleted") + self$tables$tab_ref[inds] <- "" + self$tables$tab_sheet[inds] <- 0 + self$tables$tab_xml[inds] <- "" + self$tables$tab_act[inds] <- 0 + + ## delete reference from worksheet to table + worksheet_table_names <- attr(self$worksheets[[sheet]]$tableParts, "tableName") + to_remove <- which(worksheet_table_names == table_name_original) + + # (1) remove the rId from worksheet_rels + rm_tab_rId <- rbindlist(xml_attr(self$worksheets[[sheet]]$tableParts[to_remove], "tablePart"))["r:id"] + ws_rels <- self$worksheets_rels[[sheet]] + is_rm_table <- grepl(rm_tab_rId, ws_rels) + self$worksheets_rels[[sheet]] <- ws_rels[!is_rm_table] + + # (2) remove the rId from tableParts + self$worksheets[[sheet]]$tableParts <- self$worksheets[[sheet]]$tableParts[-to_remove] + attr(self$worksheets[[sheet]]$tableParts, "tableName") <- worksheet_table_names[-to_remove] + + + ## Now delete data from the worksheet + refs <- strsplit(refs, split = ":")[[1]] + rows <- as.integer(gsub("[A-Z]", "", refs)) + rows <- seq(from = rows[1], to = rows[2], by = 1) + + cols <- col2int(refs) + cols <- seq(from = cols[1], to = cols[2], by = 1) + + ## now delete data + delete_data(wb = self, sheet = sheet, rows = rows, cols = cols) + invisible(self) +} diff --git a/R/class-workbook-validate-sheet.R b/R/class-workbook-validate-sheet.R new file mode 100644 index 000000000..d782417c3 --- /dev/null +++ b/R/class-workbook-validate-sheet.R @@ -0,0 +1,24 @@ +wb_validate_sheet_impl <- function(self, private, sheet) { + # workbook has no sheets + if (!length(self$sheet_names)) { + return(NA_integer_) + } + + # write_comment uses wb_validate and bails otherwise + if (inherits(sheet, "openxlsx2_waiver")) { + sheet <- private$get_sheet_index(sheet) + } + + # input is number + if (is.numeric(sheet)) { + badsheet <- !sheet %in% seq_along(self$sheet_names) + if (any(badsheet)) sheet[badsheet] <- NA_integer_ + return(sheet) + } + + if (!sheet %in% replaceXMLEntities(self$sheet_names)) { + return(NA_integer_) + } + + which(replaceXMLEntities(self$sheet_names) == sheet) +} diff --git a/R/class-workbook-worksheet.R b/R/class-workbook-worksheet.R new file mode 100644 index 000000000..7a25fe759 --- /dev/null +++ b/R/class-workbook-worksheet.R @@ -0,0 +1,200 @@ +wb_remove_worksheet_impl <- function(self, private, sheet = current_sheet()) { + + # To delete a worksheet + # Remove colwidths element + # Remove drawing partname from Content_Types (drawing(sheet).xml) + # Remove highest sheet from Content_Types + # Remove drawings element + # Remove drawings_rels element + + # Remove vml element + # Remove vml_rels element + + # Remove rowHeights element + # Remove last sheet element from workbook + # Remove last sheet element from workbook.xml.rels + # Remove element from worksheets + # Remove element from worksheets_rels + # Remove hyperlinks + # Reduce calcChain i attributes & remove calcs on sheet + # Remove sheet from sheetOrder + # Remove queryTable references from workbook$definedNames to worksheet + # remove tables + + # TODO can we allow multiple sheets? + if (length(sheet) != 1) { + stop("sheet must have length 1.") + } + + sheet <- private$get_sheet_index(sheet) + sheet_names <- self$sheet_names + nSheets <- length(sheet_names) + sheet_names <- sheet_names[[sheet]] + + ## definedNames + if (length(self$workbook$definedNames)) { + # wb_validate_sheet() makes sheet an integer + # so we need to remove this before getting rid of the sheet names + self$workbook$definedNames <- self$workbook$definedNames[ + !get_nr_from_definedName(self)$sheets %in% self$sheet_names[sheet] + ] + } + + self$remove_named_region(sheet) + self$sheet_names <- self$sheet_names[-sheet] + private$original_sheet_names <- private$original_sheet_names[-sheet] + + # if a sheet has no relationships, we xml_rels will not contain data + if (!is.null(self$worksheets_rels[[sheet]])) { + + xml_rels <- rbindlist( + xml_attr(self$worksheets_rels[[sheet]], "Relationship") + ) + + if (nrow(xml_rels) && ncol(xml_rels)) { + xml_rels$type <- basename(xml_rels$Type) + xml_rels$target <- basename(xml_rels$Target) + xml_rels$target[xml_rels$type == "hyperlink"] <- "" + xml_rels$target_ind <- as.numeric(gsub("\\D+", "", xml_rels$target)) + } + + comment_id <- xml_rels$target_ind[xml_rels$type == "comments"] + # TODO not every sheet has a drawing. this originates from a time where + # every sheet created got a drawing assigned. + drawing_id <- xml_rels$target_ind[xml_rels$type == "drawing"] + pivotTable_id <- xml_rels$target_ind[xml_rels$type == "pivotTable"] + table_id <- xml_rels$target_ind[xml_rels$type == "table"] + thrComment_id <- xml_rels$target_ind[xml_rels$type == "threadedComment"] + vmlDrawing_id <- xml_rels$target_ind[xml_rels$type == "vmlDrawing"] + + # NULL the sheets + if (length(comment_id)) self$comments[[comment_id]] <- NULL + if (length(drawing_id)) self$drawings[[drawing_id]] <- "" + if (length(drawing_id)) self$drawings_rels[[drawing_id]] <- "" + if (length(thrComment_id)) self$threadComments[[thrComment_id]] <- NULL + if (length(vmlDrawing_id)) self$vml[[vmlDrawing_id]] <- NULL + if (length(vmlDrawing_id)) self$vml_rels[[vmlDrawing_id]] <- NULL + + #### Modify Content_Types + ## remove last drawings(sheet).xml from Content_Types + drawing_name <- xml_rels$target[xml_rels$type == "drawing"] + if (!is.null(drawing_name) && !identical(drawing_name, character())) + self$Content_Types <- grep(drawing_name, self$Content_Types, invert = TRUE, value = TRUE) + + } + + self$isChartSheet <- self$isChartSheet[-sheet] + + ## remove highest sheet + # (don't chagne this to a "grep(value = TRUE)" ... ) + self$Content_Types <- self$Content_Types[!grepl(sprintf("sheet%s.xml", nSheets), self$Content_Types)] + + # The names for the other drawings have changed + de <- xml_node(read_xml(self$Content_Types), "Default") + ct <- rbindlist(xml_attr(read_xml(self$Content_Types), "Override")) + ct[grepl("drawing", ct$PartName), "PartName"] <- sprintf("/xl/drawings/drawing%i.xml", seq_along(self$drawings)) + ct <- df_to_xml("Override", ct[c("PartName", "ContentType")]) + self$Content_Types <- c(de, ct) + + + ## sheetOrder + toRemove <- which(self$sheetOrder == sheet) + self$sheetOrder[self$sheetOrder > sheet] <- self$sheetOrder[self$sheetOrder > sheet] - 1L + self$sheetOrder <- self$sheetOrder[-toRemove] + + # TODO regexpr should be replaced + ## Need to remove reference from workbook.xml.rels to pivotCache + removeRels <- grep("pivotTables", self$worksheets_rels[[sheet]], value = TRUE) + if (length(removeRels)) { + ## sheet rels links to a pivotTable file, the corresponding pivotTable_rels file links to the cacheDefn which is listing in workbook.xml.rels + ## remove reference to this file from the workbook.xml.rels + fileNo <- reg_match0(removeRels, "(?<=pivotTable)[0-9]+(?=\\.xml)") + fileNo <- as.integer(unlist(fileNo)) + + toRemove <- stri_join( + sprintf("(pivotCacheDefinition%i\\.xml)", fileNo), + sep = " ", + collapse = "|" + ) + + toRemove <- stri_join( + sprintf("(pivotCacheDefinition%i\\.xml)", grep(toRemove, self$pivotTables.xml.rels)), + sep = " ", + collapse = "|" + ) + + ## remove reference to file from workbook.xml.res + self$workbook.xml.rels <- grep(toRemove, self$workbook.xml.rels, invert = TRUE, value = TRUE) + } + + ## As above for slicers + ## Need to remove reference from workbook.xml.rels to pivotCache + # removeRels <- grepl("slicers", self$worksheets_rels[[sheet]]) + + if (any(grepl("slicers", self$worksheets_rels[[sheet]]))) { + # don't change to a grep(value = TRUE) + self$workbook.xml.rels <- self$workbook.xml.rels[!grepl(sprintf("(slicerCache%s\\.xml)", sheet), self$workbook.xml.rels)] + } + + ## wont't remove tables and then won't need to reassign table r:id's but will rename them! + self$worksheets[[sheet]] <- NULL + self$worksheets_rels[[sheet]] <- NULL + + sel <- self$tables$tab_sheet == sheet + # tableName is a character Vector with an attached name Vector. + if (any(sel)) { + self$tables$tab_name[sel] <- paste0(self$tables$tab_name[sel], "_openxlsx_deleted") + tab_sheet <- self$tables$tab_sheet + tab_sheet[sel] <- 0 + tab_sheet[tab_sheet > sheet] <- tab_sheet[tab_sheet > sheet] - 1L + self$tables$tab_sheet <- tab_sheet + self$tables$tab_ref[sel] <- "" + self$tables$tab_xml[sel] <- "" + + # deactivate sheet + self$tables$tab_act[sel] <- 0 + } + + # ## drawing will always be the first relationship + # if (nSheets > 1) { + # for (i in seq_len(nSheets - 1L)) { + # # did this get updated from length of 3 to 2? + # #self$worksheets_rels[[i]][1:2] <- genBaseSheetRels(i) + # rel <- rbindlist(xml_attr(self$worksheets_rels[[i]], "Relationship")) + # if (nrow(rel) && ncol(rel)) { + # if (any(basename(rel$Type) == "drawing")) { + # rel$Target[basename(rel$Type) == "drawing"] <- sprintf("../drawings/drawing%s.xml", i) + # } + # if (is.null(rel$TargetMode)) rel$TargetMode <- "" + # self$worksheets_rels[[i]] <- df_to_xml("Relationship", rel[c("Id", "Type", "Target", "TargetMode")]) + # } + # } + # } else { + # self$worksheets_rels <- list() + # } + + ## remove sheet + sn <- apply_reg_match0(self$workbook$sheets, pat = '(?<= name=")[^"]+') + self$workbook$sheets <- self$workbook$sheets[!sn %in% sheet_names] + + ## Reset rIds + if (nSheets > 1) { + for (i in (sheet + 1L):nSheets) { + self$workbook$sheets <- gsub( + stri_join("rId", i), + stri_join("rId", i - 1L), + self$workbook$sheets, + fixed = TRUE + ) + } + } else { + self$workbook$sheets <- NULL + } + + ## Can remove highest sheet + # (don't use grepl(value = TRUE)) + self$workbook.xml.rels <- self$workbook.xml.rels[!grepl(sprintf("sheet%s.xml", nSheets), self$workbook.xml.rels)] + + invisible(self) +} + diff --git a/R/class-workbook-wrappers.R b/R/class-workbook-wrappers.R index 03cd91707..7fef90503 100644 --- a/R/class-workbook-wrappers.R +++ b/R/class-workbook-wrappers.R @@ -114,12 +114,9 @@ wb_add_data <- function( sep = ", ", applyCellStyle = TRUE, removeCellStyle = FALSE, - na.strings + na.strings = getOption("openxlsx2.na.strings", "#N/A") ) { assert_workbook(wb) - - if (missing(na.strings)) na.strings <- substitute() - wb$clone(deep = TRUE)$add_data( sheet = sheet, x = x, @@ -183,49 +180,47 @@ wb_add_data <- function( #' @export wb_add_data_table <- function( wb, - sheet = current_sheet(), + sheet = current_sheet(), x, - startCol = 1, - startRow = 1, - dims = rowcol_to_dims(startRow, startCol), - xy = NULL, - colNames = TRUE, - rowNames = FALSE, - tableStyle = "TableStyleLight9", - tableName = NULL, - withFilter = TRUE, - sep = ", ", - firstColumn = FALSE, - lastColumn = FALSE, - bandedRows = TRUE, - bandedCols = FALSE, + startCol = 1, + startRow = 1, + dims = rowcol_to_dims(startRow, startCol), + xy = NULL, + colNames = TRUE, + rowNames = FALSE, + tableStyle = "TableStyleLight9", + tableName = NULL, + withFilter = TRUE, + sep = ", ", + firstColumn = FALSE, + lastColumn = FALSE, + bandedRows = TRUE, + bandedCols = FALSE, applyCellStyle = TRUE, removeCellStyle = FALSE, - na.strings + na.strings = getOption("openxlsx2.na.strings", "#N/A") ) { assert_workbook(wb) - if (missing(na.strings)) na.strings <- substitute() - wb$clone()$add_data_table( - sheet = sheet, - x = x, - startCol = startCol, - startRow = startRow, - dims = dims, - xy = xy, - colNames = colNames, - rowNames = rowNames, - tableStyle = tableStyle, - tableName = tableName, - withFilter = withFilter, - sep = sep, - firstColumn = firstColumn, - lastColumn = lastColumn, - bandedRows = bandedRows, - bandedCols = bandedCols, + sheet = sheet, + x = x, + startCol = startCol, + startRow = startRow, + dims = dims, + xy = xy, + colNames = colNames, + rowNames = rowNames, + tableStyle = tableStyle, + tableName = tableName, + withFilter = withFilter, + sep = sep, + firstColumn = firstColumn, + lastColumn = lastColumn, + bandedRows = bandedRows, + bandedCols = bandedCols, applyCellStyle = applyCellStyle, removeCellStyle = removeCellStyle, - na.strings = na.strings + na.strings = na.strings ) } @@ -424,26 +419,26 @@ wb_unmerge_cells <- function(wb, sheet = current_sheet(), rows = NULL, cols = NU #' wb$add_data(sheet = 7, 1:400) #' wb$add_data(sheet = 8, 1:400) wb_add_worksheet <- function( - wb, - sheet = next_sheet(), - gridLines = TRUE, - rowColHeaders = TRUE, - tabColour = NULL, - zoom = 100, - header = NULL, - footer = NULL, - oddHeader = header, - oddFooter = footer, - evenHeader = header, - evenFooter = footer, - firstHeader = header, - firstFooter = footer, - visible = c("true", "false", "hidden", "visible", "veryhidden"), - hasDrawing = FALSE, - paperSize = getOption("openxlsx2.paperSize", default = 9), - orientation = getOption("openxlsx2.orientation", default = "portrait"), - hdpi = getOption("openxlsx2.hdpi", default = getOption("openxlsx2.dpi", default = 300)), - vdpi = getOption("openxlsx2.vdpi", default = getOption("openxlsx2.dpi", default = 300)) + wb, + sheet = next_sheet(), + gridLines = TRUE, + rowColHeaders = TRUE, + tabColour = NULL, + zoom = 100, + header = NULL, + footer = NULL, + oddHeader = header, + oddFooter = footer, + evenHeader = header, + evenFooter = footer, + firstHeader = header, + firstFooter = footer, + visible = c("true", "false", "hidden", "visible", "veryhidden"), + hasDrawing = FALSE, + paperSize = getOption("openxlsx2.paperSize", default = 9), + orientation = getOption("openxlsx2.orientation", default = "portrait"), + hdpi = getOption("openxlsx2.hdpi", default = getOption("openxlsx2.dpi", default = 300)), + vdpi = getOption("openxlsx2.vdpi", default = getOption("openxlsx2.dpi", default = 300)) ) { assert_workbook(wb) wb$clone()$add_worksheet( @@ -771,10 +766,10 @@ wb_add_plot <- function( #' } #‘ @export wb_add_drawing <- function( - wb, - sheet = current_sheet(), - xml, - dims = "A1:H8" + wb, + sheet = current_sheet(), + xml, + dims = "A1:H8" ) { assert_workbook(wb) wb$clone()$add_drawing(sheet = sheet, xml = xml, dims = dims) @@ -1407,26 +1402,26 @@ NULL #' @rdname named_region #' @export wb_add_named_region <- function( - wb, - sheet = current_sheet(), - cols, - rows, - name, - localSheet = FALSE, - overwrite = FALSE, - comment = NULL, - customMenu = NULL, - description = NULL, - is_function = NULL, - functionGroupId = NULL, - help = NULL, - hidden = NULL, - localName = NULL, - publishToServer = NULL, - statusBar = NULL, - vbProcedure = NULL, - workbookParameter = NULL, - xml = NULL + wb, + sheet = current_sheet(), + cols, + rows, + name, + localSheet = FALSE, + overwrite = FALSE, + comment = NULL, + customMenu = NULL, + description = NULL, + is_function = NULL, + functionGroupId = NULL, + help = NULL, + hidden = NULL, + localName = NULL, + publishToServer = NULL, + statusBar = NULL, + vbProcedure = NULL, + workbookParameter = NULL, + xml = NULL ) { assert_workbook(wb) wb$clone()$add_named_region( @@ -1975,17 +1970,17 @@ wb_set_last_modified_by <- function(wb, LastModifiedBy) { #' wb$add_image(2, img, startRow = 2, startCol = 2) #' wb$add_image(3, img, width = 15, height = 12, startRow = 3, startCol = "G", units = "cm") wb_add_image <- function( - wb, - sheet = current_sheet(), - file, - width = 6, - height = 3, - startRow = 1, - startCol = 1, - rowOffset = 0, - colOffset = 0, - units = "in", - dpi = 300 + wb, + sheet = current_sheet(), + file, + width = 6, + height = 3, + startRow = 1, + startCol = 1, + rowOffset = 0, + colOffset = 0, + units = "in", + dpi = 300 ) { assert_workbook(wb) wb$clone()$add_image( @@ -2011,10 +2006,10 @@ wb_add_image <- function( #' @param dims the dimensions where the sheet will appear #' @export wb_add_chart_xml <- function( - wb, - sheet = current_sheet(), - xml, - dims = "A1:H8" + wb, + sheet = current_sheet(), + xml, + dims = "A1:H8" ) { assert_workbook(wb) wb$clone()$add_chart_xml(sheet, xml, dims) @@ -2071,10 +2066,8 @@ wb_open <- function(wb) { #' yellow <- create_dxfs_style(font_color = yellow_f, bgFill = yellow_b) #' wb <- wb_workbook() %>% wb_add_style(yellow) #' @export -wb_add_style <- function(wb, style = NULL, style_name = NULL) { +wb_add_style <- function(wb, style = NULL, style_name = substitute(style)) { assert_workbook(wb) - # deparse this name, otherwise it will remain "style" - if (is.null(style_name)) style_name <- deparse(substitute(style)) wb$clone()$add_style(style, style_name) } @@ -2261,25 +2254,25 @@ wb_add_fill <- function( #' @family styles #' @export wb_add_font <- function( - wb, - sheet = current_sheet(), - dims = "A1", - name = "Calibri", - color = wb_colour(hex = "FF000000"), - size = "11", - bold = "", - italic = "", - outline = "", - strike = "", - underline = "", - # fine tuning - charset = "", - condense = "", - extend = "", - family = "", - scheme = "", - shadow = "", - vertAlign = "" + wb, + sheet = current_sheet(), + dims = "A1", + name = "Calibri", + color = wb_colour(hex = "FF000000"), + size = "11", + bold = "", + italic = "", + outline = "", + strike = "", + underline = "", + # fine tuning + charset = "", + condense = "", + extend = "", + family = "", + scheme = "", + shadow = "", + vertAlign = "" ) { assert_workbook(wb) wb$clone()$add_font( @@ -2457,7 +2450,7 @@ wb_add_comment <- function( row, dims = rowcol_to_dims(row, col), comment - ) { +) { assert_workbook(wb) assert_comment(comment) @@ -2492,7 +2485,7 @@ wb_remove_comment <- function( row, dims = rowcol_to_dims(row, col), gridExpand = TRUE - ) { +) { assert_workbook(wb) diff --git a/R/class-workbook.R b/R/class-workbook.R index 1e60cdae3..a15b79572 100644 --- a/R/class-workbook.R +++ b/R/class-workbook.R @@ -185,98 +185,21 @@ wbWorkbook <- R6::R6Class( #' is created, not when the Excel files are saved. #' @return a `wbWorkbook` object initialize = function( - creator = NULL, - title = NULL, - subject = NULL, - category = NULL, - datetimeCreated = Sys.time() + creator = NULL, + title = NULL, + subject = NULL, + category = NULL, + datetimeCreated = Sys.time() ) { - self$apps <- character() - self$charts <- list() - self$isChartSheet <- logical() - - self$connections <- NULL - self$Content_Types <- genBaseContent_Type() - self$core <- - genBaseCore( - creator = creator, - title = title, - subject = subject, - category = category - ) - self$comments <- list() - self$threadComments <- list() - - - self$drawings <- list() - self$drawings_rels <- list() - # self$drawings_vml <- list() - - self$embeddings <- NULL - self$externalLinks <- NULL - self$externalLinksRels <- NULL - - self$headFoot <- NULL - - self$media <- list() - self$metadata <- NULL - - self$persons <- NULL - - self$pivotTables <- NULL - self$pivotTables.xml.rels <- NULL - self$pivotDefinitions <- NULL - self$pivotRecords <- NULL - self$pivotDefinitionsRels <- NULL - - self$queryTables <- NULL - - self$slicers <- NULL - self$slicerCaches <- NULL - - self$sheet_names <- character() - self$sheetOrder <- integer() - - self$sharedStrings <- list() - attr(self$sharedStrings, "uniqueCount") <- 0 - - self$styles_mgr <- style_mgr$new(self) - self$styles_mgr$styles <- genBaseStyleSheet() - - self$tables <- NULL - self$tables.xml.rels <- NULL - self$theme <- NULL - - - self$vbaProject <- NULL - self$vml <- list() - self$vml_rels <- list() - - self$creator <- - creator %||% - getOption("openxlsx2.creator") %||% - # USERNAME may only be present for windows - Sys.getenv("USERNAME", Sys.getenv("USER")) - - assert_class(self$creator, "character") - assert_class(title, "character", or_null = TRUE) - assert_class(subject, "character", or_null = TRUE) - assert_class(category, "character", or_null = TRUE) - assert_class(datetimeCreated, "POSIXt") - - stopifnot( - length(title) <= 1L, - length(category) <= 1L, - length(datetimeCreated) == 1L + wb_initialize_impl( + self = self, + private = private, + creator = creator, + title = title, + subject = subject, + category = category, + datetimeCreated = datetimeCreated ) - - self$title <- title - self$subject <- subject - self$category <- category - self$datetimeCreated <- datetimeCreated - private$generate_base_core() - private$current_sheet <- 0L - invisible(self) }, #' @description @@ -284,45 +207,21 @@ wbWorkbook <- R6::R6Class( #' @param field A valid field name #' @param value A value for the field append = function(field, value) { - self[[field]] <- c(self[[field]], value) - invisible(self) + wb_append_impl(self, private, field, value) }, #' @description #' Append to `self$workbook$sheets` This method is intended for internal use #' @param value A value for `self$workbook$sheets` append_sheets = function(value) { - self$workbook$sheets <- c(self$workbook$sheets, value) - invisible(self) + wb_append_sheets_impl(self, private, value) }, #' @description validate sheet #' @param sheet A character sheet name or integer location #' @returns The integer position of the sheet validate_sheet = function(sheet) { - - # workbook has no sheets - if (!length(self$sheet_names)) { - return(NA_integer_) - } - - # write_comment uses wb_validate and bails otherwise - if (inherits(sheet, "openxlsx2_waiver")) { - sheet <- private$get_sheet_index(sheet) - } - - # input is number - if (is.numeric(sheet)) { - badsheet <- !sheet %in% seq_along(self$sheet_names) - if (any(badsheet)) sheet[badsheet] <- NA_integer_ - return(sheet) - } - - if (!sheet %in% replaceXMLEntities(self$sheet_names)) { - return(NA_integer_) - } - - which(replaceXMLEntities(self$sheet_names) == sheet) + wb_validate_sheet_impl(self, private, sheet) }, #' @description @@ -368,207 +267,29 @@ wbWorkbook <- R6::R6Class( hdpi = getOption("openxlsx2.hdpi", default = getOption("openxlsx2.dpi", default = 300)), vdpi = getOption("openxlsx2.vdpi", default = getOption("openxlsx2.dpi", default = 300)) ) { - visible <- tolower(as.character(visible)) - visible <- match.arg(visible) - orientation <- match.arg(orientation, c("portrait", "landscape")) - - # set up so that a single error can be reported on fail - fail <- FALSE - msg <- NULL - - private$validate_new_sheet(sheet) - - if (is_waiver(sheet)) { - if (sheet == "current_sheet") { - stop("cannot add worksheet to current sheet") - } - - # TODO openxlsx2.sheet.default_name is undocumented. should incorporate - # a better check for this - sheet <- paste0( - getOption("openxlsx2.sheet.default_name", "Sheet "), - length(self$sheet_names) + 1L - ) - } - - sheet <- as.character(sheet) - sheet_name <- replace_legal_chars(sheet) - private$validate_new_sheet(sheet_name) - - if (!is.logical(gridLines) | length(gridLines) > 1) { - fail <- TRUE - msg <- c(msg, "gridLines must be a logical of length 1.") - } - - if (!is.null(tabColour)) { - tabColour <- validateColour(tabColour, "Invalid tabColour in add_worksheet.") - } - - if (!is.numeric(zoom)) { - fail <- TRUE - msg <- c(msg, "zoom must be numeric") - } - - # nocov start - if (zoom < 10) { - zoom <- 10 - } else if (zoom > 400) { - zoom <- 400 - } - #nocov end - - if (!is.null(oddHeader) & length(oddHeader) != 3) { - fail <- TRUE - msg <- c(msg, lcr("header")) - } - - if (!is.null(oddFooter) & length(oddFooter) != 3) { - fail <- TRUE - msg <- c(msg, lcr("footer")) - } - - if (!is.null(evenHeader) & length(evenHeader) != 3) { - fail <- TRUE - msg <- c(msg, lcr("evenHeader")) - } - - if (!is.null(evenFooter) & length(evenFooter) != 3) { - fail <- TRUE - msg <- c(msg, lcr("evenFooter")) - } - - if (!is.null(firstHeader) & length(firstHeader) != 3) { - fail <- TRUE - msg <- c(msg, lcr("firstHeader")) - } - - if (!is.null(firstFooter) & length(firstFooter) != 3) { - fail <- TRUE - msg <- c(msg, lcr("firstFooter")) - } - - vdpi <- as.integer(vdpi) - hdpi <- as.integer(hdpi) - - if (is.na(vdpi)) { - fail <- TRUE - msg <- c(msg, "vdpi must be numeric") - } - - if (is.na(hdpi)) { - fail <- TRUE - msg <- c(msg, "hdpi must be numeric") - } - - if (fail) { - stop(msg, call. = FALSE) - } - - newSheetIndex <- length(self$worksheets) + 1L - private$set_current_sheet(newSheetIndex) - sheetId <- private$get_sheet_id_max() # checks for self$worksheet length - - # check for errors ---- - - visible <- switch( - visible, - true = "visible", - false = "hidden", - veryhidden = "veryHidden", - visible - ) - - # Order matters: if a sheet is added to a blank workbook, we add a default style. If we already have - # sheets in the workbook, we do not add a new style. This could confuse Excel which will complain. - # This fixes output of the example in wb_load. - if (length(self$sheet_names) == 0) { - # TODO this should live wherever the other default values for an empty worksheet are initialized - empty_cellXfs <- data.frame(numFmtId = "0", fontId = "0", fillId = "0", borderId = "0", xfId = "0", stringsAsFactors = FALSE) - self$styles_mgr$styles$cellXfs <- write_xf(empty_cellXfs) - } - - self$append_sheets( - sprintf( - '', - sheet_name, - sheetId, - visible, - newSheetIndex - ) - ) - - ## append to worksheets list - self$append("worksheets", - wbWorksheet$new( - tabColour = tabColour, - oddHeader = oddHeader, - oddFooter = oddFooter, - evenHeader = evenHeader, - evenFooter = evenFooter, - firstHeader = firstHeader, - firstFooter = firstFooter, - paperSize = paperSize, - orientation = orientation, - hdpi = hdpi, - vdpi = vdpi, - printGridLines = gridLines - ) - ) - - # NULL or TRUE/FALSE - rightToLeft <- getOption("openxlsx2.rightToLeft") - - # set preselected set for sheetview - self$worksheets[[newSheetIndex]]$set_sheetview( - workbookViewId = 0, - zoomScale = zoom, - showGridLines = gridLines, - showRowColHeaders = rowColHeaders, - tabSelected = newSheetIndex == 1, - rightToLeft = rightToLeft - ) - - - ## update content_tyes - ## add a drawing.xml for the worksheet - if (hasDrawing) { - self$append("Content_Types", c( - sprintf('', newSheetIndex), - sprintf('', newSheetIndex) - )) - } else { - self$append("Content_Types", - sprintf( - '', - newSheetIndex - ) - ) - } - - ## Update xl/rels - self$append("workbook.xml.rels", - sprintf( - '', - newSheetIndex - ) + wb_add_worksheet_impl( + self = self, + private = private, + sheet = sheet, + gridLines = gridLines, + rowColHeaders = rowColHeaders, + tabColour = tabColour, + zoom = zoom, + header = header, + footer = footer, + oddHeader = oddHeader, + oddFooter = oddFooter, + evenHeader = evenHeader, + evenFooter = evenFooter, + firstHeader = firstHeader, + firstFooter = firstFooter, + visible = visible, + hasDrawing = hasDrawing, + paperSize = paperSize, + orientation = orientation, + hdpi = hdpi, + vdpi = vdpi ) - - ## create sheet.rels to simplify id assignment - new_drawings_idx <- length(self$drawings) + 1 - self$drawings[[new_drawings_idx]] <- "" - self$drawings_rels[[new_drawings_idx]] <- "" - - self$worksheets_rels[[newSheetIndex]] <- genBaseSheetRels(newSheetIndex) - self$vml_rels[[newSheetIndex]] <- list() - self$vml[[newSheetIndex]] <- list() - self$isChartSheet[[newSheetIndex]] <- FALSE - self$comments[[newSheetIndex]] <- list() - self$threadComments[[newSheetIndex]] <- list() - - self$append("sheetOrder", as.integer(newSheetIndex)) - private$set_single_sheet_name(newSheetIndex, sheet_name, sheet) - - invisible(self) }, # TODO should this be as simple as: wb$wb_add_worksheet(wb$worksheets[[1]]$clone()) ? @@ -578,292 +299,7 @@ wbWorkbook <- R6::R6Class( #' @param old name of worksheet to clone #' @param new name of new worksheet to add clone_worksheet = function(old = current_sheet(), new = next_sheet()) { - private$validate_new_sheet(new) - old <- private$get_sheet_index(old) - - newSheetIndex <- length(self$worksheets) + 1L - private$set_current_sheet(newSheetIndex) - sheetId <- private$get_sheet_id_max() # checks for length of worksheets - - if (!all(self$charts$chartEx == "")) { - warning( - "The file you have loaded contains chart extensions. At the moment,", - " cloning worksheets can damage the output." - ) - } - - # not the best but a quick fix - new_raw <- new - new <- replace_legal_chars(new) - - ## copy visibility from cloned sheet! - visible <- rbindlist(xml_attr(self$workbook$sheets[[old]], "sheet"))$state - - ## Add sheet to workbook.xml - self$append_sheets( - xml_node_create( - "sheet", - xml_attributes = c( - name = new, - sheetId = sheetId, - state = visible, - `r:id` = paste0("rId", newSheetIndex) - ) - ) - ) - - ## append to worksheets list - self$append("worksheets", self$worksheets[[old]]$clone(deep = TRUE)) - - ## update content_tyes - ## add a drawing.xml for the worksheet - # FIXME only add what is needed. If no previous drawing is found, don't - # add a new one - self$append("Content_Types", c( - if (self$isChartSheet[old]) { - sprintf('', newSheetIndex) - } else { - sprintf('', newSheetIndex) - } - )) - - ## Update xl/rels - self$append( - "workbook.xml.rels", - if (self$isChartSheet[old]) { - sprintf('', newSheetIndex) - } else { - sprintf('', newSheetIndex) - } - ) - - ## create sheet.rels to simplify id assignment - self$worksheets_rels[[newSheetIndex]] <- self$worksheets_rels[[old]] - - old_drawing_sheet <- NULL - - if (length(self$worksheets_rels[[old]])) { - relship <- rbindlist(xml_attr(self$worksheets_rels[[old]], "Relationship")) - relship$typ <- basename(relship$Type) - old_drawing_sheet <- as.integer(gsub("\\D+", "", relship$Target[relship$typ == "drawing"])) - } - - if (length(old_drawing_sheet)) { - - new_drawing_sheet <- length(self$drawings) + 1 - - self$drawings_rels[[new_drawing_sheet]] <- self$drawings_rels[[old_drawing_sheet]] - - # 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, self$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 - } - - old_sheet_name <- guard_ws(self$sheet_names[[old]]) - new_sheet_name <- guard_ws(new) - - ## we need to replace "'oldname'" as well as "oldname" - chart <- gsub( - old_sheet_name, - new_sheet_name, - chart, - perl = TRUE - ) - - self$charts$chart[chartid] <- chart - - # 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 <- gsub(stri_join("(?<=charts/)", cf), newname, rl, perl = TRUE) - } - - rl - - }, - NA_character_, - USE.NAMES = FALSE - ) - - # otherwise an empty drawings relationship is written - if (identical(self$drawings_rels[[new_drawing_sheet]], character())) - self$drawings_rels[[new_drawing_sheet]] <- list() - - - self$drawings[[new_drawing_sheet]] <- self$drawings[[old_drawing_sheet]] - } - - ## TODO Currently it is not possible to clone a sheet with a slicer in a - # safe way. It will always result in a broken xlsx file which is fixable - # but will not contain a slicer. - - # most likely needs to add slicerCache for each slicer with updated names - - ## SLICERS - - rid <- as.integer(sub("\\D+", "", get_relship_id(obj = self$worksheets_rels[[newSheetIndex]], "slicer"))) - if (length(rid)) { - - warning("Cloning slicers is not yet supported. It will not appear on the sheet.") - self$worksheets_rels[[newSheetIndex]] <- relship_no(obj = self$worksheets_rels[[newSheetIndex]], x = "slicer") - - newid <- length(self$slicers) + 1 - - cloned_slicers <- self$slicers[[old]] - slicer_attr <- xml_attr(cloned_slicers, "slicers") - - # Replace name with name_n. This will prevent the slicer from loading, - # but the xlsx file is not broken - slicer_child <- xml_node(cloned_slicers, "slicers", "slicer") - slicer_df <- rbindlist(xml_attr(slicer_child, "slicer"))[c("name", "cache", "caption", "rowHeight")] - slicer_df$name <- paste0(slicer_df$name, "_n") - slicer_child <- df_to_xml("slicer", slicer_df) - - self$slicers[[newid]] <- xml_node_create("slicers", slicer_child, slicer_attr[[1]]) - - self$worksheets_rels[[newSheetIndex]] <- c( - self$worksheets_rels[[newSheetIndex]], - sprintf("", - rid, - newid) - ) - - self$Content_Types <- c( - self$Content_Types, - sprintf("", newid) - ) - - } - - # The IDs in the drawings array are sheet-specific, so within the new - # cloned sheet the same IDs can be used => no need to modify drawings - self$vml_rels[[newSheetIndex]] <- self$vml_rels[[old]] - self$vml[[newSheetIndex]] <- self$vml[[old]] - self$isChartSheet[[newSheetIndex]] <- self$isChartSheet[[old]] - self$comments[[newSheetIndex]] <- self$comments[[old]] - self$threadComments[[newSheetIndex]] <- self$threadComments[[old]] - - self$append("sheetOrder", as.integer(newSheetIndex)) - self$append("sheet_names", new) - private$set_single_sheet_name(pos = newSheetIndex, clean = new, raw = new_raw) - - - ############################ - ## DRAWINGS - - # if we have drawings to clone, remove every table reference from Relationship - - rid <- as.integer(sub("\\D+", "", get_relship_id(obj = self$worksheets_rels[[newSheetIndex]], x = "drawing"))) - - if (length(rid)) { - - self$worksheets_rels[[newSheetIndex]] <- relship_no(obj = self$worksheets_rels[[newSheetIndex]], x = "drawing") - - self$worksheets_rels[[newSheetIndex]] <- c( - self$worksheets_rels[[newSheetIndex]], - sprintf( - '', - rid, - new_drawing_sheet - ) - ) - - } - - ############################ - ## TABLES - ## ... are stored in the $tables list, with the name and sheet as attr - ## and in the worksheets[]$tableParts list. We also need to adjust the - ## worksheets_rels and set the content type for the new table - - # if we have tables to clone, remove every table referece from Relationship - rid <- as.integer(sub("\\D+", "", get_relship_id(obj = self$worksheets_rels[[newSheetIndex]], x = "table"))) - - if (length(rid)) { - - self$worksheets_rels[[newSheetIndex]] <- relship_no(obj = self$worksheets_rels[[newSheetIndex]], x = "table") - - # make this the new sheets object - tbls <- self$tables[self$tables$tab_sheet == old, ] - if (NROW(tbls)) { - - # newid and rid can be different. ids must be unique - newid <- max(as.integer(rbindlist(xml_attr(self$tables$tab_xml, "table"))$id)) + seq_along(rid) - - # add _n to all table names found - tbls$tab_name <- stri_join(tbls$tab_name, "_n") - tbls$tab_sheet <- newSheetIndex - # modify tab_xml with updated name, displayName and id - tbls$tab_xml <- vapply(seq_len(nrow(tbls)), function(x) { - xml_attr_mod(tbls$tab_xml[x], - xml_attributes = c(name = tbls$tab_name[x], - displayName = tbls$tab_name[x], - id = newid[x]) - ) - }, - NA_character_ - ) - - # add new tables to old tables - self$tables <- rbind( - self$tables, - tbls - ) - - self$worksheets[[newSheetIndex]]$tableParts <- sprintf('', rid) - attr(self$worksheets[[newSheetIndex]]$tableParts, "tableName") <- tbls$tab_name - - ## hint: Content_Types will be created once the sheet is written. no need to add tables there - - # increase tables.xml.rels - self$append("tables.xml.rels", rep("", nrow(tbls))) - - # add table.xml to worksheet relationship - self$worksheets_rels[[newSheetIndex]] <- c( - self$worksheets_rels[[newSheetIndex]], - sprintf( - '', - rid, - newid - ) - ) - } - - } - - # TODO: The following items are currently NOT copied/duplicated for the cloned sheet: - # - Comments ??? - # - Slicers - - invisible(self) + wb_clone_worksheet_impl(self, private, old = old, new = new) }, #' @description @@ -873,79 +309,13 @@ wbWorkbook <- R6::R6Class( #' @param zoom zoom #' @return The `wbWorkbook` object, invisibly addChartSheet = function(sheet = current_sheet(), tabColour = NULL, zoom = 100) { - # TODO private$new_sheet_index()? - newSheetIndex <- length(self$worksheets) + 1L - sheetId <- private$get_sheet_id_max() # checks for length of worksheets - - ## Add sheet to workbook.xml - self$append_sheets( - sprintf( - '', - sheet, - sheetId, - newSheetIndex - ) - ) - - ## append to worksheets list - self$append("worksheets", - wbChartSheet$new(tabColour = tabColour) - ) - - - # nocov start - if (zoom < 10) { - zoom <- 10 - } else if (zoom > 400) { - zoom <- 400 - } - #nocov end - - self$worksheets[[newSheetIndex]]$set_sheetview( - workbookViewId = 0, - zoomScale = zoom, - tabSelected = newSheetIndex == 1 - ) - - self$append("sheet_names", sheet) - - ## update content_tyes - self$append("Content_Types", - sprintf( - '', - newSheetIndex - ) - ) - - ## Update xl/rels - self$append("workbook.xml.rels", - sprintf( - '', - newSheetIndex - ) - ) - - ## add a drawing.xml for the worksheet - self$append("Content_Types", - sprintf( - '', - newSheetIndex - ) + wb_add_chartsheet_impl( + self = self, + private = private, + sheet = sheet, + tabColour = tabColour, + zoom = zoom ) - - ## create sheet.rels to simplify id assignment - new_drawings_idx <- length(self$drawings) + 1 - self$drawings[[new_drawings_idx]] <- "" - self$drawings_rels[[new_drawings_idx]] <- "" - - self$worksheets_rels[[newSheetIndex]] <- genBaseSheetRels(newSheetIndex) - self$isChartSheet[[newSheetIndex]] <- TRUE - self$vml_rels[[newSheetIndex]] <- list() - self$vml[[newSheetIndex]] <- list() - self$append("sheetOrder", newSheetIndex) - - # invisible(newSheetIndex) - invisible(self) }, ### add data ---- @@ -968,27 +338,26 @@ wbWorkbook <- R6::R6Class( #' @param na.strings na.strings #' @param return The `wbWorkbook` object add_data = function( - sheet = current_sheet(), - x, - startCol = 1, - startRow = 1, - dims = rowcol_to_dims(startRow, startCol), - array = FALSE, - xy = NULL, - colNames = TRUE, - rowNames = FALSE, - withFilter = FALSE, - name = NULL, - sep = ", ", - applyCellStyle = TRUE, - removeCellStyle = FALSE, - na.strings - ) { - - if (missing(na.strings)) na.strings <- substitute() - - write_data( - wb = self, + sheet = current_sheet(), + x, + startCol = 1, + startRow = 1, + dims = rowcol_to_dims(startRow, startCol), + array = FALSE, + xy = NULL, + colNames = TRUE, + rowNames = FALSE, + withFilter = FALSE, + name = NULL, + sep = ", ", + applyCellStyle = TRUE, + removeCellStyle = FALSE, + na.strings = getOption("openxlsx2.na.strings", "#N/A") + ) { + # TODO shouldn't this have a default? + wb_add_data_impl( + self = self, + private = private, sheet = sheet, x = x, startCol = startCol, @@ -1005,7 +374,6 @@ wbWorkbook <- R6::R6Class( removeCellStyle = removeCellStyle, na.strings = na.strings ) - invisible(self) }, #' @description add a data table @@ -1030,54 +398,50 @@ wbWorkbook <- R6::R6Class( #' @param na.strings na.strings #' @returns The `wbWorkbook` object add_data_table = function( - sheet = current_sheet(), - x, - startCol = 1, - startRow = 1, - dims = rowcol_to_dims(startRow, startCol), - xy = NULL, - colNames = TRUE, - rowNames = FALSE, - tableStyle = "TableStyleLight9", - tableName = NULL, - withFilter = TRUE, - sep = ", ", - firstColumn = FALSE, - lastColumn = FALSE, - bandedRows = TRUE, - bandedCols = FALSE, - applyCellStyle = TRUE, - removeCellStyle = FALSE, - na.strings + sheet = current_sheet(), + x, + startCol = 1, + startRow = 1, + dims = rowcol_to_dims(startRow, startCol), + xy = NULL, + colNames = TRUE, + rowNames = FALSE, + tableStyle = "TableStyleLight9", + tableName = NULL, + withFilter = TRUE, + sep = ", ", + firstColumn = FALSE, + lastColumn = FALSE, + bandedRows = TRUE, + bandedCols = FALSE, + applyCellStyle = TRUE, + removeCellStyle = FALSE, + na.strings = getOption("openxlsx2.na.strings", "#N/A") ) { - - if (missing(na.strings)) na.strings <- substitute() - - write_datatable( - wb = self, - sheet = sheet, - x = x, - dims = dims, - startCol = startCol, - startRow = startRow, - xy = xy, - colNames = colNames, - rowNames = rowNames, - tableStyle = tableStyle, - tableName = tableName, - withFilter = withFilter, - sep = sep, - firstColumn = firstColumn, - lastColumn = lastColumn, - bandedRows = bandedRows, - bandedCols = bandedCols, - applyCellStyle = applyCellStyle, + wb_add_data_table_impl( + self = self, + private = private, + sheet = sheet, + x = x, + startCol = startCol, + startRow = startRow, + dims = dims, + xy = xy, + colNames = colNames, + rowNames = rowNames, + tableStyle = tableStyle, + tableName = tableName, + withFilter = withFilter, + sep = sep, + firstColumn = firstColumn, + lastColumn = lastColumn, + bandedRows = bandedRows, + bandedCols = bandedCols, + applyCellStyle = applyCellStyle, removeCellStyle = removeCellStyle, - na.strings = na.strings + na.strings = na.strings ) - invisible(self) }, - #' @description add formula #' @param sheet sheet #' @param x x @@ -1090,48 +454,38 @@ wbWorkbook <- R6::R6Class( #' @param removeCellStyle if writing into existing cells, should the cell style be removed? #' @returns The `wbWorkbook` object add_formula = function( - sheet = current_sheet(), - x, - startCol = 1, - startRow = 1, - dims = rowcol_to_dims(startRow, startCol), - array = FALSE, - xy = NULL, - applyCellStyle = TRUE, - removeCellStyle = FALSE + sheet = current_sheet(), + x, + startCol = 1, + startRow = 1, + dims = rowcol_to_dims(startRow, startCol), + array = FALSE, + xy = NULL, + applyCellStyle = TRUE, + removeCellStyle = FALSE ) { - write_formula( - wb = self, - sheet = sheet, - x = x, - startCol = startCol, - startRow = startRow, - dims = dims, - array = array, - xy = xy, - applyCellStyle = applyCellStyle, + wb_add_formula_impl( + self = self, + private = private, + sheet = sheet, + x = x, + startCol = startCol, + startRow = startRow, + dims = dims, + array = array, + xy = xy, + applyCellStyle = applyCellStyle, removeCellStyle = removeCellStyle ) - invisible(self) }, #' @description add style #' @param style style #' @param style_name style_name #' @returns The `wbWorkbook` object - add_style = function(style = NULL, style_name = NULL) { - - assert_class(style, "character") - - if (is.null(style_name)) { - style_name <- deparse(substitute(style)) - } else { - assert_class(style_name, "character") - } - - self$styles_mgr$add(style, style_name) - - invisible(self) + add_style = function(style = NULL, style_name = substitute(style)) { + force(style_name) + wb_add_style_impl(self, private, style = style, style_name = style_name) }, # TODO wb_save can be shortened a lot by some formatting and by using a @@ -1144,618 +498,18 @@ wbWorkbook <- R6::R6Class( #' @param overwrite If `FALSE`, will not overwrite when `path` exists #' @return The `wbWorkbook` object invisibly save = function(path = self$path, overwrite = TRUE) { - assert_class(path, "character") - assert_class(overwrite, "logical") - - if (file.exists(path) & !overwrite) { - stop("File already exists!") - } - - ## temp directory to save XML files prior to compressing - tmpDir <- file.path(tempfile(pattern = "workbookTemp_")) - on.exit(unlink(tmpDir, recursive = TRUE), add = TRUE) + wb_save_impl(self, private, path = path, overwrite = overwrite) + }, - if (file.exists(tmpDir)) { - unlink(tmpDir, recursive = TRUE, force = TRUE) - } - - success <- dir.create(path = tmpDir, recursive = FALSE) - if (!success) { # nocov start - stop(sprintf("Failed to create temporary directory '%s'", tmpDir)) - } # nocov end - - private$preSaveCleanUp() - - nSheets <- length(self$worksheets) - nThemes <- length(self$theme) - nPivots <- length(self$pivotDefinitions) - nSlicers <- length(self$slicers) - nComments <- sum(lengths(self$comments) > 0) - nThreadComments <- sum(lengths(self$threadComments) > 0) - nPersons <- length(self$persons) - nVML <- sum(lengths(self$vml) > 0) - - relsDir <- dir_create(tmpDir, "_rels") - docPropsDir <- dir_create(tmpDir, "docProps") - xlDir <- dir_create(tmpDir, "xl") - xlrelsDir <- dir_create(tmpDir, "xl", "_rels") - xlTablesDir <- dir_create(tmpDir, "xl", "tables") - xlTablesRelsDir <- dir_create(xlTablesDir, "_rels") - - if (length(self$media)) { - xlmediaDir <- dir_create(tmpDir, "xl", "media") - } - - ## will always have a theme - xlthemeDir <- dir_create(tmpDir, "xl", "theme") - - if (is.null(self$theme)) { - con <- file(file.path(xlthemeDir, "theme1.xml"), open = "wb") - writeBin(charToRaw(genBaseTheme()), con) - close(con) - } else { - # TODO replace with seq_len() or seq_along() - lapply(seq_len(nThemes), function(i) { - con <- file(file.path(xlthemeDir, stri_join("theme", i, ".xml")), open = "wb") - writeBin(charToRaw(pxml(self$theme[[i]])), con) - close(con) - }) - } - - - ## Content types has entries of all xml files in the workbook - ct <- self$Content_Types - - - ## will always have drawings - xlworksheetsDir <- dir_create(tmpDir, "xl", "worksheets") - xlworksheetsRelsDir <- dir_create(tmpDir, "xl", "worksheets", "_rels") - xldrawingsDir <- dir_create(tmpDir, "xl", "drawings") - xldrawingsRelsDir <- dir_create(tmpDir, "xl", "drawings", "_rels") - xlchartsDir <- dir_create(tmpDir, "xl", "charts") - xlchartsRelsDir <- dir_create(tmpDir, "xl", "charts", "_rels") - - ## xl/comments.xml - if (nComments > 0 | nVML > 0) { - - cmts <- rbindlist(xml_attr(unlist(self$worksheets_rels), "Relationship")) - cmts$target <- basename(cmts$Target) - cmts$typ <- basename(cmts$Type) - cmts <- cmts[cmts$typ == "comments", ] - cmts$id <- as.integer(gsub("\\D+", "", cmts$target)) - - sel <- vapply(self$comments, function(x) length(x) > 0, NA) - comments <- self$comments[sel] - - if (length(cmts$id) != length(comments)) - warning("comments length != comments ids") - - # TODO use seq_len() or seq_along()? - for (i in seq_along(comments)) { - fn <- sprintf("comments%s.xml", cmts$id[i]) - - write_comment_xml( - comment_list = comments[[i]], - file_name = file.path(tmpDir, "xl", fn) - ) - } - - private$writeDrawingVML(xldrawingsDir, xldrawingsRelsDir) - } - - ## Threaded Comments xl/threadedComments/threadedComment.xml - if (nThreadComments > 0) { - xlThreadComments <- dir_create(tmpDir, "xl", "threadedComments") - - for (i in seq_len(nSheets)) { - if (length(self$threadComments[[i]])) { - fl <- self$threadComments[[i]] - file.copy( - from = fl, - to = file.path(xlThreadComments, basename(fl)), - overwrite = TRUE, - copy.date = TRUE - ) - } - } - } - - ## xl/persons/person.xml - if (nPersons) { - personDir <- dir_create(tmpDir, "xl", "persons") - file.copy(self$persons, personDir, overwrite = TRUE) - } - - - - if (length(self$embeddings)) { - embeddingsDir <- dir_create(tmpDir, "xl", "embeddings") - for (fl in self$embeddings) { - file.copy(fl, embeddingsDir, overwrite = TRUE) - } - } - - - if (nPivots > 0) { - # TODO consider just making a function to create a bunch of directories - # and return as a named list? Easier/cleaner than checking for each - # element if we just go seq_along()? - pivotTablesDir <- dir_create(tmpDir, "xl", "pivotTables") - pivotTablesRelsDir <- dir_create(tmpDir, "xl", "pivotTables", "_rels") - pivotCacheDir <- dir_create(tmpDir, "xl", "pivotCache") - pivotCacheRelsDir <- dir_create(tmpDir, "xl", "pivotCache", "_rels") - - file_copy_wb_save(self$pivotTables, "pivotTable%i.xml", pivotTablesDir) - file_copy_wb_save(self$pivotDefinitions, "pivotCacheDefinition%i.xml", pivotCacheDir) - file_copy_wb_save(self$pivotRecords, "pivotCacheRecords%i.xml", pivotCacheDir) - file_copy_wb_save(self$pivotDefinitionsRels, "pivotCacheDefinition%i.xml.rels", pivotCacheRelsDir) - - for (i in seq_along(self$pivotTables.xml.rels)) { - write_file( - body = self$pivotTables.xml.rels[[i]], - fl = file.path(pivotTablesRelsDir, sprintf("pivotTable%s.xml.rels", i)) - ) - } - } - - ## slicers - if (nSlicers) { - slicersDir <- dir_create(tmpDir, "xl", "slicers") - slicerCachesDir <- dir_create(tmpDir, "xl", "slicerCaches") - - slicer <- self$slicers[self$slicers != ""] - for (i in seq_along(slicer)) { - write_file( - body = slicer[i], - fl = file.path(slicersDir, sprintf("slicer%s.xml", i)) - ) - } - - for (i in seq_along(self$slicerCaches)) { - write_file( - body = self$slicerCaches[[i]], - fl = file.path(slicerCachesDir, sprintf("slicerCache%s.xml", i)) - ) - } - } - - - ## Write content - - # if custom is present, we need 4 relationships, otherwise 3 - - Ids <- c("rId3", "rId2", "rId1") - Types <- c( - "http://schemas.openxmlformats.org/officeDocument/2006/relationships/extended-properties", - "http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties", - "http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument" - ) - Targets <- c("docProps/app.xml", "docProps/core.xml", "xl/workbook.xml") - - if (length(self$custom)) { - Ids <- c(Ids, "rId4") - Types <- c( - Types, - "http://schemas.openxmlformats.org/officeDocument/2006/relationships/custom-properties" - ) - Targets <- c(Targets, "docProps/custom.xml") - } - - relship <- df_to_xml("Relationship", - data.frame(Id = Ids, Type = Types, Target = Targets, stringsAsFactors = FALSE) - ) - - - ## write .rels - write_file( - head = '\n', - body = pxml(relship), - tail = "", - fl = file.path(relsDir, ".rels") - ) - - app <- "Microsoft Excel" - # further protect argument (might be extended with: , , , , , , ) - if (!is.null(self$apps)) app <- paste0(app, self$apps) - - ## write app.xml - if (length(self$app) == 0) { - write_file( - head = '', - body = app, - tail = "", - fl = file.path(docPropsDir, "app.xml") - ) - } else { - write_file( - head = '', - body = pxml(self$app), - tail = '', - fl = file.path(docPropsDir, "app.xml") - ) - } - - ## write core.xml - write_file( - head = "", - body = pxml(self$core), - tail = "", - fl = file.path(docPropsDir, "core.xml") - ) - - - ## write core.xml - if (length(self$custom)) { - write_file( - head = "", - body = pxml(self$custom), - tail = "", - fl = file.path(docPropsDir, "custom.xml") - ) - } - - ## write workbook.xml.rels - write_file( - head = '', - body = pxml(self$workbook.xml.rels), - tail = "", - fl = file.path(xlrelsDir, "workbook.xml.rels") - ) - - ## write tables - - ## update tables in content types (some have been added, some removed, get the final state) - default <- xml_node(ct, "Default") - override <- rbindlist(xml_attr(ct, "Override")) - override$typ <- gsub(".xml$", "", basename(override$PartName)) - override <- override[!grepl("table", override$typ), ] - override$typ <- NULL - - # TODO remove length() check since we have seq_along() - if (any(self$tables$tab_act == 1)) { - - # TODO get table Id from table entry - table_ids <- function() { - z <- 0 - if (!all(identical(unlist(self$worksheets_rels), character()))) { - relship <- rbindlist(xml_attr(unlist(self$worksheets_rels), "Relationship")) - relship$typ <- basename(relship$Type) - relship$tid <- as.numeric(gsub("\\D+", "", relship$Target)) - - z <- sort(relship$tid[relship$typ == "table"]) - } - z - } - - tab_ids <- table_ids() - - for (i in seq_along(tab_ids)) { - - # select only active tabs. in future there should only be active tabs - tabs <- self$tables[self$tables$tab_act == 1, ] - - if (NROW(tabs)) { - write_file( - body = pxml(tabs$tab_xml[i]), - fl = file.path(xlTablesDir, sprintf("table%s.xml", tab_ids[i])) - ) - - ## add entry to content_types as well - override <- rbind( - override, - # new entry for table - c("application/vnd.openxmlformats-officedocument.spreadsheetml.table+xml", - sprintf("/xl/tables/table%s.xml", tab_ids[i])) - ) - - if (self$tables.xml.rels[[i]] != "") { - write_file( - body = self$tables.xml.rels[[i]], - fl = file.path(xlTablesRelsDir, sprintf("table%s.xml.rels", tab_ids[i])) - ) - } - } - } - - } - - ## ct is updated as xml - ct <- c(default, df_to_xml(name = "Override", df_col = override[c("PartName", "ContentType")])) - - - ## write query tables - if (length(self$queryTables)) { - xlqueryTablesDir <- dir_create(tmpDir, "xl", "queryTables") - - for (i in seq_along(self$queryTables)) { - write_file( - body = self$queryTables[[i]], - fl = file.path(xlqueryTablesDir, sprintf("queryTable%s.xml", i)) - ) - } - } - - ## connections - if (length(self$connections)) { - write_file(body = self$connections, fl = file.path(xlDir, "connections.xml")) - } - - ## connections - if (length(self$ctrlProps)) { - ctrlPropsDir <- dir_create(tmpDir, "xl", "ctrlProps") - - for (i in seq_along(self$ctrlProps)) { - write_file(body = self$ctrlProps[i], fl = file.path(ctrlPropsDir, sprintf("ctrlProp%i.xml", i))) - } - } - - if (length(self$customXml)) { - customXmlDir <- dir_create(tmpDir, "customXml") - customXmlRelsDir <- dir_create(tmpDir, "customXml", "_rels") - for (fl in self$customXml[!grepl(".xml.rels$", self$customXml)]) { - file.copy(fl, customXmlDir, overwrite = TRUE) - } - for (fl in self$customXml[grepl(".xml.rels$", self$customXml)]) { - file.copy(fl, customXmlRelsDir, overwrite = TRUE) - } - } - - ## externalLinks - if (length(self$externalLinks)) { - externalLinksDir <- dir_create(tmpDir, "xl", "externalLinks") - - for (i in seq_along(self$externalLinks)) { - write_file( - body = self$externalLinks[[i]], - fl = file.path(externalLinksDir, sprintf("externalLink%s.xml", i)) - ) - } - } - - ## externalLinks rels - if (length(self$externalLinksRels)) { - externalLinksRelsDir <- dir_create(tmpDir, "xl", "externalLinks", "_rels") - - for (i in seq_along(self$externalLinksRels)) { - write_file( - body = self$externalLinksRels[[i]], - fl = file.path( - externalLinksRelsDir, - sprintf("externalLink%s.xml.rels", i) - ) - ) - } - } - - ## media (copy file from origin to destination) - # TODO replace with seq_along() - for (x in self$media) { - file.copy(x, file.path(xlmediaDir, names(self$media)[which(self$media == x)])) - } - - ## VBA Macro - if (!is.null(self$vbaProject)) { - file.copy(self$vbaProject, xlDir) - } - - ## write worksheet, worksheet_rels, drawings, drawing_rels - ct <- private$writeSheetDataXML( - ct, - xldrawingsDir, - xldrawingsRelsDir, - xlchartsDir, - xlchartsRelsDir, - xlworksheetsDir, - xlworksheetsRelsDir - ) - - ## write sharedStrings.xml - if (length(self$sharedStrings)) { - write_file( - head = sprintf( - '', - length(self$sharedStrings), - attr(self$sharedStrings, "uniqueCount") - ), - #body = stri_join(set_sst(attr(self$sharedStrings, "text")), collapse = "", sep = " "), - body = stri_join(self$sharedStrings, collapse = "", sep = ""), - tail = "", - fl = file.path(xlDir, "sharedStrings.xml") - ) - } else { - ## Remove relationship to sharedStrings - ct <- ct[!grepl("sharedStrings", ct)] - } - - if (nComments > 0) { - ct <- c( - ct, - # TODO this default extension is most likely wrong here and should be set when searching for and writing the vml entrys - '', - sprintf('', seq_len(nComments) - ) - ) - } - - ## do not write updated content types to self - # self$Content_Types <- ct - - ## write [Content_type] - write_file( - head = '', - body = pxml(unique(ct)), - tail = "", - fl = file.path(tmpDir, "[Content_Types].xml") - ) - - - styleXML <- self$styles_mgr$styles - if (length(styleXML$numFmts)) { - styleXML$numFmts <- - stri_join( - sprintf('', length(styleXML$numFmts)), - pxml(styleXML$numFmts), - "" - ) - } - styleXML$fonts <- - stri_join( - sprintf('', length(styleXML$fonts)), - pxml(styleXML$fonts), - "" - ) - styleXML$fills <- - stri_join( - sprintf('', length(styleXML$fills)), - pxml(styleXML$fills), - "" - ) - styleXML$borders <- - stri_join( - sprintf('', length(styleXML$borders)), - pxml(styleXML$borders), - "" - ) - styleXML$cellStyleXfs <- - c( - sprintf('', length(styleXML$cellStyleXfs)), - pxml(styleXML$cellStyleXfs), - "" - ) - styleXML$cellXfs <- - stri_join( - sprintf('', length(styleXML$cellXfs)), - paste0(styleXML$cellXfs, collapse = ""), - "" - ) - styleXML$cellStyles <- - stri_join( - sprintf('', length(styleXML$cellStyles)), - pxml(styleXML$cellStyles), - "" - ) - # styleXML$cellStyles <- - # stri_join( - # pxml(self$styles_mgr$tableStyles) - # ) - # TODO - # tableStyles - # extLst - - styleXML$dxfs <- - if (length(styleXML$dxfs)) { - stri_join( - sprintf('', length(styleXML$dxfs)), - stri_join(unlist(styleXML$dxfs), sep = " ", collapse = ""), - "" - ) - } else { - '' - } - - ## write styles.xml - if (length(unlist(self$styles_mgr$styles))) { - write_file( - head = '', - body = pxml(styleXML), - tail = "", - fl = file.path(xlDir, "styles.xml") - ) - } else { - write_file( - head = '', - body = '', - tail = '', - fl = file.path(xlDir, "styles.xml") - ) - } - - if (length(self$calcChain)) { - write_file( - head = '', - body = pxml(self$calcChain), - tail = "", - fl = file.path(xlDir, "calcChain.xml") - ) - } - - # write metadata file. required if cm attribut is set. - if (length(self$metadata)) { - write_file( - head = '', - body = self$metadata, - tail = '', - fl = file.path(xlDir, "metadata.xml") - ) - } - - ## write workbook.xml - workbookXML <- self$workbook - workbookXML$sheets <- stri_join("", pxml(workbookXML$sheets), "") - - if (length(workbookXML$definedNames)) { - workbookXML$definedNames <- stri_join("", pxml(workbookXML$definedNames), "") - } - - # openxml 2.8.1 expects the following order of xml nodes. While we create this per default, it is not - # assured that the order of entries is still valid when we write the file. Functions can change the - # workbook order, therefore we have to make sure that the expected order is written. - # Othterwise spreadsheet software will complain. - workbook_openxml281 <- c( - "fileVersion", "fileSharing", "workbookPr", "alternateContent", "revisionPtr", "absPath", - "workbookProtection", "bookViews", "sheets", "functionGroups", "externalReferences", - "definedNames", "calcPr", "oleSize", "customWorkbookViews", "pivotCaches", "smartTagPr", - "smartTagTypes", "webPublishing", "fileRecoveryPr", "webPublishObjects", "extLst" - ) - - write_file( - head = '', - body = pxml(workbookXML[workbook_openxml281]), - tail = "", - fl = file.path(xlDir, "workbook.xml") - ) - - ## Need to reset sheet order to allow multiple savings - self$workbook$sheets <- self$workbook$sheets[order(self$sheetOrder)] - - ## compress to xlsx - - # TODO make self$vbaProject be TRUE/FALSE - tmpFile <- tempfile(tmpdir = tmpDir, fileext = if (isTRUE(self$vbaProject)) ".xlsm" else ".xlsx") - - ## zip it - zip::zip( - zipfile = tmpFile, - files = list.files(tmpDir, full.names = FALSE), - recurse = TRUE, - compression_level = getOption("openxlsx2.compresssionevel", 6), - include_directories = FALSE, - # change the working directory for this - root = tmpDir, - # change default to match historical zipr - mode = "cherry-pick" - ) - - # Copy file; stop if failed - if (!file.copy(from = tmpFile, to = path, overwrite = overwrite, copy.mode = FALSE)) { - stop("Failed to save workbook") - } - - # (re)assign file path (if successful) - self$path <- path - invisible(self) - }, - - #' @description open wbWorkbook in Excel. - #' @details minor helper wrapping xl_open which does the entire same thing - #' @param interactive If `FALSE` will throw a warning and not open the path. - #' This can be manually set to `TRUE`, otherwise when `NA` (default) uses - #' the value returned from [base::interactive()] - #' @return The `wbWorkbook`, invisibly - open = function(interactive = NA) { - xl_open(self, interactive = interactive) - invisible(self) - }, + #' @description open wbWorkbook in Excel. + #' @details minor helper wrapping xl_open which does the entire same thing + #' @param interactive If `FALSE` will throw a warning and not open the path. + #' This can be manually set to `TRUE`, otherwise when `NA` (default) uses + #' the value returned from [base::interactive()] + #' @return The `wbWorkbook`, invisibly + open = function(interactive = NA) { + wb_open_impl(self, private, interactive) + }, #' @description #' Build table @@ -1786,163 +540,31 @@ wbWorkbook <- R6::R6Class( showRowStripes = 1, showColumnStripes = 0 ) { - - ## id will start at 3 and drawing will always be 1, printer Settings at 2 (printer settings has been removed) - last_table_id <- function() { - z <- 0 - - if (!all(unlist(self$worksheets_rels) == "")) { - relship <- rbindlist(xml_attr(unlist(self$worksheets_rels), "Relationship")) - # assign("relship", relship, globalenv()) - relship$typ <- basename(relship$Type) - relship$tid <- as.numeric(gsub("\\D+", "", relship$Target)) - if (any(relship$typ == "table")) - z <- max(relship$tid[relship$typ == "table"]) - } - - z - } - - id <- as.character(last_table_id() + 1) # otherwise will start at 0 for table 1 length indicates the last known - sheet <- wb_validate_sheet(self, sheet) - # get the next highest rid - rid <- 1 - if (!all(identical(self$worksheets_rels[[sheet]], character()))) { - rid <- max(as.integer(sub("\\D+", "", rbindlist(xml_attr(self$worksheets_rels[[sheet]], "Relationship"))[["Id"]]))) + 1 - } - - if (is.null(self$tables)) { - nms <- NULL - tSheets <- NULL - tNames <- NULL - tActive <- NULL - } else { - nms <- self$tables$tab_ref - tSheets <- self$tables$tab_sheet - tNames <- self$tables$tab_name - tActive <- self$tables$tab_act - } - - - ### autofilter - autofilter <- if (withFilter) { - xml_node_create(xml_name = "autoFilter", xml_attributes = c(ref = ref)) - } - - ### tableColumn - tableColumn <- sapply(colNames, function(x) { - id <- which(colNames %in% x) - xml_node_create("tableColumn", xml_attributes = c(id = id, name = x)) - }) - - tableColumns <- xml_node_create( - xml_name = "tableColumns", - xml_children = tableColumn, - xml_attributes = c(count = as.character(length(colNames))) - ) - - - ### tableStyleInfo - tablestyle_attr <- c( - name = tableStyle, - showFirstColumn = as.integer(showFirstColumn), - showLastColumn = as.integer(showLastColumn), - showRowStripes = as.integer(showRowStripes), - showColumnStripes = as.integer(showColumnStripes) - ) - - tableStyleXML <- xml_node_create(xml_name = "tableStyleInfo", xml_attributes = tablestyle_attr) - - - ### full table - table_attrs <- c( - xmlns = "http://schemas.openxmlformats.org/spreadsheetml/2006/main", - `xmlns:mc` = "http://schemas.openxmlformats.org/markup-compatibility/2006", - id = id, - name = tableName, - displayName = tableName, - ref = ref, - totalsRowCount = totalsRowCount, - totalsRowShown = "0" - #headerRowDxfId="1" - ) - - tab_xml_new <- xml_node_create( - xml_name = "table", - xml_children = c(autofilter, tableColumns, tableStyleXML), - xml_attributes = table_attrs + wb_build_table_impl( + self = self, + private = private, + sheet = sheet, + colNames = colNames, + ref = ref, + showColNames = showColNames, + tableStyle = tableStyle, + tableName = tableName, + withFilter = withFilter, + totalsRowCount = totalsRowCount, + showFirstColumn = showFirstColumn, + showLastColumn = showLastColumn, + showRowStripes = showRowStripes, + showColumnStripes = showColumnStripes ) - - self$tables <- data.frame( - tab_name = c(tNames, tableName), - tab_sheet = c(tSheets, sheet), - tab_ref = c(nms, ref), - tab_xml = c(self$tables$tab_xml, tab_xml_new), - tab_act = c(self$tables$tab_act, 1), - stringsAsFactors = FALSE - ) - - self$worksheets[[sheet]]$tableParts <- c( - self$worksheets[[sheet]]$tableParts, - sprintf('', rid) - ) - attr(self$worksheets[[sheet]]$tableParts, "tableName") <- c( - tNames[tSheets == sheet & tActive == 1], - tableName - ) - - ## create a table.xml.rels - self$append("tables.xml.rels", "") - - ## update worksheets_rels - self$worksheets_rels[[sheet]] <- c( - self$worksheets_rels[[sheet]], - sprintf( - '', - rid, - id - ) - ) - - invisible(self) }, - ### base font ---- #' @description #' Get the base font #' @return A list of of the font get_base_font = function() { - baseFont <- self$styles_mgr$styles$fonts[[1]] - - sz <- unlist(xml_attr(baseFont, "font", "sz")) - colour <- unlist(xml_attr(baseFont, "font", "color")) - name <- unlist(xml_attr(baseFont, "font", "name")) - - if (length(sz[[1]]) == 0) { - sz <- list("val" = "11") - } else { - sz <- as.list(sz) - } - - if (length(colour[[1]]) == 0) { - colour <- list("rgb" = "#000000") - } else { - colour <- as.list(colour) - } - - if (length(name[[1]]) == 0) { - name <- list("val" = "Calibri") - } else { - name <- as.list(name) - } - - list( - size = sz, - colour = colour, - name = name - ) + wb_get_base_font_impl(self, private) }, #' @description @@ -1951,10 +573,18 @@ wbWorkbook <- R6::R6Class( #' @param fontColour fontColour #' @param fontName fontName #' @return The `wbWorkbook` object - set_base_font = function(fontSize = 11, fontColour = wb_colour(theme = "1"), fontName = "Calibri") { - if (fontSize < 0) stop("Invalid fontSize") - if (is.character(fontColour) && is.null(names(fontColour))) fontColour <- wb_colour(fontColour) - self$styles_mgr$styles$fonts[[1]] <- create_font(sz = as.character(fontSize), color = fontColour, name = fontName) + set_base_font = function( + fontSize = 11, + fontColour = wb_colour(theme = "1"), + fontName = "Calibri" + ) { + wb_set_base_font_impl( + self = self, + private = private, + fontSize = fontSize, + fontColour = fontColour, + fontName = fontName + ) }, ### book views ---- @@ -1990,40 +620,23 @@ wbWorkbook <- R6::R6Class( xWindow = NULL, yWindow = NULL ) { - - wbv <- self$workbook$bookViews - - if (is.null(wbv)) { - wbv <- xml_node_create("workbookView") - } else { - wbv <- xml_node(wbv, "bookViews", "workbookView") - } - - wbv <- xml_attr_mod( - wbv, - xml_attributes = c( - activeTab = as_xml_attr(activeTab), - autoFilterDateGrouping = as_xml_attr(autoFilterDateGrouping), - firstSheet = as_xml_attr(firstSheet), - minimized = as_xml_attr(minimized), - showHorizontalScroll = as_xml_attr(showHorizontalScroll), - showSheetTabs = as_xml_attr(showSheetTabs), - showVerticalScroll = as_xml_attr(showVerticalScroll), - tabRatio = as_xml_attr(tabRatio), - visibility = as_xml_attr(visibility), - windowHeight = as_xml_attr(windowHeight), - windowWidth = as_xml_attr(windowWidth), - xWindow = as_xml_attr(xWindow), - yWindow = as_xml_attr(yWindow) - ) + wb_set_bookview_impl( + self = self, + private = private, + activeTab = activeTab, + autoFilterDateGrouping = autoFilterDateGrouping, + firstSheet = firstSheet, + minimized = minimized, + showHorizontalScroll = showHorizontalScroll, + showSheetTabs = showSheetTabs, + showVerticalScroll = showVerticalScroll, + tabRatio = tabRatio, + visibility = visibility, + windowHeight = windowHeight, + windowWidth = windowWidth, + xWindow = xWindow, + yWindow = yWindow ) - - self$workbook$bookViews <- xml_node_create( - "bookViews", - xml_children = wbv - ) - - invisible(self) }, ### sheet names ---- @@ -2033,9 +646,7 @@ wbWorkbook <- R6::R6Class( #' names represent the original value of the worksheet prior to any #' character substitutions. get_sheet_names = function() { - res <- self$sheet_names - names(res) <- private$original_sheet_names - res[self$sheetOrder] + wb_get_sheet_names_impl(self, private) }, #' @description @@ -2044,65 +655,7 @@ wbWorkbook <- R6::R6Class( #' @param new New sheet name #' @return The `wbWorkbook` object, invisibly set_sheet_names = function(old = NULL, new) { - # assume all names. Default values makes the test check for wrappers a - # little weird - old <- old %||% seq_along(self$sheet_names) - - if (identical(old, new)) { - return(self) - } - - if (!length(self$worksheets)) { - stop("workbook does not contain any sheets") - } - - if (length(old) != length(new)) { - stop("`old` and `new` must be the same length") - } - - pos <- private$get_sheet_index(old) - new_raw <- as.character(new) - new_name <- replace_legal_chars(new_raw) - - if (identical(self$sheet_names[pos], new_name)) { - return(self) - } - - bad <- duplicated(tolower(new)) - if (any(bad)) { - stop("Sheet names cannot have duplicates: ", toString(new[bad])) - } - - # should be able to pull this out into a single private function - for (i in seq_along(pos)) { - private$validate_new_sheet(new_name[i]) - private$set_single_sheet_name(pos[i], new_name[i], new_raw[i]) - # TODO move this work into private$set_single_sheet_name() - - ## Rename in workbook - sheetId <- private$get_sheet_id(type = "sheetId", pos[i]) - rId <- private$get_sheet_id(type = 'rId', pos[i]) - self$workbook$sheets[[pos[i]]] <- - sprintf( - '', - new_name[i], - sheetId, - rId - ) - - ## rename defined names - if (length(self$workbook$definedNames)) { - ind <- get_named_regions(self)$sheets == old - if (any(ind)) { - nn <- sprintf("'%s'", new_name[i]) - nn <- stringi::stri_replace_all_fixed(self$workbook$definedName[ind], old, nn) - nn <- stringi::stri_replace_all(nn, "'+", "'") - self$workbook$definedNames[ind] <- nn - } - } - } - - invisible(self) + wb_set_sheet_names_impl(self, private, old, new) }, #' @description @@ -2115,7 +668,6 @@ wbWorkbook <- R6::R6Class( self$set_sheet_names(old = sheet, new = name) }, - ### row heights ---- #' @description @@ -2125,31 +677,13 @@ wbWorkbook <- R6::R6Class( #' @param heights heights #' @return The `wbWorkbook` object, invisibly set_row_heights = function(sheet = current_sheet(), rows, heights) { - sheet <- private$get_sheet_index(sheet) - - # TODO move to wbWorksheet method - - # create all A columns so that row_attr is available - dims <- rowcol_to_dims(rows, 1) - private$do_cell_init(sheet, dims) - - if (length(rows) > length(heights)) { - heights <- rep(heights, length.out = length(rows)) - } - - if (length(heights) > length(rows)) { - stop("Greater number of height values than rows.") - } - - row_attr <- self$worksheets[[sheet]]$sheet_data$row_attr - - sel <- match(rows, row_attr$r) - row_attr[sel, "ht"] <- as.character(as.numeric(heights)) - row_attr[sel, "customHeight"] <- "1" - - self$worksheets[[sheet]]$sheet_data$row_attr <- row_attr - - invisible(self) + wb_set_row_heights_impl( + self = self, + private = private, + sheet = sheet, + rows = rows, + heights = heights + ) }, #' @description @@ -2158,25 +692,15 @@ wbWorkbook <- R6::R6Class( #' @param rows rows #' @return The `wbWorkbook` object, invisibly remove_row_heights = function(sheet = current_sheet(), rows) { - sheet <- private$get_sheet_index(sheet) - - row_attr <- self$worksheets[[sheet]]$sheet_data$row_attr - - if (is.null(row_attr)) { - warning("There are no initialized rows on this sheet") - return(invisible(self)) - } - - sel <- match(rows, row_attr$r) - row_attr[sel, "ht"] <- "" - row_attr[sel, "customHeight"] <- "" - - self$worksheets[[sheet]]$sheet_data$row_attr <- row_attr - - invisible(self) + wb_remove_row_heights_impl( + self = self, + private = private, + sheet = sheet, + rows = rows + ) }, - ## columns ---- + ### columns ---- #' description #' creates column object for worksheet @@ -2185,8 +709,15 @@ wbWorkbook <- R6::R6Class( #' @param beg beg #' @param end end createCols = function(sheet = current_sheet(), n, beg, end) { - sheet <- private$get_sheet_index(sheet) - self$worksheets[[sheet]]$cols_attr <- df_to_xml("col", empty_cols_attr(n, beg, end)) + # TODO replace with $add_cols() + wb_add_cols_impl( + self = self, + private = private, + sheet = sheet, + n = n, + beg = beg, + end = end + ) }, #' @description @@ -2196,66 +727,20 @@ wbWorkbook <- R6::R6Class( #' @param collapsed collapsed #' @param levels levels #' @return The `wbWorkbook` object, invisibly - group_cols = function(sheet = current_sheet(), cols, collapsed = FALSE, levels = NULL) { - sheet <- private$get_sheet_index(sheet) - - if (length(collapsed) > length(cols)) { - stop("Collapses argument is of greater length than number of cols.") - } - - if (!is.logical(collapsed)) { - stop("Collapses should be a logical value (TRUE/FALSE).") - } - - if (any(cols < 1L)) { - stop("Invalid rows entered (<= 0).") - } - - collapsed <- rep(as.character(as.integer(collapsed)), length.out = length(cols)) - levels <- levels %||% rep("1", length(cols)) - - # Remove duplicates - ok <- !duplicated(cols) - collapsed <- collapsed[ok] - levels <- levels[ok] - cols <- cols[ok] - - # fetch the row_attr data.frame - col_attr <- self$worksheets[[sheet]]$unfold_cols() - - if (NROW(col_attr) == 0) { - # TODO should this be a warning? Or an error? - message("worksheet has no columns. please create some with createCols") - } - - # reverse to make it easier to get the fist - cols_rev <- rev(cols) - - # get the selection based on the col_attr frame. - - # the first n -1 cols get outlineLevel - select <- col_attr$min %in% as.character(cols_rev[-1]) - if (length(select)) { - col_attr$outlineLevel[select] <- as.character(levels[-1]) - col_attr$collapsed[select] <- as.character(as.integer(collapsed[-1])) - col_attr$hidden[select] <- as.character(as.integer(collapsed[-1])) - } - - # the n-th row gets only collapsed - select <- col_attr$min %in% as.character(cols_rev[1]) - if (length(select)) { - col_attr$collapsed[select] <- as.character(as.integer(collapsed[1])) - } - - self$worksheets[[sheet]]$fold_cols(col_attr) - - - # check if there are valid outlineLevel in col_attr and assign outlineLevelRow the max outlineLevel (thats in the documentation) - if (any(col_attr$outlineLevel != "")) { - self$worksheets[[sheet]]$sheetFormatPr <- xml_attr_mod(self$worksheets[[sheet]]$sheetFormatPr, xml_attributes = c(outlineLevelCol = as.character(max(as.integer(col_attr$outlineLevel), na.rm = TRUE)))) - } - - invisible(self) + group_cols = function( + sheet = current_sheet(), + cols, + collapsed = FALSE, + levels = NULL + ) { + wb_group_cols_impl( + self = self, + private = private, + sheet = sheet, + cols = cols, + collapsed = collapsed, + levels = levels + ) }, #' @description ungroup cols @@ -2263,35 +748,7 @@ wbWorkbook <- R6::R6Class( #' @param cols = cols #' @returns The `wbWorkbook` object ungroup_cols = function(sheet = current_sheet(), cols) { - sheet <- private$get_sheet_index(sheet) - - # check if any rows are selected - if (any(cols < 1L)) { - stop("Invalid cols entered (<= 0).") - } - - # fetch the cols_attr data.frame - col_attr <- self$worksheets[[sheet]]$unfold_cols() - - # get the selection based on the col_attr frame. - select <- col_attr$min %in% as.character(cols) - - if (length(select)) { - col_attr$outlineLevel[select] <- "" - col_attr$collapsed[select] <- "" - # TODO only if unhide = TRUE - col_attr$hidden[select] <- "" - self$worksheets[[sheet]]$fold_cols(col_attr) - } - - # If all outlineLevels are missing: remove the outlineLevelCol attribute. Assigning "" will remove the attribute - if (all(col_attr$outlineLevel == "")) { - self$worksheets[[sheet]]$sheetFormatPr <- xml_attr_mod(self$worksheets[[sheet]]$sheetFormatPr, xml_attributes = c(outlineLevelCol = "")) - } else { - self$worksheets[[sheet]]$sheetFormatPr <- xml_attr_mod(self$worksheets[[sheet]]$sheetFormatPr, xml_attributes = c(outlineLevelCol = as.character(max(as.integer(col_attr$outlineLevel))))) - } - - invisible(self) + wb_ungroup_cols_impl(self, private, sheet, cols) }, #' @description Remove row heights from a worksheet @@ -2299,26 +756,12 @@ wbWorkbook <- R6::R6Class( #' @param cols Indices of columns to remove custom width (if any) from. #' @return The `wbWorkbook` object, invisibly remove_col_widths = function(sheet = current_sheet(), cols) { - sheet <- private$get_sheet_index(sheet) - - if (!is.numeric(cols)) { - cols <- col2int(cols) - } - - customCols <- as.integer(names(self$colWidths[[sheet]])) - removeInds <- which(customCols %in% cols) - if (length(removeInds)) { - remainingCols <- customCols[-removeInds] - if (length(remainingCols) == 0) { - self$colWidths[[sheet]] <- list() - } else { - rem_widths <- self$colWidths[[sheet]][-removeInds] - names(rem_widths) <- as.character(remainingCols) - self$colWidths[[sheet]] <- rem_widths - } - } - - invisible(self) + wb_remove_col_widths_impl( + self = self, + private = private, + sheet = sheet, + cols = cols + ) }, # TODO wb_group_rows() and group_cols() are very similiar. Can problem turn @@ -2330,390 +773,68 @@ wbWorkbook <- R6::R6Class( #' @param hidden A logical vector to determine which cols are hidden; values #' are repeated across length of `cols` #' @return The `wbWorkbook` object, invisibly - set_col_widths = function(sheet = current_sheet(), cols, widths = 8.43, hidden = FALSE) { - sheet <- private$get_sheet_index(sheet) - - # should do nothing if the cols' length is zero - # TODO why would cols ever be 0? Can we just signal this as an error? - if (length(cols) == 0L) { - return(self) - } - - cols <- col2int(cols) - - if (length(widths) > length(cols)) { - stop("More widths than columns supplied.") - } - - if (length(hidden) > length(cols)) { - stop("hidden argument is longer than cols.") - } - - if (length(widths) < length(cols)) { - widths <- rep(widths, length.out = length(cols)) - } - - if (length(hidden) < length(cols)) { - hidden <- rep(hidden, length.out = length(cols)) - } - - # TODO add bestFit option? - bestFit <- rep("1", length.out = length(cols)) - customWidth <- rep("1", length.out = length(cols)) - - ## Remove duplicates - ok <- !duplicated(cols) - col_width <- widths[ok] - hidden <- hidden[ok] - cols <- cols[ok] - - col_df <- self$worksheets[[sheet]]$unfold_cols() - base_font <- wb_get_base_font(self) - - if (any(widths == "auto")) { - df <- wb_to_df(self, sheet = sheet, cols = cols, colNames = FALSE) - # TODO format(x) might not be the way it is formatted in the xlsx file. - col_width <- vapply(df, function(x) max(nchar(format(x))), NA_real_) - } - - - # https://docs.microsoft.com/en-us/dotnet/api/documentformat.openxml.spreadsheet.column - widths <- calc_col_width(base_font = base_font, col_width = col_width) - - # create empty cols - if (NROW(col_df) == 0) - col_df <- col_to_df(read_xml(self$createCols(sheet, n = max(cols)))) - - # found a few cols, but not all required cols. create the missing columns - if (any(!cols %in% as.numeric(col_df$min))) { - beg <- max(as.numeric(col_df$min)) + 1 - end <- max(cols) - - # new columns - new_cols <- col_to_df(read_xml(self$createCols(sheet, beg = beg, end = end))) - - # rbind only the missing columns. avoiding dups - sel <- !new_cols$min %in% col_df$min - col_df <- rbind(col_df, new_cols[sel, ]) - col_df <- col_df[order(as.numeric(col_df[, "min"])), ] - } - - select <- as.numeric(col_df$min) %in% cols - col_df$width[select] <- widths - col_df$hidden[select] <- tolower(hidden) - col_df$bestFit[select] <- bestFit - col_df$customWidth[select] <- customWidth - self$worksheets[[sheet]]$fold_cols(col_df) - invisible(self) + set_col_widths = function( + sheet = current_sheet(), + cols, + widths = 8.43, + hidden = FALSE + ) { + wb_set_col_widths_impl( + self = self, + private = private, + sheet = sheet, + cols = cols, + widths = widths, + hidden = hidden + ) }, - ## rows ---- + ### rows ---- # TODO groupRows() and groupCols() are very similiar. Can problem turn # these into some wrappers for another method - #' @description - #' Group rows - #' @param sheet sheet - #' @param rows rows - #' @param collapsed collapsed - #' @param levels levels - #' @return The `wbWorkbook` object, invisibly - group_rows = function(sheet = current_sheet(), rows, collapsed = FALSE, levels = NULL) { - sheet <- private$get_sheet_index(sheet) - - if (length(collapsed) > length(rows)) { - stop("Collapses argument is of greater length than number of rows.") - } - - if (!is.logical(collapsed)) { - stop("Collapses should be a logical value (TRUE/FALSE).") - } - - if (any(rows <= 0L)) { - stop("Invalid rows entered (<= 0).") - } - - collapsed <- rep(as.character(as.integer(collapsed)), length.out = length(rows)) - - levels <- levels %||% rep("1", length(rows)) - - # Remove duplicates - ok <- !duplicated(rows) - collapsed <- collapsed[ok] - levels <- levels[ok] - rows <- rows[ok] - sheet <- private$get_sheet_index(sheet) - - # fetch the row_attr data.frame - row_attr <- self$worksheets[[sheet]]$sheet_data$row_attr - - rows_rev <- rev(rows) - - # get the selection based on the row_attr frame. - - # the first n -1 rows get outlineLevel - select <- row_attr$r %in% as.character(rows_rev[-1]) - if (length(select)) { - row_attr$outlineLevel[select] <- as.character(levels[-1]) - row_attr$collapsed[select] <- as.character(as.integer(collapsed[-1])) - row_attr$hidden[select] <- as.character(as.integer(collapsed[-1])) - } - - # the n-th row gets only collapsed - select <- row_attr$r %in% as.character(rows_rev[1]) - if (length(select)) { - row_attr$collapsed[select] <- as.character(as.integer(collapsed[1])) - } - - self$worksheets[[sheet]]$sheet_data$row_attr <- row_attr - - # check if there are valid outlineLevel in row_attr and assign outlineLevelRow the max outlineLevel (thats in the documentation) - if (any(row_attr$outlineLevel != "")) { - self$worksheets[[sheet]]$sheetFormatPr <- xml_attr_mod(self$worksheets[[sheet]]$sheetFormatPr, xml_attributes = c(outlineLevelRow = as.character(max(as.integer(row_attr$outlineLevel), na.rm = TRUE)))) - } - - invisible(self) - }, - - #' @description ungroup rows - #' @param sheet sheet - #' @param rows rows - #' @return The `wbWorkbook` object - ungroup_rows = function(sheet = current_sheet(), rows) { - sheet <- private$get_sheet_index(sheet) - - # check if any rows are selected - if (any(rows < 1L)) { - stop("Invalid rows entered (<= 0).") - } - - # fetch the row_attr data.frame - row_attr <- self$worksheets[[sheet]]$sheet_data$row_attr - - # get the selection based on the row_attr frame. - select <- row_attr$r %in% as.character(rows) - if (length(select)) { - row_attr$outlineLevel[select] <- "" - row_attr$collapsed[select] <- "" - # TODO only if unhide = TRUE - row_attr$hidden[select] <- "" - self$worksheets[[sheet]]$sheet_data$row_attr <- row_attr - } - - # If all outlineLevels are missing: remove the outlineLevelRow attribute. Assigning "" will remove the attribute - if (all(row_attr$outlineLevel == "")) { - self$worksheets[[sheet]]$sheetFormatPr <- xml_attr_mod(self$worksheets[[sheet]]$sheetFormatPr, xml_attributes = c(outlineLevelRow = "")) - } else { - self$worksheets[[sheet]]$sheetFormatPr <- xml_attr_mod(self$worksheets[[sheet]]$sheetFormatPr, xml_attributes = c(outlineLevelRow = as.character(max(as.integer(row_attr$outlineLevel))))) - } - - invisible(self) - }, - - #' @description - #' Remove a worksheet - #' @param sheet The worksheet to delete - #' @return The `wbWorkbook` object, invisibly - remove_worksheet = function(sheet = current_sheet()) { - # To delete a worksheet - # Remove colwidths element - # Remove drawing partname from Content_Types (drawing(sheet).xml) - # Remove highest sheet from Content_Types - # Remove drawings element - # Remove drawings_rels element - - # Remove vml element - # Remove vml_rels element - - # Remove rowHeights element - # Remove last sheet element from workbook - # Remove last sheet element from workbook.xml.rels - # Remove element from worksheets - # Remove element from worksheets_rels - # Remove hyperlinks - # Reduce calcChain i attributes & remove calcs on sheet - # Remove sheet from sheetOrder - # Remove queryTable references from workbook$definedNames to worksheet - # remove tables - - # TODO can we allow multiple sheets? - if (length(sheet) != 1) { - stop("sheet must have length 1.") - } - - sheet <- private$get_sheet_index(sheet) - sheet_names <- self$sheet_names - nSheets <- length(sheet_names) - sheet_names <- sheet_names[[sheet]] - - ## definedNames - if (length(self$workbook$definedNames)) { - # wb_validate_sheet() makes sheet an integer - # so we need to remove this before getting rid of the sheet names - self$workbook$definedNames <- self$workbook$definedNames[ - !get_nr_from_definedName(self)$sheets %in% self$sheet_names[sheet] - ] - } - - self$remove_named_region(sheet) - self$sheet_names <- self$sheet_names[-sheet] - private$original_sheet_names <- private$original_sheet_names[-sheet] - - # if a sheet has no relationships, we xml_rels will not contain data - if (!is.null(self$worksheets_rels[[sheet]])) { - - xml_rels <- rbindlist( - xml_attr(self$worksheets_rels[[sheet]], "Relationship") - ) - - if (nrow(xml_rels) && ncol(xml_rels)) { - xml_rels$type <- basename(xml_rels$Type) - xml_rels$target <- basename(xml_rels$Target) - xml_rels$target[xml_rels$type == "hyperlink"] <- "" - xml_rels$target_ind <- as.numeric(gsub("\\D+", "", xml_rels$target)) - } - - comment_id <- xml_rels$target_ind[xml_rels$type == "comments"] - # TODO not every sheet has a drawing. this originates from a time where - # every sheet created got a drawing assigned. - drawing_id <- xml_rels$target_ind[xml_rels$type == "drawing"] - pivotTable_id <- xml_rels$target_ind[xml_rels$type == "pivotTable"] - table_id <- xml_rels$target_ind[xml_rels$type == "table"] - thrComment_id <- xml_rels$target_ind[xml_rels$type == "threadedComment"] - vmlDrawing_id <- xml_rels$target_ind[xml_rels$type == "vmlDrawing"] - - # NULL the sheets - if (length(comment_id)) self$comments[[comment_id]] <- NULL - if (length(drawing_id)) self$drawings[[drawing_id]] <- "" - if (length(drawing_id)) self$drawings_rels[[drawing_id]] <- "" - if (length(thrComment_id)) self$threadComments[[thrComment_id]] <- NULL - if (length(vmlDrawing_id)) self$vml[[vmlDrawing_id]] <- NULL - if (length(vmlDrawing_id)) self$vml_rels[[vmlDrawing_id]] <- NULL - - #### Modify Content_Types - ## remove last drawings(sheet).xml from Content_Types - drawing_name <- xml_rels$target[xml_rels$type == "drawing"] - if (!is.null(drawing_name) && !identical(drawing_name, character())) - self$Content_Types <- grep(drawing_name, self$Content_Types, invert = TRUE, value = TRUE) - - } - - self$isChartSheet <- self$isChartSheet[-sheet] - - ## remove highest sheet - # (don't chagne this to a "grep(value = TRUE)" ... ) - self$Content_Types <- self$Content_Types[!grepl(sprintf("sheet%s.xml", nSheets), self$Content_Types)] - - # The names for the other drawings have changed - de <- xml_node(read_xml(self$Content_Types), "Default") - ct <- rbindlist(xml_attr(read_xml(self$Content_Types), "Override")) - ct[grepl("drawing", ct$PartName), "PartName"] <- sprintf("/xl/drawings/drawing%i.xml", seq_along(self$drawings)) - ct <- df_to_xml("Override", ct[c("PartName", "ContentType")]) - self$Content_Types <- c(de, ct) - - - ## sheetOrder - toRemove <- which(self$sheetOrder == sheet) - self$sheetOrder[self$sheetOrder > sheet] <- self$sheetOrder[self$sheetOrder > sheet] - 1L - self$sheetOrder <- self$sheetOrder[-toRemove] - - # TODO regexpr should be replaced - ## Need to remove reference from workbook.xml.rels to pivotCache - removeRels <- grep("pivotTables", self$worksheets_rels[[sheet]], value = TRUE) - if (length(removeRels)) { - ## sheet rels links to a pivotTable file, the corresponding pivotTable_rels file links to the cacheDefn which is listing in workbook.xml.rels - ## remove reference to this file from the workbook.xml.rels - fileNo <- reg_match0(removeRels, "(?<=pivotTable)[0-9]+(?=\\.xml)") - fileNo <- as.integer(unlist(fileNo)) - - toRemove <- stri_join( - sprintf("(pivotCacheDefinition%i\\.xml)", fileNo), - sep = " ", - collapse = "|" - ) - - toRemove <- stri_join( - sprintf("(pivotCacheDefinition%i\\.xml)", grep(toRemove, self$pivotTables.xml.rels)), - sep = " ", - collapse = "|" - ) - - ## remove reference to file from workbook.xml.res - self$workbook.xml.rels <- grep(toRemove, self$workbook.xml.rels, invert = TRUE, value = TRUE) - } - - ## As above for slicers - ## Need to remove reference from workbook.xml.rels to pivotCache - # removeRels <- grepl("slicers", self$worksheets_rels[[sheet]]) - - if (any(grepl("slicers", self$worksheets_rels[[sheet]]))) { - # don't change to a grep(value = TRUE) - self$workbook.xml.rels <- self$workbook.xml.rels[!grepl(sprintf("(slicerCache%s\\.xml)", sheet), self$workbook.xml.rels)] - } - - ## wont't remove tables and then won't need to reassign table r:id's but will rename them! - self$worksheets[[sheet]] <- NULL - self$worksheets_rels[[sheet]] <- NULL - - sel <- self$tables$tab_sheet == sheet - # tableName is a character Vector with an attached name Vector. - if (any(sel)) { - self$tables$tab_name[sel] <- paste0(self$tables$tab_name[sel], "_openxlsx_deleted") - tab_sheet <- self$tables$tab_sheet - tab_sheet[sel] <- 0 - tab_sheet[tab_sheet > sheet] <- tab_sheet[tab_sheet > sheet] - 1L - self$tables$tab_sheet <- tab_sheet - self$tables$tab_ref[sel] <- "" - self$tables$tab_xml[sel] <- "" - - # deactivate sheet - self$tables$tab_act[sel] <- 0 - } - - # ## drawing will always be the first relationship - # if (nSheets > 1) { - # for (i in seq_len(nSheets - 1L)) { - # # did this get updated from length of 3 to 2? - # #self$worksheets_rels[[i]][1:2] <- genBaseSheetRels(i) - # rel <- rbindlist(xml_attr(self$worksheets_rels[[i]], "Relationship")) - # if (nrow(rel) && ncol(rel)) { - # if (any(basename(rel$Type) == "drawing")) { - # rel$Target[basename(rel$Type) == "drawing"] <- sprintf("../drawings/drawing%s.xml", i) - # } - # if (is.null(rel$TargetMode)) rel$TargetMode <- "" - # self$worksheets_rels[[i]] <- df_to_xml("Relationship", rel[c("Id", "Type", "Target", "TargetMode")]) - # } - # } - # } else { - # self$worksheets_rels <- list() - # } - - ## remove sheet - sn <- apply_reg_match0(self$workbook$sheets, pat = '(?<= name=")[^"]+') - self$workbook$sheets <- self$workbook$sheets[!sn %in% sheet_names] - - ## Reset rIds - if (nSheets > 1) { - for (i in (sheet + 1L):nSheets) { - self$workbook$sheets <- gsub( - stri_join("rId", i), - stri_join("rId", i - 1L), - self$workbook$sheets, - fixed = TRUE - ) - } - } else { - self$workbook$sheets <- NULL - } - - ## Can remove highest sheet - # (don't use grepl(value = TRUE)) - self$workbook.xml.rels <- self$workbook.xml.rels[!grepl(sprintf("sheet%s.xml", nSheets), self$workbook.xml.rels)] + #' @description + #' Group rows + #' @param sheet sheet + #' @param rows rows + #' @param collapsed collapsed + #' @param levels levels + #' @return The `wbWorkbook` object, invisibly + group_rows = function( + sheet = current_sheet(), + rows, + collapsed = FALSE, + levels = NULL + ) { + wb_group_rows_impl( + self = self, + private = private, + sheet = sheet, + rows = rows, + collapsed = collapsed, + levels = levels + ) + }, - invisible(self) + #' @description ungroup rows + #' @param sheet sheet + #' @param rows rows + #' @return The `wbWorkbook` object + ungroup_rows = function(sheet = current_sheet(), rows) { + wb_ungroup_rows_impl(self, private, sheet = sheet, rows = rows) + }, + + #' @description + #' Remove a worksheet + #' @param sheet The worksheet to delete + #' @return The `wbWorkbook` object, invisibly + remove_worksheet = function(sheet = current_sheet()) { + wb_remove_worksheet_impl(self, private, sheet = sheet) }, + ### cells ---- + #' @description Adds data validation #' @param sheet sheet #' @param cols cols @@ -2731,113 +852,27 @@ wbWorkbook <- R6::R6Class( #' @param prompt The prompt text #' @returns The `wbWorkbook` object add_data_validation = function( - sheet = current_sheet(), + sheet = current_sheet(), cols, rows, type, operator, value, - allowBlank = TRUE, + allowBlank = TRUE, showInputMsg = TRUE, showErrorMsg = TRUE, - errorStyle = NULL, - errorTitle = NULL, - error = NULL, - promptTitle = NULL, - prompt = NULL + errorStyle = NULL, + errorTitle = NULL, + error = NULL, + promptTitle = NULL, + prompt = NULL ) { - - sheet <- private$get_sheet_index(sheet) - - ## rows and cols - if (!is.numeric(cols)) { - cols <- col2int(cols) - } - rows <- as.integer(rows) - - assert_class(allowBlank, "logical") - assert_class(showInputMsg, "logical") - assert_class(showErrorMsg, "logical") - - ## check length of value - if (length(value) > 2) { - stop("value argument must be length <= 2") - } - - valid_types <- c( - "custom", - "whole", - "decimal", - "date", - "time", ## need to conv - "textLength", - "list" - ) - - if (!tolower(type) %in% tolower(valid_types)) { - stop("Invalid 'type' argument!") - } - - ## operator == 'between' we leave out - valid_operators <- c( - "between", - "notBetween", - "equal", - "notEqual", - "greaterThan", - "lessThan", - "greaterThanOrEqual", - "lessThanOrEqual" - ) - - if (!tolower(type) %in% c("custom", "list")) { - if (!tolower(operator) %in% tolower(valid_operators)) { - stop("Invalid 'operator' argument!") - } - - operator <- valid_operators[tolower(valid_operators) %in% tolower(operator)][1] - } else if (tolower(type) == "custom") { - operator <- NULL - } else { - operator <- "between" ## ignored - } - - ## All inputs validated - - type <- valid_types[tolower(valid_types) %in% tolower(type)][1] - - ## check input combinations - if ((type == "date") && !inherits(value, "Date")) { - stop("If type == 'date' value argument must be a Date vector.") - } - - if ((type == "time") && !inherits(value, c("POSIXct", "POSIXt"))) { - stop("If type == 'time' value argument must be a POSIXct or POSIXlt vector.") - } - - - value <- head(value, 2) - allowBlank <- as.character(as.integer(allowBlank[1])) - showInputMsg <- as.character(as.integer(showInputMsg[1])) - showErrorMsg <- as.character(as.integer(showErrorMsg[1])) - - # prepare for worksheet - origin <- get_date_origin(self, origin = TRUE) - - sqref <- stri_join( - get_cell_refs(data.frame( - "x" = c(min(rows), max(rows)), - "y" = c(min(cols), max(cols)) - )), - sep = " ", - collapse = ":" - ) - - if (type == "list") { - operator <- NULL - } - - self$worksheets[[sheet]]$.__enclos_env__$private$data_validation( + workbook_add_data_validations( + self = self, + private = private, + sheet = sheet, + cols = cols, + rows = rows, type = type, operator = operator, value = value, @@ -2848,12 +883,8 @@ wbWorkbook <- R6::R6Class( errorTitle = errorTitle, error = error, promptTitle = promptTitle, - prompt = prompt, - origin = origin, - sqref = sqref + prompt = prompt ) - - invisible(self) }, #' @description @@ -2862,42 +893,13 @@ wbWorkbook <- R6::R6Class( #' @param rows,cols Row and column specifications. #' @return The `wbWorkbook` object, invisibly merge_cells = function(sheet = current_sheet(), rows = NULL, cols = NULL) { - sheet <- private$get_sheet_index(sheet) - - # TODO send to wbWorksheet() method - # self$worksheets[[sheet]]$merge_cells(rows = rows, cols = cols) - # invisible(self) - - rows <- range(as.integer(rows)) - cols <- range(as.integer(cols)) - - sqref <- paste0(int2col(cols), rows) - sqref <- stri_join(sqref, collapse = ":", sep = " ") - - current <- rbindlist(xml_attr(xml = self$worksheets[[sheet]]$mergeCells, "mergeCell"))$ref - - # regmatch0 will return character(0) when x is NULL - if (length(current)) { - - new_merge <- unname(unlist(dims_to_dataframe(sqref, fill = TRUE))) - current_cells <- lapply(current, function(x) unname(unlist(dims_to_dataframe(x, fill = TRUE)))) - intersects <- vapply(current_cells, function(x) any(x %in% new_merge), NA) - - # Error if merge intersects - if (any(intersects)) { - msg <- sprintf( - "Merge intersects with existing merged cells: \n\t\t%s.\nRemove existing merge first.", - stri_join(current[intersects], collapse = "\n\t\t") - ) - stop(msg, call. = FALSE) - } - } - - # TODO does this have to be xml? Can we just save the data.frame or - # matrix and then check that? This would also simplify removing the - # merge specifications - private$append_sheet_field(sheet, "mergeCells", sprintf('', sqref)) - invisible(self) + wb_merge_cells_impl( + self = self, + private = private, + sheet = sheet, + rows = rows, + cols = cols + ) }, #' @description @@ -2905,27 +907,18 @@ wbWorkbook <- R6::R6Class( #' @param sheet sheet #' @param rows,cols Row and column specifications. #' @return The `wbWorkbook` object, invisibly - unmerge_cells = function(sheet = current_sheet(), rows = NULL, cols = NULL) { - sheet <- private$get_sheet_index(sheet) - - rows <- range(as.integer(rows)) - cols <- range(as.integer(cols)) - - sqref <- paste0(int2col(cols), rows) - sqref <- stri_join(sqref, collapse = ":", sep = " ") - - current <- rbindlist(xml_attr(xml = self$worksheets[[sheet]]$mergeCells, "mergeCell"))$ref - - if (!is.null(current)) { - new_merge <- unname(unlist(dims_to_dataframe(sqref, fill = TRUE))) - current_cells <- lapply(current, function(x) unname(unlist(dims_to_dataframe(x, fill = TRUE)))) - intersects <- vapply(current_cells, function(x) any(x %in% new_merge), NA) - - # Remove intersection - self$worksheets[[sheet]]$mergeCells <- self$worksheets[[sheet]]$mergeCells[!intersects] - } - - invisible(self) + unmerge_cells = function( + sheet = current_sheet(), + rows = NULL, + cols = NULL + ) { + wb_unmerge_cells_impl( + self = self, + private = private, + sheet = sheet, + rows = rows, + cols = cols + ) }, #' @description @@ -2937,94 +930,24 @@ wbWorkbook <- R6::R6Class( #' @param firstCol firstCol #' @return The `wbWorkbook` object, invisibly freeze_pane = function( - sheet = current_sheet(), + sheet = current_sheet(), firstActiveRow = NULL, firstActiveCol = NULL, - firstRow = FALSE, - firstCol = FALSE + firstRow = FALSE, + firstCol = FALSE ) { - # TODO rename to setFreezePanes? - - # fine to do the validation before the actual check to prevent other errors - sheet <- private$get_sheet_index(sheet) - - if (is.null(firstActiveRow) & is.null(firstActiveCol) & !firstRow & !firstCol) { - return(invisible(self)) - } - - # TODO simplify asserts - if (!is.logical(firstRow)) stop("firstRow must be TRUE/FALSE") - if (!is.logical(firstCol)) stop("firstCol must be TRUE/FALSE") - - # make overwrides for arguments - if (firstRow & !firstCol) { - firstActiveCol <- NULL - firstActiveRow <- NULL - firstCol <- FALSE - } else if (firstCol & !firstRow) { - firstActiveRow <- NULL - firstActiveCol <- NULL - firstRow <- FALSE - } else if (firstRow & firstCol) { - firstActiveRow <- 2L - firstActiveCol <- 2L - firstRow <- FALSE - firstCol <- FALSE - } else { - ## else both firstRow and firstCol are FALSE - firstActiveRow <- firstActiveRow %||% 1L - firstActiveCol <- firstActiveCol %||% 1L - - # Convert to numeric if column letter given - # TODO is col2int() safe for non characters? - firstActiveRow <- col2int(firstActiveRow) - firstActiveCol <- col2int(firstActiveCol) - } - - paneNode <- - if (firstRow) { - '' - } else if (firstCol) { - '' - } else { - if (firstActiveRow == 1 & firstActiveCol == 1) { - ## nothing to do - # return(NULL) - return(invisible(self)) - } - - if (firstActiveRow > 1 & firstActiveCol == 1) { - attrs <- sprintf('ySplit="%s"', firstActiveRow - 1L) - activePane <- "bottomLeft" - } - - if (firstActiveRow == 1 & firstActiveCol > 1) { - attrs <- sprintf('xSplit="%s"', firstActiveCol - 1L) - activePane <- "topRight" - } - - if (firstActiveRow > 1 & firstActiveCol > 1) { - attrs <- sprintf('ySplit="%s" xSplit="%s"', - firstActiveRow - 1L, - firstActiveCol - 1L - ) - activePane <- "bottomRight" - } - - sprintf( - '', - stri_join(attrs, collapse = " ", sep = " "), - get_cell_refs(data.frame(firstActiveRow, firstActiveCol)), - activePane, - activePane - ) - } - - self$worksheets[[sheet]]$freezePane <- paneNode - invisible(self) + wb_free_panes_impl( + self = self, + private = private, + sheet = sheet, + firstActiveRow = firstActiveRow, + firstActiveCol = firstActiveCol, + firstRow = firstRow, + firstCol = firstCol + ) }, - ## comment ---- + ### comment ---- #' @description Add comment #' @param sheet sheet @@ -3034,27 +957,21 @@ wbWorkbook <- R6::R6Class( #' @param comment a comment to apply to the worksheet #' @returns The `wbWorkbook` object add_comment = function( - sheet = current_sheet(), - col, - row, - dims = rowcol_to_dims(row, col), - comment) { - - if (!missing(dims)) { - xy <- unlist(dims_to_rowcol(dims)) - col <- xy[[1]] - row <- as.integer(xy[[2]]) - } - - write_comment( - wb = self, - sheet = sheet, - col = col, - row = row, + sheet = current_sheet(), + col, + row, + dims = rowcol_to_dims(row, col), + comment + ) { + wb_add_comment_impl( + self = self, + private = private, + sheet = sheet, + col = col, + row = row, + dims = dims, comment = comment - ) # has no use: xy - - invisible(self) + ) }, #' @description Remove comment @@ -3065,27 +982,24 @@ wbWorkbook <- R6::R6Class( #' @param gridExpand Remove all comments inside the grid. Similar to dims "A1:B2" #' @returns The `wbWorkbook` object remove_comment = function( - sheet = current_sheet(), + sheet = current_sheet(), col, row, - dims = rowcol_to_dims(row, col), + dims = rowcol_to_dims(row, col), gridExpand = TRUE ) { - - if (!missing(dims)) { - xy <- unlist(dims_to_rowcol(dims)) - col <- xy[[1]] - row <- as.integer(xy[[2]]) - # with gridExpand this is always true - gridExpand <- TRUE - } - - remove_comment(wb = self, sheet = sheet, col = col, row = row, gridExpand = TRUE) - - invisible(self) + wb_remove_comment_impl( + self = self, + private = private, + sheet = sheet, + col = col, + row = row, + dims = dims, + gridExpand = gridExpand + ) }, - ## conditional formatting ---- + ### conditional formatting ---- # TODO remove_conditional_formatting? @@ -3099,243 +1013,37 @@ wbWorkbook <- R6::R6Class( #' @param params Additional parameters #' @returns The `wbWorkbook` object add_conditional_formatting = function( - sheet = current_sheet(), - cols, - rows, - rule = NULL, - style = NULL, - # TODO add vector of possible values - type = c("expression", "colorScale", "dataBar", "duplicatedValues", - "containsText", "notContainsText", "beginsWith", "endsWith", - "between", "topN", "bottomN"), - params = list( - showValue = TRUE, - gradient = TRUE, - border = TRUE, - percent = FALSE, - rank = 5L - ) - ) { - - if (!is.null(style)) assert_class(style, "character") - assert_class(type, "character") - assert_class(params, "list") - - type <- match.arg(type) - - ## rows and cols - if (!is.numeric(cols)) { - cols <- col2int(cols) - } - - rows <- as.integer(rows) - - ## check valid rule - dxfId <- NULL - if (!is.null(style)) dxfId <- self$styles_mgr$get_dxf_id(style) - params <- validate_cf_params(params) - values <- NULL - - sel <- c("expression", "duplicatedValues", "containsText", "notContainsText", "beginsWith", "endsWith", "between", "topN", "bottomN") - if (is.null(style) && type %in% sel) { - smp <- random_string() - style <- create_dxfs_style(font_color = wb_colour(hex = "FF9C0006"), bgFill = wb_colour(hex = "FFFFC7CE")) - self$styles_mgr$add(style, smp) - dxfId <- self$styles_mgr$get_dxf_id(smp) - } - - switch( - type, - - expression = { - # TODO should we bother to do any conversions or require the text - # entered to be exactly as an Excel expression would be written? - msg <- "When type == 'expression', " - - if (!is.character(rule) || length(rule) != 1L) { - stop(msg, "rule must be a single length character vector") - } - - rule <- gsub("!=", "<>", rule) - rule <- gsub("==", "=", rule) - rule <- replace_legal_chars(rule) # replaces <> - - if (!grepl("[A-Z]", substr(rule, 1, 2))) { - ## formula looks like "operatorX" , attach top left cell to rule - rule <- paste0( - get_cell_refs(data.frame(min(rows), min(cols))), - rule - ) - } ## else, there is a letter in the formula and apply as is - - }, - - colorScale = { - # - style is a vector of colours with length 2 or 3 - # - rule specifies the quantiles (numeric vector of length 2 or 3), if NULL min and max are used - msg <- "When type == 'colourScale', " - - if (!is.character(style)) { - stop(msg, "style must be a vector of colours of length 2 or 3.") - } - - if (!length(style) %in% 2:3) { - stop(msg, "style must be a vector of length 2 or 3.") - } - - if (!is.null(rule)) { - if (length(rule) != length(style)) { - stop(msg, "rule and style must have equal lengths.") - } - } - - style <- check_valid_colour(style) - - if (isFALSE(style)) { - stop(msg, "style must be valid colors") - } - - values <- rule - rule <- style - }, - - dataBar = { - # - style is a vector of colours of length 2 or 3 - # - rule specifies the quantiles (numeric vector of length 2 or 3), if NULL min and max are used - msg <- "When type == 'dataBar', " - style <- style %||% "#638EC6" - - # TODO use inherits() not class() - if (!inherits(style, "character")) { - stop(msg, "style must be a vector of colours of length 1 or 2.") - } - - if (!length(style) %in% 1:2) { - stop(msg, "style must be a vector of length 1 or 2.") - } - - if (!is.null(rule)) { - if (length(rule) != length(style)) { - stop(msg, "rule and style must have equal lengths.") - } - } - - ## Additional parameters passed by ... - # showValue, gradient, border - style <- check_valid_colour(style) - - if (isFALSE(style)) { - stop(msg, "style must be valid colors") - } - - values <- rule - rule <- style - }, - - duplicatedValues = { - # type == "duplicatedValues" - # - style is a Style object - # - rule is ignored - - rule <- style - }, - - containsText = { - # - style is Style object - # - rule is text to look for - msg <- "When type == 'contains', " - - if (!inherits(rule, "character")) { - stop(msg, "rule must be a character vector of length 1.") - } - - values <- rule - rule <- style - }, - - notContainsText = { - # - style is Style object - # - rule is text to look for - msg <- "When type == 'notContains', " - - if (!inherits(rule, "character")) { - stop(msg, "rule must be a character vector of length 1.") - } - - values <- rule - rule <- style - }, - - beginsWith = { - # - style is Style object - # - rule is text to look for - msg <- "When type == 'beginsWith', " - - if (!is.character("character")) { - stop(msg, "rule must be a character vector of length 1.") - } - - values <- rule - rule <- style - }, - - endsWith = { - # - style is Style object - # - rule is text to look for - msg <- "When type == 'endsWith', " - - if (!inherits(rule, "character")) { - stop(msg, "rule must be a character vector of length 1.") - } - - values <- rule - rule <- style - }, - - between = { - rule <- range(rule) - }, - - topN = { - # - rule is ignored - # - 'rank' and 'percent' are named params - - ## Additional parameters passed by ... - # percent, rank - - values <- params - rule <- style - }, - - bottomN = { - # - rule is ignored - # - 'rank' and 'percent' are named params - - ## Additional parameters passed by ... - # percent, rank - - values <- params - rule <- style - } + sheet = current_sheet(), + cols, + rows, + rule = NULL, + style = NULL, + # TODO add vector of possible values + type = c("expression", "colorScale", "dataBar", "duplicatedValues", + "containsText", "notContainsText", "beginsWith", "endsWith", + "between", "topN", "bottomN"), + params = list( + showValue = TRUE, + gradient = TRUE, + border = TRUE, + percent = FALSE, + rank = 5L ) - - private$do_conditional_formatting( - sheet = sheet, - startRow = min(rows), - endRow = max(rows), - startCol = min(cols), - endCol = max(cols), - dxfId = dxfId, - formula = rule, - type = type, - values = values, - params = params + ) { + wb_add_conditional_formatting_impl( + self = self, + private = private, + sheet = sheet, + cols = cols, + rows = rows, + rule = rule, + style = style, + type = type, + params = params ) - - invisible(self) }, - ## plots and images ---- + ### plots and images ---- #' @description #' Insert an image into a sheet @@ -3351,7 +1059,7 @@ wbWorkbook <- R6::R6Class( #' @param dpi dpi #' @return The `wbWorkbook` object, invisibly add_image = function( - sheet = current_sheet(), + sheet = current_sheet(), file, width = 6, height = 3, @@ -3362,148 +1070,20 @@ wbWorkbook <- R6::R6Class( units = "in", dpi = 300 ) { - if (!file.exists(file)) { - stop("File does not exist.") - } - - # TODO require user to pass a valid path - if (!grepl("\\\\|\\/", file)) { - file <- file.path(getwd(), file, fsep = .Platform$file.sep) - } - - units <- tolower(units) - - # TODO use match.arg() - if (!units %in% c("cm", "in", "px")) { - stop("Invalid units.\nunits must be one of: cm, in, px") - } - - startCol <- col2int(startCol) - startRow <- as.integer(startRow) - - ## convert to inches - if (units == "px") { - width <- width / dpi - height <- height / dpi - } else if (units == "cm") { - width <- width / 2.54 - height <- height / 2.54 - } - - ## Convert to EMUs - width <- as.integer(round(width * 914400L, 0)) # (EMUs per inch) - height <- as.integer(round(height * 914400L, 0)) # (EMUs per inch) - - ## within the sheet the drawing node's Id refernce an id in the sheetRels - ## sheet rels reference the drawingi.xml file - ## drawingi.xml refernece drawingRels - ## drawing rels reference an image in the media folder - ## worksheetRels(sheet(i)) references drawings(j) - - sheet <- private$get_sheet_index(sheet) - - # TODO tools::file_ext() ... - imageType <- regmatches(file, gregexpr("\\.[a-zA-Z]*$", file)) - imageType <- gsub("^\\.", "", imageType) - - drawing_sheet <- 1 - if (length(self$worksheets_rels[[sheet]])) { - relship <- rbindlist(xml_attr(self$worksheets_rels[[sheet]], "Relationship")) - relship$typ <- basename(relship$Type) - drawing_sheet <- as.integer(gsub("\\D+", "", relship$Target[relship$typ == "drawing"])) - } - - drawing_len <- 0 - if (!all(self$drawings_rels[[drawing_sheet]] == "")) - drawing_len <- length(xml_node(unlist(self$drawings_rels[[drawing_sheet]]), "Relationship")) - - imageNo <- drawing_len + 1L - mediaNo <- length(self$media) + 1L - - startCol <- col2int(startCol) - - ## update Content_Types - if (!any(grepl(stri_join("image/", imageType), self$Content_Types))) { - self$Content_Types <- - unique(c( - sprintf( - '', - imageType, - imageType - ), - self$Content_Types - )) - } - - # update worksheets_rels - if (length(self$worksheets_rels[[sheet]]) == 0) { - self$worksheets_rels[[sheet]] <- sprintf('', imageNo) ## will always be 1 - } - - # update drawings_rels - old_drawings_rels <- unlist(self$drawings_rels[[drawing_sheet]]) - if (all(old_drawings_rels == "")) old_drawings_rels <- NULL - ## drawings rels (Reference from drawings.xml to image file in media folder) - self$drawings_rels[[drawing_sheet]] <- c( - old_drawings_rels, - sprintf( - '', - imageNo, - mediaNo, - imageType - ) - ) - - ## write file path to media slot to copy across on save - tmp <- file - names(tmp) <- stri_join("image", mediaNo, ".", imageType) - self$append("media", tmp) - - ## create drawing.xml - anchor <- '' - - from <- sprintf( - ' - %s - %s - %s - %s - ', - startCol - 1L, - colOffset, - startRow - 1L, - rowOffset - ) - - drawingsXML <- stri_join( - anchor, - from, - sprintf('', width, height), - genBasePic(imageNo), - "", - "" - ) - - - # If no drawing is found, initiate one. If one is found, append a child to the exisiting node. - # Might look into updating attributes as well. - if (all(self$drawings[[drawing_sheet]] == "")) { - xml_attr <- c( - "xmlns:xdr" = "http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing", - "xmlns:a" = "http://schemas.openxmlformats.org/drawingml/2006/main", - "xmlns:r" = "http://schemas.openxmlformats.org/officeDocument/2006/relationships" - ) - self$drawings[[drawing_sheet]] <- xml_node_create("xdr:wsDr", xml_children = drawingsXML, xml_attributes = xml_attr) - } else { - self$drawings[[drawing_sheet]] <- xml_add_child(self$drawings[[drawing_sheet]], drawingsXML) - } - - # Finally we must assign the drawing to the sheet, if no drawing is assigned. If drawing is not - # empty, we must assume that the rId matches another drawing rId in worksheets_rels - if (identical(self$worksheets[[sheet]]$drawing, character())) - self$worksheets[[sheet]]$drawing <- '' ## will always be 1 - - invisible(self) + wb_add_image_impl( + self = self, + private = private, + sheet = sheet, + file = file, + width = width, + height = height, + startRow = startRow, + startCol = startCol, + rowOffset = rowOffset, + colOffset = colOffset, + units = units, + dpi = dpi + ) }, #' @description Add plot. A wrapper for add_image() @@ -3532,58 +1112,18 @@ wbWorkbook <- R6::R6Class( units = "in", dpi = 300 ) { - if (is.null(dev.list()[[1]])) { - warning("No plot to insert.") - return(invisible(self)) - } - - if (!is.null(xy)) { - startCol <- xy[[1]] - startRow <- xy[[2]] - } - - fileType <- tolower(fileType) - units <- tolower(units) - - # TODO just don't allow jpg - if (fileType == "jpg") { - fileType <- "jpeg" - } - - # TODO add match.arg() - if (!fileType %in% c("png", "jpeg", "tiff", "bmp")) { - stop("Invalid file type.\nfileType must be one of: png, jpeg, tiff, bmp") - } - - if (!units %in% c("cm", "in", "px")) { - stop("Invalid units.\nunits must be one of: cm, in, px") - } - - fileName <- tempfile(pattern = "figureImage", fileext = paste0(".", fileType)) - - # TODO use switch() - if (fileType == "bmp") { - dev.copy(bmp, filename = fileName, width = width, height = height, units = units, res = dpi) - } else if (fileType == "jpeg") { - dev.copy(jpeg, filename = fileName, width = width, height = height, units = units, quality = 100, res = dpi) - } else if (fileType == "png") { - dev.copy(png, filename = fileName, width = width, height = height, units = units, res = dpi) - } else if (fileType == "tiff") { - dev.copy(tiff, filename = fileName, width = width, height = height, units = units, compression = "none", res = dpi) - } - - ## write image - invisible(dev.off()) - - self$add_image( + wb_add_plot_impl( + self = self, + private = private, sheet = sheet, - file = fileName, width = width, height = height, + xy = xy, startRow = startRow, startCol = startCol, rowOffset = rowOffset, colOffset = colOffset, + fileType = fileType, units = units, dpi = dpi ) @@ -3597,115 +1137,15 @@ wbWorkbook <- R6::R6Class( add_drawing = function( sheet = current_sheet(), xml, - dims = "A1:H8" + dims = "A1:H8" ) { - sheet <- private$get_sheet_index(sheet) - - xml <- read_xml(xml, pointer = FALSE) - - if (!(xml_node_name(xml) == "xdr:wsDr")) { - error("xml needs to be a drawing.") - } - - grpSp <- xml_node(xml, "xdr:wsDr", "xdr:absoluteAnchor", "xdr:grpSp") - ext <- xml_node(xml, "xdr:wsDr", "xdr:absoluteAnchor", "xdr:ext") - - # include rvg graphic from specific position to one or two cell anchor - if (!is.null(dims) && xml_node_name(xml, "xdr:wsDr") == "xdr:absoluteAnchor") { - - twocell <- grepl(":", dims) - - if (twocell) { - - xdr_typ <- "xdr:twoCellAnchor" - ext <- NULL - - dims_list <- strsplit(dims, ":")[[1]] - cols <- col2int(dims_list) - rows <- as.numeric(gsub("\\D+", "", dims_list)) - - anchor <- paste0( - "", - "%s0", - "%s0", - "", - "", - "%s0", - "%s0", - "" - ) - anchor <- sprintf(anchor, cols[1] - 1L, rows[1] - 1L, cols[2], rows[2]) - - } else { - - xdr_typ <- "xdr:oneCellAnchor" - - cols <- col2int(dims) - rows <- as.numeric(gsub("\\D+", "", dims)) - - anchor <- paste0( - "", - "%s0", - "%s0", - "" - ) - anchor <- sprintf(anchor, cols[1] - 1L, rows[1] - 1L) - - } - - xdr_typ_xml <- xml_node_create( - xdr_typ, - xml_children = c( - anchor, - ext, - grpSp, - "" - ) - ) - - xml <- xml_node_create( - "xdr:wsDr", - xml_attributes = c( - "xmlns:a" = "http://schemas.openxmlformats.org/drawingml/2006/main", - "xmlns:r" = "http://schemas.openxmlformats.org/officeDocument/2006/relationships", - "xmlns:pic" = "http://schemas.openxmlformats.org/drawingml/2006/picture", - "xmlns:xdr" = "http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing" - ), - xml_children = xdr_typ_xml - ) - } - - # check if sheet already contains drawing. if yes, try to integrate - # our drawing into this else we only use our drawing. - drawings <- self$drawings[[sheet]] - if (drawings == "") { - drawings <- xml - } else { - drawing_type <- xml_node_name(xml, "xdr:wsDr") - xml_drawing <- xml_node(xml, "xdr:wsDr", drawing_type) - drawings <- xml_add_child(drawings, xml_drawing) - } - self$drawings[[sheet]] <- drawings - - # get the correct next free relship id - if (length(self$worksheets_rels[[sheet]]) == 0) { - next_relship <- 1 - has_no_drawing <- TRUE - } else { - relship <- rbindlist(xml_attr(self$worksheets_rels[[sheet]], "Relationship")) - relship$typ <- basename(relship$Type) - next_relship <- as.integer(gsub("\\D+", "", relship$Id)) + 1L - has_no_drawing <- !any(relship$typ == "drawing") - } - - # if a drawing exisits, we already added ourself to it. Otherwise we - # create a new drawing. - if (has_no_drawing) { - self$worksheets_rels[[sheet]] <- sprintf("", next_relship, sheet) - self$worksheets[[sheet]]$drawing <- sprintf("", next_relship) - } - - invisible(self) + wb_add_drawing_impl( + self = self, + private = private, + sheet = sheet, + xml = xml, + dims = dims + ) }, #' @description Add xml drawing @@ -3717,43 +1157,15 @@ wbWorkbook <- R6::R6Class( add_chart_xml = function( sheet = current_sheet(), xml, - dims = "A1:H8" + dims = "A1:H8" ) { - - dims_list <- strsplit(dims, ":")[[1]] - cols <- col2int(dims_list) - rows <- as.numeric(gsub("\\D+", "", dims_list)) - - sheet <- private$get_sheet_index(sheet) - - next_chart <- NROW(self$charts) + 1 - - chart <- data.frame( - chart = xml, - colors = colors1_xml, - style = styleplot_xml, - rels = chart1_rels_xml(next_chart), - chartEx = "", - relsEx = "" - ) - - self$charts <- rbind(self$charts, chart) - - len_drawing <- length(xml_node_name(self$drawings[[sheet]], "xdr:wsDr")) + 1L - - from <- c(cols[1] - 1L, rows[1] - 1L) - to <- c(cols[2], rows[2]) - - # create drawing. add it to self$drawings, the worksheet and rels - self$add_drawing( - sheet = sheet, - xml = drawings(len_drawing, from, to), - dims = dims + wb_add_chart_xml_impl( + self = self, + private = private, + sheet = sheet, + xml = xml, + dims = dims ) - - self$drawings_rels[[sheet]] <- drawings_rels(self$drawings_rels[[sheet]], next_chart) - - invisible(self) }, #' @description Add mschart chart to the workbook @@ -3766,68 +1178,25 @@ wbWorkbook <- R6::R6Class( dims = "B2:H8", graph ) { - - requireNamespace("mschart") - assert_class(graph, "ms_chart") - - sheetname <- private$get_sheet_name(sheet) - - # format.ms_chart is exported in mschart >= 0.4 - out_xml <- read_xml( - format( - graph, - sheetname = sheetname, - id_x = "64451212", - id_y = "64453248" - ), - pointer = FALSE + wb_add_mschart_impl( + self = self, + private = private, + sheet = sheet, + dims = dims, + graph = graph ) - - # write the chart data to the workbook - if (inherits(graph$data_series, "wb_data")) { - self$ - add_chart_xml(sheet = sheet, xml = out_xml, dims = dims) - } else { - self$ - add_data(x = graph$data_series)$ - add_chart_xml(sheet = sheet, xml = out_xml, dims = dims) - } }, + ### methods ---- + #' @description #' Prints the `wbWorkbook` object #' @return The `wbWorkbook` object, invisibly; called for its side-effects print = function() { - exSheets <- self$get_sheet_names() - nSheets <- length(exSheets) - nImages <- length(self$media) - nCharts <- length(self$charts) - - showText <- "A Workbook object.\n" - - ## worksheets - if (nSheets > 0) { - showText <- c(showText, "\nWorksheets:\n") - sheetTxt <- sprintf("Sheets: %s", paste(names(exSheets), collapse = " ")) - - showText <- c(showText, sheetTxt, "\n") - } else { - showText <- - c(showText, "\nWorksheets:\n", "No worksheets attached\n") - } - - if (nSheets > 0) { - showText <- - c(showText, sprintf( - "Write order: %s", - stri_join(self$sheetOrder, sep = " ", collapse = ", ") - )) - } - - cat(unlist(showText)) - invisible(self) + wb_print_impl(self, private) }, + ### protect --- #' @description #' Protect a workbook @@ -3850,41 +1219,18 @@ wbWorkbook <- R6::R6Class( username = unname(Sys.info()["user"]), readOnlyRecommended = FALSE ) { - - if (!protect) { - self$workbook$workbookProtection <- NULL - return(self) - } - - # match.arg() doesn't handle numbers too well - type <- if (!is.character(type)) as.character(type) - password <- if (is.null(password)) "" else hashPassword(password) - - # TODO: Shall we parse the existing protection settings and preserve all - # unchanged attributes? - - if (fileSharing) { - self$workbook$fileSharing <- xml_node_create( - "fileSharing", - xml_attributes = c( - userName = username, - readOnlyRecommended = if (readOnlyRecommended | type == "2") "1", - reservationPassword = password - ) - ) - } - - self$workbook$workbookProtection <- xml_node_create( - "workbookProtection", - xml_attributes = c( - hashPassword = password, - lockStructure = toString(as.numeric(lockStructure)), - lockWindows = toString(as.numeric(lockWindows)) - ) + wb_protect_impl( + self = self, + private = private, + protect = protect, + password = password, + lockStructure = lockStructure, + lockWindows = lockWindows, + type = type, + fileSharing = fileSharing, + username = username, + readOnlyRecommended = readOnlyRecommended ) - - self$workbook$apps <- xml_node_create("DocSecurity", type) - invisible(self) }, #' @description protect worksheet @@ -3899,91 +1245,56 @@ wbWorkbook <- R6::R6Class( #' `"autoFilter"`, `"pivotTables"`, `"objects"`, `"scenarios"` #' @returns The `wbWorkbook` object protect_worksheet = function( - sheet = current_sheet(), - protect = TRUE, - password = NULL, - properties = NULL + sheet = current_sheet(), + protect = TRUE, + password = NULL, + properties = NULL ) { - - sheet <- wb_validate_sheet(self, sheet) - - if (!protect) { - # initializes as character() - self$worksheets[[sheet]]$sheetProtection <- character() - return(self) - } - - all_props <- worksheet_lock_properties() - - if (!is.null(properties)) { - # ensure only valid properties are listed - properties <- match.arg(properties, all_props, several.ok = TRUE) - } - - properties <- as.character(as.numeric(all_props %in% properties)) - names(properties) <- all_props - - if (!is.null(password)) - properties <- c(properties, password = hashPassword(password)) - - self$worksheets[[sheet]]$sheetProtection <- xml_node_create( - "sheetProtection", - xml_attributes = c( - sheet = "1", - properties[properties != "0"] - ) + wb_protect_worksheet_impl( + self = self, + private = private, + sheet = sheet, + protect = protect, + password = password, + properties = properties ) - - invisible(self) }, - ### creators -------------------------------------------------------------- #' @description Set creator(s) #' @param creators A character vector of creators to set. Duplicates are #' ignored. set_creators = function(creators) { - private$modify_creators("set", creators) + wb_modify_creators_impl(self, private, "set", creators) }, - #' @description Add creator(s) #' @param creators A character vector of creators to add. Duplicates are #' ignored. add_creators = function(creators) { - private$modify_creators("add", creators) + wb_modify_creators_impl(self, private, "add", creators) }, - #' @description Remove creator(s) #' @param creators A character vector of creators to remove. All duplicated #' are removed. remove_creators = function(creators) { - private$modify_creators("remove", creators) + wb_modify_creators_impl(self, private, "remove", creators) }, + ### last modified by ---- #' @description #' Change the last modified by #' @param LastModifiedBy A new value #' @return The `wbWorkbook` object, invisibly set_last_modified_by = function(LastModifiedBy = NULL) { - # TODO rename to wb_set_last_modified_by() ? - if (!is.null(LastModifiedBy)) { - current_LastModifiedBy <- - stri_match(self$core, regex = "(.*?)")[1, 2] - self$core <- - stri_replace_all_fixed( - self$core, - pattern = current_LastModifiedBy, - replacement = LastModifiedBy - ) - } - - invisible(self) + wb_set_last_modified_by_impl(self, private, LastModifiedBy) }, + ### page setup ---- + #' @description page_setup() #' @param sheet sheet #' @param orientation orientation @@ -4020,138 +1331,29 @@ wbWorkbook <- R6::R6Class( summaryRow = NULL, summaryCol = NULL ) { - sheet <- private$get_sheet_index(sheet) - xml <- self$worksheets[[sheet]]$pageSetup - - if (!is.null(orientation)) { - orientation <- tolower(orientation) - if (!orientation %in% c("portrait", "landscape")) stop("Invalid page orientation.") - } else { - # if length(xml) == 1 then use if () {} else {} - orientation <- ifelse(grepl("landscape", xml), "landscape", "portrait") ## get existing - } - - if ((scale < 10) || (scale > 400)) { - stop("Scale must be between 10 and 400.") - } - - if (!is.null(paperSize)) { - paperSizes <- 1:68 - paperSizes <- paperSizes[!paperSizes %in% 48:49] - if (!paperSize %in% paperSizes) { - stop("paperSize must be an integer in range [1, 68]. See ?ws_page_setup details.") - } - paperSize <- as.integer(paperSize) - } else { - paperSize <- regmatches(xml, regexpr('(?<=paperSize=")[0-9]+', xml, perl = TRUE)) ## get existing - } - - ## Keep defaults on orientation, hdpi, vdpi, paperSize ---- - hdpi <- regmatches(xml, regexpr('(?<=horizontalDpi=")[0-9]+', xml, perl = TRUE)) - vdpi <- regmatches(xml, regexpr('(?<=verticalDpi=")[0-9]+', xml, perl = TRUE)) - - ## Update ---- - self$worksheets[[sheet]]$pageSetup <- sprintf( - '', - paperSize, orientation, scale, as.integer(fitToWidth), as.integer(fitToHeight), hdpi, vdpi - ) - - if (fitToHeight || fitToWidth) { - self$worksheets[[sheet]]$sheetPr <- unique(c(self$worksheets[[sheet]]$sheetPr, '')) - } - - self$worksheets[[sheet]]$pageMargins <- - sprintf('', left, right, top, bottom, header, footer) - - validRow <- function(summaryRow) { - return(tolower(summaryRow) %in% c("above", "below")) - } - validCol <- function(summaryCol) { - return(tolower(summaryCol) %in% c("left", "right")) - } - - outlinepr <- "" - - if (!is.null(summaryRow)) { - - if (!validRow(summaryRow)) { - stop("Invalid \`summaryRow\` option. Must be one of \"Above\" or \"Below\".") - } else if (tolower(summaryRow) == "above") { - outlinepr <- ' summaryBelow=\"0\"' - } else { - outlinepr <- ' summaryBelow=\"1\"' - } - } - - if (!is.null(summaryCol)) { - - if (!validCol(summaryCol)) { - stop("Invalid \`summaryCol\` option. Must be one of \"Left\" or \"Right\".") - } else if (tolower(summaryCol) == "left") { - outlinepr <- paste0(outlinepr, ' summaryRight=\"0\"') - } else { - outlinepr <- paste0(outlinepr, ' summaryRight=\"1\"') - } - } - - if (!stri_isempty(outlinepr)) { - self$worksheets[[sheet]]$sheetPr <- unique(c(self$worksheets[[sheet]]$sheetPr, paste0(""))) - } - - ## print Titles ---- - if (!is.null(printTitleRows) && is.null(printTitleCols)) { - if (!is.numeric(printTitleRows)) { - stop("printTitleRows must be numeric.") - } - - private$create_named_region( - ref1 = paste0("$", min(printTitleRows)), - ref2 = paste0("$", max(printTitleRows)), - name = "_xlnm.Print_Titles", - sheet = self$get_sheet_names()[[sheet]], - localSheetId = sheet - 1L - ) - } else if (!is.null(printTitleCols) && is.null(printTitleRows)) { - if (!is.numeric(printTitleCols)) { - stop("printTitleCols must be numeric.") - } - - cols <- int2col(range(printTitleCols)) - private$create_named_region( - ref1 = paste0("$", cols[1]), - ref2 = paste0("$", cols[2]), - name = "_xlnm.Print_Titles", - sheet = self$get_sheet_names()[[sheet]], - localSheetId = sheet - 1L - ) - } else if (!is.null(printTitleCols) && !is.null(printTitleRows)) { - if (!is.numeric(printTitleRows)) { - stop("printTitleRows must be numeric.") - } - - if (!is.numeric(printTitleCols)) { - stop("printTitleCols must be numeric.") - } - - cols <- int2col(range(printTitleCols)) - rows <- range(printTitleRows) - - cols <- paste(paste0("$", cols[1]), paste0("$", cols[2]), sep = ":") - rows <- paste(paste0("$", rows[1]), paste0("$", rows[2]), sep = ":") - localSheetId <- sheet - 1L - sheet <- self$get_sheet_names()[[sheet]] - - self$workbook$definedNames <- c( - self$workbook$definedNames, - sprintf('\'%s\'!%s,\'%s\'!%s', localSheetId, sheet, cols, sheet, rows) - ) - - } - - invisible(self) - }, - - ## header footer ---- + wb_page_setup_impl( + self = self, + private = private, + sheet = sheet, + orientation = orientation, + scale = scale, + left = left, + right = right, + top = top, + bottom = bottom, + header = header, + footer = footer, + fitToWidth = fitToWidth, + fitToHeight = fitToHeight, + paperSize = paperSize, + printTitleRows = printTitleRows, + printTitleCols = printTitleCols, + summaryRow = summaryRow, + summaryCol = summaryCol + ) + }, + + ### header footer ---- #' @description Sets headers and footers #' @param sheet sheet @@ -4171,195 +1373,84 @@ wbWorkbook <- R6::R6Class( firstHeader = NULL, firstFooter = NULL ) { - sheet <- private$get_sheet_index(sheet) - - if (!is.null(header) && length(header) != 3) { - stop("header must have length 3 where elements correspond to positions: left, center, right.") - } - - if (!is.null(footer) && length(footer) != 3) { - stop("footer must have length 3 where elements correspond to positions: left, center, right.") - } - - if (!is.null(evenHeader) && length(evenHeader) != 3) { - stop("evenHeader must have length 3 where elements correspond to positions: left, center, right.") - } - - if (!is.null(evenFooter) && length(evenFooter) != 3) { - stop("evenFooter must have length 3 where elements correspond to positions: left, center, right.") - } - - if (!is.null(firstHeader) && length(firstHeader) != 3) { - stop("firstHeader must have length 3 where elements correspond to positions: left, center, right.") - } - - if (!is.null(firstFooter) && length(firstFooter) != 3) { - stop("firstFooter must have length 3 where elements correspond to positions: left, center, right.") - } - - # TODO this could probably be moved to the hf assignment - oddHeader <- headerFooterSub(header) - oddFooter <- headerFooterSub(footer) - evenHeader <- headerFooterSub(evenHeader) - evenFooter <- headerFooterSub(evenFooter) - firstHeader <- headerFooterSub(firstHeader) - firstFooter <- headerFooterSub(firstFooter) - - hf <- list( - oddHeader = naToNULLList(oddHeader), - oddFooter = naToNULLList(oddFooter), - evenHeader = naToNULLList(evenHeader), - evenFooter = naToNULLList(evenFooter), - firstHeader = naToNULLList(firstHeader), - firstFooter = naToNULLList(firstFooter) + wb_set_header_footer_impl( + self = self, + private = private, + sheet = sheet, + header = header, + footer = footer, + evenHeader = evenHeader, + evenFooter = evenFooter, + firstHeader = firstHeader, + firstFooter = firstFooter ) - - if (all(lengths(hf) == 0)) { - hf <- NULL - } - - self$worksheets[[sheet]]$headerFooter <- hf - invisible(self) }, + ### tables ---- + #' @description get tables #' @param sheet sheet #' @returns The sheet tables. `character()` if empty get_tables = function(sheet = current_sheet()) { - if (length(sheet) != 1) { - stop("sheet argument must be length 1") - } - - if (is.null(self$tables)) { - return(character()) - } - - sheet <- private$get_sheet_index(sheet) - if (is.na(sheet)) stop("No such sheet in workbook") - - sel <- self$tables$tab_sheet == sheet & self$tables$tab_act == 1 - tables <- self$tables$tab_name[sel] - refs <- self$tables$tab_ref[sel] - - if (length(tables)) { - attr(tables, "refs") <- refs - } - - return(tables) + wb_get_tables_impl( + self = self, + private = private, + sheet = sheet + ) }, - #' @description remove tables #' @param sheet sheet #' @param table table #' @returns The `wbWorkbook` object remove_tables = function(sheet = current_sheet(), table) { - if (length(table) != 1) { - stop("table argument must be length 1") - } - - ## delete table object and all data in it - sheet <- private$get_sheet_index(sheet) - - if (!table %in% self$tables$tab_name) { - stop(sprintf("table '%s' does not exist.", table), call. = FALSE) - } - - ## delete table object (by flagging as deleted) - inds <- self$tables$tab_sheet %in% sheet & self$tables$tab_name %in% table - table_name_original <- self$tables$tab_name[inds] - refs <- self$tables$tab_ref[inds] - - self$tables$tab_name[inds] <- paste0(table_name_original, "_openxlsx_deleted") - self$tables$tab_ref[inds] <- "" - self$tables$tab_sheet[inds] <- 0 - self$tables$tab_xml[inds] <- "" - self$tables$tab_act[inds] <- 0 - - ## delete reference from worksheet to table - worksheet_table_names <- attr(self$worksheets[[sheet]]$tableParts, "tableName") - to_remove <- which(worksheet_table_names == table_name_original) - - # (1) remove the rId from worksheet_rels - rm_tab_rId <- rbindlist(xml_attr(self$worksheets[[sheet]]$tableParts[to_remove], "tablePart"))["r:id"] - ws_rels <- self$worksheets_rels[[sheet]] - is_rm_table <- grepl(rm_tab_rId, ws_rels) - self$worksheets_rels[[sheet]] <- ws_rels[!is_rm_table] - - # (2) remove the rId from tableParts - self$worksheets[[sheet]]$tableParts <- self$worksheets[[sheet]]$tableParts[-to_remove] - attr(self$worksheets[[sheet]]$tableParts, "tableName") <- worksheet_table_names[-to_remove] - - - ## Now delete data from the worksheet - refs <- strsplit(refs, split = ":")[[1]] - rows <- as.integer(gsub("[A-Z]", "", refs)) - rows <- seq(from = rows[1], to = rows[2], by = 1) - - cols <- col2int(refs) - cols <- seq(from = cols[1], to = cols[2], by = 1) - - ## now delete data - delete_data(wb = self, sheet = sheet, rows = rows, cols = cols) - invisible(self) + wb_remove_tables_impl( + self = self, + private = private, + sheet = sheet, + table = table + ) }, + ### filters ---- + #' @description add filters #' @param sheet sheet #' @param rows rows #' @param cols cols #' @returns The `wbWorkbook` object add_filter = function(sheet = current_sheet(), rows, cols) { - sheet <- private$get_sheet_index(sheet) - - if (length(rows) != 1) { - stop("row must be a numeric of length 1.") - } - - if (!is.numeric(cols)) { - cols <- col2int(cols) - } - - self$worksheets[[sheet]]$autoFilter <- sprintf( - '', - paste(get_cell_refs(data.frame("x" = c(rows, rows), "y" = c(min(cols), max(cols)))), collapse = ":") + wb_add_filter_impl( + self = self, + private = private, + sheet = sheet, + rows = rows, + cols = cols ) - - invisible(self) }, #' @description remove filters #' @param sheet sheet #' @returns The `wbWorkbook` object remove_filter = function(sheet = current_sheet()) { - for (s in private$get_sheet_index(sheet)) { - self$worksheets[[s]]$autoFilter <- character() - } - - invisible(self) + wb_remove_filter_impl(self, private, sheet) }, + ### grid lines ---- + #' @description grid lines #' @param sheet sheet #' @param show show #' @param print print #' @returns The `wbWorkbook` object grid_lines = function(sheet = current_sheet(), show = FALSE, print = show) { - sheet <- private$get_sheet_index(sheet) - - assert_class(show, "logical") - assert_class(print, "logical") - - ## show - sv <- self$worksheets[[sheet]]$sheetViews - sv <- xml_attr_mod(sv, c(showGridLines = as_xml_attr(show))) - self$worksheets[[sheet]]$sheetViews <- sv - - ## print - if (print) - self$worksheets[[sheet]]$set_print_options(gridLines = print, gridLinesSet = print) - - invisible(self) + wb_grid_lines_impl( + self = self, + private = private, + sheet = sheet, + show = show, + print = print + ) }, ### named region ---- @@ -4400,83 +1491,35 @@ wbWorkbook <- R6::R6Class( help = NULL, hidden = NULL, localName = NULL, - publishToServer = NULL, - statusBar = NULL, - vbProcedure = NULL, - workbookParameter = NULL, - xml = NULL - ) { - sheet <- private$get_sheet_index(sheet) - - if (!is.numeric(rows)) { - stop("rows argument must be a numeric/integer vector") - } - - if (!is.numeric(cols)) { - stop("cols argument must be a numeric/integer vector") - } - - localSheetId <- "" - if (localSheet) localSheetId <- as.character(sheet) - - ## check name doesn't already exist - ## named region - - definedNames <- rbindlist(xml_attr(self$workbook$definedNames, level1 = "definedName")) - sel1 <- tolower(definedNames$name) == tolower(name) - sel2 <- definedNames$localSheetId == localSheetId - if (!is.null(definedNames$localSheetId)) { - sel <- sel1 & sel2 - } else { - sel <- sel1 - } - match_dn <- which(sel) - - if (any(match_dn)) { - if (overwrite) - self$workbook$definedNames <- self$workbook$definedNames[-match_dn] - else - stop(sprintf("Named region with name '%s' already exists! Use overwrite = TRUE if you want to replace it", name)) - } else if (grepl("^[A-Z]{1,3}[0-9]+$", name)) { - stop("name cannot look like a cell reference.") - } - - cols <- round(cols) - rows <- round(rows) - - startCol <- min(cols) - endCol <- max(cols) - - startRow <- min(rows) - endRow <- max(rows) - - ref1 <- paste0("$", int2col(startCol), "$", startRow) - ref2 <- paste0("$", int2col(endCol), "$", endRow) - - if (localSheetId == "") localSheetId <- NULL - - private$create_named_region( - ref1 = ref1, - ref2 = ref2, - name = name, - sheet = self$sheet_names[sheet], - localSheetId = localSheetId, - comment = comment, - customMenu = customMenu, - description = description, - is_function = is_function, - functionGroupId = functionGroupId, - help = help, - hidden = hidden, - localName = localName, - publishToServer = publishToServer, - statusBar = statusBar, - vbProcedure = vbProcedure, - workbookParameter = workbookParameter, - xml = xml + publishToServer = NULL, + statusBar = NULL, + vbProcedure = NULL, + workbookParameter = NULL, + xml = NULL + ) { + wb_add_named_region_impl( + self = self, + private = private, + sheet = sheet, + cols = cols, + rows = rows, + name = name, + localSheet = localSheet, + overwrite = overwrite, + comment = comment, + customMenu = customMenu, + description = description, + is_function = is_function, + functionGroupId = functionGroupId, + help = help, + hidden = hidden, + localName = localName, + publishToServer = publishToServer, + statusBar = statusBar, + vbProcedure = vbProcedure, + workbookParameter = workbookParameter, + xml = xml ) - - invisible(self) }, #' @description remove a named region @@ -4484,64 +1527,29 @@ wbWorkbook <- R6::R6Class( #' @param name name #' @returns The `wbWorkbook` object remove_named_region = function(sheet = current_sheet(), name = NULL) { - # get all nown defined names - dn <- get_named_regions(self) - - if (is.null(name) && !is.null(sheet)) { - sheet <- private$get_sheet_index(sheet) - del <- dn$id[dn$sheet == sheet] - } else if (!is.null(name) && is.null(sheet)) { - del <- dn$id[dn$name == name] - } else { - sheet <- private$get_sheet_index(sheet) - del <- dn$id[dn$sheet == sheet & dn$name == name] - } - - if (length(del)) { - self$workbook$definedNames <- self$workbook$definedNames[-del] - } else { - if (!is.null(name)) - warning(sprintf("Cannot find named region with name '%s'", name)) - # do not warn if wb and sheet are selected. wb_delete_named_region is - # called with every wb_remove_worksheet and would throw meaningless - # warnings. For now simply assume if no name is defined, that the - # user does not care, as long as no defined name remains on a sheet. - } - - invisible(self) + wb_remove_named_region_impl( + self = self, + private = private, + sheet = sheet, + name = name + ) }, + ### order ---- + #' @description set worksheet order #' @param sheets sheets #' @return The `wbWorkbook` object set_order = function(sheets) { - sheets <- private$get_sheet_index(sheet = sheets) - - if (anyDuplicated(sheets)) { - stop("`sheets` cannot have duplicates") - } - - if (length(sheets) != length(self$worksheets)) { - stop(sprintf("Worksheet order must be same length as number of worksheets [%s]", length(self$worksheets))) - } - - if (any(sheets > length(self$worksheets))) { - stop("Elements of order are greater than the number of worksheets") - } - - self$sheetOrder <- sheets - invisible(self) + wb_set_order_impl(self, private, sheets) }, - ## sheet visibility ---- + ### sheet visibility ---- #' @description Get sheet visibility #' @returns Returns sheet visibility get_sheet_visibility = function() { - state <- rep("visible", length(self$workbook$sheets)) - state[grepl("hidden", self$workbook$sheets)] <- "hidden" - state[grepl("veryHidden", self$workbook$sheets, ignore.case = TRUE)] <- "veryHidden" - state + wb_get_sheet_visibility_impl(self, private) }, #' @description Set sheet visibility @@ -4549,44 +1557,15 @@ wbWorkbook <- R6::R6Class( #' @param sheet sheet #' @returns The `wbWorkbook` object set_sheet_visibility = function(sheet = current_sheet(), value) { - if (length(value) != length(sheet)) { - stop("`value` and `sheet` must be the same length") - } - - sheet <- private$get_sheet_index(sheet) - - value <- tolower(as.character(value)) - value[value %in% "true"] <- "visible" - value[value %in% "false"] <- "hidden" - value[value %in% "veryhidden"] <- "veryHidden" - - exState0 <- reg_match0(self$workbook$sheets[sheet], '(?<=state=")[^"]+') - exState <- tolower(exState0) - exState[exState %in% "true"] <- "visible" - exState[exState %in% "hidden"] <- "hidden" - exState[exState %in% "false"] <- "hidden" - exState[exState %in% "veryhidden"] <- "veryHidden" - - - inds <- which(value != exState) - - if (length(inds) == 0) { - return(invisible(self)) - } - - for (i in seq_along(self$worksheets)) { - self$workbook$sheets[sheet[i]] <- gsub(exState0[i], value[i], self$workbook$sheets[sheet[i]], fixed = TRUE) - } - - if (!any(self$get_sheet_visibility() %in% c("true", "visible"))) { - warning("A workbook must have atleast 1 visible worksheet. Setting first for visible") - self$set_sheet_visibility(1, TRUE) - } - - invisible(self) + wb_set_sheet_visibility_impl( + self = self, + private = private, + sheet = sheet, + value = value + ) }, - ## page breaks ---- + ### page breaks ---- #' @description Add a page break #' @param sheet sheet @@ -4594,11 +1573,17 @@ wbWorkbook <- R6::R6Class( #' @param col col #' @returns The `wbWorkbook` object add_page_break = function(sheet = current_sheet(), row = NULL, col = NULL) { - sheet <- private$get_sheet_index(sheet) - self$worksheets[[sheet]]$add_page_break(row = row, col = col) - invisible(self) + wb_add_page_breaks_impl( + self = self, + private = private, + sheet = sheet, + row = row, + col = col + ) }, + ### clean sheet---- + #' @description clean sheet (remove all values) #' @param sheet sheet #' @param numbers remove all numbers @@ -4607,20 +1592,25 @@ wbWorkbook <- R6::R6Class( #' @param merged_cells remove all merged_cells #' @return The `wbWorksheetObject`, invisibly clean_sheet = function( - sheet = current_sheet(), - numbers = TRUE, - characters = TRUE, - styles = TRUE, - merged_cells = TRUE + sheet = current_sheet(), + numbers = TRUE, + characters = TRUE, + styles = TRUE, + merged_cells = TRUE ) { - sheet <- private$get_sheet_index(sheet) - self$worksheets[[sheet]]$clean_sheet(numbers = numbers, characters = characters, + wb_clean_sheet_impl( + self = self, + private = private, + sheet = sheet, + numbers = numbers, + characters = characters, styles = styles, merged_cells = merged_cells ) - invisible(self) }, + ### styles ---- + #' @description create borders for cell region #' @param sheet a worksheet #' @param dims dimensions on the worksheet e.g. "A1", "A1:A5", "A1:H5" @@ -4654,396 +1644,39 @@ wbWorkbook <- R6::R6Class( #' wb$add_border(1, dims = "A2:K33", inner_vgrid = "thin", inner_vcolor = c(rgb="FF808080")) #' @return The `wbWorksheetObject`, invisibly add_border = function( - sheet = current_sheet(), - dims = "A1", - bottom_color = wb_colour(hex = "FF000000"), - left_color = wb_colour(hex = "FF000000"), - right_color = wb_colour(hex = "FF000000"), - top_color = wb_colour(hex = "FF000000"), - bottom_border = "thin", - left_border = "thin", - right_border = "thin", - top_border = "thin", - inner_hgrid = NULL, - inner_hcolor = NULL, - inner_vgrid = NULL, - inner_vcolor = NULL + sheet = current_sheet(), + dims = "A1", + bottom_color = wb_colour(hex = "FF000000"), + left_color = wb_colour(hex = "FF000000"), + right_color = wb_colour(hex = "FF000000"), + top_color = wb_colour(hex = "FF000000"), + bottom_border = "thin", + left_border = "thin", + right_border = "thin", + top_border = "thin", + inner_hgrid = NULL, + inner_hcolor = NULL, + inner_vgrid = NULL, + inner_vcolor = NULL ) { - - # TODO merge styles and if a style is already present, only add the newly - # created border style - - # cc <- wb$worksheets[[sheet]]$sheet_data$cc - # df_s <- as.data.frame(lapply(df, function(x) cc$c_s[cc$r %in% x])) - - df <- dims_to_dataframe(dims, fill = TRUE) - sheet <- private$get_sheet_index(sheet) - - private$do_cell_init(sheet, dims) - - ### beg border creation - full_single <- create_border( - top = top_border, top_color = top_color, - bottom = bottom_border, bottom_color = bottom_color, - left = left_border, left_color = left_color, - right = left_border, right_color = right_color - ) - - top_single <- create_border( - top = top_border, top_color = top_color, - bottom = inner_hgrid, bottom_color = inner_hcolor, - left = left_border, left_color = left_color, - right = left_border, right_color = right_color - ) - - middle_single <- create_border( - top = inner_hgrid, top_color = inner_hcolor, - bottom = inner_hgrid, bottom_color = inner_hcolor, - left = left_border, left_color = left_color, - right = left_border, right_color = right_color - ) - - bottom_single <- create_border( - top = inner_hgrid, top_color = inner_hcolor, - bottom = bottom_border, bottom_color = bottom_color, - left = left_border, left_color = left_color, - right = left_border, right_color = right_color - ) - - left_single <- create_border( - top = top_border, top_color = top_color, - bottom = bottom_border, bottom_color = bottom_color, - left = left_border, left_color = left_color, - right = inner_vgrid, right_color = inner_vcolor - ) - - right_single <- create_border( - top = top_border, top_color = top_color, - bottom = bottom_border, bottom_color = bottom_color, - left = inner_vgrid, left_color = inner_vcolor, - right = right_border, right_color = right_color - ) - - center_single <- create_border( - top = top_border, top_color = top_color, - bottom = bottom_border, bottom_color = bottom_color, - left = inner_vgrid, left_color = inner_vcolor, - right = inner_vgrid, right_color = inner_vcolor - ) - - top_left <- create_border( - top = top_border, top_color = top_color, - bottom = inner_hgrid, bottom_color = inner_hcolor, - left = left_border, left_color = left_color, - right = inner_vgrid, right_color = inner_vcolor - ) - - top_right <- create_border( - top = top_border, top_color = top_color, - bottom = inner_hgrid, bottom_color = inner_hcolor, - left = inner_vgrid, left_color = inner_vcolor, - right = left_border, right_color = right_color - ) - - bottom_left <- create_border( - top = inner_hgrid, top_color = inner_hcolor, - bottom = bottom_border, bottom_color = bottom_color, - left = left_border, left_color = left_color, - right = inner_vgrid, right_color = inner_vcolor - ) - - bottom_right <- create_border( - top = inner_hgrid, top_color = inner_hcolor, - bottom = bottom_border, bottom_color = bottom_color, - left = inner_vgrid, left_color = inner_vcolor, - right = left_border, right_color = right_color - ) - - top_center <- create_border( - top = top_border, top_color = top_color, - bottom = inner_hgrid, bottom_color = inner_hcolor, - left = inner_vgrid, left_color = inner_vcolor, - right = inner_vgrid, right_color = inner_vcolor - ) - - bottom_center <- create_border( - top = inner_hgrid, top_color = inner_hcolor, - bottom = bottom_border, bottom_color = bottom_color, - left = inner_vgrid, left_color = inner_vcolor, - right = inner_vgrid, right_color = inner_vcolor - ) - - middle_left <- create_border( - top = inner_hgrid, top_color = inner_hcolor, - bottom = inner_hgrid, bottom_color = inner_hcolor, - left = left_border, left_color = left_color, - right = inner_vgrid, right_color = inner_vcolor - ) - - middle_right <- create_border( - top = inner_hgrid, top_color = inner_hcolor, - bottom = inner_hgrid, bottom_color = inner_hcolor, - left = inner_vgrid, left_color = inner_vcolor, - right = right_border, right_color = right_color + wb_add_border_impl( + self = self, + private = private, + sheet = sheet, + dims = dims, + bottom_color = bottom_color, + left_color = left_color, + right_color = right_color, + top_color = top_color, + bottom_border = bottom_border, + left_border = left_border, + right_border = right_border, + top_border = top_border, + inner_hgrid = inner_hgrid, + inner_hcolor = inner_hcolor, + inner_vgrid = inner_vgrid, + inner_vcolor = inner_vcolor ) - - inner_cell <- create_border( - top = inner_hgrid, top_color = inner_hcolor, - bottom = inner_hgrid, bottom_color = inner_hcolor, - left = inner_vgrid, left_color = inner_vcolor, - right = inner_vgrid, right_color = inner_vcolor - ) - ### end border creation - - # - # /* top_single */ - # /* middle_single */ - # /* bottom_single */ - # - - # /* left_single --- center_single --- right_single */ - - # - # /* top_left --- top_center --- top_right */ - # /* - - */ - # /* - - */ - # /* - - */ - # /* left_middle right_middle */ - # /* - - */ - # /* - - */ - # /* - - */ - # /* left_bottom - bottom_center - bottom_right */ - # - - ## beg cell references - if (ncol(df) == 1 && nrow(df) == 1) - dim_full_single <- df[1, 1] - - if (ncol(df) == 1 && nrow(df) >= 2) { - dim_top_single <- df[1, 1] - dim_bottom_single <- df[nrow(df), 1] - if (nrow(df) >= 3) { - mid <- df[, 1] - dim_middle_single <- mid[!mid %in% c(dim_top_single, dim_bottom_single)] - } - } - - if (ncol(df) >= 2 && nrow(df) == 1) { - dim_left_single <- df[1, 1] - dim_right_single <- df[1, ncol(df)] - if (ncol(df) >= 3) { - ctr <- df[1, ] - dim_center_single <- ctr[!ctr %in% c(dim_left_single, dim_right_single)] - } - } - - if (ncol(df) >= 2 && nrow(df) >= 2) { - dim_top_left <- df[1, 1] - dim_bottom_left <- df[nrow(df), 1] - dim_top_right <- df[1, ncol(df)] - dim_bottom_right <- df[nrow(df), ncol(df)] - - if (nrow(df) >= 3) { - top_mid <- df[, 1] - bottom_mid <- df[, ncol(df)] - - dim_middle_left <- top_mid[!top_mid %in% c(dim_top_left, dim_bottom_left)] - dim_middle_right <- bottom_mid[!bottom_mid %in% c(dim_top_right, dim_bottom_right)] - } - - if (ncol(df) >= 3) { - top_ctr <- df[1, ] - bottom_ctr <- df[nrow(df), ] - - dim_top_center <- top_ctr[!top_ctr %in% c(dim_top_left, dim_top_right)] - dim_bottom_center <- bottom_ctr[!bottom_ctr %in% c(dim_bottom_left, dim_bottom_right)] - } - - if (ncol(df) > 2 && nrow(df) > 2) { - t_row <- 1 - b_row <- nrow(df) - l_row <- 1 - r_row <- ncol(df) - dim_inner_cell <- as.character(unlist(df[c(-t_row, -b_row), c(-l_row, -r_row)])) - } - } - ### end cell references - - # add some random string to the name. if called multiple times, new - # styles will be created. We do not look for identical styles, therefor - # we might create duplicates, but if a single style changes, the rest of - # the workbook remains valid. - smp <- random_string() - s <- function(x) paste0(smp, "s", deparse(substitute(x)), seq_along(x)) - sfull_single <- paste0(smp, "full_single") - stop_single <- paste0(smp, "full_single") - sbottom_single <- paste0(smp, "bottom_single") - smiddle_single <- paste0(smp, "middle_single") - sleft_single <- paste0(smp, "left_single") - sright_single <- paste0(smp, "right_single") - scenter_single <- paste0(smp, "center_single") - stop_left <- paste0(smp, "top_left") - stop_right <- paste0(smp, "top_right") - sbottom_left <- paste0(smp, "bottom_left") - sbottom_right <- paste0(smp, "bottom_right") - smiddle_left <- paste0(smp, "middle_left") - smiddle_right <- paste0(smp, "middle_right") - stop_center <- paste0(smp, "top_center") - sbottom_center <- paste0(smp, "bottom_center") - sinner_cell <- paste0(smp, "inner_cell") - - # ncol == 1 - if (ncol(df) == 1) { - - # single cell - if (nrow(df) == 1) { - self$styles_mgr$add(full_single, sfull_single) - xf_prev <- get_cell_styles(self, sheet, dims) - xf_full_single <- set_border(xf_prev, self$styles_mgr$get_border_id(sfull_single)) - self$styles_mgr$add(xf_full_single, xf_full_single) - self$set_cell_style(sheet, dims, self$styles_mgr$get_xf_id(xf_full_single)) - } - - # create top & bottom piece - if (nrow(df) >= 2) { - - # top single - self$styles_mgr$add(top_single, stop_single) - xf_prev <- get_cell_styles(self, sheet, dim_top_single) - xf_top_single <- set_border(xf_prev, self$styles_mgr$get_border_id(stop_single)) - self$styles_mgr$add(xf_top_single, xf_top_single) - self$set_cell_style(sheet, dim_top_single, self$styles_mgr$get_xf_id(xf_top_single)) - - # bottom single - self$styles_mgr$add(bottom_single, sbottom_single) - xf_prev <- get_cell_styles(self, sheet, dim_bottom_single) - xf_bottom_single <- set_border(xf_prev, self$styles_mgr$get_border_id(sbottom_single)) - self$styles_mgr$add(xf_bottom_single, xf_bottom_single) - self$set_cell_style(sheet, dim_bottom_single, self$styles_mgr$get_xf_id(xf_bottom_single)) - } - - # create middle piece(s) - if (nrow(df) >= 3) { - - # middle single - self$styles_mgr$add(middle_single, smiddle_single) - xf_prev <- get_cell_styles(self, sheet, dim_middle_single) - xf_middle_single <- set_border(xf_prev, self$styles_mgr$get_border_id(smiddle_single)) - self$styles_mgr$add(xf_middle_single, xf_middle_single) - self$set_cell_style(sheet, dim_middle_single, self$styles_mgr$get_xf_id(xf_middle_single)) - } - - } - - # create left and right single row pieces - if (ncol(df) >= 2 && nrow(df) == 1) { - - # left single - self$styles_mgr$add(left_single, sleft_single) - xf_prev <- get_cell_styles(self, sheet, dim_left_single) - xf_left_single <- set_border(xf_prev, self$styles_mgr$get_border_id(sleft_single)) - self$styles_mgr$add(xf_left_single, xf_left_single) - self$set_cell_style(sheet, dim_left_single, self$styles_mgr$get_xf_id(xf_left_single)) - - # right single - self$styles_mgr$add(right_single, sright_single) - xf_prev <- get_cell_styles(self, sheet, dim_right_single) - xf_right_single <- set_border(xf_prev, self$styles_mgr$get_border_id(sright_single)) - self$styles_mgr$add(xf_right_single, xf_right_single) - self$set_cell_style(sheet, dim_right_single, self$styles_mgr$get_xf_id(xf_right_single)) - - # add single center piece(s) - if (ncol(df) >= 3) { - - # center single - self$styles_mgr$add(center_single, scenter_single) - xf_prev <- get_cell_styles(self, sheet, dim_center_single) - xf_center_single <- set_border(xf_prev, self$styles_mgr$get_border_id(scenter_single)) - self$styles_mgr$add(xf_center_single, xf_center_single) - self$set_cell_style(sheet, dim_center_single, self$styles_mgr$get_xf_id(xf_center_single)) - } - - } - - # create left & right - top & bottom corners pieces - if (ncol(df) >= 2 && nrow(df) >= 2) { - - # top left - self$styles_mgr$add(top_left, stop_left) - xf_prev <- get_cell_styles(self, sheet, dim_top_left) - xf_top_left <- set_border(xf_prev, self$styles_mgr$get_border_id(stop_left)) - self$styles_mgr$add(xf_top_left, xf_top_left) - self$set_cell_style(sheet, dim_top_left, self$styles_mgr$get_xf_id(xf_top_left)) - - # top right - self$styles_mgr$add(top_right, stop_right) - xf_prev <- get_cell_styles(self, sheet, dim_top_right) - xf_top_right <- set_border(xf_prev, self$styles_mgr$get_border_id(stop_right)) - self$styles_mgr$add(xf_top_right, xf_top_right) - self$set_cell_style(sheet, dim_top_right, self$styles_mgr$get_xf_id(xf_top_right)) - - # bottom left - self$styles_mgr$add(bottom_left, sbottom_left) - xf_prev <- get_cell_styles(self, sheet, dim_bottom_left) - xf_bottom_left <- set_border(xf_prev, self$styles_mgr$get_border_id(sbottom_left)) - self$styles_mgr$add(xf_bottom_left, xf_bottom_left) - self$set_cell_style(sheet, dim_bottom_left, self$styles_mgr$get_xf_id(xf_bottom_left)) - - # bottom right - self$styles_mgr$add(bottom_right, sbottom_right) - xf_prev <- get_cell_styles(self, sheet, dim_bottom_right) - xf_bottom_right <- set_border(xf_prev, self$styles_mgr$get_border_id(sbottom_right)) - self$styles_mgr$add(xf_bottom_right, xf_bottom_right) - self$set_cell_style(sheet, dim_bottom_right, self$styles_mgr$get_xf_id(xf_bottom_right)) - } - - # create left and right middle pieces - if (ncol(df) >= 2 && nrow(df) >= 3) { - - # middle left - self$styles_mgr$add(middle_left, smiddle_left) - xf_prev <- get_cell_styles(self, sheet, dim_middle_left) - xf_middle_left <- set_border(xf_prev, self$styles_mgr$get_border_id(smiddle_left)) - self$styles_mgr$add(xf_middle_left, xf_middle_left) - self$set_cell_style(sheet, dim_middle_left, self$styles_mgr$get_xf_id(xf_middle_left)) - - # middle right - self$styles_mgr$add(middle_right, smiddle_right) - xf_prev <- get_cell_styles(self, sheet, dim_middle_right) - xf_middle_right <- set_border(xf_prev, self$styles_mgr$get_border_id(smiddle_right)) - self$styles_mgr$add(xf_middle_right, xf_middle_right) - self$set_cell_style(sheet, dim_middle_right, self$styles_mgr$get_xf_id(xf_middle_right)) - } - - # create top and bottom center pieces - if (ncol(df) >= 3 & nrow(df) >= 2) { - - # top center - self$styles_mgr$add(top_center, stop_center) - xf_prev <- get_cell_styles(self, sheet, dim_top_center) - xf_top_center <- set_border(xf_prev, self$styles_mgr$get_border_id(stop_center)) - self$styles_mgr$add(xf_top_center, xf_top_center) - self$set_cell_style(sheet, dim_top_center, self$styles_mgr$get_xf_id(xf_top_center)) - - # bottom center - self$styles_mgr$add(bottom_center, sbottom_center) - xf_prev <- get_cell_styles(self, sheet, dim_bottom_center) - xf_bottom_center <- set_border(xf_prev, self$styles_mgr$get_border_id(sbottom_center)) - self$styles_mgr$add(xf_bottom_center, xf_bottom_center) - self$set_cell_style(sheet, dim_bottom_center, self$styles_mgr$get_xf_id(xf_bottom_center)) - } - - if (nrow(df) > 2 && ncol(df) > 2) { - - # inner cells - self$styles_mgr$add(inner_cell, sinner_cell) - xf_prev <- get_cell_styles(self, sheet, dim_inner_cell) - xf_inner_cell <- set_border(xf_prev, self$styles_mgr$get_border_id(sinner_cell)) - self$styles_mgr$add(xf_inner_cell, xf_inner_cell) - self$set_cell_style(sheet, dim_inner_cell, self$styles_mgr$get_xf_id(xf_inner_cell)) - } - - invisible(self) }, #' @description provide simple fill function @@ -5066,47 +1699,25 @@ wbWorkbook <- R6::R6Class( #' " #' @return The `wbWorksheetObject`, invisibly add_fill = function( - sheet = current_sheet(), - dims = "A1", - color = wb_colour(hex = "FFFFFF00"), - pattern = "solid", - gradient_fill = "", - every_nth_col = 1, - every_nth_row = 1 + sheet = current_sheet(), + dims = "A1", + color = wb_colour(hex = "FFFFFF00"), + pattern = "solid", + gradient_fill = "", + every_nth_col = 1, + every_nth_row = 1 ) { - sheet <- private$get_sheet_index(sheet) - private$do_cell_init(sheet, dims) - - # dim in dataframe can contain various styles. go cell by cell. - did <- dims_to_dataframe(dims, fill = TRUE) - # select a few cols and rows to fill - cols <- (seq_len(ncol(did)) %% every_nth_col) == 0 - rows <- (seq_len(nrow(did)) %% every_nth_row) == 0 - - dims <- unname(unlist(did[rows, cols, drop = FALSE])) - - cc <- self$worksheets[[sheet]]$sheet_data$cc - cc <- cc[cc$r %in% dims, ] - styles <- unique(cc[["c_s"]]) - - for (style in styles) { - dim <- cc[cc$c_s == style, "r"] - - new_fill <- create_fill( - gradientFill = gradient_fill, - patternType = pattern, - fgColor = color - ) - self$styles_mgr$add(new_fill, new_fill) - - xf_prev <- get_cell_styles(self, sheet, dim[[1]]) - xf_new_fill <- set_fill(xf_prev, self$styles_mgr$get_fill_id(new_fill)) - self$styles_mgr$add(xf_new_fill, xf_new_fill) - s_id <- self$styles_mgr$get_xf_id(xf_new_fill) - self$set_cell_style(sheet, dim, s_id) - } - - invisible(self) + wb_add_fill_impl( + self = self, + private = private, + sheet = sheet, + dims = dims, + color = color, + pattern = pattern, + gradient_fill = gradient_fill, + every_nth_col = every_nth_col, + every_nth_row = every_nth_row + ) }, #' @description provide simple font function @@ -5132,66 +1743,46 @@ wbWorkbook <- R6::R6Class( #' wb$add_font("S1", "A1:K1", name = "Arial", color = wb_colour(theme = "4")) #' @return The `wbWorksheetObject`, invisibly add_font = function( - sheet = current_sheet(), - dims = "A1", - name = "Calibri", - color = wb_colour(hex = "FF000000"), - size = "11", - bold = "", - italic = "", - outline = "", - strike = "", - underline = "", - # fine tuning - charset = "", - condense = "", - extend = "", - family = "", - scheme = "", - shadow = "", - vertAlign = "" + sheet = current_sheet(), + dims = "A1", + name = "Calibri", + color = wb_colour(hex = "FF000000"), + size = "11", + bold = "", + italic = "", + outline = "", + strike = "", + underline = "", + # fine tuning + charset = "", + condense = "", + extend = "", + family = "", + scheme = "", + shadow = "", + vertAlign = "" ) { - sheet <- private$get_sheet_index(sheet) - private$do_cell_init(sheet, dims) - - did <- dims_to_dataframe(dims, fill = TRUE) - dims <- unname(unlist(did)) - - cc <- self$worksheets[[sheet]]$sheet_data$cc - cc <- cc[cc$r %in% dims, ] - styles <- unique(cc[["c_s"]]) - - for (style in styles) { - dim <- cc[cc$c_s == style, "r"] - - new_font <- create_font( - b = bold, - charset = charset, - color = color, - condense = condense, - extend = extend, - family = family, - i = italic, - name = name, - outline = outline, - scheme = scheme, - shadow = shadow, - strike = strike, - sz = size, - u = underline, - vertAlign = vertAlign - ) - self$styles_mgr$add(new_font, new_font) - - xf_prev <- get_cell_styles(self, sheet, dim[[1]]) - xf_new_font <- set_font(xf_prev, self$styles_mgr$get_font_id(new_font)) - - self$styles_mgr$add(xf_new_font, xf_new_font) - s_id <- self$styles_mgr$get_xf_id(xf_new_font) - self$set_cell_style(sheet, dim, s_id) - } - - invisible(self) + wb_add_font_impl( + self = self, + private = private, + sheet = sheet, + dims = dims, + name = name, + color = color, + size = size, + bold = bold, + italic = italic, + outline = outline, + strike = strike, + underline = underline, + charset = charset, + condense = condense, + extend = extend, + family = family, + scheme = scheme, + shadow = shadow, + vertAlign = vertAlign + ) }, #' @description provide simple number format function @@ -5203,51 +1794,17 @@ wbWorkbook <- R6::R6Class( #' wb$add_numfmt("S1", "A1:A33", numfmt = 1) #' @return The `wbWorksheetObject`, invisibly add_numfmt = function( - sheet = current_sheet(), - dims = "A1", - numfmt + sheet = current_sheet(), + dims = "A1", + numfmt ) { - sheet <- private$get_sheet_index(sheet) - private$do_cell_init(sheet, dims) - - did <- dims_to_dataframe(dims, fill = TRUE) - dims <- unname(unlist(did)) - - cc <- self$worksheets[[sheet]]$sheet_data$cc - cc <- cc[cc$r %in% dims, ] - styles <- unique(cc[["c_s"]]) - - if (inherits(numfmt, "character")) { - - for (style in styles) { - dim <- cc[cc$c_s == style, "r"] - - new_numfmt <- create_numfmt( - numFmtId = self$styles_mgr$next_numfmt_id(), - formatCode = numfmt - ) - self$styles_mgr$add(new_numfmt, new_numfmt) - - xf_prev <- get_cell_styles(self, sheet, dim[[1]]) - xf_new_numfmt <- set_numfmt(xf_prev, self$styles_mgr$get_numfmt_id(new_numfmt)) - self$styles_mgr$add(xf_new_numfmt, xf_new_numfmt) - s_id <- self$styles_mgr$get_xf_id(xf_new_numfmt) - self$set_cell_style(sheet, dim, s_id) - } - - } else { # format is numeric - for (style in styles) { - dim <- cc[cc$c_s == style, "r"] - xf_prev <- get_cell_styles(self, sheet, dim[[1]]) - xf_new_numfmt <- set_numfmt(xf_prev, numfmt) - self$styles_mgr$add(xf_new_numfmt, xf_new_numfmt) - s_id <- self$styles_mgr$get_xf_id(xf_new_numfmt) - self$set_cell_style(sheet, dim, s_id) - } - - } - - invisible(self) + wb_add_numfmt_impl( + self = self, + private = private, + sheet = sheet, + dims = dims, + numfm = numfmt + ) }, #' @description provide simple cell style format function @@ -5289,81 +1846,65 @@ wbWorkbook <- R6::R6Class( #' wrapText = "1") #' @return The `wbWorksheetObject`, invisibly add_cell_style = function( - sheet = current_sheet(), - dims = "A1", - applyAlignment = NULL, - applyBorder = NULL, - applyFill = NULL, - applyFont = NULL, - applyNumberFormat = NULL, - applyProtection = NULL, - borderId = NULL, - extLst = NULL, - fillId = NULL, - fontId = NULL, - hidden = NULL, - horizontal = NULL, - indent = NULL, - justifyLastLine = NULL, - locked = NULL, - numFmtId = NULL, - pivotButton = NULL, - quotePrefix = NULL, - readingOrder = NULL, - relativeIndent = NULL, - shrinkToFit = NULL, - textRotation = NULL, - vertical = NULL, - wrapText = NULL, - xfId = NULL + sheet = current_sheet(), + dims = "A1", + applyAlignment = NULL, + applyBorder = NULL, + applyFill = NULL, + applyFont = NULL, + applyNumberFormat = NULL, + applyProtection = NULL, + borderId = NULL, + extLst = NULL, + fillId = NULL, + fontId = NULL, + hidden = NULL, + horizontal = NULL, + indent = NULL, + justifyLastLine = NULL, + locked = NULL, + numFmtId = NULL, + pivotButton = NULL, + quotePrefix = NULL, + readingOrder = NULL, + relativeIndent = NULL, + shrinkToFit = NULL, + textRotation = NULL, + vertical = NULL, + wrapText = NULL, + xfId = NULL ) { - sheet <- private$get_sheet_index(sheet) - private$do_cell_init(sheet, dims) - - did <- dims_to_dataframe(dims, fill = TRUE) - dims <- unname(unlist(did)) - - cc <- self$worksheets[[sheet]]$sheet_data$cc - cc <- cc[cc$r %in% dims, ] - styles <- unique(cc[["c_s"]]) - - for (style in styles) { - dim <- cc[cc$c_s == style, "r"] - xf_prev <- get_cell_styles(self, sheet, dim[[1]]) - xf_new_cellstyle <- set_cellstyle( - xf_node = xf_prev, - applyAlignment = applyAlignment, - applyBorder = applyBorder, - applyFill = applyFill, - applyFont = applyFont, - applyNumberFormat = applyNumberFormat, - applyProtection = applyProtection, - borderId = borderId, - extLst = extLst, - fillId = fillId, - fontId = fontId, - hidden = hidden, - horizontal = horizontal, - indent = indent, - justifyLastLine = justifyLastLine, - locked = locked, - numFmtId = numFmtId, - pivotButton = pivotButton, - quotePrefix = quotePrefix, - readingOrder = readingOrder, - relativeIndent = relativeIndent, - shrinkToFit = shrinkToFit, - textRotation = textRotation, - vertical = vertical, - wrapText = wrapText, - xfId = xfId - ) - self$styles_mgr$add(xf_new_cellstyle, xf_new_cellstyle) - s_id <- self$styles_mgr$get_xf_id(xf_new_cellstyle) - self$set_cell_style(sheet, dim, s_id) - } - - invisible(self) + wb_add_cell_style_impl( + self = self, + private = private, + sheet = sheet, + dims = dims, + applyAlignment = applyAlignment, + applyBorder = applyBorder, + applyFill = applyFill, + applyFont = applyFont, + applyNumberFormat = applyNumberFormat, + applyProtection = applyProtection, + borderId = borderId, + extLst = extLst, + fillId = fillId, + fontId = fontId, + hidden = hidden, + horizontal = horizontal, + indent = indent, + justifyLastLine = justifyLastLine, + locked = locked, + numFmtId = numFmtId, + pivotButton = pivotButton, + quotePrefix = quotePrefix, + readingOrder = readingOrder, + relativeIndent = relativeIndent, + shrinkToFit = shrinkToFit, + textRotation = textRotation, + vertical = vertical, + wrapText = wrapText, + xfId = xfId + ) }, #' @description get sheet style @@ -5371,20 +1912,12 @@ wbWorkbook <- R6::R6Class( #' @param dims dims #' @returns a character vector of cell styles get_cell_style = function(sheet = current_sheet(), dims) { - - if (length(dims) == 1 && grepl(":", dims)) - dims <- dims_to_dataframe(dims, fill = TRUE) - sheet <- private$get_sheet_index(sheet) - - # This alters the workbook - temp <- self$clone()$.__enclos_env__$private$do_cell_init(sheet, dims) - - # if a range is passed (e.g. "A1:B2") we need to get every cell - dims <- unname(unlist(dims)) - - # TODO check that cc$r is alway valid. not sure atm - sel <- temp$worksheets[[sheet]]$sheet_data$cc$r %in% dims - temp$worksheets[[sheet]]$sheet_data$cc$c_s[sel] + wb_get_cell_style_impl( + self = self, + private = private, + sheet = sheet, + dims = dims + ) }, #' @description set sheet style @@ -5393,106 +1926,28 @@ wbWorkbook <- R6::R6Class( #' @param style style #' @return The `wbWorksheetObject`, invisibly set_cell_style = function(sheet = current_sheet(), dims, style) { - - if (length(dims) == 1 && grepl(":|;", dims)) - dims <- dims_to_dataframe(dims, fill = TRUE) - sheet <- private$get_sheet_index(sheet) - - private$do_cell_init(sheet, dims) - - # if a range is passed (e.g. "A1:B2") we need to get every cell - dims <- unname(unlist(dims)) - - sel <- self$worksheets[[sheet]]$sheet_data$cc$r %in% dims - - self$worksheets[[sheet]]$sheet_data$cc$c_s[sel] <- style - - invisible(self) + wb_set_cell_style_impl( + self = self, + private = private, + sheet = sheet, + dims = dims, + style = style + ) }, #' @description clone style from one sheet to another #' @param from the worksheet you are cloning #' @param to the worksheet the style is applied to clone_sheet_style = function(from = current_sheet(), to) { - - id_org <- private$get_sheet_index(from) - id_new <- private$get_sheet_index(to) - - org_style <- self$worksheets[[id_org]]$sheet_data$cc - wb_style <- self$worksheets[[id_new]]$sheet_data$cc - - # only clone styles from sheets with cc - if (is.null(org_style)) { - message("'from' has no sheet data styles to clone") - } else { - - if (is.null(wb_style)) # if null, create empty dataframe - wb_style <- create_char_dataframe(names(org_style), n = 0) - - # remove all values - org_style <- org_style[c("r", "row_r", "c_r", "c_s")] - - # do not merge c_s and do not create duplicates - merged_style <- merge(org_style, - wb_style[-which(names(wb_style) == "c_s")], - all = TRUE) - merged_style[is.na(merged_style)] <- "" - merged_style <- merged_style[!duplicated(merged_style["r"]), ] - - # will be ordere on save - self$worksheets[[id_new]]$sheet_data$cc <- merged_style - - } - - - # copy entire attributes from original sheet to new sheet - org_rows <- self$worksheets[[id_org]]$sheet_data$row_attr - new_rows <- self$worksheets[[id_new]]$sheet_data$row_attr - - if (is.null(org_style)) { - message("'from' has no row styles to clone") - } else { - - if (is.null(new_rows)) - new_rows <- create_char_dataframe(names(org_rows), n = 0) - - # only add the row information, nothing else - merged_rows <- merge(org_rows, - new_rows["r"], - all = TRUE) - merged_rows[is.na(merged_rows)] <- "" - merged_rows <- merged_rows[!duplicated(merged_rows["r"]), ] - ordr <- ordered(order(as.integer(merged_rows$r))) - merged_rows <- merged_rows[ordr, ] - - self$worksheets[[id_new]]$sheet_data$row_attr <- merged_rows - } - - self$worksheets[[id_new]]$cols_attr <- - self$worksheets[[id_org]]$cols_attr - - self$worksheets[[id_new]]$dimension <- - self$worksheets[[id_org]]$dimension - - self$worksheets[[id_new]]$mergeCells <- - self$worksheets[[id_org]]$mergeCells - - invisible(self) + wb_clone_sheet_style_impl(self, private, from, to) }, - #' @description apply sparkline to worksheet #' @param sheet the worksheet you are using #' @param sparklines sparkline created by `create_sparkline()` - add_sparklines = function( - sheet = current_sheet(), - sparklines - ) { - sheet <- private$get_sheet_index(sheet) - self$worksheets[[sheet]]$add_sparklines(sparklines) - invisible(self) + add_sparklines = function(sheet = current_sheet(), sparklines) { + wb_add_sparklines_impl(self, private, sheet, sparklines) } - ), ## private ---- @@ -5695,27 +2150,6 @@ wbWorkbook <- R6::R6Class( invisible(self) }, - modify_creators = function(method = c("add", "set", "remove"), value) { - method <- match.arg(method) - assert_class(value, "character") - - if (any(!has_chr(value))) { - stop("all creators must contain characters without NAs", call. = FALSE) - } - - value <- switch( - method, - add = unique(c(self$creator, value)), - set = unique(value), - remove = setdiff(self$creator, value) - ) - - self$creator <- value - # core is made on initialization - private$generate_base_core() - invisible(self) - }, - get_worksheet = function(sheet) { self$worksheets[[private$get_sheet_index(sheet)]] }, @@ -5790,10 +2224,10 @@ wbWorkbook <- R6::R6Class( ## write vml output write_file( - head = '', - body = pxml(vml_xml), - tail = '', - fl = file.path(dir, sprintf("vmlDrawing%s.vml", i)) + head = '', + body = pxml(vml_xml), + tail = '', + fl = file.path(dir, sprintf("vmlDrawing%s.vml", i)) ) ## vml drawing @@ -6130,16 +2564,16 @@ wbWorkbook <- R6::R6Class( }, do_conditional_formatting = function( - sheet, - startRow, - endRow, - startCol, - endCol, - dxfId, - formula, - type, - values, - params + sheet, + startRow, + endRow, + startCol, + endCol, + dxfId, + formula, + type, + values, + params ) { # TODO consider defaults for logicals # TODO rename: setConditionFormatting? Or addConditionalFormatting @@ -6295,9 +2729,9 @@ wbWorkbook <- R6::R6Class( seq_along(self$workbook.xml.rels), function(i) { gsub('(?<=Relationship Id="rId)[0-9]+', - i, - self$workbook.xml.rels[[i]], - perl = TRUE + i, + self$workbook.xml.rels[[i]], + perl = TRUE ) } ) @@ -6306,19 +2740,19 @@ wbWorkbook <- R6::R6Class( if (length(self$metadata)) { self$append("workbook.xml.rels", - sprintf( - '', - 1L + length(self$workbook.xml.rels) - ) + sprintf( + '', + 1L + length(self$workbook.xml.rels) + ) ) } if (!is.null(self$vbaProject)) { self$append("workbook.xml.rels", - sprintf( - '', - 1L + length(self$workbook.xml.rels) - ) + sprintf( + '', + 1L + length(self$workbook.xml.rels) + ) ) } diff --git a/R/onUnload.R b/R/onUnload.R deleted file mode 100644 index cef02ed63..000000000 --- a/R/onUnload.R +++ /dev/null @@ -1,3 +0,0 @@ -.onUnload <- function(libpath) { - library.dynam.unload("openxlsx2", libpath) # nocov -} diff --git a/R/openxlsx2.R b/R/openxlsx2.R index d92b802e3..247d1d25f 100644 --- a/R/openxlsx2.R +++ b/R/openxlsx2.R @@ -7,7 +7,7 @@ #' or chains, `openxlsx2` allows to break many new ground. #' #' @name openxlsx2 -#' @docType package +#' @docType packages #' @useDynLib openxlsx2, .registration=TRUE #' #' @import Rcpp @@ -64,6 +64,28 @@ #' NULL +# TODO export op.openxlsx2 +op.openxlsx2 <- list( + openxlsx2.borderColour = "black", + openxlsx2.borderStyle = "thin", + openxlsx2.dateFormat = "mm/dd/yyy", + openxlsx2.datetimeFormat = "yyyy-mm-dd hh:mm:ss", + openxlsx2.na.strings = "#N/A", + openxlsx2.numFmt = NULL, + openxlsx2.paperSize = 9, + openxlsx2.orientation = "portrait", + openxlsx2.sheet.default_name = "Sheet ", + openxlsx2.rightToLeft = NULL +) + +.onLoad <- function(libname, pkgname) { + options(op.openxlsx2[names(op.openxlsx2) %out% names(options())]) +} + +.onUnload <- function(libpath) { + library.dynam.unload("openxlsx2", libpath) # nocov +} + # matches enum celltype openxlsx2_celltype <- c( short_date = 0, diff --git a/R/wb_functions.R b/R/wb_functions.R index a15299209..836dcb328 100644 --- a/R/wb_functions.R +++ b/R/wb_functions.R @@ -7,7 +7,6 @@ #' } #' @export dims_to_dataframe <- function(dims, fill = FALSE) { - if (grepl(";", dims)) { dims <- unlist(strsplit(dims, ";")) } @@ -311,7 +310,7 @@ wb_to_df <- function( rows = NULL, cols = NULL, detectDates = TRUE, - na.strings = "#N/A", + na.strings = getOption("openxlsx2.na.strings", "#N/A"), na.numbers = NA, fillMergedCells = FALSE, dims, diff --git a/R/write.R b/R/write.R index 505ac474b..ece037969 100644 --- a/R/write.R +++ b/R/write.R @@ -8,13 +8,19 @@ #' @param cell the cell you want to update in Excel connotation e.g. "A1" #' @param colNames if TRUE colNames are passed down #' @param removeCellStyle keep the cell style? -#' @param na.strings optional na.strings argument. if missing #N/A is used. If NULL no cell value is written, if character or numeric this is written (even if NA is part of numeric data) +#' @param na.strings na.strings argument. If NULL no cell value is written, if character or numeric this is written (even if NA is part of numeric data) #' #' @keywords internal #' @noRd -update_cell <- function(x, wb, sheet, cell, colNames = FALSE, - removeCellStyle = FALSE, na.strings) { - +update_cell <- function( + x, + wb, + sheet, + cell, + colNames = FALSE, + removeCellStyle = FALSE, + na.strings = getOption("openxlsx2.na.strings", "#N/A") + ) { sheet_id <- wb$validate_sheet(sheet) dims <- dims_to_dataframe(cell, fill = TRUE) @@ -82,10 +88,6 @@ update_cell <- function(x, wb, sheet, cell, colNames = FALSE, wb$worksheets[[sheet_id]]$dimension <- paste0("") } - if (missing(na.strings)) { - na.strings <- NULL - } - if (removeCellStyle) { cell_style <- "c_s" } else { @@ -133,7 +135,7 @@ nmfmt_df <- function(x) { #' @param startCol col to place it #' @param applyCellStyle apply styles when writing on the sheet #' @param removeCellStyle keep the cell style? -#' @param na.strings optional na.strings argument. if missing #N/A is used. If NULL no cell value is written, if character or numeric this is written (even if NA is part of numeric data) +#' @param na.strings na.strings argument. If NULL no cell value is written, if character or numeric this is written (even if NA is part of numeric data) #' @param data_table logical. if `TRUE` and `rowNames = TRUE`, do not write the cell containing `"_rowNames_"` #' @details #' The string `"_openxlsx_NA"` is reserved for `openxlsx2`. If the data frame @@ -160,19 +162,17 @@ write_data2 <- function( wb, sheet, data, - name = NULL, - colNames = TRUE, - rowNames = FALSE, - startRow = 1, - startCol = 1, - applyCellStyle = TRUE, + name = NULL, + colNames = TRUE, + rowNames = FALSE, + startRow = 1, + startCol = 1, + applyCellStyle = TRUE, removeCellStyle = FALSE, - na.strings, - data_table = FALSE + na.strings = getOption("openxlsx2.na.strings", "#N/A"), + data_table = FALSE ) { - if (missing(na.strings)) na.strings <- substitute() - is_data_frame <- FALSE #### prepare the correct data formats for openxml dc <- openxlsx2_type(data) @@ -576,32 +576,32 @@ write_data2 <- function( #' @param name If not NULL, a named region is defined. #' @param applyCellStyle apply styles when writing on the sheet #' @param removeCellStyle if writing into existing cells, should the cell style be removed? -#' @param na.strings optional na.strings argument. if missing #N/A is used. If NULL no cell value is written, if character or numeric this is written (even if NA is part of numeric data) +#' @param na.strings na.strings argument. If NULL no cell value is written, if character or numeric this is written (even if NA is part of numeric data) #' @noRd write_data_table <- function( wb, sheet, x, - startCol = 1, - startRow = 1, + startCol = 1, + startRow = 1, dims, - array = FALSE, - xy = NULL, - colNames = TRUE, - rowNames = FALSE, - tableStyle = "TableStyleLight9", - tableName = NULL, - withFilter = TRUE, - sep = ", ", - firstColumn = FALSE, - lastColumn = FALSE, - bandedRows = TRUE, - bandedCols = FALSE, - name = NULL, - applyCellStyle = TRUE, + array = FALSE, + xy = NULL, + colNames = TRUE, + rowNames = FALSE, + tableStyle = "TableStyleLight9", + tableName = NULL, + withFilter = TRUE, + sep = ", ", + firstColumn = FALSE, + lastColumn = FALSE, + bandedRows = TRUE, + bandedCols = FALSE, + name = NULL, + applyCellStyle = TRUE, removeCellStyle = FALSE, - data_table = FALSE, - na.strings + data_table = FALSE, + na.strings = getOption("openxlsx2.na.strings", "#N/A") ) { op <- openxlsx2_options() @@ -625,8 +625,6 @@ write_data_table <- function( startRow <- min(dims[[2]]) } - if (missing(na.strings)) na.strings <- substitute() - ## common part --------------------------------------------------------------- if ((!is.character(sep)) || (length(sep) != 1)) stop("sep must be a character vector of length 1") @@ -853,7 +851,7 @@ write_data_table <- function( #' @param name If not NULL, a named region is defined. #' @param applyCellStyle apply styles when writing on the sheet #' @param removeCellStyle if writing into existing cells, should the cell style be removed? -#' @param na.strings optional na.strings argument. if missing #N/A is used. If NULL no cell value is written, if character or numeric this is written (even if NA is part of numeric data) +#' @param na.strings na.strings argument. If NULL no cell value is written, if character or numeric this is written (even if NA is part of numeric data) #' @seealso [write_datatable()] #' @export write_data #' @details Formulae written using write_formula to a Workbook object will not get picked up by read_xlsx(). @@ -918,47 +916,45 @@ write_data <- function( wb, sheet, x, - startCol = 1, - startRow = 1, - dims = rowcol_to_dims(startRow, startCol), - array = FALSE, - xy = NULL, - colNames = TRUE, - rowNames = FALSE, - withFilter = FALSE, - sep = ", ", - name = NULL, - applyCellStyle = TRUE, + startCol = 1, + startRow = 1, + dims = rowcol_to_dims(startRow, startCol), + array = FALSE, + xy = NULL, + colNames = TRUE, + rowNames = FALSE, + withFilter = FALSE, + sep = ", ", + name = NULL, + applyCellStyle = TRUE, removeCellStyle = FALSE, - na.strings + na.strings = getOption("openxlsx2.na.strings", "#N/A") ) { - if (missing(na.strings)) na.strings <- substitute() - write_data_table( - wb = wb, - sheet = sheet, - x = x, - startCol = startCol, - startRow = startRow, - dims = dims, - array = array, - xy = xy, - colNames = colNames, - rowNames = rowNames, - tableStyle = NULL, - tableName = NULL, - withFilter = withFilter, - sep = sep, - firstColumn = FALSE, - lastColumn = FALSE, - bandedRows = FALSE, - bandedCols = FALSE, - name = name, - applyCellStyle = applyCellStyle, + wb = wb, + sheet = sheet, + x = x, + startCol = startCol, + startRow = startRow, + dims = dims, + array = array, + xy = xy, + colNames = colNames, + rowNames = rowNames, + tableStyle = NULL, + tableName = NULL, + withFilter = withFilter, + sep = sep, + firstColumn = FALSE, + lastColumn = FALSE, + bandedRows = FALSE, + bandedCols = FALSE, + name = name, + applyCellStyle = applyCellStyle, removeCellStyle = removeCellStyle, - data_table = FALSE, - na.strings = na.strings + data_table = FALSE, + na.strings = na.strings ) } @@ -1058,12 +1054,12 @@ write_formula <- function( wb, sheet, x, - startCol = 1, - startRow = 1, - dims = rowcol_to_dims(startRow, startCol), - array = FALSE, - xy = NULL, - applyCellStyle = TRUE, + startCol = 1, + startRow = 1, + dims = rowcol_to_dims(startRow, startCol), + array = FALSE, + xy = NULL, + applyCellStyle = TRUE, removeCellStyle = FALSE ) { assert_class(x, "character") @@ -1078,17 +1074,17 @@ write_formula <- function( } write_data( - wb = wb, - sheet = sheet, - x = dfx, - startCol = startCol, - startRow = startRow, - dims = dims, - array = array, - xy = xy, - colNames = FALSE, - rowNames = FALSE, - applyCellStyle = applyCellStyle, + wb = wb, + sheet = sheet, + x = dfx, + startCol = startCol, + startRow = startRow, + dims = dims, + array = array, + xy = xy, + colNames = FALSE, + rowNames = FALSE, + applyCellStyle = applyCellStyle, removeCellStyle = removeCellStyle ) } @@ -1123,7 +1119,7 @@ write_formula <- function( #' @param bandedCols logical. If TRUE, the columns are colour banded #' @param applyCellStyle apply styles when writing on the sheet #' @param removeCellStyle if writing into existing cells, should the cell style be removed? -#' @param na.strings optional na.strings argument. if missing #N/A is used. If NULL no cell value is written, if character or numeric this is written (even if NA is part of numeric data) +#' @param na.strings na.strings argument. If NULL no cell value is written, if character or numeric this is written (even if NA is part of numeric data) #' @details columns of x with class Date/POSIXt, currency, accounting, #' hyperlink, percentage are automatically styled as dates, currency, accounting, #' hyperlinks, percentages respectively. @@ -1220,50 +1216,47 @@ write_datatable <- function( wb, sheet, x, - startCol = 1, - startRow = 1, - dims = rowcol_to_dims(startRow, startCol), - xy = NULL, - colNames = TRUE, - rowNames = FALSE, - tableStyle = "TableStyleLight9", - tableName = NULL, - withFilter = TRUE, - sep = ", ", - firstColumn = FALSE, - lastColumn = FALSE, - bandedRows = TRUE, - bandedCols = FALSE, - applyCellStyle = TRUE, + startCol = 1, + startRow = 1, + dims = rowcol_to_dims(startRow, startCol), + xy = NULL, + colNames = TRUE, + rowNames = FALSE, + tableStyle = "TableStyleLight9", + tableName = NULL, + withFilter = TRUE, + sep = ", ", + firstColumn = FALSE, + lastColumn = FALSE, + bandedRows = TRUE, + bandedCols = FALSE, + applyCellStyle = TRUE, removeCellStyle = FALSE, - na.strings + na.strings = getOption("openxlsx2.na.strings", "#N/A") ) { - - if (missing(na.strings)) na.strings <- substitute() - write_data_table( - wb = wb, - sheet = sheet, - x = x, - startCol = startCol, - startRow = startRow, - dims = dims, - array = FALSE, - xy = xy, - colNames = colNames, - rowNames = rowNames, - tableStyle = tableStyle, - tableName = tableName, - withFilter = withFilter, - sep = sep, - firstColumn = firstColumn, - lastColumn = lastColumn, - bandedRows = bandedRows, - bandedCols = bandedCols, - name = NULL, - data_table = TRUE, - applyCellStyle = applyCellStyle, + wb = wb, + sheet = sheet, + x = x, + startCol = startCol, + startRow = startRow, + dims = dims, + array = FALSE, + xy = xy, + colNames = colNames, + rowNames = rowNames, + tableStyle = tableStyle, + tableName = tableName, + withFilter = withFilter, + sep = sep, + firstColumn = firstColumn, + lastColumn = lastColumn, + bandedRows = bandedRows, + bandedCols = bandedCols, + name = NULL, + data_table = TRUE, + applyCellStyle = applyCellStyle, removeCellStyle = removeCellStyle, - na.strings = na.strings + na.strings = na.strings ) } diff --git a/man/openxlsx2.Rd b/man/openxlsx2.Rd index 2159aacd5..32bad49c6 100644 --- a/man/openxlsx2.Rd +++ b/man/openxlsx2.Rd @@ -1,6 +1,6 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/openxlsx2.R -\docType{package} +\docType{packages} \name{openxlsx2} \alias{openxlsx2} \title{xlsx reading, writing and editing.} diff --git a/man/wbWorkbook.Rd b/man/wbWorkbook.Rd index 7c739438b..5e8df1d0a 100644 --- a/man/wbWorkbook.Rd +++ b/man/wbWorkbook.Rd @@ -554,7 +554,7 @@ add data sep = ", ", applyCellStyle = TRUE, removeCellStyle = FALSE, - na.strings + na.strings = getOption("openxlsx2.na.strings", "#N/A") )}\if{html}{\out{}} } @@ -621,7 +621,7 @@ add a data table bandedCols = FALSE, applyCellStyle = TRUE, removeCellStyle = FALSE, - na.strings + na.strings = getOption("openxlsx2.na.strings", "#N/A") )}\if{html}{\out{}} } @@ -718,7 +718,7 @@ add formula \subsection{Method \code{add_style()}}{ add style \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{wbWorkbook$add_style(style = NULL, style_name = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{wbWorkbook$add_style(style = NULL, style_name = substitute(style))}\if{html}{\out{
}} } \subsection{Arguments}{ diff --git a/man/wb_add_data_table.Rd b/man/wb_add_data_table.Rd index 95f2a6d03..f22407bc3 100644 --- a/man/wb_add_data_table.Rd +++ b/man/wb_add_data_table.Rd @@ -24,7 +24,7 @@ wb_add_data_table( bandedCols = FALSE, applyCellStyle = TRUE, removeCellStyle = FALSE, - na.strings + na.strings = getOption("openxlsx2.na.strings", "#N/A") ) } \arguments{ diff --git a/man/wb_add_style.Rd b/man/wb_add_style.Rd index e1f61572a..a0e57d14f 100644 --- a/man/wb_add_style.Rd +++ b/man/wb_add_style.Rd @@ -4,7 +4,7 @@ \alias{wb_add_style} \title{add style to workbook} \usage{ -wb_add_style(wb, style = NULL, style_name = NULL) +wb_add_style(wb, style = NULL, style_name = substitute(style)) } \arguments{ \item{wb}{workbook} diff --git a/man/wb_to_df.Rd b/man/wb_to_df.Rd index 0ae5d424c..ff4208802 100644 --- a/man/wb_to_df.Rd +++ b/man/wb_to_df.Rd @@ -16,7 +16,7 @@ wb_to_df( rows = NULL, cols = NULL, detectDates = TRUE, - na.strings = "#N/A", + na.strings = getOption("openxlsx2.na.strings", "#N/A"), na.numbers = NA, fillMergedCells = FALSE, dims, diff --git a/man/write_data.Rd b/man/write_data.Rd index 9f01332b1..e37a5d079 100644 --- a/man/write_data.Rd +++ b/man/write_data.Rd @@ -21,7 +21,7 @@ wb_add_data( sep = ", ", applyCellStyle = TRUE, removeCellStyle = FALSE, - na.strings + na.strings = getOption("openxlsx2.na.strings", "#N/A") ) write_data( @@ -40,7 +40,7 @@ write_data( name = NULL, applyCellStyle = TRUE, removeCellStyle = FALSE, - na.strings + na.strings = getOption("openxlsx2.na.strings", "#N/A") ) } \arguments{ @@ -76,7 +76,7 @@ write_data( \item{removeCellStyle}{if writing into existing cells, should the cell style be removed?} -\item{na.strings}{optional na.strings argument. if missing #N/A is used. If NULL no cell value is written, if character or numeric this is written (even if NA is part of numeric data)} +\item{na.strings}{na.strings argument. If NULL no cell value is written, if character or numeric this is written (even if NA is part of numeric data)} } \value{ A clone of `wb`` diff --git a/man/write_data2.Rd b/man/write_data2.Rd index ab3d4d7d3..f90d4eb0d 100644 --- a/man/write_data2.Rd +++ b/man/write_data2.Rd @@ -15,7 +15,7 @@ write_data2( startCol = 1, applyCellStyle = TRUE, removeCellStyle = FALSE, - na.strings, + na.strings = getOption("openxlsx2.na.strings", "#N/A"), data_table = FALSE ) } @@ -40,7 +40,7 @@ write_data2( \item{removeCellStyle}{keep the cell style?} -\item{na.strings}{optional na.strings argument. if missing #N/A is used. If NULL no cell value is written, if character or numeric this is written (even if NA is part of numeric data)} +\item{na.strings}{na.strings argument. If NULL no cell value is written, if character or numeric this is written (even if NA is part of numeric data)} \item{data_table}{logical. if \code{TRUE} and \code{rowNames = TRUE}, do not write the cell containing \code{"_rowNames_"}} } diff --git a/man/write_datatable.Rd b/man/write_datatable.Rd index 02eeddb8f..3984101cc 100644 --- a/man/write_datatable.Rd +++ b/man/write_datatable.Rd @@ -24,7 +24,7 @@ write_datatable( bandedCols = FALSE, applyCellStyle = TRUE, removeCellStyle = FALSE, - na.strings + na.strings = getOption("openxlsx2.na.strings", "#N/A") ) } \arguments{ @@ -72,7 +72,7 @@ A vector of the form c(startCol, startRow)} \item{removeCellStyle}{if writing into existing cells, should the cell style be removed?} -\item{na.strings}{optional na.strings argument. if missing #N/A is used. If NULL no cell value is written, if character or numeric this is written (even if NA is part of numeric data)} +\item{na.strings}{na.strings argument. If NULL no cell value is written, if character or numeric this is written (even if NA is part of numeric data)} } \description{ Write to a worksheet and format as an Excel table diff --git a/tests/testthat/test-class-color.R b/tests/testthat/test-class-color.R index fa41432bd..e34a83c92 100644 --- a/tests/testthat/test-class-color.R +++ b/tests/testthat/test-class-color.R @@ -12,6 +12,6 @@ test_that("get()", { got <- wb_colour("black") expect_true(is_wbColour(got)) - expect_equal(exp, got) + expect_equal(got, exp) }) diff --git a/tests/testthat/test-class-comment.R b/tests/testthat/test-class-comment.R index 1a41545c3..c339877d2 100644 --- a/tests/testthat/test-class-comment.R +++ b/tests/testthat/test-class-comment.R @@ -130,6 +130,6 @@ test_that("print comment", { exp <- "Author: Marco Polo\nText:\n Marco Polo:\nthis is another comment\n\nStyle:\n\n\n\n\nFont name: Calibri\nFont size: 11\nFont colour: #000000\n\n" got <- capture_output(print(c2), print = TRUE) - expect_equal(exp, got) + expect_equal(got, exp) }) diff --git a/tests/testthat/test-class-hyperlink.R b/tests/testthat/test-class-hyperlink.R index 9b9664177..5c5b5692a 100644 --- a/tests/testthat/test-class-hyperlink.R +++ b/tests/testthat/test-class-hyperlink.R @@ -38,6 +38,6 @@ test_that("formulas with hyperlinks works", { exp <- "=IF(2017 = VALUE(A1), HYPERLINK(\"github.com\",\"github.com\"), A1)" got <- wb$worksheets[[1]]$sheet_data$cc["12", "f"] - expect_equal(exp, got) + expect_equal(got, exp) }) diff --git a/tests/testthat/test-class-workbook-wrappers.R b/tests/testthat/test-class-workbook-wrappers.R index e3abdcbeb..3de0f0ec9 100644 --- a/tests/testthat/test-class-workbook-wrappers.R +++ b/tests/testthat/test-class-workbook-wrappers.R @@ -182,14 +182,10 @@ test_that("wb_add_plot() is a wrapper", { }) test_that("wb_add_drawing is a wrapper", { - fl <- system.file("extdata", "loadExample.xlsx", package = "openxlsx2") - wb <- wb_load(file = fl) - - xml <- wb$drawings[[2]] - - wb <- wb_workbook()$add_worksheet() - + xml <- wb_load(file = fl)$drawings[[2]] + wb <- wb_workbook() + wb$add_worksheet() expect_wrapper("add_drawing", wb = wb, params = list(xml = xml)) }) @@ -464,25 +460,16 @@ test_that("wb_add_sparklines() is a wrapper", { # wb_add_style() ---------------------------------------------------------- test_that("wb_add_style() is a wrapper", { - # with name style <- create_numfmt(numFmtId = "165", formatCode = "#.#") wb <- wb_workbook() - expect_wrapper( - "add_style", - wb = wb, - params = list(style = style, style_name = "numfmt") - ) + params <- list(style = style, style_name = "numfmt") + expect_wrapper("add_style", wb = wb, params = params) # without name wb <- wb_workbook() numfmt <- create_numfmt(numFmtId = "165", formatCode = "#.#") - expect_wrapper( - "add_style", - wb = wb, - params = list(style = numfmt) - ) - + expect_wrapper("add_style", wb = wb, params = list(style = numfmt)) }) diff --git a/tests/testthat/test-class-workbook.R b/tests/testthat/test-class-workbook.R index 0cb687418..8a57ce0ac 100644 --- a/tests/testthat/test-class-workbook.R +++ b/tests/testthat/test-class-workbook.R @@ -61,7 +61,7 @@ test_that("wb_set_col_widths", { "" ) got <- wb$worksheets[[1]]$cols_attr - expect_equal(exp, got) + expect_equal(got, exp) }) @@ -108,7 +108,7 @@ test_that("$set_sheet_names() and $get_sheet_names() work", { exp <- c(`Sheet 1` = "Sheet 1") got <- wb$get_sheet_names() - expect_equal(exp, got) + expect_equal(got, exp) }) # data validation --------------------------------------------------------- @@ -158,7 +158,7 @@ test_that("data validation", { "79" ) got <- wb$worksheets[[1]]$dataValidations - expect_equal(exp, got) + expect_equal(got, exp) exp <- c( @@ -166,14 +166,14 @@ test_that("data validation", { "42369.768518518542370.2314814815" ) got <- wb$worksheets[[2]]$dataValidations - expect_equal(exp, got) + expect_equal(got, exp) exp <- c( "'Sheet 4'!$A$1:$A$10" ) got <- wb$worksheets[[3]]$dataValidations - expect_equal(exp, got) + expect_equal(got, exp) wb$save(temp) @@ -206,7 +206,7 @@ test_that("data validation", { "'Sheet 4'!$A$1:$A$10" ) got <- wb2$worksheets[[3]]$dataValidations - expect_equal(exp, got) + expect_equal(got, exp) ### tests if conditions @@ -221,7 +221,7 @@ test_that("data validation", { exp <- "19" got <- wb$worksheets[[1]]$dataValidations - expect_equal(exp, got) + expect_equal(got, exp) # to many values @@ -297,7 +297,7 @@ test_that("data validation", { exp <- "0" got <- wb$worksheets[[1]]$dataValidations - expect_equal(exp, got) + expect_equal(got, exp) # add custom data wb <- wb_workbook()$ @@ -308,7 +308,7 @@ test_that("data validation", { exp <- "A1=B1" got <- wb$worksheets[[1]]$dataValidations - expect_equal(exp, got) + expect_equal(got, exp) }) @@ -337,7 +337,7 @@ test_that("clone worksheet", { "" ) got <- wb$worksheets_rels[[5]] - expect_equal(exp, got) + expect_equal(got, exp) # wb$open() # clone drawing --------------------------------------------------------- @@ -394,7 +394,7 @@ test_that("set and remove row heights work", { class = "data.frame" ) got <- wb$worksheets[[1]]$sheet_data$row_attr[c(1, 2, 4, 19, 22), c("customHeight", "ht", "r")] - expect_equal(exp, got) + expect_equal(got, exp) ## remove row heights wb$remove_row_heights(rows = 1:21) @@ -408,7 +408,7 @@ test_that("set and remove row heights work", { class = "data.frame" ) got <- wb$worksheets[[1]]$sheet_data$row_attr[c(1, 2, 4, 19, 22), c("customHeight", "ht", "r")] - expect_equal(exp, got) + expect_equal(got, exp) expect_warning( wb$add_worksheet()$remove_row_heights(rows = 1:3), @@ -532,7 +532,7 @@ test_that("add_drawing works", { "" ) got <- wb$drawings_rels - expect_equal(exp, got) + expect_equal(got, exp) # write data starting at B2 @@ -551,6 +551,6 @@ test_that("add_drawing works", { character(0) ) got <- wb$worksheets_rels - expect_equal(exp, got) + expect_equal(got, exp) }) diff --git a/tests/testthat/test-class-worksheet.R b/tests/testthat/test-class-worksheet.R index 5831338c3..bd1abfe47 100644 --- a/tests/testthat/test-class-worksheet.R +++ b/tests/testthat/test-class-worksheet.R @@ -23,7 +23,7 @@ test_that("test data validation list and sparklines", { "'Sheet 1'!A3:K3L3'Sheet 1'!A4:K4L4" ) got <- wb$worksheets[[1]]$extLst - expect_equal(exp, got) + expect_equal(got, exp) }) @@ -64,7 +64,7 @@ test_that("set_sheetview", { exp <- "" got <- wb$worksheets[[1]]$sheetViews - expect_equal(exp, got) + expect_equal(got, exp) exp <- "" @@ -72,14 +72,14 @@ test_that("set_sheetview", { wb <- wb_workbook()$add_worksheet() got <- wb$worksheets[[1]]$sheetViews - expect_equal(exp, got) + expect_equal(got, exp) options("openxlsx2.rightToLeft" = "1") wb <- wb_workbook()$add_worksheet() got <- wb$worksheets[[1]]$sheetViews - expect_equal(exp, got) + expect_equal(got, exp) }) @@ -95,16 +95,16 @@ test_that("print options work", { exp <- character() got <- wb$worksheets[[1]]$printOptions - expect_equal(exp, got) + expect_equal(got, exp) exp <- "" got <- wb$worksheets[[2]]$printOptions - expect_equal(exp, got) + expect_equal(got, exp) wb$save(temp) wb <- wb_load(temp) got <- wb$worksheets[[2]]$printOptions - expect_equal(exp, got) + expect_equal(got, exp) }) diff --git a/tests/testthat/test-conditional_formatting.R b/tests/testthat/test-conditional_formatting.R index ee0aa7dc8..9cb2c40e0 100644 --- a/tests/testthat/test-conditional_formatting.R +++ b/tests/testthat/test-conditional_formatting.R @@ -561,7 +561,7 @@ test_that("extend dataBar tests", { `K1:K11` = "{F7189283-14F7-4DE0-9601-54DE9DB40005}" ) got <- wb$worksheets[[1]]$conditionalFormatting - expect_equal(exp, got) + expect_equal(got, exp) exp <- read_xml(" @@ -573,7 +573,7 @@ test_that("extend dataBar tests", { 05K1:K11 ", pointer = FALSE) got <- wb$worksheets[[1]]$extLst - expect_equal(exp, got) + expect_equal(got, exp) }) @@ -592,7 +592,7 @@ test_that("wb_conditional_formatting", { exp <- c(`A1:A11` = "{F7189283-14F7-4DE0-9601-54DE9DB40000}") got <- wb$worksheets[[1]]$conditionalFormatting - expect_equal(exp, got) + expect_equal(got, exp) }) test_that("create dxfs style without font family and size", { @@ -600,7 +600,7 @@ test_that("create dxfs style without font family and size", { # a workbook with this style loads, but has no highlighting exp <- "" got <- create_dxfs_style() - expect_equal(exp, got) + expect_equal(got, exp) # most likely what the user expects. change font color and background color exp <- "" @@ -608,7 +608,7 @@ test_that("create dxfs style without font family and size", { font_color = wb_colour(hex = "FF9C0006"), bgFill = wb_colour(hex = "FFFFC7CE") ) - expect_equal(exp, got) + expect_equal(got, exp) # the fully fletched old default dxfs style exp <- "" @@ -618,6 +618,6 @@ test_that("create dxfs style without font family and size", { font_color = wb_colour(hex = "FF9C0006"), bgFill = wb_colour(hex = "FFFFC7CE") ) - expect_equal(exp, got) + expect_equal(got, exp) }) diff --git a/tests/testthat/test-converters.R b/tests/testthat/test-converters.R index c5bf455eb..ca56961a0 100644 --- a/tests/testthat/test-converters.R +++ b/tests/testthat/test-converters.R @@ -2,7 +2,7 @@ test_that("int2col", { exp <- LETTERS[1:10] got <- int2col(1:10) - expect_equal(exp, got) + expect_equal(got, exp) expect_error(int2col("a"), "x must be numeric.") @@ -21,7 +21,7 @@ test_that("get_cell_refs", { exp <- c("B1", "C2", "D3") got <- get_cell_refs(data.frame(1:3, 2:4)) - expect_equal(exp, got) + expect_equal(got, exp) expect_error(get_cell_refs(data.frame("a", "a")), "cellCoords must only contain integers") diff --git a/tests/testthat/test-helper_functions.R b/tests/testthat/test-helper_functions.R index 4ff402c7d..13f9fe8e1 100644 --- a/tests/testthat/test-helper_functions.R +++ b/tests/testthat/test-helper_functions.R @@ -44,7 +44,7 @@ test_that("openxlsx2_types", { ) - expect_equal(exp, got) + expect_equal(got, exp) }) @@ -109,11 +109,11 @@ test_that("amp_split & genHeaderFooterNode", { oddFooter = c("", "&"Times New Roman,Standard"&12Seite &P", "") ) got <- getHeaderFooterNode(xml) - expect_equal(exp, got) + expect_equal(got, exp) exp <- xml got <- genHeaderFooterNode(got) - expect_equal(exp, got) + expect_equal(got, exp) }) @@ -191,7 +191,7 @@ test_that("add_sparklines", { ', pointer = FALSE) got <- wb$worksheets[[1]]$extLst - expect_equal(exp, got) + expect_equal(got, exp) expect_error( wb$add_sparklines(sparklines = xml_node_create("sparklines", sparklines)), diff --git a/tests/testthat/test-illegal-characters.R b/tests/testthat/test-illegal-characters.R index 19cec1389..559e1d871 100644 --- a/tests/testthat/test-illegal-characters.R +++ b/tests/testthat/test-illegal-characters.R @@ -2,10 +2,10 @@ test_that("clean_worksheet_name", { exp <- "test that" got <- clean_worksheet_name("test\that") - expect_equal(exp, got) + expect_equal(got, exp) exp <- c("a b", "a b", "a b", "a b", "a b", "a b", "a b") got <- clean_worksheet_name(c("a\b", "a/b", "a?b", "a*b", "a:b", "a[b", "a]b")) - expect_equal(exp, got) + expect_equal(got, exp) }) diff --git a/tests/testthat/test-loading_workbook.R b/tests/testthat/test-loading_workbook.R index 1b8708f13..c744d65c3 100644 --- a/tests/testthat/test-loading_workbook.R +++ b/tests/testthat/test-loading_workbook.R @@ -175,13 +175,13 @@ test_that("additional wb tests", { # showFormula exp <- data.frame(Var7 = "1/0", row.names = "2") got <- wb_to_df(wb1, showFormula = TRUE, rows = 1:2, cols = 8) - expect_equal(exp, got, ignore_attr = TRUE) + expect_equal(got, exp, ignore_attr = TRUE) expect_equal(names(exp), names(got)) # detectDates exp <- data.frame(Var5 = as.Date("2015-02-07"), row.names = "2") got <- wb_to_df(wb1, showFormula = TRUE, rows = 1:2, cols = 6) - expect_equal(exp, got, ignore_attr = TRUE) + expect_equal(got, exp, ignore_attr = TRUE) expect_equal(names(exp), names(got)) # types @@ -190,7 +190,7 @@ test_that("additional wb tests", { Var3 = c(1.00, NaN, 1.34, NA)) got <- wb_to_df(wb1, cols = c(1, 4), types = c("Var1" = 0, "Var3" = 1))[seq_len(4), ] - expect_equal(exp, got, ignore_attr = TRUE) + expect_equal(got, exp, ignore_attr = TRUE) expect_equal(names(exp), names(got)) }) @@ -307,7 +307,7 @@ test_that("loading slicers works", { exp <- "" got <- wb$workbook$calcPr - expect_equal(exp, got) + expect_equal(got, exp) exp <- c( "", @@ -323,7 +323,7 @@ test_that("loading slicers works", { "" ) got <- wb$workbook.xml.rels - expect_equal(exp, got) + expect_equal(got, exp) wb <- wb_load(file = fl, calc_chain = FALSE) got <- wb$workbook.xml.rels @@ -335,7 +335,7 @@ test_that("loading slicers works", { exp <- "" got <- wb$workbook$calcPr - expect_equal(exp, got) + expect_equal(got, exp) wb <- wb_load(file = fl, calc_chain = FALSE) @@ -344,7 +344,7 @@ test_that("loading slicers works", { exp <- character() got <- wb$calcChain - expect_equal(exp, got) + expect_equal(got, exp) # check the default once again wb <- wb_load(file = fl) @@ -354,7 +354,7 @@ test_that("loading slicers works", { exp <- character() got <- wb$calcChain - expect_equal(exp, got) + expect_equal(got, exp) }) @@ -365,6 +365,6 @@ test_that("vml target is updated on load", { exp <- "" got <- wb$worksheets_rels[[4]][2] - expect_equal(exp, got) + expect_equal(got, exp) }) diff --git a/tests/testthat/test-options.R b/tests/testthat/test-options.R index 21a71f4c4..13e1895b2 100644 --- a/tests/testthat/test-options.R +++ b/tests/testthat/test-options.R @@ -4,7 +4,7 @@ test_that("sheet.default_name", { exp <- "Sheet 1" got <- names(wb$get_sheet_names()) - expect_equal(exp, got) + expect_equal(got, exp) op <- options("openxlsx2.sheet.default_name" = "Tabelle") on.exit(options(op), add = TRUE) @@ -12,6 +12,6 @@ test_that("sheet.default_name", { exp <- "Tabelle1" got <- names(wb$get_sheet_names()) - expect_equal(exp, got) + expect_equal(got, exp) }) diff --git a/tests/testthat/test-pugi_cpp.R b/tests/testthat/test-pugi_cpp.R index 5e106d6cc..db4bdff36 100644 --- a/tests/testthat/test-pugi_cpp.R +++ b/tests/testthat/test-pugi_cpp.R @@ -178,7 +178,7 @@ test_that("getXMLPtr1con", { xml <- "" exp <- c("", "", "") got <- getXMLPtr1con(read_xml(xml)) - expect_equal(exp, got) + expect_equal(got, exp) }) diff --git a/tests/testthat/test-pugixml.R b/tests/testthat/test-pugixml.R index eb1a94c42..0e50f679e 100644 --- a/tests/testthat/test-pugixml.R +++ b/tests/testthat/test-pugixml.R @@ -3,11 +3,11 @@ test_that("read_xml", { exp <- "" got <- read_xml("", empty_tags = FALSE, pointer = FALSE) - expect_equal(exp, got) + expect_equal(got, exp) exp <- "" got <- read_xml("", empty_tags = TRUE, pointer = FALSE) - expect_equal(exp, got) + expect_equal(got, exp) # a pointer x <- read_xml("") @@ -65,25 +65,25 @@ test_that("read_xml", { exp <- " " got <- readLines(tmp, warn = FALSE) - expect_equal(exp, got) + expect_equal(got, exp) xml <- '' exp <- c("", "") got <- xml_node(xml, "a") - expect_equal(exp, got) + expect_equal(got, exp) exp <- c("", "") got <- xml_node(xml, "a", "b") - expect_equal(exp, got) + expect_equal(got, exp) exp <- "" got <- xml_node(xml, "a", "b", "c1") - expect_equal(exp, got) + expect_equal(got, exp) exp <- "" got <- xml_node(xml, "a", "b", "c2") - expect_equal(exp, got) + expect_equal(got, exp) }) @@ -275,31 +275,31 @@ test_that("xml_rm_child", { exp <- "2" got <- xml_rm_child(xml_node, "b", which = 1) - expect_equal(exp, got) + expect_equal(got, exp) xml_node <- exp exp <- "2" got <- xml_rm_child(xml_node, xml_child, "b", which = 1) - expect_equal(exp, got) + expect_equal(got, exp) exp <- "2" got <- xml_rm_child(xml_node, xml_child, level = "b", which = 2) - expect_equal(exp, got) + expect_equal(got, exp) exp <- "2" got <- xml_rm_child(xml_node, xml_child, "b", which = 0) - expect_equal(exp, got) + expect_equal(got, exp) xml_node <- "123" exp <- "13" got <- xml_rm_child(xml_node, xml_child, level = c("a", "b"), which = 2) - expect_equal(exp, got) + expect_equal(got, exp) exp <- "" got <- xml_rm_child(xml_node, xml_child, level = c("a", "b"), which = 0) - expect_equal(exp, got) + expect_equal(got, exp) }) @@ -368,13 +368,13 @@ test_that("works with x namespace", { exp <- "" got <- read_xml(tmp, pointer = FALSE) - expect_equal(exp, got) + expect_equal(got, exp) op <- options("openxlsx2.namespace_xml" = "x") on.exit(options(op), add = TRUE) exp <- "" got <- read_xml(tmp, pointer = FALSE) - expect_equal(exp, got) + expect_equal(got, exp) }) diff --git a/tests/testthat/test-read_sources.R b/tests/testthat/test-read_sources.R index 564c955a2..e30edebea 100644 --- a/tests/testthat/test-read_sources.R +++ b/tests/testthat/test-read_sources.R @@ -122,19 +122,19 @@ test_that("encoding", { ) } - expect_equal(exp, got) + expect_equal(got, exp) exp <- "\n äöüß\n ÄÖÜ\n €\n" got <- paste(capture.output( read_xml(system.file("extdata", "unicode.xml", package = "openxlsx2")) ), collapse = "\n") - expect_equal(exp, got) + expect_equal(got, exp) exp <- "äöüßÄÖÜ€" got <- read_xml(system.file("extdata", "unicode.xml", package = "openxlsx2"), pointer = FALSE) - expect_equal(exp, got) + expect_equal(got, exp) }) @@ -148,7 +148,7 @@ test_that("reading charts", { exp <- c("", "", "", "", "", "", "", "", "", "", "", "", "", "", "") got <- wb$charts$rels - expect_equal(exp, got) + expect_equal(got, exp) img <- system.file("extdata", "einstein.jpg", package = "openxlsx2") @@ -175,7 +175,7 @@ test_that("reading charts", { "" ) got <- wb$drawings_rels[[20]] - expect_equal(exp, got) + expect_equal(got, exp) wb$add_worksheet() @@ -218,11 +218,11 @@ test_that("reading file with macro and custom xml", { exp <- "" got <- wb$worksheets[[1]]$sheetPr - expect_equal(exp, got) + expect_equal(got, exp) exp <- "openxlsx2" got <- wb$custom - expect_equal(exp, got) + expect_equal(got, exp) }) test_that("load file with connection", { @@ -259,7 +259,7 @@ test_that("calcChain is updated", { exp <- "" got <- wb$calcChain - expect_equal(exp, got) + expect_equal(got, exp) expect_silent(wb$save(temp)) @@ -267,7 +267,7 @@ test_that("calcChain is updated", { exp <- character() got <- wb$calcChain - expect_equal(exp, got) + expect_equal(got, exp) expect_silent(wb$save(temp)) @@ -304,12 +304,12 @@ test_that("reading of formControl works", { "" ) got <- wb$ctrlProps - expect_equal(exp, got) + expect_equal(got, exp) wb$save(temp) wb <- wb_load(temp) got <- wb$ctrlProps - expect_equal(exp, got) + expect_equal(got, exp) }) diff --git a/tests/testthat/test-save.R b/tests/testthat/test-save.R index 6097b8a2e..03f29714e 100644 --- a/tests/testthat/test-save.R +++ b/tests/testthat/test-save.R @@ -186,11 +186,11 @@ test_that("writing NA, NaN and Inf", { # we wont get the same input back exp <- c(NA_character_, "#NUM!", "#NUM!", "#VALUE!") got <- unname(unlist(wb_to_df(tmp))) - expect_equal(exp, got) + expect_equal(got, exp) wb$clone_worksheet(old = "Test1", new = "Clone1")$add_data(x = x)$save(tmp) got <- unname(unlist(wb_to_df(tmp, "Clone1"))) - expect_equal(exp, got) + expect_equal(got, exp) # distinguish between "NA" and NA_character_ x <- data.frame(x = c(NA, "NA")) @@ -198,11 +198,11 @@ test_that("writing NA, NaN and Inf", { exp <- c(NA_character_, "NA") got <- unname(unlist(wb_to_df(tmp, "Test2"))) - expect_equal(exp, got) + expect_equal(got, exp) wb$clone_worksheet(old = "Test2", new = "Clone2")$add_data(x = x)$save(tmp) got <- unname(unlist(wb_to_df(tmp, "Clone2"))) - expect_equal(exp, got) + expect_equal(got, exp) }) @@ -219,35 +219,34 @@ test_that("writing NA, NaN and Inf", { exp <- c(NA, "s", "s", "s") got <- unname(unlist(attr(wb_to_df(tmp, "Test1"), "tt"))) - expect_equal(exp, got) + expect_equal(got, exp) exp <- c("N/A", "#NUM!", "#NUM!", "#VALUE!") got <- unname(unlist(wb_to_df(tmp, "Test2"))) - expect_equal(exp, got) + expect_equal(got, exp) wb$clone_worksheet("Test1", "Clone1")$add_data(x = x, na.strings = NULL)$save(tmp) wb$clone_worksheet("Test3", "Clone3")$add_data(x = x, na.strings = "N/A")$save(tmp) exp <- c(NA, "s", "s", "s") got <- unname(unlist(attr(wb_to_df(tmp, "Test1"), "tt"))) - expect_equal(exp, got) + expect_equal(got, exp) exp <- c("N/A", "#NUM!", "#NUM!", "#VALUE!") got <- unname(unlist(wb_to_df(tmp, "Test2"))) - expect_equal(exp, got) + expect_equal(got, exp) }) test_that("write cells without data", { - temp <- temp_xlsx() tmp <- temp_dir() dat <- as.data.frame(matrix(NA, 2, 2)) - wb <- wb_workbook()$ - add_worksheet()$ - add_data(x = dat, startRow = 2, startCol = 2, na.strings = NULL, colNames = FALSE) + wb <- wb_workbook() + wb$add_worksheet() + wb$add_data(x = dat, startRow = 2, startCol = 2, na.strings = NULL, colNames = FALSE) wb$worksheets[[1]]$sheet_data$cc$c_t <- "" @@ -259,35 +258,33 @@ test_that("write cells without data", { unzip(temp, exdir = tmp) - exp <- structure( - list( - r = c("B2", "C2", "B3", "C3"), - row_r = c("2", "2", "3", "3"), - c_r = c("B", "C", "B", "C"), - c_s = c("", "", "", ""), - c_t = c("", "", "", ""), - c_cm = c("", "", "", ""), - c_ph = c("", "", "", ""), - c_vm = c("", "", "", ""), - v = c("", "", "", ""), - f = c("", "", "", ""), - f_t = c("", "", "", ""), - f_ref = c("", "", "", ""), - f_ca = c("", "", "", ""), - f_si = c("", "", "", ""), - is = c("", "", "", ""), - typ = c("3", "3", "3", "3") - ), - row.names = c(NA, 4L), - class = "data.frame") + exp <- data.frame( + r = c("B2", "C2", "B3", "C3"), + row_r = c("2", "2", "3", "3"), + c_r = c("B", "C", "B", "C"), + c_s = c("", "", "", ""), + c_t = c("", "", "", ""), + c_cm = c("", "", "", ""), + c_ph = c("", "", "", ""), + c_vm = c("", "", "", ""), + v = c("", "", "", ""), + f = c("", "", "", ""), + f_t = c("", "", "", ""), + f_ref = c("", "", "", ""), + f_ca = c("", "", "", ""), + f_si = c("", "", "", ""), + is = c("", "", "", ""), + typ = c("3", "3", "3", "3"), + stringsAsFactors = FALSE + ) + got <- wb$worksheets[[1]]$sheet_data$cc - expect_equal(exp, got) + expect_equal(got, exp) sheet <- paste0(tmp, "/xl/worksheets/sheet1.xml") exp <- "" got <- xml_node(sheet, "worksheet", "sheetData") - expect_equal(exp, got) - + expect_equal(got, exp) }) test_that("write_xlsx with na.strings", { @@ -302,15 +299,15 @@ test_that("write_xlsx with na.strings", { exp <- df got <- read_xlsx(test) - expect_equal(exp, got, ignore_attr = TRUE) + expect_equal(got, exp, ignore_attr = TRUE) write_xlsx(df, file = test, na.strings = "N/A") got <- read_xlsx(test, na.strings = "N/A") - expect_equal(exp, got, ignore_attr = TRUE) + expect_equal(got, exp, ignore_attr = TRUE) exp$num[exp$num == -99] <- NA got <- read_xlsx(test, na.strings = "N/A", na.numbers = -99) - expect_equal(exp, got, ignore_attr = TRUE) + expect_equal(got, exp, ignore_attr = TRUE) }) @@ -341,13 +338,13 @@ test_that("escaping of inlinestrings works", { exp <- "A & B" got <- wb_to_df(wb, colNames = FALSE)$A - expect_equal(exp, got) + expect_equal(got, exp) got <- wb_to_df(temp, colNames = FALSE)$A - expect_equal(exp, got) + expect_equal(got, exp) wb2 <- wb_load(temp) got <- wb_to_df(wb2, colNames = FALSE)$A - expect_equal(exp, got) + expect_equal(got, exp) }) diff --git a/tests/testthat/test-strings_xml.R b/tests/testthat/test-strings_xml.R index b5857129d..1becde22b 100644 --- a/tests/testthat/test-strings_xml.R +++ b/tests/testthat/test-strings_xml.R @@ -98,22 +98,22 @@ test_that("strings_xml", { exp <- "A & B" got <- wb_to_df(amp, colNames = FALSE)[1, 1] - expect_equal(exp, got) + expect_equal(got, exp) # a couple of saves and loads later ... exp <- "A & B" got <- wb$worksheets[[1]]$sheet_data$cc$is - expect_equal(exp, got) + expect_equal(got, exp) wb <- wb_load(amp) got <- wb$worksheets[[1]]$sheet_data$cc$is - expect_equal(exp, got) + expect_equal(got, exp) wb$save(amp) wb <- wb_load(amp) got <- wb$worksheets[[1]]$sheet_data$cc$is - expect_equal(exp, got) + expect_equal(got, exp) }) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index c54b665bf..e3c690a03 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -18,31 +18,31 @@ test_that("dims to col & row and back", { exp <- list(c("A", "B"), c("1", "2")) got <- dims_to_rowcol("A1:B2") - expect_equal(exp, got) + expect_equal(got, exp) exp <- list(1:2, 1:2) got <- dims_to_rowcol("A1:B2", as_integer = TRUE) - expect_equal(exp, got) + expect_equal(got, exp) exp <- list(1:2, c(1L)) got <- dims_to_rowcol("A:B", as_integer = TRUE) - expect_equal(exp, got) + expect_equal(got, exp) exp <- list("A", c("1")) got <- dims_to_rowcol("A:A", as_integer = FALSE) - expect_equal(exp, got) + expect_equal(got, exp) exp <- "A1:A1" got <- rowcol_to_dims(1, "A") - expect_equal(exp, got) + expect_equal(got, exp) exp <- "A1:A10" got <- rowcol_to_dims(1:10, 1) - expect_equal(exp, got) + expect_equal(got, exp) exp <- "E2:J8" got <- rowcol_to_dims(2:8, 5:10) - expect_equal(exp, got) + expect_equal(got, exp) }) @@ -53,7 +53,7 @@ test_that("create_char_dataframe", { got <- create_char_dataframe(colnames = c("x1", "z1"), n = 5) - expect_equal(exp, got) + expect_equal(got, exp) }) @@ -92,10 +92,10 @@ test_that("relship", { exp <- "" got <- relship_no(obj = wb$worksheets_rels[[3]], x = "table") - expect_equal(exp, got) + expect_equal(got, exp) exp <- "rId2" got <- get_relship_id(obj = wb$worksheets_rels[[1]], x = "drawing") - expect_equal(exp, got) + expect_equal(got, exp) }) diff --git a/tests/testthat/test-wb_functions.R b/tests/testthat/test-wb_functions.R index b77160159..af1250bb4 100644 --- a/tests/testthat/test-wb_functions.R +++ b/tests/testthat/test-wb_functions.R @@ -23,7 +23,7 @@ test_that("wb_to_df", { class = "data.frame" ) got <- wb_to_df(wb1) - expect_equal(exp, got, ignore_attr = TRUE) + expect_equal(got, exp, ignore_attr = TRUE) # do not convert first row to colNames got <- wb_to_df(wb1, colNames = FALSE) @@ -111,7 +111,7 @@ test_that("wb_to_df", { rownames(exp) <- seq(2, nrow(exp) + 1) # read dataset with inlinestr got <- wb_to_df(wb2) - expect_equal(exp, got, ignore_attr = TRUE) + expect_equal(got, exp, ignore_attr = TRUE) ########################################################################### @@ -122,12 +122,12 @@ test_that("wb_to_df", { # read dataset with named_region (returns global first) exp <- data.frame(A = "S2A1", B = "S2B1") got <- wb_to_df(wb3, named_region = "MyRange", colNames = FALSE) - expect_equal(exp, got, ignore_attr = TRUE) + expect_equal(got, exp, ignore_attr = TRUE) # read named_region from sheet exp <- data.frame(A = "S3A1", B = "S3B1") got <- wb_to_df(wb3, named_region = "MyRange", sheet = 4, colNames = FALSE) - expect_equal(exp, got, ignore_attr = TRUE) + expect_equal(got, exp, ignore_attr = TRUE) }) @@ -173,14 +173,14 @@ test_that("dims_to_dataframe", { class = "data.frame" ) got <- dims_to_dataframe("A1:A2;C1:C2", fill = TRUE) - expect_equal(exp, got) + expect_equal(got, exp) got <- dims_to_dataframe("A1;A2;C1;C2", fill = TRUE) - expect_equal(exp, got) + expect_equal(got, exp) exp <- list(c("A", "B"), "1") got <- dims_to_rowcol("A1;B1") - expect_equal(exp, got) + expect_equal(got, exp) }) @@ -195,31 +195,30 @@ test_that("dataframe_to_dims", { }) test_that("handle 29Feb1900", { - dates <- c("1900-02-28", "1900-03-01") as_date <- as.Date(dates) as_posix <- as.POSIXct(dates) exp <- c(59, 61) got <- conv_to_excel_date(as_date) - expect_equal(exp, got) + expect_equal(got, exp) got <- conv_to_excel_date(as_posix) - expect_equal(exp, got) + expect_equal(got, exp) expect_warning( conv_to_excel_date("x"), "could not convert x to Excel date. x is of class: character" ) - wb <- wb_workbook()$ - add_worksheet()$add_data(x = as_date)$ - add_worksheet()$add_data(x = as_posix) + wb <- wb_workbook() + wb$add_worksheet()$add_data(x = as_date) + wb$add_worksheet()$add_data(x = as_posix) got <- wb_to_df(wb, sheet = 1, colNames = FALSE)$A - expect_equal(as_date, got) + expect_equal(got, as_date) got <- wb_to_df(wb, sheet = 2, colNames = FALSE)$A - expect_equal(as_posix, got) - + expect_equal(got, as_posix) }) + diff --git a/tests/testthat/test-wb_styles.R b/tests/testthat/test-wb_styles.R index 369760dc6..74099e3f8 100644 --- a/tests/testthat/test-wb_styles.R +++ b/tests/testthat/test-wb_styles.R @@ -1,16 +1,16 @@ test_that("wb_clone_sheet_style", { - fl <- system.file("extdata", "oxlsx2_sheet.xlsx", package = "openxlsx2") - wb <- wb_load(fl)$clone_worksheet("SUM", "clone") - wb <- wb$clean_sheet(sheet = "clone", numbers = TRUE, characters = TRUE, styles = TRUE, merged_cells = FALSE) - wb <- wb_clone_sheet_style(wb, "SUM", "clone") + wb <- wb_load(fl) + wb$clone_worksheet("SUM", "clone") + wb$clean_sheet(sheet = "clone", numbers = TRUE, characters = TRUE, styles = TRUE, merged_cells = FALSE) + wb$clone_sheet_style("SUM", "clone") expect_warning(cloneSheetStyle(wb, "SUM", "clone"), "deprecated") # clone style to empty sheet (creates cells and style) fl <- system.file("extdata", "oxlsx2_sheet.xlsx", package = "openxlsx2") wb <- wb_load(fl)$add_worksheet("copy") - wb <- wb_clone_sheet_style(wb, "SUM", "copy") + wb$clone_sheet_style("SUM", "copy") expect_equal(dim(wb$worksheets[[1]]$sheet_data$cc), dim(wb$worksheets[[1]]$sheet_data$cc)) expect_equal(dim(wb$worksheets[[1]]$sheet_data$row_attr), @@ -18,15 +18,18 @@ test_that("wb_clone_sheet_style", { # clone style to sheet with data fl <- system.file("extdata", "oxlsx2_sheet.xlsx", package = "openxlsx2") - wb <- wb_load(fl)$add_worksheet("copy")$add_data(x = mtcars, startRow = 5, startCol = 2) - wb <- wb_clone_sheet_style(wb, "SUM", "copy") + wb <- wb_load(fl) + wb$add_worksheet("copy") + wb$add_data(x = mtcars, startRow = 5, startCol = 2) + wb$clone_sheet_style("SUM", "copy") expect_equal(c(36, 13), dim(wb$worksheets[[2]]$sheet_data$row_attr)) # clone style on cloned and cleaned worksheet fl <- system.file("extdata", "oxlsx2_sheet.xlsx", package = "openxlsx2") - wb <- wb_load(fl)$clone_worksheet("SUM", "clone") - wb <- wb$clean_sheet(sheet = "clone", numbers = TRUE, characters = TRUE, styles = TRUE, merged_cells = FALSE) - wb <- wb_clone_sheet_style(wb, "SUM", "clone") + wb <- wb_load(fl) + wb$clone_worksheet("SUM", "clone") + wb$clean_sheet(sheet = "clone", numbers = TRUE, characters = TRUE, styles = TRUE, merged_cells = FALSE) + wb$clone_sheet_style("SUM", "clone") # sort for this test, does not matter later, because we will sort prior to saving ord <- match( @@ -41,23 +44,23 @@ test_that("wb_clone_sheet_style", { # output if copying from empty sheet fl <- system.file("extdata", "oxlsx2_sheet.xlsx", package = "openxlsx2") - wb <- wb_load(fl)$add_worksheet("copy") + wb <- wb_load(fl) + wb$add_worksheet("copy") expect_message( expect_message( - wb <- wb_clone_sheet_style(wb, "copy", "SUM"), + wb$clone_sheet_style("copy", "SUM"), "'from' has no sheet data styles to clone" ), "'from' has no row styles to clone" ) - }) test_that("test add_border()", { - wb <- wb_workbook() - wb$add_worksheet("S1")$add_data("S1", mtcars) - expect_silent(wb$add_border(1, dims = "A1:K1", left_border = NULL, right_border = NULL, top_border = NULL, bottom_border = "double")) + wb$add_worksheet("S1") + wb$add_data("S1", mtcars) + expect_silent(wb$add_border(dims = "A1:K1", left_border = NULL, right_border = NULL, top_border = NULL, bottom_border = "double")) # check xf exp <- c("", @@ -67,7 +70,7 @@ test_that("test add_border()", { ) got <- wb$styles_mgr$styles$cellXfs - expect_equal(exp, got) + expect_equal(got, exp) # check borders exp <- c("", @@ -77,7 +80,7 @@ test_that("test add_border()", { ) got <- wb$styles_mgr$styles$borders - expect_equal(exp, got) + expect_equal(got, exp) wb <- wb_workbook() @@ -85,7 +88,7 @@ test_that("test add_border()", { exp <- c("1", "3", "3", "3", "3", "3", "3", "3", "3", "3", "2") got <- wb$worksheets[[1]]$sheet_data$cc$c_s - expect_equal(exp, got) + expect_equal(got, exp) }) @@ -101,7 +104,7 @@ test_that("test add_fill()", { ) got <- wb$styles_mgr$styles$cellXfs - expect_equal(exp, got) + expect_equal(got, exp) # check fill @@ -111,7 +114,7 @@ test_that("test add_fill()", { ) got <- wb$styles_mgr$styles$fills - expect_equal(exp, got) + expect_equal(got, exp) # every_nth_col/row wb <- wb_workbook() @@ -126,21 +129,21 @@ test_that("test add_fill()", { ) got <- wb$styles_mgr$styles$fills - expect_equal(exp, got) + expect_equal(got, exp) exp <- c("", "", "") got <- wb$styles_mgr$styles$cellXfs - expect_equal(exp, got) + expect_equal(got, exp) # check the actual styles exp <- c("", "1", "", "1", "", "2", "2", "2", "2", "2", "", "1", "", "1", "", "2", "2", "2", "2", "2", "", "1", "", "1", "", "2", "2", "2", "2", "2") got <- wb$worksheets[[1]]$sheet_data$cc$c_s - expect_equal(exp, got) + expect_equal(got, exp) wb <- wb_workbook() @@ -148,7 +151,7 @@ test_that("test add_fill()", { exp <- rep("1", 8) got <- wb$worksheets[[1]]$sheet_data$cc$c_s - expect_equal(exp, got) + expect_equal(got, exp) }) @@ -165,7 +168,7 @@ test_that("test add_font()", { ) got <- wb$styles_mgr$styles$cellXfs - expect_equal(exp, got) + expect_equal(got, exp) # check font @@ -175,20 +178,20 @@ test_that("test add_font()", { ) got <- wb$styles_mgr$styles$fonts - expect_equal(exp, got) + expect_equal(got, exp) # check the actual styles exp <- c("1", "1", "1", "1", "1", "1", "1", "1", "1", "1", "1", "", "", "", "", "", "", "", "", "") got <- head(wb$worksheets[[1]]$sheet_data$cc$c_s, 20) - expect_equal(exp, got) + expect_equal(got, exp) wb <- wb_workbook() wb$add_worksheet("S1")$add_font("S1", dims = "A1:K1", color = wb_colour(hex = "FFFFFF00")) exp <- rep("1", 11) got <- wb$worksheets[[1]]$sheet_data$cc$c_s - expect_equal(exp, got) + expect_equal(got, exp) }) @@ -206,20 +209,20 @@ test_that("test add_numfmt()", { ) got <- wb$styles_mgr$styles$cellXfs - expect_equal(exp, got) + expect_equal(got, exp) # check numfmt exp <- "" got <- wb$styles_mgr$styles$numFmts - expect_equal(exp, got) + expect_equal(got, exp) # check the actual styles exp <- c("1", "", "", "", "", "2", "", "", "", "", "", "1", "", "", "", "", "2", "", "", "") got <- head(wb$worksheets[[1]]$sheet_data$cc$c_s, 20) - expect_equal(exp, got) + expect_equal(got, exp) wb <- wb_workbook() @@ -227,7 +230,7 @@ test_that("test add_numfmt()", { exp <- rep("1", 33) got <- wb$worksheets[[1]]$sheet_data$cc$c_s - expect_equal(exp, got) + expect_equal(got, exp) }) @@ -245,13 +248,13 @@ test_that("test add_cell_style()", { ) got <- wb$styles_mgr$styles$cellXfs - expect_equal(exp, got) + expect_equal(got, exp) # check the actual styles exp <- c("1", "", "", "", "", "2", "", "", "", "", "", "1", "", "", "", "", "2", "", "", "") got <- head(wb$worksheets[[1]]$sheet_data$cc$c_s, 20) - expect_equal(exp, got) + expect_equal(got, exp) wb <- wb_workbook() @@ -259,7 +262,7 @@ test_that("test add_cell_style()", { exp <- rep("1", 33) got <- wb$worksheets[[1]]$sheet_data$cc$c_s - expect_equal(exp, got) + expect_equal(got, exp) ### exp <- "" @@ -284,45 +287,42 @@ test_that("test add_cell_style()", { hidden = "1", locked = "1" ) - expect_equal(exp, got) + expect_equal(got, exp) }) test_that("add_style", { - # without name num <- create_numfmt(numFmtId = "165", formatCode = "#.#") - wb <- wb_workbook() %>% wb_add_style(num) + wb <- wb_workbook() + wb$add_style(num) exp <- num got <- wb$styles_mgr$styles$numFmts - expect_equal(exp, got) + expect_equal(got, exp) exp <- structure(list(typ = "numFmt", id = "165", name = "num"), row.names = c(NA, -1L), class = "data.frame") got <- wb$styles_mgr$numfmt - expect_equal(exp, got) + expect_equal(got, exp) # with name wb <- wb_workbook() %>% wb_add_style(num, "num") exp <- num got <- wb$styles_mgr$styles$numFmts - expect_equal(exp, got) + expect_equal(got, exp) exp <- structure(list(typ = "numFmt", id = "165", name = "num"), row.names = c(NA, -1L), class = "data.frame") got <- wb$styles_mgr$numfmt - expect_equal(exp, got) - + expect_equal(got, exp) }) test_that("assigning styles to loaded workbook works", { - wb <- wb_load(file = system.file("extdata", "oxlsx2_sheet.xlsx", package = "openxlsx2")) - # previously it would break on xml_import, because NA was returned expect_silent(wb$add_font()$add_font()) @@ -331,8 +331,9 @@ test_that("assigning styles to loaded workbook works", { test_that("get & set cell style(s)", { # set a style in b1 - wb <- wb_workbook()$add_worksheet()$ - add_numfmt(dims = "B1", numfmt = "#,0") + wb <- wb_workbook() + wb$add_worksheet() + wb$add_numfmt(dims = "B1", numfmt = "#,0") # get style from b1 to assign it to a1 numfmt <- wb$get_cell_style(dims = "B1") @@ -374,19 +375,19 @@ test_that("get_cell_styles()", { exp <- "1" got <- wb$get_cell_style(dims = "B2") - expect_equal(exp, got) + expect_equal(got, exp) exp <- "" got <- get_cell_styles(wb, 1, "B2") - expect_equal(exp, got) + expect_equal(got, exp) exp <- "3" got <- wb$get_cell_style(dims = "B3") - expect_equal(exp, got) + expect_equal(got, exp) exp <- "" got <- get_cell_styles(wb, 1, "B3") - expect_equal(exp, got) + expect_equal(got, exp) wb$add_cell_style(dims = "B3:L3", textRotation = "45", @@ -396,25 +397,23 @@ test_that("get_cell_styles()", { exp <- "" got <- get_cell_styles(wb, 1, "B3") - expect_equal(exp, got) + expect_equal(got, exp) }) test_that("applyCellStyle works", { - - wb <- wb_workbook()$ - add_worksheet()$ - add_fill(dims = "B2:G8", color = wb_colour("yellow"))$ - add_data(dims = "C3", x = Sys.Date())$ - add_data(dims = "E3", x = Sys.Date(), applyCellStyle = FALSE)$ - add_data(dims = "E5", x = Sys.Date(), removeCellStyle = TRUE)$ - add_data(dims = "A1", x = Sys.Date()) + wb <- wb_workbook() + wb$add_worksheet() + wb$add_fill(dims = "B2:G8", color = wb_colour("yellow")) + wb$add_data(dims = "C3", x = Sys.Date()) + wb$add_data(dims = "E3", x = Sys.Date(), applyCellStyle = FALSE) + wb$add_data(dims = "E5", x = Sys.Date(), removeCellStyle = TRUE) + wb$add_data(dims = "A1", x = Sys.Date()) cc <- wb$worksheets[[1]]$sheet_data$cc exp <- c("3", "2", "1", "3") got <- cc[cc$r %in% c("A1", "C3", "E3", "E5"), "c_s"] - expect_equal(exp, got) - + expect_equal(got, exp) }) test_that("style names are xml", { @@ -468,7 +467,7 @@ test_that("style names are xml", { extLst = NULL ) got <- wb$styles_mgr$styles - expect_equal(exp, got) + expect_equal(got, exp) }) diff --git a/tests/testthat/test-write.R b/tests/testthat/test-write.R index db9947a6e..cf335726f 100644 --- a/tests/testthat/test-write.R +++ b/tests/testthat/test-write.R @@ -1,5 +1,4 @@ test_that("write_formula", { - set.seed(123) df <- data.frame(C = rnorm(10), D = rnorm(10)) @@ -16,43 +15,41 @@ test_that("write_formula", { # write data add array formula later wb <- wb_workbook() - wb <- wb_add_worksheet(wb, "df") + wb$add_worksheet("df") wb$add_data("df", df, startCol = "C") - write_formula(wb, "df", startCol = "E", startRow = "2", - x = "SUM(C2:C11*D2:D11)", - array = TRUE) + wb$add_formula("df", startCol = "E", startRow = "2", + x = "SUM(C2:C11*D2:D11)", + array = TRUE) cc <- wb$worksheets[[1]]$sheet_data$cc got <- cc[cc$row_r == "2" & cc$c_r == "E", ] expect_equal(exp[1:16], got[1:16]) - rownames(exp) <- 1L # write formula first add data later wb <- wb_workbook() - wb <- wb_add_worksheet(wb, "df") - write_formula(wb, "df", startCol = "E", startRow = "2", - x = "SUM(C2:C11*D2:D11)", - array = TRUE) + wb$add_worksheet("df") + wb$add_formula("df", startCol = "E", startRow = "2", + x = "SUM(C2:C11*D2:D11)", + array = TRUE) wb$add_data("df", df, startCol = "C") cc <- wb$worksheets[[1]]$sheet_data$cc got <- cc[cc$row_r == "2" & cc$c_r == "E", ] expect_equal(exp[1:11], got[1:11]) - }) test_that("silent with numfmt option", { - wb <- wb_workbook() wb$add_worksheet("S1") wb$add_worksheet("S2") wb$add_data_table("S1", x = iris) expect_warning( - wb$add_data_table("S2", - x = mtcars, xy = c("B", 3), rowNames = TRUE, - tableStyle = "TableStyleLight9") + wb$add_data_table( + "S2", x = mtcars, xy = c("B", 3), rowNames = TRUE, + tableStyle = "TableStyleLight9" + ) ) # [1:4] to ignore factor @@ -65,7 +62,6 @@ test_that("silent with numfmt option", { attr(got, "types") <- NULL expect_equal(mtcars, got) expect_equal(rownames(mtcars), rownames(got)) - }) test_that("test options", { @@ -77,7 +73,6 @@ test_that("test options", { # adding data to the worksheet should not alter the global options expect_equal(ops, ops2) - }) test_that("missing x is caught early [246]", { @@ -88,10 +83,11 @@ test_that("missing x is caught early [246]", { }) test_that("update_cells", { - ## exactly the same data <- mtcars - wb <- wb_workbook()$add_worksheet()$add_data(x = data) + wb <- wb_workbook() + wb$add_worksheet() + wb$add_data(x = data) cc1 <- wb$worksheets[[1]]$sheet_data$cc wb$add_data(x = data) @@ -101,57 +97,58 @@ test_that("update_cells", { ## write na.strings data <- matrix(NA, 2, 2) - wb <- wb_workbook()$add_worksheet()$add_data(x = data)$add_data(x = data, na.strings = "N/A") + wb <- wb_workbook() + wb$add_worksheet() + wb$add_data(x = data) + wb$add_data(x = data, na.strings = "N/A") exp <- c("V1", "V2", "N/A") got <- unique(wb$worksheets[[1]]$sheet_data$cc$is) - expect_equal(exp, got) + expect_equal(got, exp) ### write logical xlsxFile <- system.file("extdata", "readTest.xlsx", package = "openxlsx2") wb1 <- wb_load(xlsxFile) data <- head(wb_to_df(wb1, sheet = 3)) - wb <- wb_workbook()$add_worksheet()$add_data(x = data)$add_data(x = data) + wb <- wb_workbook() + wb$add_worksheet() + wb$add_data(x = data) exp <- c("inlineStr", "", "b", "e") got <- unique(wb$worksheets[[1]]$sheet_data$cc$c_t) - expect_equal(exp, got) - + expect_equal(got, exp) set.seed(123) df <- data.frame(C = rnorm(10), D = rnorm(10)) - wb <- wb_workbook()$ - add_worksheet("df")$ - add_data(x = df, startCol = "C") + wb <- wb_workbook() + wb$add_worksheet("df") + wb$add_data(x = df, startCol = "C") # TODO add_formula() - write_formula(wb, "df", startCol = "E", startRow = "2", - x = "SUM(C2:C11*D2:D11)", - array = TRUE) - write_formula(wb, "df", x = "C3 + D3", startCol = "E", startRow = 3) + wb$add_formula("df", startCol = "E", startRow = "2", + x = "SUM(C2:C11*D2:D11)", + array = TRUE) + wb$add_formula("df", x = "C3 + D3", startCol = "E", startRow = 3) x <- c(google = "https://www.google.com") class(x) <- "hyperlink" wb$add_data(sheet = "df", x = x, startCol = "E", startRow = 4) - exp <- structure( list(c_t = c("", "str", "str"), f = c("SUM(C2:C11*D2:D11)", "C3 + D3", "=HYPERLINK(\"https://www.google.com\")"), f_t = c("array", "", "")), row.names = c("23", "110", "111"), class = "data.frame") got <- wb$worksheets[[1]]$sheet_data$cc[c(5, 8, 11), c("c_t", "f", "f_t")] - expect_equal(exp, got) - + expect_equal(got, exp) }) test_that("write dims", { - # create a workbook - wb <- wb_workbook()$ - add_worksheet()$add_data(dims = "B2:C3", x = matrix(1:4, 2, 2), colNames = FALSE)$ - add_worksheet()$add_data_table(dims = "B:C", x = as.data.frame(matrix(1:4, 2, 2)))$ - add_worksheet()$add_formula(dims = "B3", x = "42") + wb <- wb_workbook() + wb$add_worksheet()$add_data(dims = "B2:C3", x = matrix(1:4, 2, 2), colNames = FALSE) + wb$add_worksheet()$add_data_table(dims = "B:C", x = as.data.frame(matrix(1:4, 2, 2))) + wb$add_worksheet()$add_formula(dims = "B3", x = "42") s1 <- wb_to_df(wb, 1, colNames = FALSE) s2 <- wb_to_df(wb, 2, colNames = FALSE) @@ -164,11 +161,9 @@ test_that("write dims", { expect_equal(colnames(s1), c("B", "C")) expect_equal(colnames(s2), c("B", "C")) expect_equal(colnames(s3), c("B")) - }) test_that("write data.table class", { - df <- mtcars class(df) <- c("data.table", "data.frame") @@ -179,29 +174,19 @@ test_that("write data.table class", { }) test_that("update cell(s)", { - xlsxFile <- system.file("extdata", "update_test.xlsx", package = "openxlsx2") wb <- wb_load(xlsxFile) # update Cells D4:D6 with 1:3 - wb <- wb_add_data(x = c(1:3), - wb = wb, sheet = "Sheet1", dims = "D4:D6") - + wb$add_data(x = c(1:3), sheet = "Sheet1", dims = "D4:D6") # update Cells B3:D3 (names()) - wb <- wb_add_data(x = c("x", "y", "z"), - wb = wb, sheet = "Sheet1", dims = "B3:D3") - + wb$add_data(x = c("x", "y", "z"), sheet = "Sheet1", dims = "B3:D3") # update D4 again (single value this time) - wb <- wb_add_data(x = 7, - wb = wb, sheet = "Sheet1", dims = "D4") - + wb$add_data(x = 7, sheet = "Sheet1", dims = "D4") # add new column on the left of the existing workbook - wb <- wb_add_data(x = 7, - wb = wb, sheet = "Sheet1", dims = "A4") - + wb$add_data(x = 7, sheet = "Sheet1", dims = "A4") # add new row on the end of the existing workbook - wb <- wb_add_data(x = 7, - wb = wb, sheet = "Sheet1", dims = "A9") + wb$add_data(x = 7, sheet = "Sheet1", dims = "A9") exp <- structure( list(c(7, NA, NA, NA, NA, 7), @@ -213,14 +198,14 @@ test_that("update cell(s)", { class = "data.frame") got <- wb_to_df(wb) - expect_equal(exp, got, ignore_attr = TRUE) + expect_equal(got, exp, ignore_attr = TRUE) #### - wb <- wb_workbook()$ - add_worksheet()$ - add_fill(dims = "B2:G8", color = wb_colour("yellow"))$ - add_data(dims = "C3", x = Sys.Date())$ - add_data(dims = "E4", x = Sys.Date(), removeCellStyle = TRUE) + wb <- wb_workbook() + wb$add_worksheet() + wb$add_fill(dims = "B2:G8", color = wb_colour("yellow")) + wb$add_data(dims = "C3", x = Sys.Date()) + wb$add_data(dims = "E4", x = Sys.Date(), removeCellStyle = TRUE) exp <- structure(list(r = c("B2", "C2", "D2", "E2", "F2", "G2"), row_r = c("2", "2", "2", "2", "2", "2"), c_r = c("B", "C", "D", "E", "F", "G"), @@ -240,14 +225,13 @@ test_that("update cell(s)", { row.names = c("1", "8", "17", "114", "121", "128"), class = "data.frame") got <- head(wb$worksheets[[1]]$sheet_data$cc) - expect_equal(exp, got) - + expect_equal(got, exp) }) test_that("write_rownames", { - wb <- wb_workbook()$ - add_worksheet()$add_data(x = mtcars, rowNames = TRUE)$ - add_worksheet()$add_data_table(x = mtcars, rowNames = TRUE) + wb <- wb_workbook() + wb$add_worksheet()$add_data(x = mtcars, rowNames = TRUE) + wb$add_worksheet()$add_data_table(x = mtcars, rowNames = TRUE) exp <- structure( list(A = c(NA, "Mazda RX4"), B = c("mpg", "21")), @@ -260,7 +244,7 @@ test_that("write_rownames", { types = c(A = 0, B = 0) ) got <- wb_to_df(wb, 1, dims = "A1:B2", colNames = FALSE) - expect_equal(exp, got) + expect_equal(got, exp) exp <- structure( list(A = c("_rowNames_", "Mazda RX4"), B = c("mpg", "21")), @@ -273,27 +257,16 @@ test_that("write_rownames", { types = c(A = 0, B = 0) ) got <- wb_to_df(wb, 2, dims = "A1:B2", colNames = FALSE) - expect_equal(exp, got) - + expect_equal(got, exp) }) test_that("NA works as expected", { - - wb <- wb_workbook()$ - add_worksheet("Sheet1")$ - add_data( - dims = "A1", - x = NA, - na.strings = NULL - )$ - add_data( - dims = "A2", - x = NA_character_, - na.strings = NULL - ) + wb <- wb_workbook() + wb$add_worksheet("Sheet1") + wb$add_data(dims = "A1", x = NA, na.strings = NULL) + wb$add_data(dims = "A2", x = NA_character_, na.strings = NULL) exp <- c(NA_real_, NA_real_) got <- wb_to_df(wb, colNames = FALSE)$A - expect_equal(exp, got) - + expect_equal(got, exp) }) diff --git a/tests/testthat/test-writing_posixct.R b/tests/testthat/test-writing_posixct.R index f3cc9d3d2..0fc12bf06 100644 --- a/tests/testthat/test-writing_posixct.R +++ b/tests/testthat/test-writing_posixct.R @@ -56,20 +56,20 @@ test_that("Writing mixed EDT/EST Posixct with write_data & write_datatable", { # compare sheet 1 exp <- df$timeval got <- wb_s1$timeval - expect_equal(exp, got, tolerance = 10 ^ -10, ignore_attr = "tzone") + expect_equal(got, exp, tolerance = 10 ^ -10, ignore_attr = "tzone") exp <- df$timetxt got <- wb_s1$timetxt - expect_equal(exp, got) + expect_equal(got, exp) # compare sheet 2 exp <- df$timeval got <- wb_s2$timeval - expect_equal(exp, got, tolerance = 10 ^ -10, ignore_attr = "tzone") + expect_equal(got, exp, tolerance = 10 ^ -10, ignore_attr = "tzone") exp <- df$timetxt got <- wb_s2$timetxt - expect_equal(exp, got) + expect_equal(got, exp) options("openxlsx2.datetimeFormat" = "yyyy-mm-dd hh:mm:ss") })