R/filters.R

Defines functions forceGrob.filtered.grob feTurbulence filterSVG.fe.turbulence feTile filterSVG.fe.tile feSpecularLighting filterSVG.fe.specular.lighting flatten.fe.specular.lighting feOffset filterSVG.fe.offset flatten.fe.offset feMorphology flatten.fe.morphology filterSVG.fe.morphology addMergeNode feMergeNode filterSVG.fe.merge.node feMerge filterSVG.fe.merge feImage filterSVG.fe.image feGaussianBlur filterSVG.fe.gaussian.blur feFlood filterSVG.fe.flood feDisplacementMap filterSVG.fe.displacement.map feDiffuseLighting filterSVG.fe.diffuse.lighting flatten.fe.diffuse.lighting feConvolveMatrix filterSVG.fe.convolve.matrix feComposite filterSVG.fe.composite transferFunction filterSVG.transfer.function addComponentFunction feComponentTransfer filterSVG.fe.component.transfer feColorMatrix filterSVG.fe.color.matrix feBlend filterSVG.fe.blend feSpotLight filterSVG.fe.spot.light flatten.fe.spot.light fePointLight filterSVG.fe.point.light flatten.fe.point.light feDistantLight filterSVG.fe.distant.light fe flatten.filter.effect filterSVG roundAttribs compileUnits cleanAttrs drawDef.filterDef svgFilter registerFilter flatten.filter flatten addFilterEffect filterEffect primToDev.filtered.grob filterGrob grid.filter

Documented in addComponentFunction addFilterEffect addMergeNode fe feBlend feColorMatrix feComponentTransfer feComposite feConvolveMatrix feDiffuseLighting feDisplacementMap feDistantLight feFlood feGaussianBlur feImage feMerge feMergeNode feMorphology feOffset fePointLight feSpecularLighting feSpotLight feTile feTurbulence filterEffect filterGrob grid.filter registerFilter transferFunction

# High level functions for applying filters to grobs
grid.filter <- function(path, filter = NULL, label = NULL,
                        group = TRUE, redraw = FALSE,
                        strict = FALSE, grep = FALSE, global = FALSE) {
    if (is.null(filter) & is.null(label)) {
        stop("At least one of 'filter' or 'label' must be supplied")
    } else if (is.null(label)) {
        label <- getNewLabel("gridSVG.filter")
        registerFilter(label, filter)
        filter <- NULL # use the ref from now on
    } else if (is.null(filter)) {
        checkForDefinition(label)
    } else {
        checkExistingDefinition(label)
        registerFilter(label, filter)
        filter <- NULL # use the ref from now on
    }

    grobApply(path, function(path) {
        grid.set(path, filterGrob(grid.get(path), filter = filter,
                                  label = label, group = group),
                 redraw = redraw)
    }, strict = strict, grep = grep, global = global)

    invisible()
}

filterGrob <- function(x, filter = NULL, label = NULL, group = TRUE) {
    if (is.null(filter) & is.null(label)) {
        stop("At least one of 'filter' or 'label' must be supplied")
    } else if (is.null(label)) {
        label <- getNewLabel("gridSVG.filter")
        registerFilter(label, filter)
    } else if (is.null(filter)) {
        checkForDefinition(label)
    } else {
        checkExistingDefinition(label)
        registerFilter(label, filter)
    }

    x$referenceLabel <- c(x$referenceLabel, label)
    # Attribs to be garnished *at draw time*. In particular needs to be
    # done because the label ID is not known until then, because of things
    # like prefixes and separators.
    x$filterLabel <- label
    x$filterGroup <- group
    class(x) <- unique(c("filtered.grob", class(x)))
    x
}

primToDev.filtered.grob <- function(x, dev) {
    setLabelUsed(x$referenceLabel)
    label <- getLabelID(x$filterLabel)
    fg <- garnishGrob(x, filter = paste0("url(#", label, ")"),
                      group = x$filterGroup)
    # Now need to remove all filter appearances in the class list.
    # This is safe because repeated filtering just clobbers existing
    # attributes.
    cl <- class(fg)
    class(fg) <- cl[cl != "filtered.grob"]
    primToDev(fg, dev)
}

