Thursday, September 19, 2013

Using Custom Images as "pch" values in R

In a previous post I show how one can use custom pch values to represent different data types. I've long wanted to be able to take a custom image and use that to represent the data. I recently discovered the rasterImage function in R, which allows the user to take an image and plot it! There are various examples out there of using RasterImage (such as RJournal_2011-1_Murrell.pdf), but I didn't find anything that did exactly what I wanted it to do

the tricky part is that rasterImage requires you to define the 4 boundaries of the image. The goal is then to be able to define the boundaries by only specifying an x, y coordinate, and have code smart enough to display the image with the appropriate dimensions


Here are the required packages
library(RCurl)  #for reading file from a URL
## Loading required package: bitops
library(png)  #for reading in a .png, use library(jpeg) for a .jpg
The function I wrote takes the image, the (x,y) coordinates of where you want to plot your image, and for now a cex and a pos argument. I intend on expanding the options, and hopefully will improve these functionalities over time.

image_points = function(image, x, y, cex = 1, pos = NULL) {
    if (length(x) != length(y)) {
        stop("length(x)!=length(y): check your data")
    }
    dim.x = dim(image)[2]  #image width
    dim.y = dim(image)[1]  #image height
    if (dim.x == dim.y) {
        # obtian the ratio of width to height or height to width
        ratio.x = ratio.y = 1
    } else if (dim.x < dim.y) {
        ratio.x = dim.x/dim.y
        ratio.y = 1
    } else {
        ratio.x = 1
        ratio.y = dim.y/dim.x
    }
    cex = cex/10  #how large the image should be, divided by 10 so that it matches more closely to plotting points
    pin = par()$pin  #pin provides the width and height of the _active graphic device_
    pin.ratio = pin/max(pin)  #take the ratio
    usr = par()$usr  #usr provides the lower.x, lower.y, upper.x, upper.y values of the plotable region

    # combine the active device dimensions, the image dimensions, and the
    # desired output size
    image.size.y = (usr[4] - usr[3]) * pin.ratio[1] * cex
    image.size.x = (usr[2] - usr[1]) * pin.ratio[2] * cex
    for (i in 1:length(x)) {
        # plot each point pos can be NULL (default) or 1, 2, 3, or 4, corresponding
        # to centered (defualt), bottom, left, top, right, respectively.
        if (is.null(pos)) {
            # centered at (x,y), define the bottom/top and left/right boundaries of the
            # image
            x.pos = c(x[i] - (image.size.x * ratio.x)/2, x[i] + (image.size.x * 
                ratio.x)/2)
            y.pos = c(y[i] - (image.size.y * ratio.y)/2, y[i] + (image.size.y * 
                ratio.y)/2)

            rasterImage(image, x.pos[1], y.pos[1], x.pos[2], y.pos[2])
        } else if (pos == 1) {
            x.pos = c(x[i] - (image.size.x * ratio.x)/2, x[i] + (image.size.x * 
                ratio.x)/2)
            y.pos = c(y[i] - (image.size.y * ratio.y), y[i])
        } else if (pos == 2) {
            x.pos = c(x[i] - (image.size.x * ratio.x), x[i])
            y.pos = c(y[i] - (image.size.y * ratio.y)/2, y[i] + (image.size.y * 
                ratio.y)/2)
        } else if (pos == 3) {
            x.pos = c(x[i] - (image.size.x * ratio.x)/2, x[i] + (image.size.x * 
                ratio.x)/2)
            y.pos = c(y[i], y[i] + (image.size.y * ratio.y))
        } else if (pos == 4) {
            x.pos = c(x[i], x[i] + (image.size.x * ratio.x))
            y.pos = c(y[i] - (image.size.y * ratio.y)/2, y[i] + (image.size.y * 
                ratio.y)/2)
        }

        rasterImage(image, x.pos[1], y.pos[1], x.pos[2], y.pos[2])  #plot image
    }
}
I pulled an image from sweetclipart.com using getURLContent() and readPNG()

URL = ("http://sweetclipart.com/multisite/sweetclipart/files/imagecache/middle/sports_car_2_red.png")  #where the image is located
image = readPNG(getURLContent(URL))  #gets the content of the URL
image is an array of dimensions width \( \times \) height \( \times \) channels. The first 3 channels represent the R, G, and B values (scaled 0 to 1) of each pixel, with the 4th channel representing the alpha value (scaled 0 to 1, 0 representing transparent)
Only pngs have the alpha channel, so jpegs will have 3 channels. Not all pngs have the 4th channel, if they do have the 4th channel the background won't necessarily be transparent. More on alpha values in a bit

