How to extract coordinates of colored dots from a jpeg image?

Question

I am trying to measure distances between objects of interests (in this example year rings in trees) using R. My earlier attempt was so complicated that I have difficulties reproducing the solution for a similar type of a problem using different kinds of figures. I think that there must be an easier way of doing the measurements. As nice as ImageJ might be for picture analysis, I find it too clumsy to use for repetitive work. Why not just to mark the objects of interest with different colors using an image handling program and trying to extract the information about their position? (this is not the question). Here is an example:

(Save the picture as tree.jpg). In order to measure the distance from the beginning (blue dot) to the red and green dots (representing two different arbitrary measurements), I need to extract the centroid and color characteristic (i.e. whether the dot is green, blue or red) of each dot in the picture.

The colors I have used are following:

cols <- list(red = rgb(255/255, 0/255, 0/255), green = rgb(0/255, 255/255, 0/255), blue = rgb(0/255, 0/255, 255/255))

I have managed to open the file and plot it:

library("jpeg")
img <- readJPEG("tree.jpg")
ydim <- attributes(img)$dim[1] # Image dimension y-axis
xdim <- attributes(img)$dim[2] # Image dimension x-axis
plot(c(0,xdim), c(0,ydim), type='n')
rasterImage(img, 0,0,xdim,ydim)

Dimensions in the plot are in pixels. I can also extract the information in one of the RGB channels (here in green):

plot(c(0,xdim), c(0,ydim), type='n')
rasterImage(img[,,2], 0,0,xdim,ydim)

After this I am starting to experience problems. I have found out that Momocs package, might be able to extract the shapes from RGB channel matrices, but I doubt that it is the right tool for this problem. Maybe one of the spatial packages could work? (I did not find a function for this purpose, though). How do I extract the position (in pixels using an arbitrary coordinate system) of colored dots from an image using R?

Answer 1

Maybe there is some library that can do this already, but here are some utility functions that I wrote to help:

# What are the cartesian coordinates of pixels within the tolerance?
extract.coord<-function(channel,tolerance=0.99){
  positions<-which(img[,,channel]>=tolerance) 
  row<-nrow(img) - (positions %% nrow(img))
  col<-floor(positions / nrow(img))  +1
  data.frame(x=col,y=row)
}

# Do these two pixels touch? (Diagonal touch returns TRUE)
touches<-function(coord1,coord2)
  coord2$x <= (coord1$x+1) & coord2$x >= (coord1$x-1) & coord2$y <= (coord1$y+1) & coord2$y >= (coord1$y-1)

# Does this pixel touch any pixel in this list?
touches.list<-function(coord1,coord.list)
  any(sapply(1:nrow(coord.list),function(x)touches(coord.list[x,],coord1)))

# Given a data.frame of pixel coordinates, give me a list of data frames
# that contain the "blobs" of pixels that all touch.
extract.pixel.blobs<-function(coords){
  blob.list<-list()
  for(row in 1:nrow(coords)){
    coord<-coords[row,]
    matched.blobs<-sapply(blob.list,touches.list,coord1=coord)
    if(!any(matched.blobs)){
      blob.list[[length(blob.list)+1]]<-coords[row,,drop=FALSE]
    } else {
      if(length(which(matched.blobs))==1) {
        blob.list[[which(matched.blobs)]]<-rbind(blob.list[[which(matched.blobs)]],coords[row,,drop=FALSE])
      } else { # Pixel touches two blobs
        touched.blobs<-blobs[which(matched.blobs)]
        blobs<-blobs[-which(matched.blobs)]
        combined.blobs<-do.call(rbind,touched.blobs)
        combined.blobs<-rbind(combined.blobs,coords[row,,drop=FALSE])
        blobs[[length(blob.list)+1]]<-combined.blobs
      }
    }
  }
  blob.list
}

# Not exact center, but maybe good enough?
extract.center<-function(coords){
  round(c(mean(coords$x),mean(coords$y))) # Good enough?
}

Use the functions like this:

coord.list<-lapply(1:3,extract.coord)
names(coord.list)<-c('red','green','blue')
pixel.blobs<-lapply(coord.list,extract.pixel.blobs)
pixel.centers<-lapply(pixel.blobs,function(x) do.call(rbind,lapply(x,extract.center)))

# $red
# [,1] [,2]
# [1,]   56   60
# [2,]   62   65
# [3,]  117  123
# [4,]  154  158
# 
# $green
# [,1] [,2]
# [1,]   72   30
# [2,]   95   15
# 
# $blue
# [,1] [,2]
# [1,]   44   45