filterEffect <- function(feList = NULL, filterUnits = c("coords", "bbox"),
                         x = unit(0.5, "npc"), y = unit(0.5, "npc"),
                         width = unit(1, "npc"), height = unit(1, "npc"),
                         just = "centre", hjust = NULL, vjust = NULL,
                         default.units = "npc",
                         primitiveUnits = c("coords", "bbox")) {
    filterUnits <- match.arg(filterUnits)
    primitiveUnits <- match.arg(primitiveUnits)
    if (is.null(feList))
        feList <- list()
    if (inherits(feList, "filter.effect"))
        feList <- list(feList)
    
    if (! is.unit(x))
        x <- unit(x, default.units)
    if (! is.unit(y))
        y <- unit(y, default.units)
    if (! is.unit(width))
        width <- unit(width, default.units)
    if (! is.unit(height))
        height <- unit(height, default.units)

    # Convert filterUnits to SVG values
    filterUnits <- switch(filterUnits,
                          bbox = "objectBoundingBox",
                          coords = "userSpaceOnUse")
    primitiveUnits <- switch(primitiveUnits,
                             bbox = "objectBoundingBox",
                             coords = "userSpaceOnUse")

    # Need to get npc-like values from units
    if (filterUnits == "objectBoundingBox") {
        # Convert to npc 
        x <- convertX(x, "npc", valueOnly = TRUE)
        y <- convertY(y, "npc", valueOnly = TRUE)
        width <- convertWidth(width, "npc", valueOnly = TRUE)
        height <- convertHeight(height, "npc", valueOnly = TRUE)
    }

    filter <- list(filterUnits = filterUnits,
                   primitiveUnits = primitiveUnits,
                   x = x, y = y,
                   width = width, height = height,
                   just = just, hjust = hjust, vjust = vjust,
                   children = feList)
    class(filter) <- "filter"
    filter
}

"[.filter" <- function(x, index, ...) {
    x$children <- x$children[index]
    x
}

"[[.filter" <- function(x, index, ...) {
    x$children[[index]]
}

"[<-.filter" <- function(x, index, ..., value) {
    x$children[index] <- value
    x
}

"[[<-.filter" <- function(x, index, ..., value) {
    if (! inherits(value, "filter.effect"))
        stop("Invalid value to assign")
    x$children[[index]] <- value
    x
}

addFilterEffect <- function(filter, filterEffect, after = NA) {
    if (! inherits(filter, "filter"))
        stop("'filter' is not an 'filter' object")
    if (! inherits(filterEffect, "filter.effect"))
        stop("'filterEffect' is not a 'filter.effect' object")
    # Assume last
    if (is.na(after))
        after <- length(filter$children)
    filter$children[[after + 1]] <- filterEffect
    filter
}

flatten <- function(x, coords) {
    UseMethod("flatten")
}

flatten.filter <- function(x, coords = TRUE) {
    if (coords) {
        loc <- leftbottom(x$x, x$y, x$width, x$height,
                          x$just, x$hjust, x$vjust, NULL)
        x$x <- loc$x
        x$y <- loc$y
        x$width <- convertWidth(x$width, "inches")
        x$height <- convertHeight(x$height, "inches")
    } else {
        # location and width are relative to the object bounding box
        # (i.e., NOT grid units)
        hjust <- resolveHJust(x$just, x$hjust)
        vjust <- resolveVJust(x$just, x$vjust)
        x$x <- x$x - hjust*x$width
        x$y <- x$y - vjust*x$height
    }

    # Now flatten all children
    x$children <- lapply(x$children, flatten, x$primitiveUnits == "userSpaceOnUse")

    x 
}

registerFilter <- function(label, filter) {
    checkExistingDefinition(label)
    if (! length(filter$children))
        stop("No filter effects exist for this filter.")
    
    # Flattening all locations
    filter <- flatten(filter, filter$filterUnits == "userSpaceOnUse")

    filter$label <- label
    filter$id <- getID(label, "ref")
    filter$vp <- getAbsoluteVp()
    class(filter) <- "filterDef"

    refDefinitions <- get("refDefinitions", envir = .gridSVGEnv)
    refDefinitions[[label]] <- filter
    assign("refDefinitions", refDefinitions, envir = .gridSVGEnv)
    assign("refUsageTable",
           rbind(get("refUsageTable", envir = .gridSVGEnv),
                 data.frame(label = label, used = FALSE,
                            stringsAsFactors = FALSE)),
           envir = .gridSVGEnv)

    # Return NULL invisibly because we don't actually care what the
    # definition looks like until gridSVG tries to draw it. 
    invisible()
}

svgFilter <- function(def, dev) {
    svgdev <- dev@dev

    if (def$filterUnits == "userSpaceOnUse") {
        def$x <- cx(def$x, dev)
        def$y <- cy(def$y, dev)
        def$width <- cw(def$width, dev)
        def$height <- ch(def$height, dev)
    }

    filter <- newXMLNode("filter",
                         attrs = list(id = def$id,
                                      x = round(def$x, 2),
                                      y = round(def$y, 2),
                                      width = round(def$width, 2),
                                      height = round(def$height, 2),
                                      filterUnits = def$filterUnits,
                                      primitiveUnits = def$primitiveUnits),
                         parent = svgDevParent(svgdev))
    svgDevChangeParent(filter, svgdev)
}

