R/helper-functions.R

In openxlsx2: Read, Write and Edit 'xlsx' Files

# `create_hyperlink()` ---------------------------------------------------------
#' Create Excel hyperlink string
#'
#' @description
#' Wrapper to create internal hyperlink string to pass to [wb_add_formula()].
#' Either link to external URLs or local files or straight to cells of local Excel sheets.
#'
#' Note that for an external URL, only `file` and `text` should be supplied.
#' You can supply `dims` to `wb_add_formula()` to control the location of the link.
#' @param sheet Name of a worksheet
#' @param row integer row number for hyperlink to link to
#' @param col column number of letter for hyperlink to link to
#' @param text Display text
#' @param file Hyperlink or Excel file name to point to. If `NULL`, hyperlink is internal.
#' @examples
#' wb <- wb_workbook()$
#'   add_worksheet("Sheet1")$add_worksheet("Sheet2")$add_worksheet("Sheet3")
#'
#' ## Internal Hyperlink - create hyperlink formula manually
#' x <- '=HYPERLINK(\"#Sheet2!B3\", "Text to Display - Link to Sheet2")'
#' wb$add_formula(sheet = "Sheet1", x = x, dims = "A1")
#'
#' ## Internal - No text to display using create_hyperlink() function
#' x <- create_hyperlink(sheet = "Sheet3", row = 1, col = 2)
#' wb$add_formula(sheet = "Sheet1", x = x, dims = "A2")
#'
#' ## Internal - Text to display
#' x <- create_hyperlink(sheet = "Sheet3", row = 1, col = 2,text = "Link to Sheet 3")
#' wb$add_formula(sheet = "Sheet1", x = x, dims = "A3")
#'
#' ## Link to file - No text to display
#' fl <- system.file("extdata", "openxlsx2_example.xlsx", package = "openxlsx2")
#' x <- create_hyperlink(sheet = "Sheet1", row = 3, col = 10, file = fl)
#' wb$add_formula(sheet = "Sheet1", x = x, dims = "A4")
#'
#' ## Link to file - Text to display
#' fl <- system.file("extdata", "openxlsx2_example.xlsx", package = "openxlsx2")
#' x <- create_hyperlink(sheet = "Sheet2", row = 3, col = 10, file = fl, text = "Link to File.")
#' wb$add_formula(sheet = "Sheet1", x = x, dims = "A5")
#'
#' ## Link to external file - Text to display
#' x <- '=HYPERLINK("[C:/Users]", "Link to an external file")'
#' wb$add_formula(sheet = "Sheet1", x = x, dims = "A6")
#'
#' x <- create_hyperlink(text = "test.png", file = "D:/somepath/somepicture.png")
#' wb$add_formula(x = x, dims = "A7")
#'
#'
#' ## Link to an URL.
#' x <- create_hyperlink(text = "openxlsx2 website", file = "https://janmarvin.github.io/openxlsx2/")
#'
#' wb$add_formula(x = x, dims = "A8")
#' # if (interactive()) wb$open()
#'
#' @seealso [wb_add_hyperlink()]
#' @export
create_hyperlink <- function(sheet, row = 1, col = 1, text = NULL, file = NULL) {
  if (missing(sheet)) {
    if (!missing(row) || !missing(col)) warning("Option for col and/or row found, but no sheet was provided.")

    if (is.null(text))
      str <- sprintf("=HYPERLINK(\"%s\")", file)

    if (is.null(file))
      str <- sprintf("=HYPERLINK(\"%s\")", text)

    if (!is.null(text) && !is.null(file))
      str <- sprintf("=HYPERLINK(\"%s\", \"%s\")", file, text)
  } else {
    cell <- paste0(int2col(col), row)
    if (!is.null(file)) {
      dest <- sprintf('"[%s]%s!%s"', file, sheet, cell)
    } else {
      dest <- sprintf('"#\'%s\'!%s"', sheet, cell)
    }

    if (is.null(text)) {
      str <- sprintf("=HYPERLINK(%s)", dest)
    } else {
      str <- sprintf('=HYPERLINK(%s, \"%s\")', dest, text)
    }
  }

  return(str)
}

# `col2hex()` -----------------------------------------------------------------
#' Convert rgb to hex
#'
#' @param my.col my.col
#' @noRd
col2hex <- function(my.col) {
  grDevices::rgb(t(grDevices::col2rgb(my.col)), maxColorValue = 255)
}

# validate color --------------------------------------------------------------
#' Validate and convert color. Returns ARGB string
#' @param color input string (something like color(), "00000", "#000000", "00000000" or "#00000000")
#' @param or_null logical for use in assert
#' @param envir parent frame for use in assert
#' @param msg return message
#' @noRd
validate_color <- function(color = NULL, or_null = FALSE, envir = parent.frame(), msg = NULL) {
  sx <- as.character(substitute(color, envir))

  if (identical(color, "none") && or_null) {
    return(NULL)
  }

  # returns black
  if (is.null(color)) {
    if (or_null) return(NULL)
    return("FF000000")
  }

  if (any(ind <- color %in% grDevices::colors())) {
    color[ind] <- col2hex(color[ind])
  }

  # remove any # from color strings
  color <- gsub("^#", "", toupper(color))

  ## create a total size of 8 in ARGB format
  color <- stringi::stri_pad_left(str = color, width = 8, pad = "F")

  if (!all(grepl("[A-F0-9]{8}$", color))) {
    if (is.null(msg)) msg <- sprintf("`%s` ['%s'] is not a valid color", sx, color)
    stop(simpleError(msg))
  }

  color
}

## header and footer replacements ----------------------------------------------
headerFooterSub <- function(x) {
  if (!is.null(x)) {
    x <- replace_legal_chars(x)
    x <- gsub("\\[Page\\]", "P", x)
    x <- gsub("\\[Pages\\]", "N", x)
    x <- gsub("\\[Date\\]", "D", x)
    x <- gsub("\\[Time\\]", "T", x)
    x <- gsub("\\[Path\\]", "Z", x)
    x <- gsub("\\[File\\]", "F", x)
    x <- gsub("\\[Tab\\]", "A", x)
  }

  x
}