dim(image)  #width, height, alpha
## [1] 275 550   4

Using the cars dataset we can plot the distance it took to stop by speed

data(cars)
plot(cars, type = "n", axes = F, xlab = "Speed", ylab = "Distance to Stop", 
    main = "Cars: Distance to Stop by Speed")
axis(1)
axis(2, las = 2)
x = cars$speed
y = cars$dist
image_points(image, x, y, 2)
Cars using Cars
It turns out that the data is from the 1920s, so using this image might be more appropriate:

library(jpeg)
URL2 = "http://embed.polyvoreimg.com/cgi/img-thing/size/y/tid/4985430.jpg"
image2 = readJPEG(getURLContent(URL2))
plot(cars, type = "n", axes = F, xlab = "Speed", ylab = "Distance to Stop", 
    main = "Cars: Distance to Stop by Speed\n1920's car")
axis(1)
axis(2, las = 2)
image_points(image2, x, y, 2)
Cars using Cars
Here we have a jpeg file that is a width \( \times \) height matrix with values 0 to 1 representing the black/white/gray scale. We can manipulate the data using rgb() and abind() to create an array with the appropriate R, G, B, and alpha values.
First, on this color scale, values that are closer to 1 are going to be lighter gray to white, so we can assign an alpha value of 0 (transparent) to any values that are greater than 0.8.

alpha.val = matrix(1, nrow(image2), ncol(image2))  #want a matrix of 1s (not transparent) the same size as the image
alpha.val[image2 > 0.8] = 0  #for lighter gray and white values, set alpha to 0 (transparent)
We then want to create a new array, and will set the first dimension to the original values. Because it is gray colors, R=G=B

library(abind)
image2.adj = array(image2, dim = c(nrow(image2), ncol(image2), 1))
image2.adj = abind(image2.adj, image2, image2, alpha.val)
We can then plot it:

plot(cars, type = "n", axes = F, xlab = "Speed", ylab = "Distance to Stop", 
    main = "Cars: Distance to Stop by Speed\n1920's Car w/Transparency")
axis(1)
axis(2, las = 2)
image_points(image2.adj, x, y, 2)
Cars using Cars
Notice that we have now essentially removed the border around the image, and even though the images overlap, we get a better sense of whwere the points lie.

A few final notes

  • If we want the cars to be reversed, we can simply…
image2.adj.reversed = image2.adj[, ncol(image2.adj):1, ]
plot(cars, type = "n", axes = F, xlab = "Speed", ylab = "Distance to Stop", 
    main = "Cars: Distance to Stop by Speed\n1920's car w/Transparency, Reversed")
axis(1)
axis(2, las = 2)
image_points(image2.adj.reversed, x, y, 2)
Cars using Cars
  • Using images with lower resolution will often yield better results, I don't know if there are better ways to display images at a lower resolution
  • There might be better ways to do what I've figured out here - perhaps there are some more par values that would help convert the resolution and control the cex value?

Sunday, May 19, 2013

Keep R Rockin' Me Baby

I've been to Phoenix, AZ. I know I've been to Seattle, but I'm not sure if I made it to Tacoma. I once rode the train from DC to NY, which had at least one stop in Philadelphia. I've somehow never been to Atlanta, not even for a layover; I've been to L.A., and I've seen Northern California.

In the song "Rockin' Me" Steve Miller travels to all these destinations. He does so, he first claims, to be with his “sweet baby,” only a few verses later "just to hear [his] sweet baby say 'Keep on a rockin' me baby.'" The thing I don’t really understand, however, is why he needs to visit these locations.

One thought, based on the first verse, is that he is travelling to all of these cities looking real hard to find a job. Another theory is he has found a job which requires his travel. Perhaps he’s just stalking this girl, but I kind of always thought he was just on a concert tour.

Regardless of the reason, I’ve found the list of cities to be curious. We start out in Phoenix, a southwestern US city, and the only city listed in which the state is named. He might name the state to ensure that we don't get it confused with one of the other 6 cities/towns named Phoenix, but I think that it’s probably because Arizona is a near-rhyme with the next city: Tacoma. From the southwest to the northwest, we round off the four corners of the country with Philadelphia and Atlanta, only to end up back on the west coast in L.A. From there it’s just a short trip up the coast to Northern California (38.2813° N, 120.9045° W), where the Steve Miller Band happened to call home. I really don’t know if I am just reading too much into the lyrics, but that is a long trip! How long? Well, I thought I’d approximate it:


