Extend setRowHeights to accept parameter(s) "auto"

NAMESPACE

@@ -12,6 +12,7 @@ export("worksheetOrder<-")
 export(addFilter)
 export(addStyle)
 export(addWorksheet)
+export(auto_heights)
 export(conditionalFormat)
 export(conditionalFormatting)
 export(convertFromExcelRef)
@@ -31,6 +32,7 @@ export(getNamedRegions)
 export(getSheetNames)
 export(getStyles)
 export(getTables)
+export(get_worksheet_entries)
 export(insertImage)
 export(insertPlot)
 export(int2col)

R/helperFunctions.R

@@ -1,7 +1,4 @@
 
-
-
-
 #' @name makeHyperlinkString
 #' @title create Excel hyperlink string
 #' @description Wrapper to create internal hyperlink string to pass to writeFormula()
@@ -86,7 +83,6 @@ getId <- function(x){
 }
 
 
-
 ## creates style object based on column classes
 ## Used in writeData for styling when no borders and writeData table for all column-class based styling
 classStyles <- function(wb, sheet, startRow, startCol, colNames, nRow, colClasses, stack = TRUE){
@@ -243,18 +239,6 @@ classStyles <- function(wb, sheet, startRow, startCol, colNames, nRow, colClasse
 }
 
 
-
-
-
-
-
-
-
-
-
-
-
-
 validateColour <- function(colour, errorMsg = "Invalid colour!"){
 
   ## check if
@@ -275,6 +259,7 @@ validateColour <- function(colour, errorMsg = "Invalid colour!"){
 
 }
 
+
 ## color helper function: eg col2hex(colors())
 col2hex <- function(my.col) {
   rgb(t(col2rgb(my.col)), maxColorValue = 255)
@@ -327,7 +312,6 @@ writeCommentXML <- function(comment_list, file_name){
 }
 
 
-
 replaceIllegalCharacters <- function(v){
 
   vEnc <- Encoding(v)
@@ -383,7 +367,6 @@ removeHeadTag <- function(x){
 }
 
 
-
 validateBorderStyle <- function(borderStyle){
 
 
@@ -399,9 +382,6 @@ validateBorderStyle <- function(borderStyle){
 }
 
 
-
-
-
 getAttrsFont <- function(xml, tag){
 
 
@@ -419,6 +399,7 @@ getAttrsFont <- function(xml, tag){
 
 }
 
+
 getAttrs <- function(xml, tag){
 
   x <- lapply(xml, getChildlessNode, tag = tag)
@@ -505,7 +486,6 @@ buildFontList <- function(fonts){
 }
 
 
-
 get_named_regions_from_string <- function(dn){
 
   dn <- gsub("</definedNames>", "", dn, fixed = TRUE)
@@ -530,7 +510,6 @@ get_named_regions_from_string <- function(dn){
 }
 
 
-
 nodeAttributes <- function(x){
 
 
@@ -654,8 +633,6 @@ buildBorder <- function(x){
 }
 
 
-
-
 genHeaderFooterNode <- function(x){
 
   # <headerFooter differentOddEven="1" differentFirst="1" scaleWithDoc="0" alignWithMargins="0">
@@ -775,7 +752,6 @@ clean_names <- function(x){
 }
 
 
-
 mergeCell2mapping <- function(x){
 
   refs <- regmatches(x, regexpr("(?<=ref=\")[A-Z0-9:]+", x, perl = TRUE))
@@ -805,8 +781,6 @@ mergeCell2mapping <- function(x){
 }
 
 
-
-
 splitHeaderFooter <- function(x){
 
   tmp <- gsub("<(/|)(odd|even|first)(Header|Footer)>(&amp;|)", "", x, perl = TRUE)
@@ -842,8 +816,6 @@ splitHeaderFooter <- function(x){
 }
 
 
-
-
 getFile <- function(xlsxFile){
 
   ## Is this a file or URL (code taken from read.table())
@@ -861,6 +833,122 @@ getFile <- function(xlsxFile){
 
 }
 
+
+#' @name get_worksheet_entries
+#' @title Get entries from workbook worksheet
+#' @description Get all entries from workbook worksheet without xml tags
+#' @param wb workbook
+#' @param sheet worksheet
+#' @author David Breuer
+#' @return vector of strings
+#' @export
+#' @examples
+#' ## Create new workbook
+#' wb <- createWorkbook()
+#' addWorksheet(wb, "Sheet")
+#' sheet <- 1
+#'
+#' ## Write dummy data
+#' writeData(wb, sheet, c("A", "BB", "CCC"), startCol = 2, startRow = 3)
+#' writeData(wb, sheet, c(4, 5), startCol = 4, startRow = 3)
+#'
+#' ## Get text entries
+#' get_worksheet_text(wb, sheet)
+#'
+get_worksheet_entries <- function(wb, sheet) {
+  # get worksheet data
+  dat <- wb$worksheets[[sheet]]$sheet_data
+  # get vector of entries
+  val <- dat$v
+  # get boolean vector of text entries
+  typ <- (dat$t == 1) & !is.na(dat$t)
+  # get text entry strings
+  str <- unlist(wb$sharedStrings[as.integer(val)[typ] + 1])
+  # remove xml tags
+  str <- gsub("<.*?>", "", str)
+  # write strings to vector of entries
+  val[typ] <- str
+  # return vector of entries
+  val
+}
+
+
+#' @name auto_heights
+#' @title Compute optimal row heights
+#' @description Compute optimal row heights for cell with fixed with and
+#' enabled automatic row heights parameter
+#' @param wb workbook
+#' @param sheet worksheet
+#' @param selected selected rows
+#' @param fontsize font size, optional (get base font size by default)
+#' @param factor factor to manually adjust font width, e.g., for bold fonts,
+#' optional
+#' @param base_height basic row height, optional
+#' @param extra_height additional row height per new line of text, optional
+#' @author David Breuer
+#' @return list of indices of columns with fixed widths and optimal row heights
+#' @export
+#' @examples
+#' ## Create new workbook
+#' wb <- createWorkbook()
+#' addWorksheet(wb, "Sheet")
+#' sheet <- 1
+#'
+#' ## Write dummy data
+#' long_string <- "ABC ABC ABC ABC ABC ABC ABC ABC ABC ABC ABC"
+#' writeData(wb, sheet, c("A", long_string, "CCC"), startCol = 2, startRow = 3)
+#' writeData(wb, sheet, c(4, 5), startCol = 4, startRow = 3)
+#'
+#' ## Set column widths and get optimal row heights
+#' setColWidths(wb, sheet, c(1,2,3,4), c(10,20,10,20))
+#' auto_heights(wb, sheet, 1:5)
+#'
+auto_heights <- function(wb, sheet, selected, fontsize = NULL, factor = 1.0,
+                         base_height = 15, extra_height = 12) {
+  # get base font size
+  if (is.null(fontsize)) {
+    fontsize <- as.integer(openxlsx::getBaseFont(wb)$size$val)
+  }
+  # set factor to adjust font width (empiricially found scale factor 4 here)
+  factor <- 4 * factor / fontsize
+  # get worksheet data
+  dat <- wb$worksheets[[sheet]]$sheet_data
+  # get columns widths
+  colWidths <- wb$colWidths[[sheet]]
+  # select fixed (non-auto) and visible (non-hidden) columns only
+  specified <- (colWidths != "auto") & (attr(colWidths, "hidden") == "0")
+  # return default row heights if no column widths are fixed
+  if (length(specified) == 0) {
+    message("No column widths specified, returning default row heights.")
+    cols <- integer(0)
+    heights <- rep(base_height, length(selected))
+    return(list(cols, heights))
+  }
+  # get fixed column indices
+  cols <- as.integer(names(specified)[specified])
+  # get fixed column widths
+  widths <- as.numeric(colWidths[specified])
+  # get all worksheet entries
+  val <- get_worksheet_entries(wb, sheet)
+  # compute optimal height per selected row
+  heights <- sapply(selected, function(row) {
+    # select entries in given row and columns of fixed widths
+    index <- (dat$rows == row) & (dat$cols %in% cols)
+    # remove line break characters
+    chr <- gsub("\\r|\\n", "", val[index])
+    # measure width of entry (in pixels)
+    wdt <- strwidth(chr, unit = "in") * 20 / 1.43 # 20 px = 1.43 in
+    # compute optimal height
+    if (length(wdt) == 0) {
+      base_height
+    } else {
+      base_height + extra_height * as.integer(max(wdt / widths * factor))
+    }
+  })
+  # return list of indices of columns with fixed widths and optimal row heights
+  list(cols, heights)
+}
+
 # Rotate the 15-bit integer by n bits to the 
 hashPassword <- function(password) {
   # password limited to 15 characters