Rdev/diverging_map.R

In Novartis/xgxr: Exploratory Graphics for Pharmacometrics

diverging.colormap<-function(s,rgb1,rgb2, outColorspace='sRGB')
{
    # This function is based on Kenneth Moreland's code for creating Diverging Colormaps.
    # Matlab code created by Andy Stein. Translated to R by Jose Gama.
    # s is a vector that goes between zero and one
    # rgb1,rgb2 are objects from the colorspace package
    # RGB, sRGB, HLS, HSV, LAB, LUV, PolarLAB, PolarLUV, XYZ
    # outColorspace is the color space for the output
    library('colorspace', character.only=TRUE)
    LabToMsh<-function(Lab) 
    {
        L<-Lab@coords[1]
        a<-Lab@coords[2]
        b<-Lab@coords[3]
        M <- sqrt(L*L + a*a + b*b)
        s <- (M > 0.001) * acos(L/M)
        h <- (s > 0.001) * atan2(b,a)
        c(M,s,h)
    }
    MshToLab<-function(Msh)
    {
    M<-Msh[1]
    s<-Msh[2]
    h<-Msh[3]
    L <- M*cos(s)
    a <- M*sin(s)*cos(h)
    b <- M*sin(s)*sin(h)
    colorspace::LAB(L,a,b)
    }

    AngleDiff<-function(a1, a2)
    {
        # Given two angular orientations, returns the smallest angle between the two.
        v1<-matrix(c(cos(a1), sin(a1)),1,2,byrow=TRUE)
        v2<-matrix(c(cos(a2), sin(a2)),1,2,byrow=TRUE)
        x<-acos(sum(v1 * v2))
        x
    }
    AdjustHue<-function(msh, unsatM)
    {
        # For the case when interpolating from a saturated color to an unsaturated
        # color, find a hue for the unsaturated color that makes sense.
        if (msh[1] >= unsatM-0.1  ) {
            # The best we can do is hold hue constant.
            h <- msh[3]
        } else {
            # This equation is designed to make the perceptual change of the interpolation to be close to constant.
            hueSpin <- (msh[2]*sqrt(unsatM^2 - msh[1]^2)/(msh[1]*sin(msh[2])))
            # Spin hue away from 0 except in purple hues.
            if (msh[3] > -0.3*pi) h <- msh[3] + hueSpin else h <- msh[3] - hueSpin
        }
        h
    }
    diverging.map.1val<-function(s, rgb1, rgb2, outColorspace='sRGB')
    {
        # Interpolate a diverging color map
        # s is a number between 0 and 1
        msh1 <- LabToMsh(as(rgb1, "LAB"))
        msh2 <- LabToMsh(as(rgb2, "LAB"))
        # If the endpoints are distinct saturated colors, then place white in between them
        if (msh1[2] > 0.05 & msh2[2] > 0.05 & AngleDiff(msh1[3],msh2[3]) > pi/3)
        {
            # Insert the white midpoint by setting one end to white and adjusting the scalar value.
            Mmid <- max(88.0, msh1[1], msh2[1])
            #Mmid <- max(Mmid)
            if (s < 0.5)
            {
                msh2[1] <- Mmid;  msh2[2] <- 0.0;  msh2[3] <- 0.0;s <- 2.0*s
            } else {
                msh1[1] <- Mmid;  msh1[2] <- 0.0;  msh1[3] <- 0.0; s <- 2.0*s - 1.0
            }
        }
        # If one color has no saturation, then its hue value is invalid.  In this
        # case, we want to set it to something logical so that the interpolation of hue makes sense.
        if ((msh1[2] < 0.05) & (msh2[2] > 0.05)) {
            msh1[3] <- AdjustHue(msh2, msh1[1]) 
        } else if ((msh2[2] < 0.05) & (msh1[2] > 0.05)) {
            msh2[3] <- AdjustHue(msh1, msh2[1])
        }
        mshTmp<-msh1
        mshTmp[1] <- (1-s)*msh1[1] + s*msh2[1]
        mshTmp[2] <- (1-s)*msh1[2] + s*msh2[2]
        mshTmp[3]<- (1-s)*msh1[3] + s*msh2[3]
        # Now convert back to the desired color space
        as(MshToLab(mshTmp),outColorspace)
    }
    dvmap<-matrix(0,length(s),3)
    for (n in 1:length(s)) dvmap[n,]<-diverging.map.1val(s[n], rgb1, rgb2, outColorspace)@coords
    dvmap
}