So that’s really it - I wanted to know how far this alleged trip was, and if past the convenient rhymes and less convenient proximities, if there were any patterns that emerged from plotting out this odyssey.

The answer - no.



R Code:


library(maps)
library(animation)
cities = c("Phoenix, AZ","Tacoma","Philadelphia","Atlanta","L.A.","Northern California")
lat = c(33.4492,47.2531,39.9522,33.7489,34.0522,38.2813)
long = -c(112.0739,122.4431,75.1642,84.3881,118.2428,120.9045)
distance = c(1093,2381,658,1938,336)

m=map("state", interior = T)
par(mar=c(0,0,0,0))
par(mar=c(5,4,4,2)+.1)
y.seq = x.seq=NULL
slope = rep(NA,length(lat)-1)
int = rep(NA,length(lat)-1)
d=NULL
for(i in 2:length(lat)-1) {
  slope[i] = (lat[i+1]-lat[i])/(long[i+1]-long[i])
  int[i] = lat[i]-slope[i]*long[i]

  l.out = sqrt((long[i]-long[i+1])^2 + (lat[i]-lat[i+1])^2)

  x.seq[[i]] = seq(long[i],long[i+1],length.out=l.out)
  y.seq[[i]] = int[i] + x.seq[[i]]*slope[i]

  a1 = lat[i]
  a2 = lat[i+1]
  b1 = long[i]
  b2 = long[i+1]
  d[[i]] = seq(0,distance[i],length=l.out)
}
x.seq[[5]] = c(x.seq[[5]],rep(x.seq[[5]][5],10))
y.seq[[5]] = c(y.seq[[5]],rep(y.seq[[5]][5],10))
d[[5]] = c(d[[5]],rep(d[[5]][5],10))
for(x in 2:5) {
  d[[x]] = d[[x]]+d[[x-1]][length(d[[x-1]])]
}

saveGIF({
  for(i in 1:5) {
    for(j in 1:length(x.seq[[i]])) {
      plot(m,type="l",axes=F,col="steelblue",xlab="",ylab="",
           main="Rockin' Me")
      #map("state", boundary = FALSE, col="gray70", add = TRUE)
   
      points(long[0:i+1],lat[0:i+1],cex=.7,pch=16)
      text(long[0:i+1],lat[0:i+1],cities[0:i+1],pos=c(1,3,3,1,1,3)[0:i+1],cex=1.1,col="red")
      text(-98.5795,39.5285,paste(round(d[[i]][j]),"Miles"),cex=1.3,col="blue2")
      if(i>1) {
        for(q in 1:(i-1)) {
          lines(x.seq[[q]],y.seq[[q]])
        }      
      }
      lines(x.seq[[i]][c(1,j)],y.seq[[i]][c(1,j)])
    }  
  }
}, movie.name = "rockinmebaby.gif", interval = 0.03, nmax = 1000,
        ani.width = 930, ani.height = 600)


Sunday, January 9, 2011

Some useful R functions

Its been a while. In that time there have been several instances when I've been in need of some of the following functions and I had to go digging through my old homeworks to find specific instances when I used them; so I thought they'd be worth posting on here.

First the proc.time() function is useful to see the runtime of a program. Here's an example that will give the run time in seconds:

time <- proc.time()
# - run some function - #
proc.time()[3] - time[3]

Some of the functions that I wrote for missing data have proven to be quite useful as well. First I always forget the is.na() function and often confuse complete.cases with na.omit


### Ways to find what values are missing
complete.cases(sed) #T/F if row has any missing
na.omit(sed) #gives only rows with no missing values
is.na(sed)==F #have to use is.na as a logical argument, not ==NA

Here are some functions that I think are quite useful and I am surprised they aren't available in R, or if they are, I don't know what they are called

### Identify cols that are entirely NA
NA.cols<-function(X) {
 cols<-apply(X,2,function(x) sum(is.na(x)))==nrow(X)
 names(cols)<-colnames(X)
 na.cols<-which(cols==T)
 if(length(na.cols)==0) na.cols<-'Each column has at least one non NA value'
 return(na.cols)
}

### Identify rows that are entirely NA (opposite of
### complete.cases)
NA.rows<-function(X) {
 rows<-apply(X,1,function(x) sum(is.na(x)))==ncol(X)
 names(rows)<-rownames(X)
 na.rows<-which(rows==T)
 if(length(na.rows)==0) na.rows<-'Each row has at least one non NA value'
 return(na.rows)
}




