R/draw.R

In be-pr/drawsvg: DSL For Drawing SVG Graphics

## Copyright (c) 2018, 2019, 2020 Bernhard Pröll

## This program is free software; you can redistribute it and/or modify it
## under the terms of the GNU General Public License as published by the Free
## Software Foundation, either version 3 of the License, or (at your option)
## any later version.

## This program is distributed in the hope that it will be useful, but WITHOUT
## ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
## FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for
## more details.

## You should have received a copy of the GNU General Public License along with
## this program.  If not, see <http://www.gnu.org/licenses/>.

defs <- function(..., collapse = "\n") {
    paste0(c("<defs>", c(...), "</defs>"),
           collapse = collapse)
}

args2attributes <- function(excl = c("...", "collapse")) {
    nparent <- sys.parent()
    xs <- as.list(sys.call(nparent))
    name <- xs[1L]
    xs[[1L]] <- NULL
    defs <- formals(sys.function(nparent))
    ## Remove parameters associated with an empty name.
    empty <- vapply(defs, function(x) identical(x, quote(expr =)),
                    logical(1L), USE.NAMES = FALSE)
    defs <- defs[!empty]
    xs <- c(xs, defs[setdiff(names(defs), names(xs))])
    matched <- match.call(sys.function(nparent), as.call(c(name, xs)),
                          expand.dots = FALSE,
                          envir = parent.frame(2L))
    matched[[1L]] <- NULL
    matched <- matched[!match(names(matched), excl, nomatch = 0L)]
    if (identical(length(matched), 0L)) return("")
    args <- eval(matched, parent.frame(2L))
    numidx <- suppressWarnings(!is.na(as.numeric(args)))
    args[numidx] <- round(unlist(args[numidx]), 2L)
    attrs <- paste(names(args), sQuote(args), sep = "=", collapse = " ")
    return(sprintf(" %s", paste(attrs, collapse = " ")))
}

svg_filter <-
    function(..., x = 0L, y = 0L, width, height, class, id, collapse = "\n") {
        attrs <- args2attributes()
        paste0(c(sprintf("<filter%s>", attrs), c(...), "</filter>"),
               collapse = collapse)
}

fegaussianblur <-
    function(`in`, stdDeviation, edgeMode, result, collapse = "\n") {
        paste0("<feGaussianBlur", args2attributes(), "/>",
               collapse = collapse)
}

feoffset <-
    function(dx = 0L, dy = 0L, `in`, result, collapse = "\n") {
        attrs <-  args2attributes()
        paste0("<feOffset", attrs, "/>", collapse = collapse)
}

feflood <- function(`in`, result, `flood-color`, `flood-opacity`,
                    collapse = "\n") {
    paste0("<feFlood", args2attributes(), "/>", collapse = collapse)
}

femerge <- function(...) {
    call <- match.call()
    call[[1L]] <- quote(c)
    nodes <- as.character(substitute(call)[-1L])
    acc <- "<feMerge>"
    for (node in nodes) {
        acc <- paste0(acc, "<feMergeNode in=", sQuote(node), "/>",
                      collapse = " ")
    }
    return(paste0(acc, "</feMerge>"))
}

style <- function(..., collapse = "\n") {
    rules <- c(...)
    if (is.null(rules))
        stop("No rules defined", call. = FALSE)
    paste0(c("<style type='text/css'>", rules, "</style>"),
           collapse = collapse)
}

css_rule <- function(selector, ..., collapse = "\n") {
    sel <- substitute(selector)
    if (is.call(sel))
        sel <- deparse(sel, control = NULL)
    decls <- paste0(c(...), sep = ";", collapse = collapse)
    paste0(c(paste(sel, "{"),
             paste0(decls, collapse = collapse),
             "}"),
           collapse = collapse)
}

draw_svg <- function(..., width, height, version, preserveAspectRatio, file,
                     viewBox = c(x = 0L, y = 0L, width = 0L, height = 0L)) {
    if (missing(file))
        stop("Output file argument required", call. = FALSE)
    attrs <- args2attributes(excl = c("...", "file", "viewBox"))
    elements <- c(...)
    cat("<svg xmlns='http://www.w3.org/2000/svg'",
        do.call("sprintf",
                as.list(c(" viewBox='%s %s %s %s'", viewBox))),
        attrs, ">\n",
        if (!is.null(elements))
            paste0(elements, collapse = "\n"),
        "\n</svg>",
        sep = "", file = file)
    invisible()
}

