Permalink
Browse files
moved colorRamp to grDevices with the other colour functions
added convertColor to map between colour spaces git-svn-id: https://svn.r-project.org/R/trunk@32082 00db46b3-68df-0310-9c12-caf00c1e9a41
- Loading branch information
Showing
with
340 additions
and 109 deletions.
- +2 −0 NEWS
- +1 −0 src/library/grDevices/NAMESPACE
- +60 −0 src/library/grDevices/R/colorRamp.R
- +196 −0 src/library/grDevices/R/convertColor.R
- 0 src/library/{graphics → grDevices}/man/colorRamp.Rd
- +80 −0 src/library/grDevices/man/convertColor.Rd
- +1 −1 src/library/graphics/NAMESPACE
- +0 −108 src/library/graphics/R/colorRamp.R
| @@ -0,0 +1,60 @@ | ||
|
|
||
| colorRampPalette<-function(colors,...) { | ||
|
|
||
| ramp<-colorRamp(colors,...) | ||
| function(n) { | ||
| x<-ramp(seq(0,1,length=n)) | ||
| rgb(x[1,],x[2,],x[3,], max=255) | ||
| } | ||
|
|
||
| } | ||
|
|
||
| colorRamp<-function(colors, bias=1, space=c("rgb","Lab"), | ||
| interpolate=c("linear","spline")) | ||
| { | ||
|
|
||
| if (bias<=0) stop("Bias must be positive") | ||
| colors<-col2rgb(colors)/255 | ||
| space<-match.arg(space) | ||
| interpolate<-match.arg(interpolate) | ||
|
|
||
| if (space=="Lab"){ | ||
| colors<-convertColor(colors, from="sRGB", to="Lab") | ||
| #apply(colors,2,srgb2lab) | ||
| } | ||
|
|
||
| colors<-t(colors) | ||
|
|
||
| interpolate<-switch(interpolate, linear=approxfun, spline=splinefun) | ||
|
|
||
| x<-seq(0,1,length=nrow(colors))^{bias} | ||
|
|
||
| palette<-c(interpolate(x,colors[,1]), | ||
| interpolate(x,colors[,2]), | ||
| interpolate(x,colors[,3])) | ||
|
|
||
| roundcolor<-function(rgb){ | ||
| rgb[rgb<0]<-0 | ||
| rgb[rgb>1]<-1 | ||
| rgb | ||
| } | ||
|
|
||
| if (space=="Lab"){ | ||
|
|
||
| function(x) { | ||
| roundcolor(convertColor(rbind(palette[[1]](x), | ||
| palette[[2]](x), | ||
| palette[[3]](x)),from="Lab",to="sRGB"))*255 | ||
| } | ||
|
|
||
| } else { | ||
|
|
||
| function(x) { | ||
| roundcolor(rbind(palette[[1]](x), | ||
| palette[[2]](x), | ||
| palette[[3]](x)))*255 | ||
| } | ||
|
|
||
| } | ||
|
|
||
| } |
| @@ -0,0 +1,196 @@ | ||
|
|
||
|
|
||
| white.points<-list(A=c(x=0.44757, y=0.40745), | ||
| B=c(x=0.34842, y=0.35161), | ||
| C=c(x=0.31006, y=0.31616), | ||
| D50=c(x=0.34574, y=0.35867), | ||
| D55=c(x=0.33250, y=0.34761), | ||
| D65=c(x=0.3137,y=0.3291), | ||
| E=c(x=1/3,y=1/3)) | ||
|
|
||
| ## http://www.brucelindbloom.com/index.html?Equations.html | ||
|
|
||
|
|
||
| rgb.matrix<-list(Adobe=matrix( | ||
| c(0.576700, 0.297361, 0.0270328, | ||
| 0.185556, 0.627355, 0.0706879, | ||
| 0.188212, 0.0752847, 0.991248),3,byrow=TRUE), | ||
| Apple=matrix( | ||
| c(0.449695, 0.244634, 0.0251829, | ||
| 0.316251, 0.672034, 0.141184, | ||
| 0.18452, 0.0833318, 0.922602),3,byrow=TRUE), | ||
| CIE=matrix( | ||
| c(0.488718, 0.176204, 0.000000, | ||
| 0.310680, 0.812985, 0.0102048, | ||
| 0.200602, 0.0108109, 0.989795),3,byrow=TRUE), | ||
| sRGB=matrix( | ||
| c(0.412424, 0.212656, 0.0193324, | ||
| 0.357579, 0.715158, 0.119193, | ||
| 0.180464, 0.0721856, 0.950444),3,byrow=TRUE), | ||
| NTSC=matrix( | ||
| c(0.606734, 0.298839, 0.000000, | ||
| 0.173564, 0.586811, 0.0661196, | ||
| 0.200112, 0.114350, 1.11491 )) | ||
| ) | ||
|
|
||
|
|
||
|
|
||
| XYZtoLab<-function(XYZ, white){ | ||
|
|
||
| epsilon <- 216/24389 | ||
| kappa <- 24389/27 | ||
|
|
||
| xyzr<-XYZ/white | ||
| fxyz<-ifelse(xyzr<=epsilon, (kappa*xyz+16)/116, xyzr^(1/3)) | ||
|
|
||
| c(L=116*fxyz[2]-16, a=500*(fxyz[1]-fxyz[2]), b=200*(fxyz[2]-fxyz[3])) | ||
| } | ||
|
|
||
| XYZtoLuv<-function(XYZ, white){ | ||
| epsilon <- 216/24389 | ||
| kappa <- 24389/27 | ||
|
|
||
| yr<-XYZ[2]/white[2] | ||
|
|
||
| denom<-sum(XYZ*c(1,15,3)) | ||
| wdenom<-sum(white*c(1,15,3)) | ||
|
|
||
| u1<- 4*XYZ[1]/denom | ||
| v1<- 9*XYZ[2]/denom | ||
| ur<-4*white[1]/wdenom | ||
| vr<-9*white[2]/wdenom | ||
|
|
||
| L<-ifelse(yr<=epsilon, kappa*yr, 116*(yr^(1/3))-16) | ||
| c(L=L, u=13*L*(u1-ur), v=13*L*(v1-vr)) | ||
|
|
||
| } | ||
|
|
||
| LabtoXYZ<-function(Lab,white){ | ||
|
|
||
| epsilon <- 216/24389 | ||
| kappa <- 24389/27 | ||
|
|
||
| yr<-ifelse(Lab[1]<kappa*epsilon, Lab[1]/kappa, ((Lab[1]+16)/116)^3) | ||
| fy<-ifelse(yr<=epsilon, (kappa*yr+16)/116, (Lab[1]+16)/116) | ||
| fx<-Lab[2]/500+fy | ||
| fz<-fy-Lab[3]/200 | ||
|
|
||
| zr<-ifelse(fz^3<=epsilon, (116*fz-16)/kappa, fz^3) | ||
| xr<-ifelse(fx^3<=epsilon, (116*fz-16)/kappa, fx^3) | ||
|
|
||
| c(X=xr,Y=yr,Z=zr)*white | ||
|
|
||
| } | ||
|
|
||
| LuvtoXYZ<-function(Luv,white){ | ||
| epsilon <- 216/24389 | ||
| kappa <- 24389/27 | ||
|
|
||
| u0<-4*white[1]/(white[1]+15*white[2]+3*white[3]) | ||
| v0<-9*white[2]/(white[1]+15*white[2]+3*white[3]) | ||
|
|
||
| Y<-ifelse(Luv[1]<=kappa*epsilon, Luv[1]/kappa, ((Luv[1]+16)/116)^3) | ||
| a<-(52*Luv[1]/(Luv[2]+13*Luv[1]*u0)-1)/3 | ||
| b<- -5*Y | ||
| c<- -1/3 | ||
| d<- Y*(39*Luv[1]/(Luv[3]+13*Luv[1]*v0)-5) | ||
|
|
||
| X<-(d-b)/(a-c) | ||
| Z<-X*a+b | ||
|
|
||
| c(X=X,Y=Y,Z=Z) | ||
| } | ||
|
|
||
|
|
||
| "%^%"<-function(a,b){ | ||
| ifelse(a<=0, -abs(a)^b, a^b) | ||
| } | ||
|
|
||
| RGBtoXYZ<-function(RGB, gamma, m){ | ||
| rgb<-RGB%^%gamma | ||
| XYZ<-rgb%*%m | ||
| colnames(XYZ)<-c("X","Y","Z") | ||
| XYZ | ||
| } | ||
|
|
||
|
|
||
| sRGBtoXYZ<-function(sRGB){ | ||
| rgb<-ifelse(sRGB<=0.04045, sRGB/12.92, ((sRGB+0.055)/1.055)^2.4) | ||
| XYZ<-rgb%*%rgb.matrix$sRGB | ||
| colnames(XYZ)<-c("X","Y","Z") | ||
| XYZ | ||
| } | ||
|
|
||
| XYZtoRGB<-function(XYZ,gamma,m){ | ||
| rgb<-XYZ%*%solve(m) | ||
| RGB<-rgb%^%(1/gamma) | ||
| colnames(RGB)<-c("R","G","B") | ||
| RGB | ||
| } | ||
|
|
||
| XYZtosRGB<-function(XYZ){ | ||
| rgb<-XYZ%*%solve(rgb.matrix$sRGB) | ||
| sRGB<-ifelse(rgb<=0.0031308, 12.92*rgb, 1.055*rgb%^%(1/2.4)-0.055) | ||
| colnames(sRGB)<-c("R","G","B") | ||
| sRGB | ||
| } | ||
|
|
||
|
|
||
| convertColor<-function(color, | ||
| from=c("sRGB","XYZ","Lab","Luv","AppleRGB","AdobeRGB","CIE.RGB","NTSC.RGB"), | ||
| to=c("sRGB","XYZ","Lab","Luv","AppleRGB","AdobeRGB","CIE.RGB","NTSC.RGB"), | ||
| white.point=c("D65","A","B","C","D50","D55","E"), gamma=1.8,scale=1, clip=TRUE) | ||
| { | ||
|
|
||
| from<-match.arg(from) | ||
| to<-match.arg(to) | ||
| if (any( c(from,to) %in% c("Lab","Luv"))){ | ||
| white.point<-white.points[[match.arg(white.point)]] | ||
| white.point<-c(white.point,1-sum(white.point)) | ||
| } | ||
|
|
||
| if (is.null(nrow(color))) | ||
| color<-matrix(color,ncol=1) | ||
|
|
||
| if (nrow(color)!=3 && ncol(color)==3) color=t(color) | ||
|
|
||
| color<-color/scale | ||
|
|
||
| trim<-function(rgb){ | ||
| if (is.na(clip)) | ||
| rgb[rgb < 0 | rgb >1]<-NaN | ||
| else if(clip){ | ||
| rgb[rgb < 0]<-0 | ||
| rgb[rgb>1]<-1 | ||
| } | ||
| rgb | ||
| } | ||
|
|
||
| xyz<-switch(from, | ||
| sRGB=apply(color,2,sRGBtoXYZ), | ||
| XYZ=color, | ||
| Lab=apply(color, 2, LabtoXYZ, white=white.point), | ||
| Luv=apply(color, 2, LuvtoXYZ, white=white.point), | ||
| AppleRGB=apply(color, 2, RGBtoXYZ, m=rgb.matrix$Apple, gamma=gamma), | ||
| AdobeRGB=apply(color, 2, RGBtoXYZ, m=rgb.matrix$Adobe, gamma=gamma), | ||
| CIE.RGB=apply(color, 2, RGBtoXYZ, m=rgb.matrix$CIE, gamma=gamma), | ||
| NTSC.RGB=apply(color, 2, RGBtoXYZ, m=rgb.matrix$NTSC, gamma=gamma)) | ||
|
|
||
| if (is.null(nrow(xyz))) | ||
| xyz<-matrix(xyz, ncol=1) | ||
|
|
||
| rval<-switch(to, | ||
| sRGB=trim(apply(xyz,2,XYZtosRGB)), | ||
| XYZ=xyz, | ||
| Lab=apply(xyz, 2, XYZtoLab, white=white.point), | ||
| Luv=apply(xyz, 2, XYZtoLuv, white=white.point), | ||
| AppleRGB=trim(apply(xyz, 2, XYZtoRGB, m=rgb.matrix$Apple, gamma=gamma)), | ||
| AdobeRGB=trim(apply(xyz, 2, XYZtoRGB, m=rgb.matrix$Adobe, gamma=gamma)), | ||
| CIE.RGB=trim(apply(xyz, 2, XYZtoRGB, m=rgb.matrix$CIE, gamma=gamma)), | ||
| NTSC.RGB=trim(apply(xyz, 2, XYZtoRGB, m=rgb.matrix$NTSC, gamma=gamma))) | ||
|
|
||
|
|
||
| rval | ||
|
|
||
|
|
||
| } |
File renamed without changes.
| @@ -0,0 +1,80 @@ | ||
| \name{convertColor} | ||
| \alias{convertColor} | ||
| %- Also NEED an '\alias' for EACH other topic documented here. | ||
| \title{Convert between color spaces } | ||
| \description{ | ||
| Convert colors between standard color space representations. This | ||
| function is experimental, and may be made obsolete by changes to \R | ||
| color handling. | ||
| } | ||
| \usage{ | ||
| convertColor(color, | ||
| from = c("sRGB", "XYZ", "Lab", "Luv", "AppleRGB", "AdobeRGB", "CIE.RGB", | ||
| "NTSC.RGB"), | ||
| to = c("sRGB", "XYZ", "Lab", "Luv", "AppleRGB", "AdobeRGB", "CIE.RGB", | ||
| "NTSC.RGB"), | ||
| white.point = c("D65", "A", "B", "C", "D50", "D55", "E"), gamma = 1.8,scale=1,clip=TRUE) | ||
| } | ||
| %- maybe also 'usage' for other objects documented here. | ||
| \arguments{ | ||
| \item{color}{A 3-row matrix whose columns specify colors} | ||
| \item{from}{Input color space} | ||
| \item{to}{Output color space} | ||
| \item{white.point}{Reference white for \code{"Lab"} and \code{"Luv"} spaces. | ||
| \item{gamma}{Display gamma for \code{RGB} spaces.} | ||
| \item{scale}{Input color components are divided by this | ||
| number. (eg 255 for 8-bit RGB)} | ||
| \item{clip}{If \code{TRUE}, truncate RGB output to [0,1], | ||
| \code{FALSE} return out-of-range RGB, \code{NA} set out of range | ||
| colors to \code{NaN}} | ||
| } | ||
| \details{ | ||
| The \code{sRGB} color space is that used by standard PC monitors. | ||
| \code{AppleRGB} is used by Apple monitors, with a gamma of about | ||
| 1.8. \code{Lab} and \code{Luv} are approximately perceptually uniform | ||
| spaces standardized by the Commission Internationale | ||
| d'Eclairage. \code{XYZ} is a 1931 CIE standard capable of representing | ||
| all visible colors (and then some), but not in a perceptually uniform | ||
| way. | ||
| The \code{Lab} and \code{Luv} spaces describe colors of objects, and | ||
| so require the specification of a reference "white light" | ||
| color. Illuminant \code{D65} is a standard indirect daylight, | ||
| Illuminant \code{D50} is close to direct sunlight, and Illuminant | ||
| \code{A} is the light from a standard incandescent bulb. | ||
| The RGB color spaces are specific to a particular class of | ||
| display. They require the user to specify the display gamma, which | ||
| describes the nonlinearity of the display response. The exception is | ||
| \code{sRGB}, where the nonlinearity is specified by the standard and | ||
| corresponds approximately to \code{gamma=2.2}. An RGB space cannot | ||
| represent all colors, and the \code{clip} option controls what is | ||
| done to out-of-range colors. | ||
| } | ||
| \value{ | ||
| A 3-row matrix whose columns specify the colors | ||
| } | ||
| \references{ | ||
| For the conversion equations | ||
| \url{http://www.brucelindbloom.com/index.html} | ||
| For the white points | ||
| \url{http://www.efg2.com/Lab/Graphics/Colors/Chromaticity.htm} | ||
| } | ||
| \seealso{\code{\link{col2rgb}}, \code{\link{colors}}} | ||
| \examples{ | ||
| ## The displayable colors from the L=70 plane of Lab space | ||
| ab<-expand.grid(a=(-10:15)*10,b=(-15:10)*10) | ||
| Lab<-rbind(L=70,t(ab)) | ||
| srgb<-t(convertColor(Lab,from="Lab",to="sRGB",clip=NA)) | ||
| clipped<-attr(na.omit(srgb),"na.action") | ||
| srgb[clipped,]<-0 | ||
| cols<-rgb(srgb[,1],srgb[,2],srgb[,3]) | ||
| image((-10:15)*10,(-15:10)*10,matrix(1:(26*26),ncol=26),col=cols, | ||
| xlab="a",ylab="b",main="Lab: L=70") | ||
| } | ||
| \keyword{color}% at least one, from doc/KEYWORDS | ||
Oops, something went wrong.