[drawings] add shapes

[JanMarvin]

This is an early idea that requires 5d062ca

# why not introduce a unique color scheme not used anywhere else?
get_color <- function(color, transparaency = 0) {

  alignment_map <- c(
    "0" =   "bg1",
    "1" =   "tx1",
    "2" =   "bg2",
    "3" =   "tx2",
    "4" =   "accent1",
    "5" =   "accent2",
    "6" =   "accent3",
    "7" =   "accent4",
    "8" =   "accent5",
    "9" =   "accent6",
    "10" =  "hlink",
    "11" =  "folHlink",
    "12" =  "phClr",
    "13" =  "dk1",
    "14" =  "lt1",
    "15" =  "dk2",
    "16" =  "lt2"
  )

  if (openxlsx2:::is_wbColour(color)) {

    # <a:gradFill>
    #  <a:gsLst>
    #   <a:gs pos="0">
    #    <a:schemeClr val="accent1">
    #     <a:lumMod val="5000" />
    #     <a:lumOff val="95000" />
    #    </a:schemeClr>
    #   </a:gs>
    #   <a:gs pos="74000">
    #    <a:schemeClr val="accent1">
    #     <a:lumMod val="45000" />
    #     <a:lumOff val="55000" />
    #    </a:schemeClr>
    #   </a:gs>
    #   <a:gs pos="83000">
    #    <a:schemeClr val="accent1">
    #     <a:lumMod val="45000" />
    #     <a:lumOff val="55000" />
    #    </a:schemeClr>
    #   </a:gs>
    #   <a:gs pos="100000">
    #    <a:schemeClr val="accent1">
    #     <a:lumMod val="30000" />
    #     <a:lumOff val="70000" />
    #    </a:schemeClr>
    #   </a:gs>
    #  </a:gsLst>
    #  <a:lin ang="5400000" scaled="1" />
    # </a:gradFill>

    if ("rgb" %in% names(color)) {
      color <- sprintf(
        '<a:solidFill>
        <a:srgbClr val="%s">
          <a:alpha val="%s" />
        </a:srgbClr>
      </a:solidFill>',
        substr(c(color["rgb"]), 3, 8),
        min(99, (100-transparaency)) * 1000
      )
    } else if ("theme" %in% names(color)) {
      color <- sprintf(
        '<a:solidFill>
        <a:schemeClr val="%s">
          <a:alpha val="%s" />
        </a:schemeClr>
      </a:solidFill>',
        alignment_map[color["theme"]],
        min(99, (100-transparaency)) * 1000
      )
    } else {
      warning("currently only rgb and theme colors are supported")
      color <- ""
    }
  } else {
    color <- ""
  }
  color
}

# it should not get to boring, therefore lets add some new string styling
# handles bold, italic, strike, size, font, charset
# unhandled charset, outline, vert_align
fmt_txt2 <- function(txt, text_color = "", transparency = 0) {
  if (!inherits(txt, "fmt_txt")) {
    txt <- fmt_txt(txt)
  }

  txts <- xml_node(txt, "r")

  out <- NULL
  for (txt in txts) { # no need to check for <b val="1"/>
    bold      <- ifelse(grepl("<b/>", txt), "1", "")
    italic    <- ifelse(grepl("<i/>", txt), "1", "")
    strike    <- ifelse(grepl("<strike/>", txt), "sngStrike", "")
    underline <- ifelse(grepl("<u/>", txt), "sng", "")

    color     <- sapply(xml_attr(txt, "r", "rPr", "color"), "[")
    if (length(color) == 0) {
      color   <- get_color(text_color, transparency)
    } else {
      color     <- get_color(wb_color(color), transparency) # tint?
    }

    sz <- sapply(xml_attr(txt, "r", "rPr", "sz"), "[")
    if (length(sz)) sz        <- as.integer(sz[["val"]]) * 100

    font <- sapply(xml_attr(txt, "r", "rPr", "rFont"), "[")
    charset <- sapply(xml_attr(txt, "r", "rPr", "charset"), "[")

    if (length(charset) == 0) charset <- c(val = "0")
    if (length(font)) font <- c(
      sprintf('<a:latin typeface="%s" charset="%s" />', font[["val"]], charset[["val"]]),
      sprintf('<a:cs typeface="%s" charset="%s" />', font[["val"]], charset[["val"]])
    ) else {
      font <- NULL
    }

    rPr <- xml_node_create(
      "a:rPr",
      xml_attributes = c(
        b = openxlsx2:::as_xml_attr(bold),
        i = openxlsx2:::as_xml_attr(italic),
        sz = openxlsx2:::as_xml_attr(sz),
        strike = openxlsx2:::as_xml_attr(strike),
        u  = openxlsx2:::as_xml_attr(underline)
      ),
      xml_children = c(color, font)
    )


    text <- xml_value(txt, "r", "t")
    text <- xml_node_create("a:t", xml_children = text)
    ar   <- xml_node_create("a:r", xml_children = c(rPr, text))

    out <- c(out, ar)
  }

  paste0(out, collapse = "")
}