write_comment_xml <- function(comment_list, file_name) {
  authors <- unique(sapply(comment_list, "[[", "author"))
  xml <- '<comments xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main" xmlns:mc="http://schemas.openxmlformats.org/markup-compatibility/2006" mc:Ignorable="xr" xmlns:xr="http://schemas.microsoft.com/office/spreadsheetml/2014/revision" xmlns:xdr="http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing">'
  xml <- c(xml, paste0("<authors>", paste(sprintf("<author>%s</author>", authors), collapse = ""), "</authors><commentList>"))

  for (i in seq_along(comment_list)) {
    authorInd <- which(authors == comment_list[[i]]$author) - 1L
    xml <- c(xml, sprintf('<comment ref="%s" authorId="%s" shapeId="0"><text>', comment_list[[i]]$ref, authorInd))

    ## Comment can have optional authors. Style and text is mandatory
    for (j in seq_along(comment_list[[i]]$comment)) {

      # write styles and comments
      if (is_xml(comment_list[[i]]$comment[[j]])) {
        comment <- comment_list[[i]]$comment[[j]]
      } else {
        comment <- sprintf('<t xml:space="preserve">%s</t>', comment_list[[i]]$comment[[j]])
      }

      # either a <r> node or <t> from unstyled comment
      is_fmt_txt <- FALSE
      if (is_xml(comment))
        is_fmt_txt <- all(xml_node_name(comment) == "r") || isFALSE(comment_list[[i]]$style[[j]])

      if (is_fmt_txt) {
        xml <- c(xml, comment)
      } else {
        xml <- c(xml, sprintf('<r>%s%s</r>',
                              comment_list[[i]]$style[[j]],
                              comment))
      }
    }

    xml <- c(xml, "</text></comment>")
  }

  write_file(body = paste(xml, collapse = ""), tail = "</commentList></comments>", fl = file_name)

  NULL
}

pxml <- function(x) {
  ## TODO does this break anything? Why is unique called? lengths are off, if non unique values are found.
  # paste(unique(unlist(x)), collapse = "")
  paste(unlist(x), collapse = "")
}

# `amp_split()` ----------------------------------------------------------------
#' split headerFooter xml into left, center, and right.
#' @param x xml string
#' @noRd
amp_split <- function(x) {
  if (length(x) == 0) return(NULL)
  # create output string of width 3
  res <- vector("character", 3)
  # Identify the names found in the string: returns them as matrix: strip the &amp;
  nam <- gsub(pattern = "&amp;", "", unlist(stri_match_all_regex(x, "&amp;[LCR]")))
  # split the string and assign names to join
  z <- unlist(stri_split_regex(x, "&amp;[LCR]", omit_empty = TRUE))

  if (length(z) == 0) return(character(0))

  names(z) <- as.character(nam)
  res[c("L", "C", "R") %in% names(z)] <- z

  # return the string vector
  unname(res)
}

# Header footer ---------------------------------------------------------------
#' get headerFooter from xml into list with left, center, and right.
#' @param x xml string
#' @noRd
getHeaderFooterNode <- function(x) {

  head_foot <- c("oddHeader", "oddFooter",
                 "evenHeader", "evenFooter",
                 "firstHeader", "firstFooter")

  headerFooter <- vector("list", length = length(head_foot))
  names(headerFooter) <- head_foot

  for (hf in head_foot) {
    headerFooter[[hf]] <- amp_split(xml_value(x, "headerFooter", hf))
  }

  headerFooter
}

#' generate headerFooter xml from left, center, and right characters
#' @param x xml string
#' @param scale_with_doc scale with doc
#' @param align_with_margins align with margins
#' @noRd
genHeaderFooterNode <- function(x, scale_with_doc = FALSE, align_with_margins = FALSE) {

  # <headerFooter differentOddEven="1" differentFirst="1" scaleWithDoc="0" alignWithMargins="0">
  #   <oddHeader>&amp;Lfirst L&amp;CfC&amp;RfR</oddHeader>
  #   <oddFooter>&amp;LfFootL&amp;CfFootC&amp;RfFootR</oddFooter>
  #   <evenHeader>&amp;LTIS&amp;CIS&amp;REVEN H</evenHeader>
  #   <evenFooter>&amp;LEVEN L F&amp;CEVEN C F&amp;REVEN RIGHT F</evenFooter>
  #   <firstHeader>&amp;L&amp;P&amp;Cfirst C&amp;Rfirst R</firstHeader>
  #   <firstFooter>&amp;Lfirst L Foot&amp;Cfirst C Foot&amp;Rfirst R Foot</firstFooter>
  #   </headerFooter>

  ## ODD

  # TODO clean up length(x)
  # TODO clean up to x <- if (cond) value; default here is NULL

  # return nothing if there is no length
  if (!length(x)) return(NULL)

  lcr <- function(x) {
    list(
      left   = ifelse(x[[1]] == "", "", sprintf("&amp;L%s", x[[1]])),
      center = ifelse(x[[2]] == "", "", sprintf("&amp;C%s", x[[2]])),
      right  = ifelse(x[[3]] == "", "", sprintf("&amp;R%s", x[[3]]))
    )
  }

  if (length(x$oddHeader)) {
    odd_header <- lcr(x$oddHeader)
    oddHeader <- paste0("<oddHeader>", odd_header[["left"]], odd_header[["center"]], odd_header[["right"]], "</oddHeader>", collapse = "")
  } else {
    oddHeader <- NULL
  }

  if (length(x$oddFooter)) {
    odd_footer <- lcr(x$oddFooter)
    oddFooter <- paste0("<oddFooter>", odd_footer[["left"]], odd_footer[["center"]], odd_footer[["right"]], "</oddFooter>", collapse = "")
  } else {
    oddFooter <- NULL
  }

  ## EVEN
  if (length(x$evenHeader)) {
    even_header <- lcr(x$evenHeader)
    evenHeader <- paste0("<evenHeader>", even_header[["left"]], even_header[["center"]], even_header[["right"]], "</evenHeader>", collapse = "")
  } else {
    evenHeader <- NULL
  }

  if (length(x$evenFooter)) {
    even_footer <- lcr(x$evenFooter)
    evenFooter <- paste0("<evenFooter>", even_footer[["left"]], even_footer[["center"]], even_footer[["right"]], "</evenFooter>", collapse = "")
  } else {
    evenFooter <- NULL
  }

  ## FIRST
  if (length(x$firstHeader)) {
    first_header <- lcr(x$firstHeader)
    firstHeader <- paste0("<firstHeader>", first_header[["left"]], first_header[["center"]], first_header[["right"]], "</firstHeader>", collapse = "")
  } else {
    firstHeader <- NULL
  }

  if (length(x$firstFooter)) {
    first_footer <- lcr(x$firstFooter)
    firstFooter <- paste0("<firstFooter>", first_footer[["left"]], first_footer[["center"]], first_footer[["right"]], "</firstFooter>", collapse = "")
  } else {
    firstFooter <- NULL
  }


  headTag <- sprintf(
    '<headerFooter differentOddEven="%s" differentFirst="%s" scaleWithDoc="%s" alignWithMargins="%s">',
    as.integer(!(is.null(evenHeader) & is.null(evenFooter))),
    as.integer(!(is.null(firstHeader) & is.null(firstFooter))),
    as_xml_attr(scale_with_doc),
    as_xml_attr(align_with_margins)
  )

  paste0(headTag, oddHeader, oddFooter, evenHeader, evenFooter, firstHeader, firstFooter, "</headerFooter>")
}