drawDef.filterDef <- function(def, dev) {
    svgdev <- dev@dev

    svgFilter(def, dev)

    # Adding the gradient stops
    children <- def$children
    for (i in 1:length(children)) {
        oldclass <- class(children[[i]])
        child <- cleanAttrs(children[[i]], c("just", "hjust", "vjust"))
        child <- compileUnits(child, def$primitiveUnits == "userSpaceOnUse",
                              dev)
        class(child) <- oldclass
        filterSVG(child, dev)
    }

    # Going back up from the filter to the parent of the filter
    svgDevChangeParent(xmlParent(svgDevParent(svgdev)), svgdev)
}

# Remove unnecessary attributes
cleanAttrs <- function(x, attrs = "") {
    ns <- names(x)
    rmInds <- which(ns %in% attrs)
    if (length(rmInds))
        x[-rmInds]
    else
        x
}

# All filter effects have these in common,
# compile the units to px to allow us to have more specific
# methods later
compileUnits <- function(x, coords, dev) {
    # Only resolve child x/y/w/h to px if UserSpaceOnUse
    # (otherwise, x/y/w/h are already just [bbox] values)
    if (coords) {
        x$x <- cx(x$x, dev)
        x$y <- cy(x$y, dev)
        x$width <- cw(x$width, dev)
        x$height <- ch(x$height, dev)
    }
    x
}

# rounding all numerics to 2 dp
roundAttribs <- function(x) {
    lapply(x, function(a) {
        if (is.numeric(a))
            round(a, 2)
        else
            a
    })
}

filterSVG <- function(x, dev) {
    UseMethod("filterSVG")
}

##################
# Filter Effects #
##################

# Light sources

flatten.filter.effect <- function(x, coords = TRUE) {
    loc <- leftbottom(x$x, x$y, x$width, x$height,
                      x$just, x$hjust, x$vjust, NULL)
    if (coords) {
        x$x <- loc$x
        x$y <- loc$y
        x$width <- convertWidth(x$width, "inches")
        x$height <- convertHeight(x$height, "inches")
    } else {
        x$x <- convertX(loc$x, "npc", valueOnly = TRUE)
        x$y <- convertY(loc$y, "npc", valueOnly = TRUE)
        x$width <- convertWidth(x$width, "npc", valueOnly = TRUE)
        x$height <- convertHeight(x$height, "npc", valueOnly = TRUE)
    }
    x$coords <- coords
    x
}

fe <- function(..., x = unit(0.5, "npc"), y = unit(0.5, "npc"),
               width = unit(1, "npc"), height = unit(1, "npc"),
               just = "centre", hjust = NULL, vjust = NULL,
               default.units = "npc", result = NULL) {
    if (! is.unit(x))
        x <- unit(x, default.units)
    if (! is.unit(y))
        y <- unit(y, default.units)
    if (! is.unit(width))
        width <- unit(width, default.units)
    if (! is.unit(height))
        height <- unit(height, default.units)

    x <- list(x = x, y = y,
              width = width, height = height,
              just = just, hjust = hjust, vjust = vjust)
    if (! is.null(result) && nzchar(result))
        x$result <- result
    x <- c(x, list(...))
    class(x) <- "filter.effect"
    x
}

filterSVG.fe.distant.light <- function(x, dev) {
    svgdev <- dev@dev
    x <- cleanAttrs(x, "coords")
    newXMLNode("feDistantLight",
               attrs = roundAttribs(x),
               parent = svgDevParent(svgdev))
}

feDistantLight <- function(azimuth = 0, elevation = 0, ...) {
    x <- fe(azimuth = azimuth, elevation = elevation, ...)
    class(x) <- c("fe.distant.light", class(x))
    x
}

flatten.fe.point.light <- function(x, coords = TRUE) {
    if (coords) {
        x$z <- if (x$zdim == "x") convertX(x$z, "inches")
               else convertY(x$z, "inches")
    } else {
        x$z <- if (x$dzim == "x") convertX(x$z, "npc", valueOnly = TRUE)
               else convertY(x$z, "npc", valueOnly = TRUE)
    }
    x$coords <- coords

    NextMethod()
}

filterSVG.fe.point.light <- function(x, dev) {
    svgdev <- dev@dev
    if (x$coords)
        x$z <- if (x$zdim == "x") cx(x$z, dev) else cy(x$z, dev)
    attrList <- cleanAttrs(x, c("coords", "zdim"))
    newXMLNode("fePointLight",
               attrs = roundAttribs(attrList),
               parent = svgDevParent(svgdev))
}

fePointLight <- function(z = unit(0, "npc"), default.units = "npc",
                         zdim = "x", ...) {
    if (! is.unit(z))
        z <- unit(z, default.units)
    x <- fe(z = z, zdim = zdim, default.units = default.units, ...)
    class(x) <- c("fe.point.light", class(x))
    x
}