### Identify cols that have no have no NA values (I guess you
### could also transpose the data and do na.omit)
complete.cols<-function(X) {
 cols<-apply(X,2,function(x) sum(is.na(x)))==0
 names(cols)<-colnames(X)
 complete.cols<-which(cols==T)
 if(length(complete.cols)==0) complete.cols<-'There are no complete variables'
 return(complete.cols)
}





I also have my simple imputation function. For real imputation techniques I recommend the Amelia package (at least thats what I used for the multivariate class, and it seemed to have some nice features).  I found using proc.time() that it takes like 22 seconds to run on my machine, mostly because the 'hot deck' imputation could probably be more efficient. The real lesson here is that when you write a function, you get to name it after yourself

### A function that returns some simple imputation methods
Alan.imputations<-function(X) {
 require(fields)


 mean.x<-rep(NA,ncol(X))
 median.x<-rep(NA,ncol(X))
 min.x<-rep(NA,ncol(X))
 max.x<-rep(NA,ncol(X))


 X.mean<-X
 X.median<-X
 X.min<-X
 X.max<-X
 X.zero<-X
 X.sample<-X


 for(j in 1:ncol(X)) {
  if(is.numeric(X[,j])==T) {
   mean.x[j]<-mean(X[,j],na.rm=T)
   median.x[j]<-median(X[,j],na.rm=T)
   min.x[j]<-min(X[,j],na.rm=T)
   max.x[j]<-max(X[,j],na.rm=T)
  }
 }
 for(j in 1:ncol(X)) {
  X.mean[is.na(X.mean[,j]),j]<-mean.x[j]
  X.median[is.na(X.median[,j]),j]<-median.x[j]
  X.min[is.na(X.min[,j]),j]<-min.x[j]
  X.max[is.na(X.max[,j]),j]<-max.x[j]

  i.na<-is.na(X[,j])
  if(sum(i.na)!=length(i.na))
  X.sample[i.na,j]<-sample(na.omit(X[,j]),sum(i.na),replace=T)
 }
 X.zero[is.na(X.zero)]<-0

 cols<-apply(X,2,function(x) sum(is.na(x)))==nrow(X)
 na.cols<-which(cols==T)
 comp.X<-na.omit(X[,-na.cols])
 numeric.cols<-rep(NA,ncol(comp.X))
 for(i in 1:ncol(comp.X)) { 
  numeric.cols[i] <- is.numeric(comp.X[,i])
 }

 X.na<-X[,-na.cols];X.na<-X.na[,numeric.cols]
 NA.index<-which(is.na(X.na)==T,arr.ind=T)
 sX <- scale(X.na)


 X.na.center<-X.na - matrix(attr(sX,"scaled:center"),nrow(X.na),ncol(X.na),byrow=T)
 X.na.scaled<-X.na.center/matrix(attr(sX,"scaled:scale"),nrow(X.na.center),ncol(X.na.center),byrow=T)
 new.na.cols<-NA.cols(X.na.scaled)
 X.na.scaled<-X.na.scaled[,-new.na.cols]
 new.complete.cols<-complete.cols(X.na.scaled)




 dist<-matrix(NA,nrow(X.na.scaled),nrow(X.na.scaled))
 for(i in 1:nrow(X.na.scaled)) {
  dist[i,]<-rdist(X.na.scaled[i,new.complete.cols],X.na.scaled[,new.complete.cols])
 }


 for(i in 1:nrow(dist)) {
 if(complete.cases(X.na.scaled)[i]==F) {
 j<-2
   min<-which(dist[i,]==dist[i,order(dist[i,])[j]])
   while(sum(is.na(X.na.scaled[min,is.na(X.na.scaled[i,])]))!=0) {
    min<-which(dist[i,]==dist[i,order(dist[i,])[j]])
    j<-j+1
   }
  X.na.scaled[i,is.na(X.na.scaled[i,])]<- X.na.scaled[min,is.na(X.na.scaled[i,])]
 }  
 }

 X.hotdeck<-X.na.scaled*matrix(attr(sX,"scaled:scale")[-new.na.cols],nrow(X.na.scaled),ncol(X.na.scaled),byrow=T)+matrix(attr(sX,"scaled:center")[-new.na.cols],nrow(X.na.scaled),ncol(X.na.scaled),byrow=T)


 alan<-list(max=X.max, mean=X.mean, median=X.median, min=X.min, sample=X.sample, zero=X.zero, hotdeck=X.hotdeck)
 return(alan)
}


(note that some of the spacing gets messed up, just in case something doesn't run right)