getFile <- function(xlsxFile) {

  ## Is this a file or URL (code taken from read.table())
  on.exit(try(close(fl), silent = TRUE), add = TRUE)
  fl <- file(description = xlsxFile)

  ## If URL download
  if (inherits(fl, "url")) {
    tmpFile <- tempfile(fileext = ".xlsx")
    download.file(url = xlsxFile, destfile = tmpFile, cacheOK = FALSE, mode = "wb", quiet = TRUE)
    xlsxFile <- tmpFile
  }

  return(xlsxFile)
}

# Rotate the 15-bit integer by n bits to the
hashPassword <- function(password) {
  # password limited to 15 characters
  # TODO add warning about password length
  chars <- strsplit(substr(password, 1L, 15L), "")[[1]]

  # See OpenOffice's documentation of the Excel format: http://www.openoffice.org/sc/excelfileformat.pdf
  # Start from the last character and for each character
  # - XOR hash with the ASCII character code
  # - rotate hash (16 bits) one bit to the left
  # Finally, XOR hash with 0xCE4B and XOR with password length
  # Output as hex (uppercase)
  rotate16bit <- function(hash, n = 1) {
    bitwOr(bitwAnd(bitwShiftR(hash, 15 - n), 0x01), bitwAnd(bitwShiftL(hash, n), 0x7fff))
  }
  hash <- Reduce(function(char, h) {
    h <- bitwXor(h, as.integer(charToRaw(char)))
    rotate16bit(h, 1)
  }, chars, 0, right = TRUE)
  hash <- bitwXor(bitwXor(hash, length(chars)), 0xCE4B)
  format(as.hexmode(hash), upper.case = TRUE)
}