flatten.fe.spot.light <- function(x, coords = TRUE) {
    if (coords) {
        x$z <- if (x$zdim == "x") convertX(x$z, "inches")
               else convertY(x$z, "inches")
        x$pointsAtZ <- if (x$zdim == "x") convertX(x$pointsAtZ, "inches")
                       else convertY(x$pointsAtZ, "inches")
        x$pointsAtX <- convertX(x$pointsAtX, "inches")
        x$pointsAtY <- convertY(x$pointsAtY, "inches")
    } else {
        x$z <- if (x$dzim == "x") convertX(x$z, "npc", valueOnly = TRUE)
               else convertY(x$z, "npc", valueOnly = TRUE)
        x$pointsAtZ <- if (x$zdim == "x") convertX(x$pointsAtZ, "npc", valueOnly = TRUE)
                       else convertY(x$pointsAtZ, "npc", valueOnly = TRUE)
        x$pointsAtX <- convertX(x$pointsAtX, "npc", valueOnly = TRUE)
        x$pointsAtY <- convertY(x$pointsAtY, "npc", valueOnly = TRUE)
    }
    x$coords <- coords

    NextMethod()
}

filterSVG.fe.spot.light <- function(x, dev) {
    svgdev <- dev@dev
    if (x$coords) {
        x$z <- if (x$zdim == "x") cw(x$z, dev) else cy(x$z, dev)
        x$pointsAtZ <- if (x$zdim == "x") cw(x$pointsAtZ, dev)
                       else cy(x$pointsAtZ, dev)
        x$pointsAtX <- cx(x$x, dev)
        x$pointsAtY <- cy(x$pointsAtY, dev)
    }
    attrList <- cleanAttrs(x, c("coords", "zdim"))
    newXMLNode("feSpotLight",
               attrs = roundAttribs(attrList),
               parent = svgDevParent(svgdev))
}

feSpotLight <- function(x = unit(0, "npc"), y = unit(0, "npc"), z = unit(0, "npc"),
                        pointsAtX = unit(1, "npc"), pointsAtY = unit(1, "npc"), pointsAtZ = unit(0, "npc"),
                        zdim = "x", default.units = "npc",
                        specularExponent = 1, limitingConeAngle = NA, ...) {
    if (! is.unit(x))
        x <- unit(x, default.units)
    if (! is.unit(y))
        y <- unit(y, default.units)
    if (! is.unit(z))
        z <- unit(z, default.units)
    if (! is.unit(pointsAtX))
        pointsAtX <- unit(pointsAtX, default.units)
    if (! is.unit(pointsAtY))
        pointsAtY <- unit(pointsAtY, default.units)
    if (! is.unit(pointsAtZ))
        pointsAtZ <- unit(pointsAtZ, default.units)
    x <- fe(x = x, y = y, z = z,
            pointsAtX = pointsAtX, pointsAtY = pointsAtY, pointsAtZ = pointsAtZ,
            zdim = zdim, default.units = default.units,
            specularExponent = specularExponent, ...)
    if (! is.na(limitingConeAngle))
        x$limitingConeAngle <- limitingConeAngle
    class(x) <- c("fe.spot.light", class(x))
    x
}

filterSVG.fe.blend <- function(x, dev) {
    svgdev <- dev@dev
    x <- cleanAttrs(x, "coords")
    newXMLNode("feBlend",
               attrs = roundAttribs(x), parent = svgDevParent(svgdev))
}

feBlend <- function(input1 = NA, input2 = NA,
                    mode = c("normal", "multiply", "screen", "darken", "lighten"),
                    ...) {
    x <- fe(mode = match.arg(mode), ...)
    if (! is.na(input1))
        x$`in` <- input1
    if (! is.na(input2))
        x$in2 <- input2
    class(x) <- c("fe.blend", class(x))
    x
}

filterSVG.fe.color.matrix <- function(x, dev) {
    svgdev <- dev@dev
    attrList <- x
    if (x$type == "luminanceToAlpha")
        attrList <- cleanAttrs(attrList, "values")
    if (x$type == "matrix")
        attrList$values <- paste0(c(attrList$values), collapse = " ")

    attrList <- cleanAttrs(attrList, "coords")
    newXMLNode("feColorMatrix",
               attrs = roundAttribs(attrList),
               parent = svgDevParent(svgdev))
}

