R: help needed improving a function for changing arrow colours from starting point to end point

Question

I have the following function in R that draws arrows changing colours:

require(plotrix)

color.scale.arrow = function(x1,y1,x2,y2,first.col,second.col,
lwd= par('lwd'),lty=par('lty'),angle=30,length=0.25) {
    x=mapply(seq,x1,x2,length.out=256) # Each column is one arrow
    y=mapply(seq,y1,y2,length.out=256) # Each column is one arrow

    arrows(x[255,],y[255,],x[256,],y[256,],
           col=ifelse(y[256,]<y[255,],first.col,second.col),
           lwd=lwd,lty=lty,angle=angle,length=length)

    rgb1=col2rgb(first.col)[,1] / 255
    rgb2=col2rgb(second.col)[,1] / 255
    cols=rbind(rgb1,(rgb1 + rgb2) / 2,rgb2)

    invisible(
          sapply(seq(ncol(x)),function(line) 
              color.scale.lines(x[,line],y[,line],
              cols[,'red'],cols[,'green'],cols[,'blue'],
              lwd=lwd,lty=lty)
          )
   )
}

I have 2 problems with this function..

Problem 1: The arrows start out as red and end as blue if they move upwards, and start out as blue and end in red if they move downwards. I actually need the arrows to always start out as blue, and always end in red. The problem is illustrated with this simplified example data:

# Create sample data 1
x <- c(5,6,5,6)
y <- c(3,5,5,4)

x1 <- c(5,5)
y1 <- c(3,5)
x2 <- c(6,6)
y2 <- c(5,4)

# Plot sample data 1
plot(x,y, main='')
color.scale.arrow(x1,y1,x2,y2,'red','blue',lwd=2)

Which creates the following plot:

Problem 2: The script only allows for arrows going from left to right. When trying to draw arrows in the other direction, I get an error message. For example, when plotting this example data:

# Create sample data 2
x <- c(1,3,5,3,2,1,6,2)
y <- c(2,5,3,7,2,1,5,6)

x1 <- c(1,3,5,3)
y1 <- c(2,5,3,7)
x2 <- c(2,1,6,2)
y2 <- c(2,1,5,6)

# Plot sample data 2
plot(x,y, main='')
color.scale.arrow(x1,y1,x2,y2,'red','blue',lwd=2)

I get the following plot:

And the following error message:

Error in rgb(c(2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,  : color intensity 2, not in [0,1]

Any idea on how to solve these problems? Many thanks in advance!

Answer 1

Here is a little different approach that does what I think you want:

csa <- function(x1,y1,x2,y2,first.col,second.col, ...) {
    cols <- colorRampPalette( c(first.col,second.col) )(250)
    x <- approx(c(0,1),c(x1,x2), xout=seq(0,1,length.out=251))$y
    y <- approx(c(0,1),c(y1,y2), xout=seq(0,1,length.out=251))$y

    arrows(x[250],y[250],x[251],y[251], col=cols[250], ...)
    segments(x[-251],y[-251],x[-1],y[-1],col=cols, ...)

}


color.scale.arrow <- Vectorize(csa, c('x1','y1','x2','y2') )

# Create sample data 2
x <- c(1,3,5,3,2,1,6,2)
y <- c(2,5,3,7,2,1,5,6)

x1 <- c(1,3,5,3)
y1 <- c(2,5,3,7)
x2 <- c(2,1,6,2)
y2 <- c(2,1,5,6)

# Plot sample data 2
plot(x,y, main='')
color.scale.arrow(x1,y1,x2,y2,'red','blue',lwd=2)

This at least works for the example data, tweaks are possible for other options.

Answer 2

second try [18:15] ----------------------

add colvar=seq(0,1,len=255) inside your local function inside the sapply statement (same level as the lwd and lty argument). IMHO the definition colors.scale.lines is not valid, except you use the colvar argument explicitly.

The arrowheads have still different colors in this solution. To avoid this just remove the ifelse in arrows by col=second.col

first try [11:05] see comment of Abdel ------------

The following line should do it:

if((x[1]-x[2])/(y[1]-y[2]) < 0) cols <- cols[nrow(cols):1,]

Add it before the 'invisible' command in 'color.scale.arrow'