#' Create sparklines object
#'
#' Create a sparkline to be added a workbook with [wb_add_sparklines()]
#'
#' Colors are all predefined to be rgb. Maybe theme colors can be
#' used too.
#' @param sheet sheet
#' @param dims Cell range of cells used to create the sparklines
#' @param sqref Cell range of the destination of the sparklines.
#' @param type Either `NULL`, `stacked` or `column`
#' @param negative negative
#' @param display_empty_cells_as Either `gap`, `span` or `zero`
#' @param markers markers add marker to line
#' @param high highlight highest value
#' @param low highlight lowest value
#' @param first highlight first value
#' @param last highlight last value
#' @param color_series colorSeries
#' @param color_negative colorNegative
#' @param color_axis colorAxis
#' @param color_markers colorMarkers
#' @param color_first colorFirst
#' @param color_last colorLast
#' @param color_high colorHigh
#' @param color_low colorLow
#' @param manual_max manualMax
#' @param manual_min manualMin
#' @param line_weight lineWeight
#' @param date_axis dateAxis
#' @param display_x_axis displayXAxis
#' @param display_hidden displayHidden
#' @param min_axis_type minAxisType
#' @param max_axis_type maxAxisType
#' @param right_to_left rightToLeft
#' @param ... additional arguments
#' @return A string containing XML code
#' @examples
#' # create sparklineGroup
#' sparklines <- c(
#'   create_sparklines("Sheet 1", "A3:L3", "M3", type = "column", first = "1"),
#'   create_sparklines("Sheet 1", "A2:L2", "M2", markers = "1"),
#'   create_sparklines("Sheet 1", "A4:L4", "M4", type = "stacked", negative = "1")
#' )
#'
#' t1 <- AirPassengers
#' t2 <- do.call(cbind, split(t1, cycle(t1)))
#' dimnames(t2) <- dimnames(.preformat.ts(t1))
#'
#' wb <- wb_workbook()$
#'   add_worksheet("Sheet 1")$
#'   add_data(x = t2)$
#'   add_sparklines(sparklines = sparklines)
#'
#' @export
create_sparklines <- function(
    sheet                  = current_sheet(),
    dims,
    sqref,
    type                   = NULL,
    negative               = NULL,
    display_empty_cells_as = "gap", # "span", "zero"
    markers                = NULL,
    high                   = NULL,
    low                    = NULL,
    first                  = NULL,
    last                   = NULL,
    color_series           = wb_color(hex = "FF376092"),
    color_negative         = wb_color(hex = "FFD00000"),
    color_axis             = wb_color(hex = "FFD00000"),
    color_markers          = wb_color(hex = "FFD00000"),
    color_first            = wb_color(hex = "FFD00000"),
    color_last             = wb_color(hex = "FFD00000"),
    color_high             = wb_color(hex = "FFD00000"),
    color_low              = wb_color(hex = "FFD00000"),
    manual_max             = NULL,
    manual_min             = NULL,
    line_weight            = NULL,
    date_axis              = NULL,
    display_x_axis         = NULL,
    display_hidden         = NULL,
    min_axis_type          = NULL,
    max_axis_type          = NULL,
    right_to_left          = NULL,
    ...
) {

  standardize_case_names(...)

  assert_class(dims, "character")
  assert_class(sqref, "character")

  if (!is.null(type) && !type %in% c("stacked", "column"))
    stop("type must be NULL, stacked or column")

  if (!is.null(markers) && as_xml_attr(markers) == "" && !is.null(type) && type %in% c("stacked", "column"))
    stop("markers only affect lines `type = NULL`, not stacked or column")

  sparklineGroup <- xml_node_create(
    "x14:sparklineGroup",
    xml_attributes = c(
      type                = type,
      displayEmptyCellsAs = as_xml_attr(display_empty_cells_as),
      markers             = as_xml_attr(markers),
      high                = as_xml_attr(high),
      low                 = as_xml_attr(low),
      first               = as_xml_attr(first),
      last                = as_xml_attr(last),
      negative            = as_xml_attr(negative),
      manualMin           = as_xml_attr(manual_min),
      manualMax           = as_xml_attr(manual_max),
      lineWeight          = as_xml_attr(line_weight),
      dateAxis            = as_xml_attr(date_axis),
      displayXAxis        = as_xml_attr(display_x_axis),
      displayHidden       = as_xml_attr(display_hidden),
      minAxisType         = as_xml_attr(min_axis_type),
      maxAxisType         = as_xml_attr(max_axis_type),
      rightToLeft         = as_xml_attr(right_to_left),
      "xr2:uid"           = sprintf("{6F57B887-24F1-C14A-942C-%s}", random_string(length = 12, pattern = "[A-F0-9]"))
    ),
    xml_children = c(
      xml_node_create("x14:colorSeries",   xml_attributes = color_series),
      xml_node_create("x14:colorNegative", xml_attributes = color_negative),
      xml_node_create("x14:colorAxis",     xml_attributes = color_axis),
      xml_node_create("x14:colorMarkers",  xml_attributes = color_markers),
      xml_node_create("x14:colorFirst",    xml_attributes = color_first),
      xml_node_create("x14:colorLast",     xml_attributes = color_last),
      xml_node_create("x14:colorHigh",     xml_attributes = color_high),
      xml_node_create("x14:colorLow",      xml_attributes = color_low),
      xml_node_create(
        "x14:sparklines", xml_children = c(
          xml_node_create(
            "x14:sparkline", xml_children = c(
              xml_node_create(
                "xm:f", xml_children = c(
                  paste0(shQuote(sheet, type = "sh"), "!", dims)
                )),
              xml_node_create(
                "xm:sqref", xml_children = c(
                  sqref
                ))
            ))
        )
      )
    )
  )

  sparklineGroup
}

### modify xml file names

read_Content_Types <- function(x) {

  df <- rbindlist(xml_attr(x, "Default"))
  or <- rbindlist(xml_attr(x, "Override"))

  sel <- grepl("/sheet[0-9]+.xml$", or$PartName)
  or$sheet_id <- NA
  or$sheet_id[sel] <- as.integer(gsub("\\D+", "", basename(or$PartName)[sel]))


  list(df, or)
}

write_Content_Types <- function(x, rm_sheet = NULL) {
  df_df <- x[[1]]
  or_df <- x[[2]]

  if (!is.null(rm_sheet)) {
    # remove a sheet and rename the remaining
    or_df <- or_df[order(or_df$sheet_id), ]
    sel <- which(or_df$sheet_id == rm_sheet)
    or_df <- or_df[-sel, ]
    or_df$PartName[!is.na(or_df$sheet_id)] <- sprintf(
      "%s/sheet%s.xml",
      dirname(or_df$PartName[!is.na(or_df$sheet_id)]),
      seq_along(or_df$sheet_id[!is.na(or_df$sheet_id)])
    )

    or_df <- or_df[order(as.integer(row.names(or_df))), ]
  }

  df_xml <- df_to_xml("Default", df_df[c("Extension", "ContentType")])
  or_xml <- df_to_xml("Override", or_df[c("PartName", "ContentType")])
  c(df_xml, or_xml)
}

read_workbook.xml.rels <- function(x) {

  wxr <- rbindlist(xml_attr(x, "Relationship"))

  sel <- grepl("/sheet[0-9]+.xml$", wxr$Target)
  wxr$sheet_id <- NA
  wxr$sheet_id[sel] <- as.integer(gsub("\\D+", "", basename(wxr$Target)[sel]))
  wxr
}

write_workbook.xml.rels <- function(x, rm_sheet = NULL) {
  wxr <- x

  if (!is.null(rm_sheet)) {
    # remove a sheet and rename the remaining
    wxr <- wxr[order(wxr$sheet_id), ]
    sel <- which(wxr$sheet_id == rm_sheet)
    wxr <- wxr[-sel, ]
    wxr$Target[!is.na(wxr$sheet_id)] <- sprintf(
      "%s/sheet%s.xml",
      dirname(wxr$Target[!is.na(wxr$sheet_id)]),
      seq_along(wxr$sheet_id[!is.na(wxr$sheet_id)])
    )
  }

  if (is.null(wxr[["TargetMode"]])) wxr$TargetMode <- ""
  df_to_xml("Relationship", df_col = wxr[c("Id", "Type", "Target", "TargetMode")])
}

