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