Nothing
# functions interacting with styles
# internal function used in wb_load
# @param x character string containing styles.xml
import_styles <- function(x) {
sxml <- openxlsx2::read_xml(x)
z <- NULL
# Number Formats numFmtId
# overrides for
# + numFmtId
# https://docs.microsoft.com/en-us/dotnet/api/documentformat.openxml.spreadsheet.numberingformat?view=openxml-2.8.1
z$numFmts <- xml_node(sxml, "styleSheet", "numFmts", "numFmt")
# Fonts fontId
# https://docs.microsoft.com/en-us/dotnet/api/documentformat.openxml.spreadsheet.font?view=openxml-2.8.1
z$fonts <- xml_node(sxml, "styleSheet", "fonts", "font")
# Fills fillId
# https://docs.microsoft.com/en-us/dotnet/api/documentformat.openxml.spreadsheet.fill?view=openxml-2.8.1
z$fills <- xml_node(sxml, "styleSheet", "fills", "fill")
# Borders borderId
# https://docs.microsoft.com/en-us/dotnet/api/documentformat.openxml.spreadsheet.border?view=openxml-2.8.1
z$borders <- xml_node(sxml, "styleSheet", "borders", "border")
# Formatting Records: Cell Style Formats
# links
# + numFmtId
# + fontId
# + fillId
# + borderId
# https://docs.microsoft.com/en-us/dotnet/api/documentformat.openxml.spreadsheet.cellstyleformats?view=openxml-2.8.1
z$cellStyleXfs <- xml_node(sxml, "styleSheet", "cellStyleXfs", "xf")
# Cell Formats
# https://docs.microsoft.com/en-us/dotnet/api/documentformat.openxml.spreadsheet.cellformat?view=openxml-2.8.1
#
# Position is 0 index s="value" used in worksheet <c ...>
# links
# + numFmtId
# + fontId
# + fillId
# + borderId
# + xfId
# https://docs.microsoft.com/en-us/dotnet/api/documentformat.openxml.spreadsheet.cellformats?view=openxml-2.8.1
z$cellXfs <- xml_node(sxml, "styleSheet", "cellXfs", "xf")
# Cell Styles (no clue)
# links
# + xfId
# + builtinId
# https://docs.microsoft.com/en-us/dotnet/api/documentformat.openxml.spreadsheet.cellstyle?view=openxml-2.8.1
z$cellStyles <- xml_node(sxml, "styleSheet", "cellStyles", "cellStyle")
# Differential Formats (No clue?)
# https://docs.microsoft.com/en-us/dotnet/api/documentformat.openxml.spreadsheet.differentialformat?view=openxml-2.8.1
z$dxfs <- xml_node(sxml, "styleSheet", "dxfs", "dxf")
# Table Styles Maybe position Id?
# https://docs.microsoft.com/en-us/dotnet/api/documentformat.openxml.spreadsheet.tablestyle?view=openxml-2.8.1
z$tableStyles <- xml_node(sxml, "styleSheet", "tableStyles")
# Colors
# https://docs.microsoft.com/en-us/dotnet/api/documentformat.openxml.spreadsheet.colors?view=openxml-2.8.1
# https://docs.microsoft.com/en-us/dotnet/api/documentformat.openxml.spreadsheet.indexedcolors?view=openxml-2.8.1
z$colors <- xml_node(sxml, "styleSheet", "colors")
# Future extensions No clue, some special styles
# https://docs.microsoft.com/en-us/dotnet/api/documentformat.openxml.spreadsheet.extensionlist?view=openxml-2.8.1
z$extLst <- xml_node(sxml, "styleSheet", "extLst")
z
}
# TODO guessing here
#' Helper to create a border
#' @description
#' Border styles can any of the following: "thin", "thick", "slantDashDot", "none", "mediumDashed", "mediumDashDot", "medium", "hair", "double", "dotted", "dashed", "dashedDotDot", "dashDot"
#' Border colors can be created with [wb_color()]
#' @param diagonal_down x
#' @param diagonal_up x
#' @param outline x
#' @param bottom X
#' @param bottom_color,diagonal_color,left_color,right_color,top_color a color created with [wb_color()]
#' @param diagonal X
#' @param end x,
#' @param horizontal x
#' @param left x
#' @param right x
#' @param start x
#' @param top x
#' @param vertical x
#' @param ... x
#' @seealso [wb_add_border()]
#' @family style creating functions
#'
#' @export
create_border <- function(
diagonal_down = "",
diagonal_up = "",
outline = "",
bottom = NULL,
bottom_color = NULL,
diagonal = NULL,
diagonal_color = NULL,
end = "",
horizontal = "",
left = NULL,
left_color = NULL,
right = NULL,
right_color = NULL,
start = "",
top = NULL,
top_color = NULL,
vertical = "",
...
) {
standardize(...)
if (!is.null(left_color)) left_color <- xml_node_create("color", xml_attributes = left_color)
if (!is.null(right_color)) right_color <- xml_node_create("color", xml_attributes = right_color)
if (!is.null(top_color)) top_color <- xml_node_create("color", xml_attributes = top_color)
if (!is.null(bottom_color)) bottom_color <- xml_node_create("color", xml_attributes = bottom_color)
if (!is.null(diagonal_color)) diagonal_color <- xml_node_create("color", xml_attributes = diagonal_color)
# excel dies on style=\"\"
if (!is.null(left)) left <- c(style = left)
if (!is.null(right)) right <- c(style = right)
if (!is.null(top)) top <- c(style = top)
if (!is.null(bottom)) bottom <- c(style = bottom)
if (!is.null(diagonal)) diagonal <- c(style = diagonal)
left <- xml_node_create("left", xml_children = left_color, xml_attributes = left)
right <- xml_node_create("right", xml_children = right_color, xml_attributes = right)
top <- xml_node_create("top", xml_children = top_color, xml_attributes = top)
bottom <- xml_node_create("bottom", xml_children = bottom_color, xml_attributes = bottom)
diagonal <- xml_node_create("diagonal", xml_children = diagonal_color, xml_attributes = diagonal)
if (left == "<left/>") left <- ""
if (right == "<right/>") right <- ""
if (top == "<top/>") top <- ""
if (bottom == "<bottom/>") bottom <- ""
if (diagonal == "<diagonal/>") diagonal <- ""
df_border <- data.frame(
start = start,
end = end,
left = left,
right = right,
top = top,
bottom = bottom,
diagonalDown = diagonal_down,
diagonalUp = diagonal_up,
diagonal = diagonal,
vertical = vertical,
horizontal = horizontal,
outline = outline, # unknown position in border
stringsAsFactors = FALSE
)
border <- write_border(df_border)
return(border)
}
#' Create number format
#' @param numFmtId an id, the list can be found in the **Details** of [create_cell_style()]
#' @param formatCode a format code
#' @seealso [wb_add_numfmt()]
#' @family style creating functions
#' @export
create_numfmt <- function(numFmtId, formatCode) {
# maybe only required in dates
formatCode <- escape_forward_slashes(formatCode)
df_numfmt <- data.frame(
numFmtId = as_xml_attr(numFmtId),
formatCode = as_xml_attr(formatCode),
stringsAsFactors = FALSE
)
numfmt <- write_numfmt(df_numfmt)
return(numfmt)
}
#' Create font format
#' @param b bold
#' @param charset charset
#' @param color rgb color: default "FF000000"
#' @param condense condense
#' @param extend extend
#' @param family font family: default "2"
#' @param i italic
#' @param name font name: default "Aptos Narrow"
#' @param outline outline
#' @param scheme font scheme: default "minor"
#' @param shadow shadow
#' @param strike strike
#' @param sz font size: default "11",
#' @param u underline
#' @param vert_align vertical alignment
#' @param ... ...
#' @seealso [wb_add_font()]
#' @family style creating functions
#' @examples
#' font <- create_font()
#' # openxml has the alpha value leading
#' hex8 <- unlist(xml_attr(read_xml(font), "font", "color"))
#' hex8 <- paste0("#", substr(hex8, 3, 8), substr(hex8, 1, 2))
#'
#' # # write test color
#' # col <- crayon::make_style(col2rgb(hex8, alpha = TRUE))
#' # cat(col("Test"))
#' @export
create_font <- function(
b = "",
charset = "",
color = wb_color(hex = "FF000000"),
condense = "",
extend = "",
family = "2",
i = "",
name = "Aptos Narrow",
outline = "",
scheme = "minor",
shadow = "",
strike = "",
sz = "11",
u = "",
vert_align = "",
...
) {
standardize(...)
if (b != "") {
b <- xml_node_create("b", xml_attributes = c("val" = as_xml_attr(b)))
}
if (charset != "") {
charset <- xml_node_create("charset", xml_attributes = c("val" = charset))
}
if (!is.null(color) && !all(color == "")) {
# alt xml_attributes(theme:)
color <- xml_node_create("color", xml_attributes = color)
}
if (condense != "") {
condense <- xml_node_create("condense", xml_attributes = c("val" = as_xml_attr(condense)))
}
if (extend != "") {
extend <- xml_node_create("extend", xml_attributes = c("val" = as_xml_attr(extend)))
}
if (family != "") {
family <- xml_node_create("family", xml_attributes = c("val" = family))
}
if (i != "") {
i <- xml_node_create("i", xml_attributes = c("val" = as_xml_attr(i)))
}
if (is.null(name)) name <- ""
if (name != "") {
name <- xml_node_create("name", xml_attributes = c("val" = name))
}
if (outline != "") {
outline <- xml_node_create("outline", xml_attributes = c("val" = as_xml_attr(outline)))
}
if (scheme != "") {
scheme <- xml_node_create("scheme", xml_attributes = c("val" = scheme))
}
if (shadow != "") {
shadow <- xml_node_create("shadow", xml_attributes = c("val" = as_xml_attr(shadow)))
}
if (strike != "") {
strike <- xml_node_create("strike", xml_attributes = c("val" = as_xml_attr(strike)))
}
if (sz != "") {
sz <- xml_node_create("sz", xml_attributes = c("val" = as_xml_attr(sz)))
}
if (u != "") {
u <- xml_node_create("u", xml_attributes = c("val" = as_xml_attr(u)))
}
if (vert_align != "") {
vert_align <- xml_node_create("vertAlign", xml_attributes = c("val" = as_xml_attr(vert_align)))
}
df_font <- data.frame(
b = b,
charset = charset,
color = color,
condense = condense,
extend = extend,
family = family,
i = i,
name = name,
outline = outline,
scheme = scheme,
shadow = shadow,
strike = strike,
sz = sz,
u = u,
vertAlign = vert_align,
stringsAsFactors = FALSE
)
font <- write_font(df_font)
if (font == "<font/>") {
font <- ""
}
return(font)
}
#' Create fill pattern
#'
#' @param gradientFill complex fills
#' @param patternType various: default is "none", but also "solid", or a color like "gray125"
#' @param bgColor hex8 color with alpha, red, green, blue only for patternFill
#' @param fgColor hex8 color with alpha, red, green, blue only for patternFill
#' @param ... ...
#' @seealso [wb_add_fill()]
#' @family style creating functions
#'
#' @export
create_fill <- function(
gradientFill = "",
patternType = "",
bgColor = NULL,
fgColor = NULL,
...
) {
standardize_color_names(...)
if (!is.null(bgColor) && !all(bgColor == "")) {
bgColor <- xml_node_create("bgColor", xml_attributes = bgColor)
}
if (!is.null(fgColor) && !all(fgColor == "")) {
fgColor <- xml_node_create("fgColor", xml_attributes = fgColor)
}
# if gradient fill is specified we can not have patternFill too. otherwise
# we end up with a solid black fill
if (gradientFill == "") {
patternFill <- xml_node_create("patternFill",
xml_children = c(fgColor, bgColor),
xml_attributes = c(patternType = patternType)
)
} else {
patternFill <- ""
}
df_fill <- data.frame(
gradientFill = gradientFill,
patternFill = patternFill,
stringsAsFactors = FALSE
)
fill <- write_fill(df_fill)
return(fill)
}
# TODO can be further generalized with additional xf attributes and children
#' Helper to create a cell style
#'
#' @param border_id dummy
#' @param fill_id dummy
#' @param font_id dummy
#' @param num_fmt_id a numFmt ID for a builtin style
#' @param pivot_button dummy
#' @param quote_prefix dummy
#' @param xf_id dummy
#' @param horizontal dummy
#' @param indent dummy
#' @param justify_last_line dummy
#' @param reading_order dummy
#' @param relative_indent dummy
#' @param shrink_to_fit dummy
#' @param text_rotation dummy
#' @param vertical dummy
#' @param wrap_text dummy
#' @param ext_lst dummy
#' @param hidden dummy
#' @param locked dummy
#' @param horizontal alignment can be "", "center", "right"
#' @param vertical alignment can be "", "center", "right"
#' @param ... reserved for additional arguments
#' @seealso [wb_add_cell_style()]
#' @family style creating functions
#'
#' @details
#' | "ID" | "numFmt" |
#' |------|-----------------------------|
#' | "0" | "General" |
#' | "1" | "0" |
#' | "2" | "0.00" |
#' | "3" | "#,##0" |
#' | "4" | "#,##0.00" |
#' | "9" | "0%" |
#' | "10" | "0.00%" |
#' | "11" | "0.00E+00" |
#' | "12" | "# ?/?" |
#' | "13" | "# ??/??" |
#' | "14" | "mm-dd-yy" |
#' | "15" | "d-mmm-yy" |
#' | "16" | "d-mmm" |
#' | "17" | "mmm-yy" |
#' | "18" | "h:mm AM/PM" |
#' | "19" | "h:mm:ss AM/PM" |
#' | "20" | "h:mm" |
#' | "21" | "h:mm:ss" |
#' | "22" | "m/d/yy h:mm" |
#' | "37" | "#,##0 ;(#,##0)" |
#' | "38" | "#,##0 ;\[Red\](#,##0)" |
#' | "39" | "#,##0.00;(#,##0.00)" |
#' | "40" | "#,##0.00;\[Red\](#,##0.00)"|
#' | "45" | "mm:ss" |
#' | "46" | "\[h\]:mm:ss" |
#' | "47" | "mmss.0" |
#' | "48" | "##0.0E+0" |
#' | "49" | "@" |
#' @export
create_cell_style <- function(
border_id = "",
fill_id = "",
font_id = "",
num_fmt_id = "",
pivot_button = "",
quote_prefix = "",
xf_id = "",
horizontal = "",
indent = "",
justify_last_line = "",
reading_order = "",
relative_indent = "",
shrink_to_fit = "",
text_rotation = "",
vertical = "",
wrap_text = "",
ext_lst = "",
hidden = "",
locked = "",
...
) {
n <- length(num_fmt_id)
arguments <- c(ls(), "is_cell_style_xf")
standardize_case_names(..., arguments = arguments)
args <- list(...)
is_cell_style_xf <- isTRUE(args$is_cell_style_xf)
applyAlignment <- ""
if (any(horizontal != "") || any(text_rotation != "") || any(vertical != "")) applyAlignment <- "1"
if (is_cell_style_xf) applyAlignment <- "0"
applyBorder <- ""
if (any(border_id != "")) applyBorder <- "1"
if (is_cell_style_xf && isTRUE(border_id == "")) applyBorder <- "0"
applyFill <- ""
if (any(fill_id != "")) applyFill <- "1"
if (is_cell_style_xf && isTRUE(fill_id == "")) applyFill <- "0"
applyFont <- ""
if (any(font_id != "")) applyFont <- "1"
if (is_cell_style_xf && isTRUE(font_id > "1")) applyFont <- "0"
applyNumberFormat <- ""
if (any(num_fmt_id != "")) applyNumberFormat <- "1"
if (is_cell_style_xf) applyNumberFormat <- "0"
applyProtection <- ""
if (any(hidden != "") || any(locked != "")) applyProtection <- "1"
if (is_cell_style_xf) applyProtection <- "0"
df_cellXfs <- data.frame(
applyAlignment = rep(applyAlignment, n),
applyBorder = rep(applyBorder, n),
applyFill = rep(applyFill, n),
applyFont = rep(applyFont, n),
applyNumberFormat = rep(applyNumberFormat, n),
applyProtection = rep(applyProtection, n),
borderId = rep(as_xml_attr(border_id), n),
fillId = rep(as_xml_attr(fill_id), n),
fontId = rep(as_xml_attr(font_id), n),
numFmtId = as_xml_attr(num_fmt_id),
pivotButton = rep(as_xml_attr(pivot_button), n),
quotePrefix = rep(as_xml_attr(quote_prefix), n),
xfId = rep(as_xml_attr(xf_id), n),
horizontal = rep(as_xml_attr(horizontal), n),
indent = rep(as_xml_attr(indent), n),
justifyLastLine = rep(as_xml_attr(justify_last_line), n),
readingOrder = rep(as_xml_attr(reading_order), n),
relativeIndent = rep(as_xml_attr(relative_indent), n),
shrinkToFit = rep(as_xml_attr(shrink_to_fit), n),
textRotation = rep(as_xml_attr(text_rotation), n),
vertical = rep(as_xml_attr(vertical), n),
wrapText = rep(as_xml_attr(wrap_text), n),
extLst = rep(ext_lst, n),
hidden = rep(as_xml_attr(hidden), n),
locked = rep(as_xml_attr(locked), n),
stringsAsFactors = FALSE
)
cellXfs <- write_xf(df_cellXfs)
cellXfs
}
#' internal function to set border to a style
#' @param xf_node some xf node
#' @param border_id some numeric value as character
#' @noRd
set_border <- function(xf_node, border_id) {
z <- read_xf(read_xml(xf_node))
z$applyBorder <- "1"
z$borderId <- as_xml_attr(border_id)
write_xf(z)
}
#' internal function to set fill to a style
#' @param xf_node some xf node
#' @param fill_id some numeric value as character
#' @noRd
set_fill <- function(xf_node, fill_id) {
z <- read_xf(read_xml(xf_node))
z$applyFill <- "1"
z$fillId <- as_xml_attr(fill_id)
write_xf(z)
}
#' internal function to set font to a style
#' @param xf_node some xf node
#' @param font_id some numeric value as character
#' @noRd
set_font <- function(xf_node, font_id) {
z <- read_xf(read_xml(xf_node))
z$applyFont <- "1"
z$fontId <- as_xml_attr(font_id)
write_xf(z)
}
#' internal function to set numfmt to a style
#' @param xf_node some xf node
#' @param numfmt_id some numeric value as character
#' @noRd
set_numfmt <- function(xf_node, numfmt) {
z <- read_xf(read_xml(xf_node))
z$applyNumberFormat <- "1"
z$numFmtId <- as_xml_attr(numfmt)
write_xf(z)
}
#' internal function to set cellstyle
#' @noRd
set_cellstyle <- function(
xf_node,
applyAlignment,
applyBorder,
applyFill,
applyFont,
applyNumberFormat,
applyProtection,
borderId,
extLst,
fillId,
fontId,
hidden,
horizontal,
indent,
justifyLastLine,
locked,
numFmtId,
pivotButton,
quotePrefix,
readingOrder,
relativeIndent,
shrinkToFit,
textRotation,
vertical,
wrapText,
xfId
) {
z <- read_xf(read_xml(xf_node))
if (!is.null(applyAlignment)) z$applyAlignment <- as_xml_attr(applyAlignment)
if (!is.null(applyBorder)) z$applyBorder <- as_xml_attr(applyBorder)
if (!is.null(applyFill)) z$applyFill <- as_xml_attr(applyFill)
if (!is.null(applyFont)) z$applyFont <- as_xml_attr(applyFont)
if (!is.null(applyNumberFormat)) z$applyNumberFormat <- as_xml_attr(applyNumberFormat)
if (!is.null(applyProtection)) z$applyProtection <- as_xml_attr(applyProtection)
if (!is.null(borderId)) z$borderId <- as_xml_attr(borderId)
if (!is.null(extLst)) z$extLst <- as_xml_attr(extLst)
if (!is.null(fillId)) z$fillId <- as_xml_attr(fillId)
if (!is.null(fontId)) z$fontId <- as_xml_attr(fontId)
if (!is.null(hidden)) z$hidden <- as_xml_attr(hidden)
if (!is.null(horizontal)) z$horizontal <- as_xml_attr(horizontal)
if (!is.null(indent)) z$indent <- as_xml_attr(indent)
if (!is.null(justifyLastLine)) z$justifyLastLine <- as_xml_attr(justifyLastLine)
if (!is.null(locked)) z$locked <- as_xml_attr(locked)
if (!is.null(numFmtId)) z$numFmtId <- as_xml_attr(numFmtId)
if (!is.null(pivotButton)) z$pivotButton <- as_xml_attr(pivotButton)
if (!is.null(quotePrefix)) z$quotePrefix <- as_xml_attr(quotePrefix)
if (!is.null(readingOrder)) z$readingOrder <- as_xml_attr(readingOrder)
if (!is.null(relativeIndent)) z$relativeIndent <- as_xml_attr(relativeIndent)
if (!is.null(shrinkToFit)) z$shrinkToFit <- as_xml_attr(shrinkToFit)
if (!is.null(textRotation)) z$textRotation <- as_xml_attr(textRotation)
if (!is.null(vertical)) z$vertical <- as_xml_attr(vertical)
if (!is.null(wrapText)) z$wrapText <- as_xml_attr(wrapText)
if (!is.null(xfId)) z$xfId <- as_xml_attr(xfId)
write_xf(z)
}
#' Get all styles on a sheet
#'
#' @param wb workbook
#' @param sheet worksheet
#'
#' @export
styles_on_sheet <- function(wb, sheet) {
sheet_id <- wb_validate_sheet(wb, sheet)
z <- unique(wb$worksheets[[sheet_id]]$sheet_data$cc$c_s)
as.numeric(z)
}
#' get xml node for a specific style of a cell. function for internal use
#' @param wb workbook
#' @param sheet worksheet
#' @param cell cell
#' @noRd
get_cell_styles <- function(wb, sheet, cell) {
cellstyles <- wb$get_cell_style(sheet, cell)
out <- NULL
for (cellstyle in cellstyles) {
if (cellstyle == "") {
tmp <- wb$styles_mgr$styles$cellXfs[1]
} else {
tmp <- wb$styles_mgr$styles$cellXfs[as.numeric(cellstyle) + 1]
}
out <- c(out, tmp)
}
out
}
#' Create a custom formatting style
#'
#' @description
#' Create a new style to apply to worksheet cells. Created styles have to be
#' assigned to a workbook to use them
#'
#' @details
#' It is possible to override border_color and border_style with \{left, right, top, bottom\}_color, \{left, right, top, bottom\}_style.
#'
# TODO maybe font_name,font_size could be documented together.
#' @param font_name A name of a font. Note the font name is not validated.
#' If `font_name` is `NULL`, the workbook `base_font` is used. (Defaults to Calibri), see [wb_get_base_font()]
#' @param font_color Color of text in cell. A valid hex color beginning with "#"
#' or one of colors(). If `font_color` is NULL, the workbook base font colors is used.
#' (Defaults to black)
#' @param font_size Font size. A numeric greater than 0.
#' By default, the workbook base font size is used. (Defaults to 11)
#' @param num_fmt Cell formatting. Some custom openxml format
#' @param border `NULL` or `TRUE`
#' @param border_color "black"
#' @param border_style "thin"
#' @param bg_fill Cell background fill color.
#' @param fg_color Cell foreground fill color.
#' @param gradient_fill An xml string beginning with `<gradientFill>` ...
#' @param text_bold bold
#' @param text_strike strikeout
#' @param text_italic italic
#' @param text_underline underline 1, true, single or double
#' @param ... Additional arguments
#' @return A dxfs style node
#' @seealso [wb_add_style()] [wb_add_dxfs_style()]
#' @family style creating functions
#' @examples
#' # do not apply anything
#' style1 <- create_dxfs_style()
#'
#' # change font color and background color
#' style2 <- create_dxfs_style(
#' font_color = wb_color(hex = "FF9C0006"),
#' bgFill = wb_color(hex = "FFFFC7CE")
#' )
#'
#' # change font (type, size and color) and background
#' # the old default in openxlsx and openxlsx2 <= 0.3
#' style3 <- create_dxfs_style(
#' font_name = "Aptos Narrow",
#' font_size = 11,
#' font_color = wb_color(hex = "FF9C0006"),
#' bgFill = wb_color(hex = "FFFFC7CE")
#' )
#'
#' ## See package vignettes for further examples
#' @export
create_dxfs_style <- function(
font_name = NULL,
font_size = NULL,
font_color = NULL,
num_fmt = NULL,
border = NULL,
border_color = wb_color(getOption("openxlsx2.borderColor", "black")),
border_style = getOption("openxlsx2.borderStyle", "thin"),
bg_fill = NULL,
fg_color = NULL,
gradient_fill = NULL,
text_bold = NULL,
text_strike = NULL,
text_italic = NULL,
text_underline = NULL, # "true" or "double"
...
) {
arguments <- c(..., ls(),
"left_color", "left_style", "right_color", "right_style",
"top_color", "top_style", "bottom_color", "bottom_style"
)
standardize(..., arguments = arguments)
if (is.null(font_color)) font_color <- ""
if (is.null(font_size)) font_size <- ""
if (is.null(text_bold)) text_bold <- ""
if (is.null(text_strike)) text_strike <- ""
if (is.null(text_italic)) text_italic <- ""
if (is.null(text_underline)) text_underline <- ""
# found numFmtId=3 in MS365 xml not sure if this should be increased
if (!is.null(num_fmt)) num_fmt <- create_numfmt(3, num_fmt)
font <- create_font(
color = font_color, name = font_name,
sz = as.character(font_size),
b = text_bold, i = text_italic, strike = text_strike,
u = text_underline,
family = "", scheme = ""
)
if (exists("pattern_type")) {
pattern_type <- pattern_type
} else {
pattern_type <- "solid"
}
if (!is.null(bg_fill) && !all(bg_fill == "") || !is.null(gradient_fill)) {
if (is.null(gradient_fill)) {
# gradientFill is an xml string
gradient_fill <- ""
} else {
pattern_type <- ""
}
fill <- create_fill(patternType = pattern_type, bgColor = bg_fill, fgColor = fg_color, gradientFill = gradient_fill)
} else {
fill <- NULL
}
# untested
if (!is.null(border)) {
left_color <- if (exists("left_color")) left_color else border_color
left_style <- if (exists("left_style")) left_style else border_style
right_color <- if (exists("right_color")) right_color else border_color
right_style <- if (exists("right_style")) right_style else border_style
top_color <- if (exists("top_color")) top_color else border_color
top_style <- if (exists("top_style")) top_style else border_style
bottom_color <- if (exists("bottom_color")) bottom_color else border_color
bottom_style <- if (exists("bottom_style")) bottom_style else border_style
border <- create_border(
left = left_style,
left_color = left_color,
right = right_style,
right_color = right_color,
top = top_style,
top_color = top_color,
bottom = bottom_style,
bottom_color = bottom_color
)
}
xml_node_create(
"dxf",
xml_children = c(
font,
num_fmt,
fill,
border
)
)
}
## The functions below are only partially covered, but span over 300+ LOC ##
# nocov start
#' Create custom (pivot) table styles
#'
#' Create a custom (pivot) table style.
#' These functions are for expert use only. Use other styling functions instead.
#'
#' @param name name
#' @param whole_table wholeTable
#' @param header_row,total_row ...Row
#' @param first_column,last_column ...Column
#' @param first_row_stripe,second_row_stripe ...RowStripe
#' @param first_column_stripe,second_column_stripe ...ColumnStripe
#' @param first_header_cell,last_header_cell ...HeaderCell
#' @param first_total_cell,last_total_cell ...TotalCell
#' @param grand_total_row totalRow
#' @param grand_total_column lastColumn
#' @param first_subtotal_column,second_subtotal_column,third_subtotal_column ...SubtotalColumn
#' @param first_subtotal_row,second_subtotal_row,third_subtotal_row ...SubtotalRow
#' @param first_column_subheading,second_column_subheading,third_column_subheading ...ColumnSubheading
#' @param first_row_subheading,second_row_subheading,third_row_subheading ...RowSubheading
#' @param blank_row blankRow
#' @param page_field_labels pageFieldLabels
#' @param page_field_values pageFieldValues
#' @param ... additional arguments
#' @name create_tablestyle
#' @family style creating functions
#' @export
# TODO: combine both functions and simply set pivot=0 or table=0
create_tablestyle <- function(
name,
whole_table = NULL,
header_row = NULL,
total_row = NULL,
first_column = NULL,
last_column = NULL,
first_row_stripe = NULL,
second_row_stripe = NULL,
first_column_stripe = NULL,
second_column_stripe = NULL,
first_header_cell = NULL,
last_header_cell = NULL,
first_total_cell = NULL,
last_total_cell = NULL,
...
) {
standardize_case_names(...)
tab_wholeTable <- NULL
if (length(whole_table)) {
tab_wholeTable <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "wholeTable", dxfId = whole_table))
}
tab_headerRow <- NULL
if (length(header_row)) {
tab_headerRow <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "headerRow", dxfId = header_row))
}
tab_totalRow <- NULL
if (length(total_row)) {
tab_totalRow <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "totalRow", dxfId = total_row))
}
tab_firstColumn <- NULL
if (length(first_column)) {
tab_firstColumn <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "firstColumn", dxfId = first_column))
}
tab_lastColumn <- NULL
if (length(last_column)) {
tab_lastColumn <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "lastColumn", dxfId = last_column))
}
tab_firstRowStripe <- NULL
if (length(first_row_stripe)) {
tab_firstRowStripe <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "firstRowStripe", dxfId = first_row_stripe))
}
tab_secondRowStripe <- NULL
if (length(second_row_stripe)) {
tab_secondRowStripe <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "secondRowStripe", dxfId = second_row_stripe))
}
tab_firstColumnStripe <- NULL
if (length(first_column_stripe)) {
tab_firstColumnStripe <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "firstColumnStripe", dxfId = first_column_stripe))
}
tab_secondColumnStripe <- NULL
if (length(second_column_stripe)) {
tab_secondColumnStripe <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "secondColumnStripe", dxfId = second_column_stripe))
}
tab_firstHeaderCell <- NULL
if (length(first_header_cell)) {
tab_firstHeaderCell <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "firstHeaderCell", dxfId = first_header_cell))
}
tab_lastHeaderCell <- NULL
if (length(last_header_cell)) {
tab_lastHeaderCell <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "lastHeaderCell", dxfId = last_header_cell))
}
tab_firstTotalCell <- NULL
if (length(first_total_cell)) {
tab_firstTotalCell <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "firstTotalCell", dxfId = first_total_cell))
}
tab_lastTotalCell <- NULL
if (length(last_total_cell)) {
tab_lastTotalCell <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "lastTotalCell", dxfId = last_total_cell))
}
xml_elements <- c(
tab_wholeTable,
tab_headerRow,
tab_totalRow,
tab_firstColumn,
tab_lastColumn,
tab_firstRowStripe,
tab_secondRowStripe,
tab_firstColumnStripe,
tab_secondColumnStripe,
tab_firstHeaderCell,
tab_lastHeaderCell,
tab_firstTotalCell,
tab_lastTotalCell
)
rand_str <- random_string(length = 12, pattern = "[A-Z0-9]")
xml_node_create(
"tableStyle",
xml_attributes = c(
name = name,
pivot = "0", # pivot uses different styles
count = as_xml_attr(length(xml_elements)),
# possible st_guid()
`xr9:uid` = sprintf("{CE23B8CA-E823-724F-9713-%s}", rand_str)
),
xml_children = xml_elements
)
}
#' @rdname create_tablestyle
#' @export
create_pivottablestyle <- function(
name,
whole_table = NULL,
header_row = NULL,
grand_total_row = NULL,
first_column = NULL,
grand_total_column = NULL,
first_row_stripe = NULL,
second_row_stripe = NULL,
first_column_stripe = NULL,
second_column_stripe = NULL,
first_header_cell = NULL,
first_subtotal_column = NULL,
second_subtotal_column = NULL,
third_subtotal_column = NULL,
first_subtotal_row = NULL,
second_subtotal_row = NULL,
third_subtotal_row = NULL,
blank_row = NULL,
first_column_subheading = NULL,
second_column_subheading = NULL,
third_column_subheading = NULL,
first_row_subheading = NULL,
second_row_subheading = NULL,
third_row_subheading = NULL,
page_field_labels = NULL,
page_field_values = NULL,
...
) {
standardize_case_names(...)
tab_wholeTable <- NULL
if (length(whole_table)) {
tab_wholeTable <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "wholeTable", dxfId = whole_table))
}
tab_pageFieldLabels <- NULL
if (length(page_field_labels)) {
tab_pageFieldLabels <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "pageFieldLabels", dxfId = page_field_labels))
}
tab_pageFieldValues <- NULL
if (length(page_field_values)) {
tab_pageFieldValues <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "pageFieldValues", dxfId = page_field_values))
}
tab_firstColumnStripe <- NULL
if (length(first_column_stripe)) {
tab_firstColumnStripe <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "firstColumnStripe", dxfId = first_column_stripe))
}
tab_secondColumnStripe <- NULL
if (length(second_column_stripe)) {
tab_secondColumnStripe <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "secondColumnStripe", dxfId = second_column_stripe))
}
tab_firstRowStripe <- NULL
if (length(first_row_stripe)) {
tab_firstRowStripe <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "firstRowStripe", dxfId = first_row_stripe))
}
tab_secondRowStripe <- NULL
if (length(second_row_stripe)) {
tab_secondRowStripe <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "secondRowStripe", dxfId = second_row_stripe))
}
tab_firstColumn <- NULL
if (length(first_column)) {
tab_firstColumn <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "firstColumn", dxfId = first_column))
}
tab_headerRow <- NULL
if (length(header_row)) {
tab_headerRow <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "headerRow", dxfId = header_row))
}
tab_firstHeaderCell <- NULL
if (length(first_header_cell)) {
tab_firstHeaderCell <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "firstHeaderCell", dxfId = first_header_cell))
}
tab_subtotalColumn1 <- NULL
if (length(first_subtotal_column)) {
tab_subtotalColumn1 <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "firstSubtotalColumn", dxfId = first_subtotal_column))
}
tab_subtotalColumn2 <- NULL
if (length(second_subtotal_column)) {
tab_subtotalColumn2 <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "secondSubtotalColumn", dxfId = second_subtotal_column))
}
tab_subtotalColumn3 <- NULL
if (length(third_subtotal_column)) {
tab_subtotalColumn3 <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "thirdSubtotalColumn", dxfId = third_subtotal_column))
}
tab_blankRow <- NULL
if (length(blank_row)) {
tab_blankRow <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "blankRow", dxfId = blank_row))
}
tab_subtotalRow1 <- NULL
if (length(first_subtotal_row)) {
tab_subtotalRow1 <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "firstSubtotalRow", dxfId = first_subtotal_row))
}
tab_subtotalRow2 <- NULL
if (length(second_subtotal_row)) {
tab_subtotalRow2 <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "secondSubtotalRow", dxfId = second_subtotal_row))
}
tab_subtotalRow3 <- NULL
if (length(third_subtotal_row)) {
tab_subtotalRow3 <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "thirdSubtotalRow", dxfId = third_subtotal_row))
}
tab_columnSubheading1 <- NULL
if (length(first_column_subheading)) {
tab_columnSubheading1 <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "firstColumnSubheading", dxfId = first_column_subheading))
}
tab_columnSubheading2 <- NULL
if (length(second_column_subheading)) {
tab_columnSubheading2 <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "secondColumnSubheading", dxfId = second_column_subheading))
}
tab_columnSubheading3 <- NULL
if (length(third_column_subheading)) {
tab_columnSubheading3 <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "thirdColumnSubheading", dxfId = third_column_subheading))
}
tab_rowSubheading1 <- NULL
if (length(first_row_subheading)) {
tab_rowSubheading1 <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "firstRowSubheading", dxfId = first_row_subheading))
}
tab_rowSubheading2 <- NULL
if (length(second_row_subheading)) {
tab_rowSubheading2 <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "secondRowSubheading", dxfId = second_row_subheading))
}
tab_rowSubheading3 <- NULL
if (length(third_row_subheading)) {
tab_rowSubheading3 <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "thirdRowSubheading", dxfId = third_row_subheading))
}
tab_grandTotalColumn <- NULL
if (length(grand_total_column)) {
tab_grandTotalColumn <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "lastColumn", dxfId = grand_total_column))
}
tab_grandTotalRow <- NULL
if (length(grand_total_row)) {
tab_grandTotalRow <- xml_node_create(
"tableStyleElement",
xml_attributes = c(type = "totalRow", dxfId = grand_total_row))
}
xml_elements <- c(
tab_wholeTable,
tab_headerRow,
tab_firstColumn,
tab_grandTotalColumn,
tab_firstRowStripe,
tab_secondRowStripe,
tab_firstColumnStripe,
tab_secondColumnStripe,
tab_firstHeaderCell,
tab_subtotalColumn1,
tab_subtotalColumn2,
tab_subtotalColumn3,
tab_subtotalRow1,
tab_subtotalRow2,
tab_subtotalRow3,
tab_blankRow,
tab_columnSubheading1,
tab_columnSubheading2,
tab_columnSubheading3,
tab_rowSubheading1,
tab_rowSubheading2,
tab_rowSubheading3,
tab_grandTotalRow,
tab_pageFieldLabels,
tab_pageFieldValues
)
rand_str <- random_string(length = 12, pattern = "[A-Z0-9]")
xml_node_create(
"tableStyle",
xml_attributes = c(
name = name,
table = "0", # table uses different styles
count = as_xml_attr(length(xml_elements)),
# possible st_guid()
`xr9:uid` = sprintf("{ADA2BA8A-2FEC-2C46-A01D-%s}", rand_str)
),
xml_children = xml_elements
)
}
#' Create custom color xml schemes
#'
#' Create custom color themes that can be used with [wb_set_base_colors()]. The color input will be checked with [wb_color()], so it must be either a color R from [grDevices::colors()] or a hex value.
#' Default values for the dark argument are: `black`, `white`, `darkblue` and `lightgray`. For the accent argument, the six inner values of [grDevices::palette()]. The link argument uses `blue` and `purple` by default for active and visited links.
#' @name create_colors_xml
#' @param name the color name
#' @param dark four colors: dark, light, brighter dark, darker light
#' @param accent six accent colors
#' @param link two link colors: link and visited link
#' @family style creating functions
#' @examples
#' colors <- create_colors_xml()
#' wb <- wb_workbook()$add_worksheet()$set_base_colors(xml = colors)
#' @export
create_colors_xml <- function(
name = "Base R",
dark = NULL,
accent = NULL,
link = NULL
) {
if (is.null(dark))
dark <- c("black", "white", "darkblue", "lightgray")
if (is.null(accent))
accent <- grDevices::palette()[2:7]
if (is.null(link))
link <- c("blue", "purple")
if (length(dark) != 4) {
stop("dark vector must be of length 4")
}
if (length(accent) != 6) {
stop("accent vector must be of length 6")
}
if (length(link) != 2) {
stop("link vector must be of length 2")
}
colors <- c(dark, accent, link)
colors <- as.character(wb_color(colors))
if (length(colors) != 12) {
stop("colors vector must be of length 12")
}
colors <- vapply(
colors,
function(x) substring(x, 3, nchar(x)),
NA_character_
)
read_xml(
sprintf(
"<a:clrScheme name=\"%s\">
<a:dk1><a:sysClr val=\"windowText\" lastClr=\"%s\"/></a:dk1>
<a:lt1><a:sysClr val=\"window\" lastClr=\"%s\"/></a:lt1>
<a:dk2><a:srgbClr val=\"%s\"/></a:dk2>
<a:lt2><a:srgbClr val=\"%s\"/></a:lt2>
<a:accent1><a:srgbClr val=\"%s\"/></a:accent1>
<a:accent2><a:srgbClr val=\"%s\"/></a:accent2>
<a:accent3><a:srgbClr val=\"%s\"/></a:accent3>
<a:accent4><a:srgbClr val=\"%s\"/></a:accent4>
<a:accent5><a:srgbClr val=\"%s\"/></a:accent5>
<a:accent6><a:srgbClr val=\"%s\"/></a:accent6>
<a:hlink><a:srgbClr val=\"%s\"/></a:hlink>
<a:folHlink><a:srgbClr val=\"%s\"/></a:folHlink>
</a:clrScheme>",
name,
colors[1], # dk1
colors[2], # lt1
colors[3], # dk2
colors[4], # lt2
colors[5], # accent1
colors[6], # accent2
colors[7], # accent3
colors[8], # accent4
colors[9], # accent5
colors[10], # accent6
colors[11], # hlink
colors[12] # folHlink
), pointer = FALSE
)
}
#' @export
#' @rdname create_colors_xml
#' @usage NULL
create_colours_xml <- create_colors_xml
# nocov end
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.