#' convert objects with attribute labels into strings
#' @param x an object to convert
#' @noRd
to_string <- function(x) {
  lbls <- attr(x, "labels")
  chr <- as.character(x)
  if (!is.null(lbls)) {
    lbls <- lbls[lbls %in% x]
    sel_l <- match(lbls, x)
    if (length(sel_l)) chr[sel_l] <- names(lbls)
  }
  chr
}

# get the next free relationship id
get_next_id <- function(x, increase = 1L) {
  if (length(x)) {
    rlshp <- rbindlist(xml_attr(x, "Relationship"))
    rlshp$id <- as.integer(gsub("\\D+", "", rlshp$Id))
    next_id <- paste0("rId", max(rlshp$id) + increase)
  } else {
    next_id <- "rId1"
  }
  next_id
}

#' create a guid string
#' @keywords internal
#' @noRd
st_guid <- function() {
  paste0(
    "{",
    random_string(length = 8, pattern = "[A-F0-9]"), "-",
    random_string(length = 4, pattern = "[A-F0-9]"), "-",
    random_string(length = 4, pattern = "[A-F0-9]"), "-",
    random_string(length = 4, pattern = "[A-F0-9]"), "-",
    random_string(length = 12, pattern = "[A-F0-9]"),
    "}"
  )
}

#' create a userid
#' @keywords internal
#' @noRd
st_userid <- function() {
  random_string(length = 16, pattern = "[a-z0-9]")
}

# solve merge helpers -----------------------------------------------------

#' check side
#' @param x a logical string
#' @name sidehelper
#' @noRd
fullsided <- function(x) {
  x[1] && x[length(x)]
}

#' @rdname sidehelper
#' @noRd
onesided <- function(x) {
  (x[1] && !x[length(x)]) || (!x[1] && x[length(x)])
}


#' @rdname sidehelper
#' @noRd
twosided <- function(x) {
  if (any(x)) (!x[1] && !x[length(x)])
  else FALSE
}

#' @rdname sidehelper
#' @noRd
top_half <- function(x) {
  if (twosided(x)) {
    out <- rep(FALSE, length(x))
    out[seq_len(which(x == TRUE)[1] - 1L)] <- TRUE
    return(out)
  } else {
    stop("not twosided")
  }
}

#' @rdname sidehelper
#' @noRd
bottom_half <- function(x) {
  if (twosided(x)) {
    out <- rep(TRUE, length(x))
    out[seq_len(rev(which(x == TRUE))[1])] <- FALSE
    return(out)
  } else {
    stop("not twosided")
  }
}

#' merge solver. split exisisting merge into pieces
#' @param have current merged cells
#' @param want newly merged cells
#' @noRd
solve_merge <- function(have, want) {

  got <- dims_to_dataframe(have, fill = TRUE)
  new <- dims_to_dataframe(want, fill = TRUE)

  cols_overlap <- colnames(got) %in% colnames(new)
  rows_overlap <- rownames(got) %in% rownames(new)

  # no overlap at all
  if (!any(cols_overlap) || !any(rows_overlap)) {
    return(have)
  }

  # return pieces of the old
  pieces <- list()

  # new overlaps old completely
  if (fullsided(cols_overlap) && fullsided(rows_overlap)) {
    return(NA_character_)
  }

  # all columns are overlapped onesided
  if (fullsided(cols_overlap) && onesided(rows_overlap)) {
    pieces[[1]] <- got[!rows_overlap, drop = FALSE]
  }

  # all columns are overlapped twosided
  if (fullsided(cols_overlap) && twosided(rows_overlap)) {
    pieces[[1]] <- got[top_half(rows_overlap), drop = FALSE]
    pieces[[2]] <- got[bottom_half(rows_overlap), drop = FALSE]
  }

  # all rows are overlapped onesided
  if (onesided(cols_overlap) && fullsided(rows_overlap)) {
    pieces[[1]] <- got[, !cols_overlap, drop = FALSE]
  }

  # all rows are overlapped twosided
  if (twosided(cols_overlap) && fullsided(rows_overlap)) {
    pieces[[1]] <- got[, top_half(cols_overlap), drop = FALSE]
    pieces[[2]] <- got[, bottom_half(cols_overlap), drop = FALSE]
  }

  # new is part of old
  if (onesided(cols_overlap) && onesided(rows_overlap)) {
    pieces[[1]] <- got[!rows_overlap, cols_overlap, drop = FALSE]
    pieces[[2]] <- got[, !cols_overlap, drop = FALSE]
  }

  if (onesided(cols_overlap) && twosided(rows_overlap)) {
    pieces[[1]] <- got[top_half(rows_overlap), cols_overlap, drop = FALSE]
    pieces[[2]] <- got[bottom_half(rows_overlap), cols_overlap, drop = FALSE]
    pieces[[3]] <- got[, !cols_overlap, drop = FALSE]
  }

  if (twosided(cols_overlap) && onesided(rows_overlap)) {
    pieces[[1]] <- got[rows_overlap, top_half(cols_overlap), drop = FALSE]
    pieces[[2]] <- got[rows_overlap, bottom_half(cols_overlap), drop = FALSE]
    pieces[[3]] <- got[!rows_overlap, , drop = FALSE]
  }

  if (twosided(cols_overlap) && twosided(rows_overlap)) {
    pieces[[1]] <- got[, top_half(cols_overlap), drop = FALSE]
    pieces[[2]] <- got[, bottom_half(cols_overlap), drop = FALSE]
    pieces[[3]] <- got[top_half(rows_overlap), cols_overlap, drop = FALSE]
    pieces[[4]] <- got[bottom_half(rows_overlap), cols_overlap, drop = FALSE]
  }

  vapply(pieces, dataframe_to_dims, NA_character_)
}

#' get the basename
#' on windows [basename()] only handles strings up to 255 characters, but we
#' can have longer strings when loading file systems
#' @param path a character string
#' @keywords internal
#' @noRd
basename2 <- function(path) {
  is_to_long <- vapply(path, to_long, NA)
  if (any(is_to_long)) {
    return(gsub(".*[\\/]", "", path))
  } else {
    return(basename(path))
  }
}