feColorMatrix <- function(input = NA,
                          type = c("matrix", "saturate", "hueRotate", "luminanceToAlpha"),
                          values = NULL, ...) {
    # Checking validity of args
    if (type == "matrix" && (! is.matrix(values) || ! dim(values) == c(4, 5)))
        stop("'values' must be a 4x5 numeric matrix when 'type' is 'matrix'")
    if (type == "saturate" && ! is.numeric(values))
        stop("'values' must be a single element numeric vector for 'saturate'")
    if (type == "hueRotate" && ! is.numeric(values))
        stop("'values' must be a single element numeric vector for 'hueRotate'")
    if (type == "luminanceToAlpha" && ! is.null(values))
        stop("'values' must be NULL for the 'luminanceToAlpha' color matrix effect")
    
    # Clamp values to valid bounds
    if (type == "matrix")
        # Need to transpose matrix so that it is written out in row-order
        values <- t(matrix(pmax(0, pmin(1, values)), ncol = 5, nrow = 4))
    if (type == "saturate")
        values <- max(0, min(1, values))
    if (type == "hueRotate")
        values <- values %% 360

    x <- fe(type = match.arg(type), values = values, ...)
    if (! is.na(input))
        x$`in` <- input
    class(x) <- c("fe.color.matrix", class(x))
    x
}

filterSVG.fe.component.transfer <- function(x, dev) {
    svgdev <- dev@dev

    parentAttrs <- cleanAttrs(x, c("coords", "transfers"))
    children <- x$transfers

    cm <- newXMLNode("feComponentTransfer",
                     attrs = roundAttribs(parentAttrs),
                     parent = svgDevParent(svgdev))

    if (! length(children))
        return()

    svgDevChangeParent(cm, svgdev)

    for (i in 1:length(children)) {
        child <- children[[i]]
        child$channel <- names(children)[i]
        filterSVG(child, dev)
    }

    svgDevChangeParent(xmlParent(cm), svgdev)
}

feComponentTransfer <- function(input = NA, transfers = NULL, ...) {
    if (is.null(transfers))
        transfers <- list()
    x <- fe(transfers = transfers, ...)
    if (! is.na(input))
        x$`in` <- input
    class(x) <- c("fe.component.transfer", class(x))
    x
}

addComponentFunction <- function(ct, channel = c("R", "G", "B", "A"), func) {
    if (! inherits(ct, "fe.component.transfer"))
        stop("'ct' must be a 'fe.component.transfer' object")
    if (! inherits(func, "transfer.function"))
        stop("'func' must be a 'transfer.function' object")
    ct$children[[channel]] <- func
    ct
}

filterSVG.transfer.function <- function(x, dev) {
    svgdev <- dev@dev

    # Need to format tableValues as a whitespace/comma separated list
    if (x$type == "table" | x$type == "discrete")
        x$tableValues <- paste0(round(x$tableValues, 2), collapse = " ")

    x <- cleanAttrs(x, "coords")
    newXMLNode(paste0("feFunc", x$channel),
               attrs = roundAttribs(x), parent = svgDevParent(svgdev))
}

transferFunction <- function(type = c("identity", "table", "discrete", "linear", "gamma"),
                             tableValues = numeric(),
                             slope = 1, intercept = 0,
                             amplitude = 1, exponent = 1, offset = 0) {
    x <- list(type = match.arg(type))
    if (x$type == "table" | x$type == "discrete") {
        if (! length(tableValues))
            stop("A non-zero vector of numeric values must be provided")
        x$tableValues <- tableValues
    }
    if (x$type == "linear") {
        x$slope <- slope
        x$intercept <- intercept
    }
    if (x$type == "") {
        x$amplitude <- amplitude
        x$exponent <- exponent
        x$offset <- offset
    }
    class(x) <- "transfer.function"
    x
}

filterSVG.fe.composite <- function(x, dev) {
    svgdev <- dev@dev
    x <- cleanAttrs(x, "coords")
    newXMLNode("feComposite",
               attrs = roundAttribs(x),
               parent = svgDevParent(svgdev))
}

feComposite <- function(input1 = NA, input2 = NA,
                        operator = c("over", "in", "out", "atop", "xor", "arithmetic"),
                        k1 = 0, k2 = 0, k3 = 0, k4 = 0, ...) {
    x <- fe(operator = match.arg(operator), ...)
    if (! is.na(input1))
        x$`in` <- input1
    if (! is.na(input2))
        x$in2 <- input2
    if (x$operator == "arithmetic") {
        x$k1 <- k1
        x$k2 <- k2 
        x$k3 <- k3
        x$k4 <- k4
    }
    class(x) <- c("fe.composite", class(x))
    x
}

filterSVG.fe.convolve.matrix <- function(x, dev) {
    svgdev <- dev@dev

    if (length(x$order) > 1)
        x$order <- paste0(x$order, collapse = " ")

    if (! is.null(x$kernelUnitLength))
        x$kernelUnitLength <- paste0(round(x$kernelUnitLength, 2),
                                     collapse = " ")

    x$kernelMatrix <- paste0(apply(x$kernelMatrix, 1, function(x) {
        paste0(round(x, 2), collapse = " ")
    }), collapse = " ")

    x <- cleanAttrs(x, "coords")
    newXMLNode("feConvolveMatrix",
               attrs = roundAttribs(x),
               parent = svgDevParent(svgdev))
}