#' create a preset geometry drawing
#' @param shape pick a nice one from: ST_ShapeType (Preset Shape Types)
#' @param name a name for the object
#' @param text a text written into the object. can use [fmt_txt()]
#' @param fill_color,text_color,line_color. a color for each, accepts only theme and rgb colors passed with [wb_color()]
#' @param fill_transparency,text_transparency,line_transparency an integer value in the range 0 to 100
#' @param text_align any of 'left', 'center', 'right', 'justify', 'justifyLow', 'distributed', 'thaiDistributed'
#' @param ... additional arguments
#' @returns a character containing the XML
#' @seealso [wb_add_drawing()]
#' @examples
#'  wb <- wb_workbook()$add_worksheet()$
#'    add_drawing(xml = create_shape())
#' @export
create_shape <- function(
    shape = "cloud",
    name = "Smiley Face 1",
    text = "",
    fill_color = NULL,
    fill_transparency = 0,
    text_color = NULL,
    text_transparency = 0,
    line_color = fill_color,
    line_transparency = 0,
    text_align = "left",
    ...
) {

  valid <- c("left", "center", "right", "justify", "justifyLow", "distributed",
             "thaiDistributed")
  match.arg(text_align, valid)

  alignment_map <- c(
    "left" = "l",
    "center" = "ctr",
    "right" = "r",
    "justify" = "just",
    "justifyLow" = "justLow",
    "distributed" = "dist",
    "thaiDistributed" = "thaiDist"
  )

  # Function to match full name to shorthand
  text_align <- alignment_map[text_align]

  openxlsx2:::standardize(...)

  text <- fmt_txt2(text, text_color = text_color, text_transparency)

  line_color <- get_color(line_color, line_transparency)
  fill_color <- get_color(fill_color, fill_transparency)

  if (line_color != "") {
    line_color <- sprintf('<a:ln>%s
    </a:ln>', line_color)
  }

  xml <- sprintf('
    <xdr:wsDr xmlns:xdr=\"http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing\" xmlns:a=\"http://schemas.openxmlformats.org/drawingml/2006/main\">
    <xdr:absoluteAnchor>
      <xdr:pos x="0" y="0" />
      <xdr:ext cx="9313333" cy="6070985" />
      <xdr:sp macro="" textlink="">
       <xdr:nvSpPr>
        <xdr:cNvPr id="2" name="%s" />
         <a:extLst>
          <a:ext uri="{FF2B5EF4-FFF2-40B4-BE49-F238E27FC236}">
           <a16:creationId xmlns:a16="http://schemas.microsoft.com/office/drawing/2014/main" id="{00000000-0008-0000-0000-000003000000}" />
          </a:ext>
         </a:extLst>
        <xdr:cNvSpPr />
       </xdr:nvSpPr>
       <xdr:spPr>
        <a:xfrm>
         <a:off x="0" y="0" />
         <a:ext cx="0" cy="0" />
        </a:xfrm>
        <a:prstGeom prst="%s">
         <a:avLst />
        </a:prstGeom>
        %s
        %s
       </xdr:spPr>
       <xdr:style>
        <a:lnRef idx="2">
         <a:schemeClr val="accent1">
          <a:shade val="50000" />
         </a:schemeClr>
        </a:lnRef>
        <a:fillRef idx="1">
         <a:schemeClr val="accent1" />
        </a:fillRef>
        <a:effectRef idx="0">
         <a:schemeClr val="accent1" />
        </a:effectRef>
        <a:fontRef idx="minor">
         <a:schemeClr val="lt1" />
        </a:fontRef>
       </xdr:style>
       <xdr:txBody>
        <a:bodyPr vertOverflow="clip" horzOverflow="clip" rtlCol="0" anchor="t" />
        <a:lstStyle />
        <a:p>
         <a:pPr algn="%s" />
         %s
        </a:p>
       </xdr:txBody>
      </xdr:sp>
      <xdr:clientData />
     </xdr:absoluteAnchor>
    </xdr:wsDr>',
    name, shape, fill_color, line_color, text_align[1], text)

  openxlsx2::read_xml(xml, pointer = FALSE)
}


## heart
txt <- fmt_txt("openxlsx2 is the \n", bold = TRUE, size = 15) +
  fmt_txt("best", underline = TRUE, bold = TRUE, size = 15) +
  fmt_txt("\n!", bold = TRUE, size = 15)

heart <- create_shape(
  shape = "heart", text = txt, text_align = "center",
  fill_colour = wb_color("pink"), text_colour = wb_color("red"))

## ribbon
txt <- fmt_txt("\nthe ") +
  fmt_txt("very", underline = TRUE, font = "Courier", color = wb_color("gold")) +
  fmt_txt(" best")

ribbon <- create_shape(shape = "ribbon", text = txt, text_align = "center")

wb <- wb_workbook()$add_worksheet(grid_lines = FALSE)$
  add_drawing(dims = "B2:E11", xml = heart)$
  add_drawing(dims = "B12:E14", xml = ribbon)$
  add_worksheet()$add_drawing(dims = "B2:E5", xml = create_shape("rect", text = txt, fill_color = wb_color(theme = 5), fill_transparency =  50))

if (interactive()) wb$open()

[JanMarvin]

This is now merged into main. #1231