fetch_styles <- function(wb, xf_xml, st_ids) {
  # returns NA if no style found
  if (all(is.na(xf_xml))) return(NULL)

  lst_out <- vector("list", length = length(xf_xml))
  names(lst_out) <- st_ids

  for (i in seq_along(xf_xml)) {

    if (is.na(xf_xml[[i]])) next
    xf_df <- read_xf(read_xml(xf_xml[[i]]))

    border_id <- which(wb$styles_mgr$border$id == xf_df$borderId)
    fill_id   <- which(wb$styles_mgr$fill$id == xf_df$fillId)
    font_id   <- which(wb$styles_mgr$font$id == xf_df$fontId)
    numFmt_id <- which(wb$styles_mgr$numfmt$id == xf_df$numFmtId)

    border_xml <- wb$styles_mgr$styles$borders[border_id]
    fill_xml   <- wb$styles_mgr$styles$fills[fill_id]
    font_xml   <- wb$styles_mgr$styles$fonts[font_id]
    numfmt_xml <- wb$styles_mgr$styles$numFmts[numFmt_id]

    out <- list(
      xf_df,
      border_xml,
      fill_xml,
      font_xml,
      numfmt_xml
    )
    names(out) <- c("xf_df", "border_xml", "fill_xml", "font_xml", "numfmt_xml")
    lst_out[[i]] <- out

  }

  # unique drops names
  lst_out <- lst_out[!duplicated(lst_out)]

  attr(lst_out, "st_ids") <- st_ids

  lst_out
}

## get cell styles for a worksheet
get_cellstyle <- function(wb, sheet = current_sheet(), dims) {

  st_ids <- NULL
  if (missing(dims)) {
    st_ids <- styles_on_sheet(wb = wb, sheet = sheet) %>% as.character()
    xf_ids <- match(st_ids, wb$styles_mgr$xf$id)
    xf_xml <- wb$styles_mgr$styles$cellXfs[xf_ids]
  } else {
    xf_xml <- get_cell_styles(wb = wb, sheet = sheet, cell = dims)
  }

  fetch_styles(wb, xf_xml, st_ids)
}

get_colstyle <- function(wb, sheet = current_sheet()) {

  st_ids <- NULL
  if (length(wb$worksheets[[sheet]]$cols_attr)) {
    cols <- wb$worksheets[[sheet]]$unfold_cols()
    st_ids <- cols$style[cols$style != ""]
    xf_ids <- match(st_ids, wb$styles_mgr$xf$id)
    xf_xml <- wb$styles_mgr$styles$cellXfs[xf_ids]
  } else {
    xf_xml <- NA_character_
  }

  fetch_styles(wb, xf_xml, st_ids)
}

get_rowstyle <- function(wb, sheet = current_sheet()) {

  st_ids <- NULL
  if (!is.null(wb$worksheets[[sheet]]$sheet_data$row_attr)) {
    rows <- wb$worksheets[[sheet]]$sheet_data$row_attr
    st_ids <- rows$s[rows$s != ""]
    xf_ids <- match(st_ids, wb$styles_mgr$xf$id)
    xf_xml <- wb$styles_mgr$styles$cellXfs[xf_ids]
  } else {
    xf_xml <- NA_character_
  }

  fetch_styles(wb, xf_xml, st_ids)
}

## apply cell styles to a worksheet and return reference ids
set_cellstyles <- function(wb, style) {

  session_ids <- random_string(n = length(style))

  for (i in seq_along(style)) {
    session_id <- session_ids[i]

    has_border <- FALSE
    if (length(style[[i]]$border_xml)) {
      has_border <- TRUE
      wb$styles_mgr$add(style[[i]]$border_xml, session_id)
    }

    has_fill <- FALSE
    if (length(style[[i]]$fill_xml) && style[[i]]$fill_xml != wb$styles_mgr$styles$fills[1]) {
      has_fill <- TRUE
      wb$styles_mgr$add(style[[i]]$fill_xml, session_id)
    }

    has_font <- FALSE
    if (length(style[[i]]$font_xml) && style[[i]]$font_xml != wb$styles_mgr$styles$fonts[1]) {
      has_font <- TRUE
      wb$styles_mgr$add(style[[i]]$font_xml, session_id)
    }

    has_numfmt <- FALSE
    if (length(style[[i]]$numfmt_xml)) {
      has_numfmt <- TRUE
      numfmt_xml <- style[[i]]$numfmt_xml
      # assuming all numfmts with ids >= 164.
      # We have to create unique numfmt ids when cloning numfmts. Otherwise one
      # ids could point to more than one format code and the output would look
      # broken.
      fmtCode <- xml_attr(numfmt_xml, "numFmt")[[1]][["formatCode"]]
      next_id <- max(163L, as.integer(wb$styles_mgr$get_numfmt()$id)) + 1L
      numfmt_xml <- create_numfmt(numFmtId = next_id, formatCode = fmtCode)

      wb$styles_mgr$add(numfmt_xml, session_id)
    }

    ## create new xf_df. This has to reference updated style ids
    xf_df <- style[[i]]$xf_df

    if (has_border)
      xf_df$borderId <- wb$styles_mgr$get_border_id(session_id)

    if (has_fill)
      xf_df$fillId <- wb$styles_mgr$get_fill_id(session_id)

    if (has_font)
      xf_df$fontId <- wb$styles_mgr$get_font_id(session_id)

    if (has_numfmt)
      xf_df$numFmtId <- wb$styles_mgr$get_numfmt_id(session_id)

    xf_xml <- write_xf(xf_df) # can be NULL

    if (length(xf_xml))
      wb$styles_mgr$add(xf_xml, session_id)
  }

  # return updated style id
  st_ids <- wb$styles_mgr$get_xf_id(session_ids)

  if (!is.null(attr(style, "st_ids"))) {
    names(st_ids) <- names(style)
    out <- attr(style, "st_ids")

    want <- match(out, names(st_ids))
    st_ids <- st_ids[want]
  }

  st_ids
}