feConvolveMatrix <- function(input = NA, order = 3,
                             kernelMatrix = matrix(),
                             divisor = 1, bias = 0,
                             targetX = 1, targetY = 1,
                             edgeMode = c("duplicate", "wrap", "none"),
                             kernelUnitLength = NA,
                             preserveAlpha = FALSE, ...) {
    # Note that defaults for targetX and targetY are: floor(order[1:2] / 2)
    # This is going to be 1 by default, as floor(1.5) is 1
    if (length(order) == 1)
        order <- rep(order, 2)

    if (length(kernelMatrix) != (order[1] * order[2]))
        stop("Invalid number of entries for 'kernelMatrix'")

    x <- fe(order = order, kernelMatrix = kernelMatrix,
            divisor = divisor, bias = bias, targetX = targetX,
            targetY = targetY, edgeMode = match.arg(edgeMode),
            preserveAlpha = preserveAlpha, ...)
    if (! is.na(input))
        x$`in` <- input
    if (! is.na(kernelUnitLength)) {
        if (length(kernelUnitLength) == 1)
            kernelUnitLength <- rep(kernelUnitLength, 2)
        x$kernelUnitLength <- kernelUnitLength
    }
    class(x) <- c("fe.convolve.matrix", class(x))
    x
}

flatten.fe.diffuse.lighting <- function(x, coords = TRUE) {
    x$lightSource <- flatten(x$lightSource, coords)
    x$coords <- coords
    NextMethod()
}

filterSVG.fe.diffuse.lighting <- function(x, dev) {
    svgdev <- dev@dev

    if (! is.null(x$kernelUnitLength))
        x$kernelUnitLength <- paste0(round(x$kernelUnitLength, 2),
                                     collapse = " ")
    diffl <- cleanAttrs(x, c("coords", "lightSource"))
    fedl <- newXMLNode("feDiffuseLighting",
                       attrs = roundAttribs(diffl),
                       parent = svgDevParent(svgdev))
    svgDevChangeParent(fedl, svgdev)
    filterSVG(x$lightSource, dev)
    svgDevChangeParent(xmlParent(fedl), svgdev)
}

feDiffuseLighting <- function(input = NA, surfaceScale = 1,
                              diffuseConstant = 1, kernelUnitLength = NA,
                              col = "white", lightSource = NULL, ...) {
    if (is.null(lightSource))
        stop("A light source must be provided")
    if (diffuseConstant < 0)
        stop("'diffuseConstant' must be non-negative")
    x <- fe(surfaceScale = surfaceScale, diffuseConstant = diffuseConstant,
            "lighting-color" = c(col2rgb(col)), lightSource = lightSource,
            ...)
    if (! is.na(input))
        x$`in` <- input
    if (! is.na(kernelUnitLength)) {
        if (length(kernelUnitLength) == 1)
            kernelUnitLength <- rep(kernelUnitLength, 2)
        x$kernelUnitLength <- kernelUnitLength
    }
    class(x) <- c("fe.diffuse.lighting", class(x))
    x
}

filterSVG.fe.displacement.map <- function(x, dev) {
    svgdev <- dev@dev
    x <- cleanAttrs(x, "coords")
    newXMLNode("feDisplacementMap",
               attrs = roundAttribs(x),
               parent = svgDevParent(svgdev))
}

feDisplacementMap <- function(input1 = NA, input2 = NA, scale = 0,
                              xChannelSelector = c("A", "R", "G", "B"),
                              yChannelSelector = c("A", "R", "G", "B"),
                              ...) {
    x <- fe(scale = scale,
            xChannelSelector = match.arg(xChannelSelector),
            yChannelSelector = match.arg(yChannelSelector), ...)
    if (! is.na(input1))
        x$`in` <- input1
    if (! is.na(input2))
        x$in2 <- input2
    class(x) <- c("fe.displacement.map", class(x))
    x
}

filterSVG.fe.flood <- function(x, dev) {
    svgdev <- dev@dev
    x <- cleanAttrs(x, "coords")
    newXMLNode("feFlood",
               attrs = roundAttribs(x),
               parent = svgDevParent(svgdev))
}

feFlood <- function(col = "black", ...) {
    cols <- c(col2rgb(col, alpha = TRUE))
    x <- fe("flood-color" = paste0("rgb(", paste0(cols[1:3], collapse = ", "), ")"),
            "flood-opacity" = cols[4] / 255, ...)
    class(x) <- c("fe.flood", class(x))
    x
}

filterSVG.fe.gaussian.blur <- function(x, dev) {
    svgdev <- dev@dev
    if (length(x$stdDeviation) > 1)
        x$stdDeviation <- paste0(round(x$stdDeviation, 2), collapse = " ")
    x <- cleanAttrs(x, "coords")
    newXMLNode("feGaussianBlur",
               attrs = roundAttribs(x),
               parent = svgDevParent(svgdev))
}

