1#  File src/library/grDevices/R/gradients.R
2#  Part of the R package, https://www.R-project.org
3#
4#  Copyright (C) 2019      The R Foundation
5#
6#  This program is free software; you can redistribute it and/or modify
7#  it under the terms of the GNU General Public License as published by
8#  the Free Software Foundation; either version 2 of the License, or
9#  (at your option) any later version.
10#
11#  This program is distributed in the hope that it will be useful,
12#  but WITHOUT ANY WARRANTY; without even the implied warranty of
13#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14#  GNU General Public License for more details.
15#
16#  A copy of the GNU General Public License is available at
17#  https://www.R-project.org/Licenses/
18
19## Create R objects defining patterns
20
21#######################################################
22## MUST match C #defines in
23## ../../../main/patterns.c and
24## ../../../include/R_ext/GraphicsEngine.h
25#######################################################
26
27patternTypes <- c("LinearGradient", "RadialGradient", "TilingPattern")
28
29extendOptions <- c("pad", "repeat", "reflect", "none")
30
31pattern <- function(type, ...) {
32    type <- match(type, patternTypes)
33    if (is.na(type))
34        stop("Invalid pattern type")
35
36    pattern <- c(list(type=as.integer(type)), list(...))
37    class(pattern) <- c(type, "Pattern")
38    pattern
39}
40
41.linearGradientPattern <- function(colours = c("black", "white"),
42                                   stops = seq(0, 1,
43                                               length.out = length(colours)),
44                                   x1 = 0, y1 = 0, x2 = 1, y2 = 1,
45                                   extend = "pad") {
46    ## Vectorising colours & stops
47    nstops <- max(length(colours), length(stops))
48    colours <- rep(colours, length.out = nstops)
49    stops <- rep(stops, length.out = nstops)
50
51    extend <- match(extend, extendOptions)
52    if (is.na(extend))
53        stop("Invalid 'extend' value")
54
55    ## Make sure we really have colours in some form
56    ## AND convert to "#RRGGBB" format
57    RGBA <- col2rgb(colours, alpha=TRUE)
58    colours <- rgb(t(RGBA[1:3,]), alpha=RGBA[4,], maxColorValue=255)
59
60    pattern("LinearGradient",
61            x1 = as.numeric(x1), y1 = as.numeric(y1),
62            x2 = as.numeric(x2), y2 = as.numeric(y2),
63            stops = as.numeric(stops), colours = colours,
64            extend = as.integer(extend))
65}
66
67.radialGradientPattern <- function(colours = c("black", "white"),
68                                   stops = seq(0, 1,
69                                               length.out = length(colours)),
70                                   cx1 = 0, cy1 = 0, r1 = 0,
71                                   cx2 = 1, cy2 = 1, r2 = .5,
72                                   extend = "pad") {
73    ## Vectorising colours & stops
74    nstops <- max(length(colours), length(stops))
75    colours <- rep(colours, length.out = nstops)
76    stops <- rep(stops, length.out = nstops)
77
78    extend <- match(extend, extendOptions)
79    if (is.na(extend))
80        stop("Invalid 'extend' value")
81
82    ## Make sure we really have colours in some form
83    ## AND convert to "#RRGGBB" format
84    RGBA <- col2rgb(colours, alpha=TRUE)
85    colours <- rgb(t(RGBA[1:3,]), alpha=RGBA[4,], maxColorValue=255)
86
87    pattern("RadialGradient",
88            cx1 = as.numeric(cx1), cy1 = as.numeric(cy1),
89            r1 = as.numeric(r1),
90            cx2 = as.numeric(cx2), cy2 = as.numeric(cy2),
91            r2 = as.numeric(r2),
92            stops = as.numeric(stops), colours = colours,
93            extend = as.integer(extend))
94}
95
96## (x, y) is (left, bottom)
97.tilingPattern <- function(fun, x, y, width, height, extend) {
98    extend <- match(extend, extendOptions)
99    if (is.na(extend))
100        stop("Invalid 'extend' value")
101
102    pattern("TilingPattern",
103            f = fun,
104            x = as.numeric(x), y = as.numeric(y),
105            width = as.numeric(width), height = as.numeric(height),
106            extend = as.integer(extend))
107}
108
109.setPattern <- function(pattern) {
110    .External(C_setPattern, pattern)
111}
112
113