clone_shared_strings <- function(wb_old, old, wb_new, new) {

  empty <- structure(list(), uniqueCount = 0)

  # old has no shared strings
  if (identical(wb_old$sharedStrings, empty)) {
    return(NULL)
  }

  if (identical(wb_new$sharedStrings, empty)) {

    wb_new$append(
      "Content_Types",
      "<Override PartName=\"/xl/sharedStrings.xml\" ContentType=\"application/vnd.openxmlformats-officedocument.spreadsheetml.sharedStrings+xml\"/>"
    )

    wb_new$append(
      "workbook.xml.rels",
      "<Relationship Id=\"rId1\" Type=\"http://schemas.openxmlformats.org/officeDocument/2006/relationships/sharedStrings\" Target=\"sharedStrings.xml\"/>"
    )

  }

  sheet_id <- wb_old$validate_sheet(old)
  cc <- wb_old$worksheets[[sheet_id]]$sheet_data$cc
  sst_ids  <- as.integer(cc$v[cc$c_t == "s"]) + 1
  sst_uni  <- sort(unique(sst_ids))
  sst_old <- wb_old$sharedStrings[sst_uni]

  old_len <- length(as.character(wb_new$sharedStrings))

  wb_new$sharedStrings <- c(as.character(wb_new$sharedStrings), sst_old)
  sst  <- xml_node_create("sst", xml_children = wb_new$sharedStrings)
  text <- xml_si_to_txt(read_xml(sst))
  attr(wb_new$sharedStrings, "uniqueCount") <- as.character(length(text))
  attr(wb_new$sharedStrings, "text") <- text


  sheet_id <- wb_new$validate_sheet(new)
  cc <- wb_new$worksheets[[sheet_id]]$sheet_data$cc
  # order ids and add new offset
  ids <- as.integer(cc$v[cc$c_t == "s"]) + 1L
  new_ids <- match(ids, sst_uni) + old_len - 1L
  new_ids <- as.character(new_ids)
  new_ids[is.na(new_ids)] <- ""
  cc$v[cc$c_t == "s"] <- new_ids
  wb_new$worksheets[[sheet_id]]$sheet_data$cc <- cc

  # print(sprintf("cloned: %s", length(new_ids)))

}

known_subtotal_funs <- function(x, total, table, row_names = FALSE) {

  # unfortunately x has no row names at this point
  ncol_x <- ncol(x) + row_names
  nms_x <- names(x)
  if (row_names) nms_x <- c("_rowNames_", nms_x)

  fml <- vector("character", ncol_x)
  atr <- vector("character", ncol_x)
  lbl <- rep(NA_character_, ncol_x)

  if (isTRUE(total) || all(as.character(total) == "109") || all(total == "sum")) {
    fml <- paste0("SUBTOTAL(109,", table, "[", names(x), "])")
    atr <- rep("sum", ncol_x)
  } else {

    # all get the same total_row value
    if (length(total) == 1) {
      total <- rep(total, ncol_x)
    }

    if (length(total) != ncol_x) {
      stop("length of total_row and table columns do not match", call. = FALSE)
    }

    builtinIds <- c("101", "103", "102", "104", "105", "107", "109", "110")
    builtins   <- c("average", "count", "countNums", "max", "min", "stdDev", "sum", "var")

    ttl <- as.character(total)

    for (i in seq_len(ncol_x)) {

      if (any(names(total)[i] == "") && (ttl[i] %in% builtinIds || ttl[i] %in% builtins)) {
        if (ttl[i] == "101" || ttl[i] == "average") {
          fml[i] <- paste0("SUBTOTAL(", 101, ",", table, "[", nms_x[i], "])")
          atr[i] <- "average"
        } else if (ttl[i] == "102" || ttl[i] == "countNums") {
          fml[i] <- paste0("SUBTOTAL(", 102, ",", table, "[", nms_x[i], "])")
          atr[i] <- "countNums"
        } else if (ttl[i] == "103" || ttl[i] == "count") {
          fml[i] <- paste0("SUBTOTAL(", 103, ",", table, "[", nms_x[i], "])")
          atr[i] <- "count"
        } else if (ttl[i] == "104" || ttl[i] == "max") {
          fml[i] <- paste0("SUBTOTAL(", 104, ",", table, "[", nms_x[i], "])")
          atr[i] <- "max"
        } else if (ttl[i] == "105" || ttl[i] == "min") {
          fml[i] <- paste0("SUBTOTAL(", 105, ",", table, "[", nms_x[i], "])")
          atr[i] <- "min"
        } else if (ttl[i] == "107" || ttl[i] == "stdDev") {
          fml[i] <- paste0("SUBTOTAL(", 107, ",", table, "[", nms_x[i], "])")
          atr[i] <- "stdDev"
        } else if (ttl[i] == "109" || ttl[i] == "sum") {
          fml[i] <- paste0("SUBTOTAL(", 109, ",", table, "[", nms_x[i], "])")
          atr[i] <- "sum"
        } else if (ttl[i] == "110" || ttl[i] == "var") {
          fml[i] <- paste0("SUBTOTAL(", 110, ",", table, "[", nms_x[i], "])")
          atr[i] <- "var"
        }

      } else if (ttl[i] == "0" || ttl[i] == "none") {
        fml[i] <- ""
        atr[i] <- "none"
      } else if (any(names(total)[i] == "text")) {
        fml[i] <- as_xml_attr(ttl[i])
        atr[i] <- ""
        lbl[i] <- as_xml_attr(ttl[i])
      } else {
        # works, but in excel the formula is added to tables.xml as a child to the column
        fml[i] <- paste0(ttl[i], "(", table, "[", nms_x[i], "])")
        atr[i] <- "custom"
      }

    }

  }

  # prepare output
  fml <- as.data.frame(t(fml))
  names(fml) <- nms_x
  names(atr) <- nms_x
  names(lbl) <- nms_x

  # prepare output to be written with formulas
  for (i in seq_along(fml)) {
    if (is.na(lbl[[i]])) class(fml[[i]]) <- c("formula", fml[[i]])
  }

  list(fml, atr, lbl)

}