feGaussianBlur <- function(input = NA, sd = 0, ...) {
    x <- fe(stdDeviation = sd, ...)
    if (! is.na(input))
        x$`in` <- input
    class(x) <- c("fe.gaussian.blur", class(x))
    x
}

filterSVG.fe.image <- function(x, dev) {
    svgdev <- dev@dev
    x <- cleanAttrs(x, "coords")
    newXMLNode("feImage",
               attrs = roundAttribs(x),
               parent = svgDevParent(svgdev))
}

feImage <- function(preserveAspectRatio = "xMidYMid meet", href = "", ...) {
    # Docs: http://www.w3.org/TR/SVG/coords.html#PreserveAspectRatioAttribute
    x <- fe(preserveAspectRatio = preserveAspectRatio,
            externalResourcesRequired = TRUE,
            "xlink:href" = href, ...)
    class(x) <- c("fe.image", class(x))
    x
}

filterSVG.fe.merge <- function(x, dev) {
    svgdev <- dev@dev
    children <- x$mergeNodes
    par <- cleanAttrs(x, c("coords", "mergeNodes"))
    merge <- newXMLNode("feMerge",
                        attrs = roundAttribs(par),
                        parent = svgDevParent(svgdev))
    if (! length(children))
        return()
    svgDevChangeParent(merge, svgdev)
    for (i in 1:length(children))
        filterSVG(children[[i]], dev)
    svgDevChangeParent(xmlParent(merge), svgdev)
}

feMerge <- function(mergeNodes = NULL, ...) {
    if (is.null(mergeNodes))
        mergeNodes <- list()
    if (inherits(mergeNodes, "fe.merge.node"))
        mergeNodes <- list(mergeNodes)
    x <- fe(mergeNodes = mergeNodes, ...)
    class(x) <- c("fe.merge", class(x))
    x
}

filterSVG.fe.merge.node <- function(x, dev) {
    svgdev <- dev@dev
    x <- cleanAttrs(x, "coords")
    newXMLNode("feMergeNode", attrs = x, parent = svgDevParent(svgdev))
}

feMergeNode <- function(input = NA) {
    x <- if (! is.na(input)) list("in" = input)
         else list()
    class(x) <- "fe.merge.node"
    x
}

addMergeNode <- function(fe, mergeNode, after = NA) {
    if (! inherits(fe, "fe.merge"))
        stop("'fe' must be a 'fe.merge' object")
    if (! inherits(mergeNode, "fe.merge.node"))
        stop("'mergeNode' must be a 'fe.merge.node' object")
    if (is.na(after))
        after <- length(fe$children)
    fe$children[[after + 1]] <- mergeNode
    fe
}

filterSVG.fe.morphology <- function(x, dev) {
    svgdev <- dev@dev
    if (x$coords) {
        if (length(x$radius) > 1)
            x$radius <- c(cx(x$radius[1], dev), cy(x$radius[2]))
        else
            x$radius <- cd(x$radius, dev)
        x$radius <- paste0(round(x$radius, 2), collapse = " ")
    }
    x <- cleanAttrs(x, "coords")
    newXMLNode("feMorphology", attrs = roundAttribs(x),
               parent = svgDevParent(svgdev))
}

flatten.fe.morphology <- function(x, coords = TRUE) {
    if (coords) {
        if (length(x$radius) > 1) {
            rx <- convertWidth(x$radius[1], "inches")
            ry <- convertHeight(x$radius[2], "inches")
            x$radius <- unit.c(rx, ry)
        } else {
            x$radius <- dToInches(x$radius, NULL)
        }
    } else {
        if (length(x$radius) > 1) {
            rx <- convertWidth(x$radius[1], "npc", valueOnly = TRUE)
            ry <- convertHeight(x$radius[2], "npc", valueOnly = TRUE)
            x$radius <- unit.c(rx, ry)
        } else {
            # Just use Width for radius
            x$radius <- convertWidth(dToInches(x$radius, NULL), "npc",
                                     valueOnly = TRUE)
        }
    }
    x$coords <- coords
    NextMethod()
}

feMorphology <- function(input = NA,
                         operator = c("erode", "dilate"),
                         radius = unit(0, "npc"),
                         default.units = "npc", ...) {
    if (! is.unit(radius))
        radius <- unit(radius, default.units)
    x <- fe(operator = match.arg(operator), radius = radius, ...)
    if (! is.na(input))
        x$`in` <- input
    class(x) <- c("fe.morphology", class(x))
    x
}

flatten.fe.offset <- function(x, coords = TRUE) {
    if (coords) {
        x$dx <- convertWidth(x$dx, "inches")
        x$dy <- convertHeight(x$dy, "inches")
    } else {
        x$dx <- convertWidth(x$dx, "npc", valueOnly = TRUE)
        x$dy <- convertHeight(x$dy, "npc", valueOnly = TRUE)
    }
    x$coords <- coords
    NextMethod()
}