draw_text <- function(text, x = 0L, y = 0L, fill, `font-size`,
                      `font-family`, `font-weight`, `text-anchor`,
                      transform, class, id, visibility, sep = "") {
    attrs <- args2attributes(excl = c("text", "sep"))
    paste(paste0("<text", attrs, ">"), text, "</text>", sep = sep)
}

tspan <- function(text, x, y, dx, dy, `font-weight`, `text-anchor`,
                  fill, class, id) {
    attrs <- args2attributes(excl = "text")
    paste0("<tspan", attrs, ">", text, "</tspan>")
}

foreignobject <- function(..., x = 0L, y = 0L, width, height, style,
                          collapse = "\n") {
    attrs <- args2attributes()
    paste0("<foreignObject", attrs,
           " requiredExtensions='http://www.w3.org/1999/xhtml'>\n",
           c(...), "\n</foreignObject>",
           collapse = collapse)
}

draw_polygon <- function(x, y, fill, stroke, class) {
    paste0("<polygon points='",
           paste(x, y, sep = ",", collapse = " "), "'",
           args2attributes(excl = c("x", "y", "collapse")),
           "/>")
}

draw_rect <- function(x = 0L, y = 0L, width, height, rx, ry,
                      fill, stroke, class, id, animate) {
    attrs <- args2attributes(excl = "animate")
    paste0("<rect", attrs,
           if (!missing(animate))
               paste0(c(">", animate, "</rect>"), collapse = "\n")
           else "/>")
}

animateTransform <- function(attributeName, type, from, to, dur, values, begin,
                             repeatCount, restart, fill) {
    attrs <- args2attributes()
    paste0("<animateTransform attributeType='XML'", attrs, "/>")
}

animate <- function(attributeName, from, to, dur, values, begin, repeatCount,
                    restart, calcMode, fill) {
    attrs <- args2attributes()
    paste0("<animate attributeType='XML'", attrs, "/>")
}

draw_line <- function(x1 = 0L, x2 = 0L, y1 = 0L, y2 = 0L, stroke,
                      `stroke-dasharray`, class, id, animate) {
    attrs <- args2attributes(excl = "animate")
    paste0("<line", attrs,
           if (!missing(animate))
               paste0(c(">", animate, "</line>"), collapse = "\n")
           else "/>")
}

draw_circle <- function(cx = 0L, cy = 0L, r = 0L,
                        fill, stroke, class, id) {
    attrs <- args2attributes()
    paste0("<circle", attrs, "/>")
}

draw_path <- function(d = "", fill, stroke, class, id) {
    attrs <- args2attributes()
    paste0("<path", attrs, "/>")
}

d <- function(...) {
    call <- substitute(list(...))
    e <- parent.frame()
    e$comma <- ","
    call[[1L]] <- NULL
    acc <- character(0L)
    for (i in call) {
        if (is.atomic(i))
            acc <- c(acc, deparse(i, control = NULL))
        else if (is.call(i))
            acc <- c(acc, eval(i, envir = e))
        else if (deparse(i, control = NULL) %in% objects(e))
            acc <- c(acc, eval(i, envir = e))
        else
            acc <- c(acc, deparse(i, control = NULL))
    }
    str <- paste0(acc, collapse = " ")
    return(gsub(" , ", ",", str))
}

g <- function(..., attrs, collapse = "\n") {
    attributes <-
        if (!missing(attrs))
            mapply(function(n, v) sprintf(" %s=%s", n, sQuote(v)),
                   names(attrs),
                   unlist(attrs),
                   SIMPLIFY = FALSE,
                   USE.NAMES = FALSE)
    paste0("<g", paste0(attributes, collapse = ""), ">\n",
           paste(c(...), collapse = collapse),
           "\n</g>")
}

draw_title <- function(text) {
    paste0("<title>", text, "</title>")
}