#' helper to read sheetPr xml to dataframe
#' @param xml xml_node
#' @noRd
read_sheetpr <- function(xml) {
  # https://learn.microsoft.com/en-us/dotnet/api/documentformat.openxml.spreadsheet.sheetproperties?view=openxml-2.8.1
  if (!inherits(xml, "pugi_xml")) xml <- read_xml(xml)

  vec_attrs <- c("codeName", "enableFormatConditionsCalculation", "filterMode",
                 "published", "syncHorizontal", "syncRef", "syncVertical",
                 "transitionEntry", "transitionEvaluation")
  vec_chlds <- c("tabColor", "outlinePr", "pageSetUpPr")

  read_xml2df(
    xml       = xml,
    vec_name  = "sheetPr",
    vec_attrs = vec_attrs,
    vec_chlds = vec_chlds
  )
}

#' helper to write sheetPr dataframe to xml
#' @param df a data frame
#' @noRd
write_sheetpr <- function(df) {

  # we have to preserve a certain order of elements at least for childs
  vec_attrs <- c("codeName", "enableFormatConditionsCalculation", "filterMode",
                 "published", "syncHorizontal", "syncRef", "syncVertical",
                 "transitionEntry", "transitionEvaluation")
  vec_chlds <- c("tabColor", "outlinePr", "pageSetUpPr")
  nms <- c(vec_attrs, vec_chlds)

  write_df2xml(
    df        = df[nms],
    vec_name  = "sheetPr",
    vec_attrs = vec_attrs,
    vec_chlds = vec_chlds
  )
}

# helper construct dim comparison from rowcol_to_dims(as_integer = TRUE) object
min_and_max <- function(x) {
  c(
    (max(x[[2]]) + 1L) - min(x[[2]]), # row
    (max(x[[1]]) + 1L) - min(x[[1]])  # col
  )
}

#' helper function to detect if x fits into dims
#'
#' This function will throw a warning depending on the experimental option: `openxlsx2.warn_if_dims_dont_fit`
#' @param x the x object
#' @param dims the worksheet dimensions
#' @param startCol,startRow start column. Since write_data() is not defunct, we might not be fully able to select this from dims
#' @noRd
fits_in_dims <- function(x, dims, startCol, startRow) {

  # happens only in direct calls to write_data2 in some old tests
  if (is.null(dims)) {
    dims <- wb_dims(from_col = startCol, from_row = startRow)
  }

  if (length(dims) == 1 && is.character(dims)) {
    dims <- dims_to_rowcol(dims, as_integer = TRUE)
  }

  dim_x <- dim(x)
  dim_d <- min_and_max(dims)

  opt <- getOption("openxlsx2.warn_if_dims_dont_fit", default = FALSE)

  if (all(dim_x <= dim_d)) {
    fits <- TRUE
  } else if (all(dim_x > dim_d)) {
    if (opt) warning("dimension of `x` exceeds all `dims`")
    fits <- FALSE
  } else if (dim_x[1] > dim_d[1]) {
    if (opt) warning("dimension of `x` exceeds rows of `dims`")
    fits <- FALSE
  } else if (dim_x[2] > dim_d[2]) {
    if (opt) warning("dimension of `x` exceeds cols of `dims`")
    fits <- FALSE
  }

  if (fits) {

    # why oh why wasn't dims_to_rowcol()/rowcol_to_dims() created as a matching pair
    dims <- rowcol_to_dims(row = dims[[2]], col = dims[[1]])

  } else {

    # # one off. needs check if dims = NULL or row names argument?
    # dims <- wb_dims(x = x, from_col = startCol, from_row = startRow)

    data_nrow <- NROW(x)
    data_ncol <- NCOL(x)

    endRow <- (startRow - 1) + data_nrow
    endCol <- (startCol - 1) + data_ncol

    dims <- paste0(
      int2col(startCol), startRow,
      ":",
      int2col(endCol), endRow
    )

  }

  rc <- dims_to_rowcol(dims)
  if (max(as.integer(rc[[2]])) > 1048576 || max(col2int(rc[[1]])) > 16384)
    stop("Dimensions exceed worksheet")

  dims
}

# transpose single column or row data frames to wide/long. keeps attributes and class
transpose_df <- function(x) {
  attribs <- attr(x, "c_cm")
  classes <- class(x[[1]])
  x <- as.data.frame(t(x))
  for (i in seq_along(x)) {
    class(x[[i]]) <- classes
  }
  attr(x, "c_cm") <- attribs
  x
}

#' helper function to update custom pids. Pids are indexed starting with 2.
#' @param wb a workbook
#' @noRd
wb_upd_custom_pid <- function(wb) {

  cstm <- xml_node(wb$custom, "Properties", "property")

  cstm_nams <- xml_node_name(cstm, "property")

  cstm_df      <- rbindlist(xml_attr(cstm, "property"))
  cstm_df$clds <- vapply(seq_along(cstm), function(x) xml_node(cstm[x], "property", cstm_nams[x]), NA_character_)
  cstm_df$pid  <- as.character(2L + (seq_len(nrow(cstm_df)) - 1L))

  out <- NULL
  for (i in seq_len(nrow(cstm_df))) {
    tmp <- xml_node_create(
      "property",
      xml_attributes = c(fmtid = cstm_df$fmtid[i], pid = cstm_df$pid[i], name = cstm_df$name[i]),
      xml_children   = c(cstm_df$clds[i])
    )
    out <- c(out, tmp)
  }

  ## return
  xml_node_create(
    "Properties",
    xml_attributes = c(
      xmlns = "http://schemas.openxmlformats.org/officeDocument/2006/custom-properties",
      `xmlns:vt` = "http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes"
    ),
    xml_children = out
  )
}