filterSVG.fe.offset <- function(x, dev) {
    svgdev <- dev@dev
    if (x$coords) {
        x$dx <- cx(x$dx, dev)
        x$dy <- cy(x$dy, dev)
    }
    x <- cleanAttrs(x, "coords")
    newXMLNode("feOffset", attrs = roundAttribs(x),
               parent = svgDevParent(svgdev))
}

feOffset <- function(input = NA,
                     dx = unit(0, "npc"), dy = unit(0, "npc"),
                     default.units = "npc", ...) {
    if (! is.unit(dx))
        dx <- unit(dx, default.units)
    if (! is.unit(dy))
        dy <- unit(dy, default.units)
    x <- fe(dx = dx, dy = dy, ...)
    if (! is.na(input))
        x$`in` <- input
    class(x) <- c("fe.offset", class(x))
    x
}

flatten.fe.specular.lighting <- function(x, coords = TRUE) {
    x$lightSource <- flatten(x$lightSource, coords)
    NextMethod()
}

filterSVG.fe.specular.lighting <- function(x, dev) {
    svgdev <- dev@dev
    if (! is.null(x$kernelUnitLength))
        x$kernelUnitLength <- paste0(round(x$kernelUnitLength, 2),
                                     collapse = " ")
    specl <- cleanAttrs(x, c("coords", "lightSource"))
    fesl <- newXMLNode("feSpecularLighting",
                       attrs = roundAttribs(specl),
                       parent = svgDevParent(svgdev))
    svgDevChangeParent(fesl, svgdev)
    filterSVG(x$lightSource, dev)
    svgDevChangeParent(xmlParent(fesl), svgdev)
}

feSpecularLighting <- function(input = NA, surfaceScale = 1,
                               specularConstant = 1, specularExponent = 1,
                               kernelUnitLength = NA, col = "white",
                               lightSource = NULL, ...) {
    if (is.null(lightSource))
        stop("A light source must be provided")
    if (specularConstant < 0)
        stop("'specularConstant' must be non-negative")
    if (specularExponent < 1) {
        warning("exponent less than 1, increasing to 1")
        specularExponent <- 1
    } else if (specularExponent > 128) {
        warning("exponent larger than 128, reducing to 128")
        specularExponent <- 128
    }
    x <- fe(surfaceScale = surfaceScale,
            specularConstant = specularConstant, specularExponent = specularExponent,
            "lighting-color" = c(col2rgb(col)), lightSource = lightSource, ...)
    if (! is.na(input))
        x$`in` <- input
    if (! is.na(kernelUnitLength)) {
        if (length(kernelUnitLength) == 1)
            kernelUnitLength <- rep(kernelUnitLength, 2)
        x$kernelUnitLength <- kernelUnitLength
    }
    class(x) <- c("fe.specular.lighting", class(x))
    x
}

filterSVG.fe.tile <- function(x, dev) {
    svgdev <- dev@dev
    x <- cleanAttrs(x, "coords")
    newXMLNode("feTile", attrs = roundAttribs(x),
               parent = svgDevParent(svgdev))
}

feTile <- function(input = NA, ...) {
    x <- fe(...)
    if (! is.na(input))
        x$`in` <- input
    class(x) <- c("fe.tile", class(x))
    x
}

filterSVG.fe.turbulence <- function(x, dev) {
    svgdev <- dev@dev
    if (length(x$baseFrequency) > 1)
        x$baseFrequency <- paste0(round(x$baseFrequency, 2),
                                  collapse = " ")
    x <- cleanAttrs(x, "coords")
    newXMLNode("feTurbulence", attrs = roundAttribs(x),
               parent = svgDevParent(svgdev))
}

feTurbulence <- function(baseFrequency = 0, numOctaves = 1, seed = 1,
                         stitchTiles = FALSE,
                         type = c("turbulence", "fractalNoise"), ...) {
    stitchTiles <- if (stitchTiles) "stitch" else "noStitch"
    x <- fe(baseFrequency = baseFrequency, numOctaves = numOctaves, seed = seed,
            stitchTiles = stitchTiles, type = match.arg(type), ...)
    class(x) <- c("fe.turbulence", class(x))
    x
}

# Ensure the filters are retained on a forced grob
forceGrob.filtered.grob <- function(x) {
    y <- NextMethod()
    if (inherits(y, "forcedgrob")) {
        y$referenceLabel <- x$referenceLabel
        y$filterLabel <- x$filterLabel
        y$filterGroup <- x$filterGroup
        class(y) <- unique(c("filtered.grob", class(y)))
    }
    y
}

Try the gridSVG package in your browser

Any scripts or data that you put into this service are public.

gridSVG documentation built on April 28, 2020, 9:05 a.m.