R-statistics blog » R code

Clustergram: visualization and diagnostics for cluster analysis (R code)

Tal Galili — Tue, 15 Jun 2010 08:22:34 +0000

About Clustergrams

In 2002, Matthias Schonlau published in “The Stata Journal” an article named “The Clustergram: A graph for visualizing hierarchical and . As explained in the abstract:

In hierarchical cluster analysis dendrogram graphs are used to visualize how clusters are formed. I propose an alternative graph named “clustergram” to examine how cluster members are assigned to clusters as the number of clusters increases.
This graph is useful in exploratory analysis for non-hierarchical clustering algorithms like k-means and for hierarchical cluster algorithms when the number of observations is large enough to make dendrograms impractical.

A similar article was later written and was (maybe) published in “computational statistics”.

Both articles gives some nice background to known methods like k-means and methods for hierarchical clustering, and then goes on to present examples of using these methods (with the Clustergarm) to analyse some datasets.

Personally, I understand the clustergram to be a type of parallel coordinates plot where each observation is given a vector. The vector contains the observation’s location according to how many clusters the dataset was split into. The scale of the vector is the scale of the first principal component of the data.

Clustergram in R (a basic function)

After finding out about this method of visualization, I was hunted by the curiosity to play with it a bit. Therefore, and since I didn’t find any implementation of the graph in R, I went about writing the code to implement it.

The code only works for kmeans, but it shows how such a plot can be produced, and could be later modified so to offer methods that will connect with different clustering algorithms.

The function I present here gets a data.frame/matrix with a row for each observation, and the variable dimensions present in the columns.
The function assumes the data is scaled.
The function then goes about calculating the cluster centers for our data, for varying number of clusters.
For each cluster iteration, the cluster centers are multiplied by the first loading of the principal components of the original data. Thus offering a weighted mean of the each cluster center dimensions that might give a decent representation of that cluster (this method has the known limitations of using the first component of a PCA for dimensionality reduction, but I won’t go into that in this post).
Finally all of our data points are ordered according to their respective cluster first component, and plotted against the number of clusters (thus creating the clustergram).

My thank goes to Hadley Wickham for offering some good tips on how to prepare the graph.

Here is the code (example follows)

 
 
clustergram.kmeans <- function(Data, k, ...)
{
	# this is the type of function that the clustergram
	# 	function takes for the clustering.
	# 	using similar structure will allow implementation of different clustering algorithms
 
	#	It returns a list with two elements:
	#	cluster = a vector of length of n (the number of subjects/items)
	#				indicating to which cluster each item belongs.
	#	centers = a k dimensional vector.  Each element is 1 number that represent that cluster
	#				In our case, we are using the weighted mean of the cluster dimensions by 
	#				Using the first component (loading) of the PCA of the Data.
 
	cl <- kmeans(Data, k,...)
 
	cluster <- cl$cluster
	centers <- cl$centers %*% princomp(Data)$loadings[,1]	# 1 number per center
												# here we are using the weighted mean for each
 
	return(list(
				cluster = cluster,
				centers = centers
			))
}		
 
clustergram.plot.matlines <- function(X,Y, k.range, 
											x.range, y.range , COL, 
											add.center.points , centers.points)
	{
		plot(0,0, col = "white", xlim = x.range, ylim = y.range,
			axes = F,
			xlab = "Number of clusters (k)", ylab = "PCA weighted Mean of the clusters", main = "Clustergram of the PCA-weighted Mean of the clusters k-mean clusters vs number of clusters (k)")
		axis(side =1, at = k.range)
		axis(side =2)
		abline(v = k.range, col = "grey")
 
		matlines(t(X), t(Y), pch = 19, col = COL, lty = 1, lwd = 1.5)
 
		if(add.center.points)
		{
			require(plyr)
 
			xx <- ldply(centers.points, rbind)
			points(xx$y~xx$x, pch = 19, col = "red", cex = 1.3)
 
			# add points	
			# temp <- l_ply(centers.points, function(xx) {
									# with(xx,points(y~x, pch = 19, col = "red", cex = 1.3))
									# points(xx$y~xx$x, pch = 19, col = "red", cex = 1.3)
									# return(1)
									# })
						# We assign the lapply to a variable (temp) only to suppress the lapply "NULL" output
		}	
	}
 
 
 
clustergram <- function(Data, k.range = 2:10 , 
							clustering.function = clustergram.kmeans,
							clustergram.plot = clustergram.plot.matlines, 
							line.width = .004, add.center.points = T)
{
	# Data - should be a scales matrix.  Where each column belongs to a different dimension of the observations
	# k.range - is a vector with the number of clusters to plot the clustergram for
	# clustering.function - this is not really used, but offers a bases to later extend the function to other algorithms 
	#			Although that would  more work on the code
	# line.width - is the amount to lift each line in the plot so they won't superimpose eachother
	# add.center.points - just assures that we want to plot points of the cluster means
 
	n <- dim(Data)[1]
 
	PCA.1 <- Data %*% princomp(Data)$loadings[,1]	# first principal component of our data
 
	if(require(colorspace)) {
			COL <- heat_hcl(n)[order(PCA.1)]	# line colors
		} else {
			COL <- rainbow(n)[order(PCA.1)]	# line colors
			warning('Please consider installing the package "colorspace" for prittier colors')
		}
 
	line.width <- rep(line.width, n)
 
	Y <- NULL	# Y matrix
	X <- NULL	# X matrix
 
	centers.points <- list()
 
	for(k in k.range)
	{
		k.clusters <- clustering.function(Data, k)
 
		clusters.vec <- k.clusters$cluster
			# the.centers <- apply(cl$centers,1, mean)
		the.centers <- k.clusters$centers 
 
		noise <- unlist(tapply(line.width, clusters.vec, cumsum))[order(seq_along(clusters.vec)[order(clusters.vec)])]	
		# noise <- noise - mean(range(noise))
		y <- the.centers[clusters.vec] + noise
		Y <- cbind(Y, y)
		x <- rep(k, length(y))
		X <- cbind(X, x)
 
		centers.points[[k]] <- data.frame(y = the.centers , x = rep(k , k))	
	#	points(the.centers ~ rep(k , k), pch = 19, col = "red", cex = 1.5)
	}
 
 
	x.range <- range(k.range)
	y.range <- range(PCA.1)
 
	clustergram.plot(X,Y, k.range, 
											x.range, y.range , COL, 
											add.center.points , centers.points)
 
 
}

Example on the iris dataset

The iris data set is a favorite example of many R bloggers when writing about R accessors , Data Exporting, Data importing, and for different visualization techniques.
So it seemed only natural to experiment on it here.

data(iris)
set.seed(250)
par(cex.lab = 1.5, cex.main = 1.2)
Data <- scale(iris[,-5]) # notice I am scaling the vectors)
clustergram(Data, k.range = 2:8, line.width = 0.004) # notice how I am using line.width.  Play with it on your problem, according to the scale of Y.

Here is the output:

Looking at the image we can notice a few interesting things. We notice that one of the clusters formed (the lower one) stays as is no matter how many clusters we are allowing (except for one observation that goes way and then beck).
We can also see that the second split is a solid one (in the sense that it splits the first cluster into two clusters which are not “close” to each other, and that about half the observations goes to each of the new clusters).
And then notice how moving to 5 clusters makes almost no difference.
Lastly, notice how when going for 8 clusters, we are practically left with 4 clusters (remember – this is according the mean of cluster centers by the loading of the first component of the PCA on the data)

If I where to take something from this graph, I would say I have a strong tendency to use 3-4 clusters on this data.

But wait, did our clustering algorithm do a stable job?
Let’s try running the algorithm 6 more times (each run will have a different starting point for the clusters)

set.seed(500)
Data <- scale(iris[,-5]) # notice I am scaling the vectors)
par(cex.lab = 1.2, cex.main = .7)
par(mfrow = c(3,2))
for(i in 1:6) clustergram(Data, k.range = 2:8 , line.width = .004, add.center.points = T)

Resulting with: (press the image to enlarge it)

Repeating the analysis offers even more insights.
First, it would appear that until 3 clusters, the algorithm gives rather stable results.
From 4 onwards we get various outcomes at each iteration.
At some of the cases, we got 3 clusters when we asked for 4 or even 5 clusters.

Reviewing the new plots, I would prefer to go with the 3 clusters option. Noting how the two “upper” clusters might have similar properties while the lower cluster is quite distinct from the other two.

By the way, the Iris data set is composed of three types of flowers. I imagine the kmeans had done a decent job in distinguishing the three.

Limitation of the method (and a possible way to overcome it?!)

It is worth noting that the current way the algorithm is built has a fundamental limitation: The plot is good for detecting a situation where there are several clusters but each of them is clearly “bigger” then the one before it (on the first principal component of the data).

For example, let’s create a dataset with 3 clusters, each one is taken from a normal distribution with a higher mean:

set.seed(250)
Data <- rbind(
				cbind(rnorm(100,0, sd = 0.3),rnorm(100,0, sd = 0.3),rnorm(100,0, sd = 0.3)),
				cbind(rnorm(100,1, sd = 0.3),rnorm(100,1, sd = 0.3),rnorm(100,1, sd = 0.3)),
				cbind(rnorm(100,2, sd = 0.3),rnorm(100,2, sd = 0.3),rnorm(100,2, sd = 0.3))
				)				
clustergram(Data, k.range = 2:5 , line.width = .004, add.center.points = T)

The resulting plot for this is the following:

The image shows a clear distinction between three ranks of clusters. There is no doubt (for me) from looking at this image, that three clusters would be the correct number of clusters.

But what if the clusters where different but didn’t have an ordering to them?
For example, look at the following 4 dimensional data:

set.seed(250)
Data <- rbind(
				cbind(rnorm(100,1, sd = 0.3),rnorm(100,0, sd = 0.3),rnorm(100,0, sd = 0.3),rnorm(100,0, sd = 0.3)),
				cbind(rnorm(100,0, sd = 0.3),rnorm(100,1, sd = 0.3),rnorm(100,0, sd = 0.3),rnorm(100,0, sd = 0.3)),
				cbind(rnorm(100,0, sd = 0.3),rnorm(100,1, sd = 0.3),rnorm(100,1, sd = 0.3),rnorm(100,0, sd = 0.3)),
				cbind(rnorm(100,0, sd = 0.3),rnorm(100,0, sd = 0.3),rnorm(100,0, sd = 0.3),rnorm(100,1, sd = 0.3))
				)				
clustergram(Data, k.range = 2:8 , line.width = .004, add.center.points = T)

In this situation, it is not clear from the location of the clusters on the Y axis that we are dealing with 4 clusters.
But what is interesting, is that through the growing number of clusters, we can notice that there are 4 “strands” of data points moving more or less together (until we reached 4 clusters, at which point the clusters started breaking up).
Another hope for handling this might be using the color of the lines in some way, but I haven’t yet figured out how.

Clustergram with ggplot2

Hadley Wickham has kindly played with recreating the clustergram using the ggplot2 engine. You can see the result here:
http://gist.github.com/439761
And this is what he wrote about it in the comments:

I’ve broken it down into three components:
* run the clustering algorithm and get predictions (many_kmeans and all_hclust)
* produce the data for the clustergram (clustergram)
* plot it (plot.clustergram)
I don’t think I have the logic behind the y-position adjustment quite right though.

Here is an example of how it looks:

Conclusions (some rules of thumb and questions for the future)

In a first look, it would appear that the clustergram can be of use. I can imagine using this graph to quickly run various clustering algorithms and then compare them to each other and review their stability (In the way I just demonstrated in the example above).

The three rules of thumb I have noticed by now are:

Look at the location of the cluster points on the Y axis. See when they remain stable, when they start flying around, and what happens to them in higher number of clusters (do they re-group together)
Observe the strands of the datapoints. Even if the clusters centers are not ordered, the lines for each item might (needs more research and thinking) tend to move together – hinting at the real number of clusters
Run the plot multiple times to observe the stability of the cluster formation (and location)

Yet there is more work to be done and questions to seek answers to:

The code needs to be extended to offer methods to various clustering algorithms.
How can the colors of the lines be used better?
How can this be done using other graphical engines (ggplot2/lattice?) – (Update: look at Hadley’s reply in the comments)
What to do in case the first principal component doesn’t capture enough of the data? (maybe plot this graph to all the relevant components. but then – how do you make conclusions of it?)
What other uses/conclusions can be made based on this graph?

I am looking forward to reading your input/ideas in the comments (or in reply posts).

How to upgrade R on windows – another strategy (and the R code to do it)

Tal Galili — Fri, 23 Apr 2010 22:45:14 +0000

Update: In the end of the post I added simple step by step instruction on how to move to the new system. I STRONGLY suggest using the code only after you read the entire post.

Background

If you didn’t hear it by now – R 2.11.0 is out with a bunch of new features.

After Andrew Gelman recently lamented the lack of an easy upgrade process for R, a Stackoverflow thread (by JD Long) invited R users to share their strategies for easily upgrading R.

Strategy

In that thread, Dirk Eddelbuettel suggested another idea for upgrading R. His idea is of using a folder for R’s packages which is outside the standard directory tree of the installation (a different strategy then the one offered on the R FAQ).

The idea of this upgrading strategy is to save us steps in upgrading. So when you wish to upgrade R, instead of doing the following three steps:
1) download new R and install
2) copy the “library” content from the old R to the new R
3) upgrade all of the packages (in the library folder) to the new version of R.
You could instead just have steps 1 and 3, and skip step 2.

For example, under windows, you might have R installed on:
C:\Program Files\R\R-2.11.0\
But (in this alternative model for upgrading) you will have your packages library on a “global library folder” (global in the sense of independent of a specific R version):
C:\Program Files\R\library

So in order to use this strategy, you will need to do the following steps -

In the OLD R installation (in the first time you move to the new system of managing the upgrade):
1. Create a new global library folder (if it doesn’t exist)
2. Copy to the new “global library folder” all of your packages from the old R installation
3. After you move to this system – the steps 1 and 2 would not need to be repeated. (hence the advantage)
In the NEW R installation:
1. Create a new global library folder (if it doesn’t exist – in case this is your first R installation)
2. Premenantly point to the Global library folder whenever R starts
3. Delete from the “Global library folder” all the packages that already exist in the local library folder of the new R install (no need to have doubles)
4. Update all packages. (notice that you picked a mirror where the packages are up-to-date, you sometimes need to choose another mirror)

Thanks to help from Dirk, David Winsemius and Uwe Ligges, I was able to write the following R code to perform all the tasks I described

So first you will need to run the following code:

Code for upgrading R

Old.R.RunMe <- function (global.library.folder = "C:/Program Files/R/library", quit.R = NULL)
{
# It will:
# 1. Create a new global library folder (if it doesn't exist)
# 2. Copy to the new "global library folder" all of your packages from the old R installation
 
 
	# checking that the global lib folder exists - and if not -> create it.
	if(!file.exists(global.library.folder))
	{	# If global lib folder doesn't exist - create it.
		dir.create(global.library.folder)
		print(paste("The path:" , global.library.folder, "Didn't exist - and was now created."))
	} else {
		print(paste("The path:" , global.library.folder, "already exist. (no need to create it)"))
	}
 
 
	print("-----------------------")
	print("I am now copying packages from old library folder to:")
	print(global.library.folder)
	print("-----------------------")
	flush.console()  # refresh the console so that the user will see the massage
 
	# Copy packages from current lib folder to the global lib folder
	list.of.dirs.in.lib <- paste( paste(R.home(), "\\library\\", sep = ""),
							list.files(paste(R.home(), "\\library\\", sep = "")),
							sep = "")
	folders.copied <- file.copy(from = list.of.dirs.in.lib, 	# copy folders
								to = global.library.folder,
								overwrite = TRUE,
								recursive =TRUE)		
 
	print("Success.")
	print(paste("We finished copying all of your packages (" , sum(folders.copied), "packages ) to the new library folder at:"))
	print(global.library.folder)
	print("-----------------------")
 
	# To quite R ?
	if(is.null(quit.R))
	{
		print("Can I close R?  y(es)/n(o)  (WARNING: your enviornment will *NOT* be saved)")
		answer <- readLines(n=1)
	} else {
		answer <- quit.R
	}
	if(tolower(answer)[1] == "y") quit(save = "no")
}
 
 
 
 
 
 
 
New.R.RunMe <- function (global.library.folder = "C:/Program Files/R/library", 
							quit.R = F,
							del.packages.that.exist.in.home.lib = T,
							update.all.packages = T)
{
# It will:
# 1. Create a new global library folder (if it doesn't exist)
# 2. Premenantly point to the Global library folder
# 3. Make sure that in the current session - R points to the "Global library folder"
# 4. Delete from the "Global library folder" all the packages that already exist in the local library folder of the new R install
# 5. Update all packages.
 
 
	# checking that the global lib folder exists - and if not -> create it.
	if(!file.exists(global.library.folder))
	{	# If global lib folder doesn't exist - create it.
		dir.create(global.library.folder)
		print(paste("The path to the Global library (" , global.library.folder, ") Didn't exist - and was now created."))
	} else {
		print(paste("The path to the Global library (" , global.library.folder, ") already exist. (NO need to create it)"))
	}
	flush.console()  # refresh the console so that the user will see the massage
 
 
	# Based on:
	# help(Startup)
	# checking if "Renviron.site" exists - and if not -> create it.
	Renviron.site.loc <- paste(R.home(), "\\etc\\Renviron.site", sep = "")
	if(!file.exists(Renviron.site.loc))
	{	# If "Renviron.site" doesn't exist (which it shouldn't be) - create it and add the global lib line to it.
		cat(paste("R_LIBS=",global.library.folder, sep = "") ,
				file = Renviron.site.loc)
		print(paste("The file:" , Renviron.site.loc, "Didn't exist - we created it and added your 'Global library link' (",global.library.folder,") to it."))
	} else {
		print(paste("The file:" , Renviron.site.loc, "existed!  make sure you add the following line by yourself:"))
		print(paste("R_LIBS=",global.library.folder, sep = "") )
		print(paste("To the file:",Renviron.site.loc))
	}
 
	# Setting the global lib for this session also
	.libPaths(global.library.folder)	# This makes sure you don't need to restart R so that the new Global lib settings will take effect in this session also
	# This line could have also been added to:
	# /etc/Rprofile.site
	# and it would do the same thing as adding "Renviron.site" did
	print("Your library paths are: ")
	print(.libPaths())	
	flush.console()  # refresh the console so that the user will see the massage
 
 
	if(del.packages.that.exist.in.home.lib)
	{
		print("We will now delete package from your Global library folder that already exist in the local-install library folder")
		flush.console()  # refresh the console so that the user will see the massage
		package.to.del.from.global.lib <- 		paste( paste(global.library.folder, "/", sep = ""),
													list.files(paste(R.home(), "\\library\\", sep = "")),
													sep = "")			
		number.of.packages.we.will.delete <- sum(list.files(paste(global.library.folder, "/", sep = "")) %in% list.files(paste(R.home(), "\\library\\", sep = "")))
		deleted.packages <- unlink(package.to.del.from.global.lib , recursive = TRUE)	# delete all the packages from the "original" library folder (no need for double folders)
		print(paste(number.of.packages.we.will.delete,"Packages where deleted."))
	}
 
	if(update.all.packages)
	{
		# Based on:
		# http://cran.r-project.org/bin/windows/base/rw-FAQ.html#What_0027s-the-best-way-to-upgrade_003f
		print("We will now update all your packges")
		flush.console()  # refresh the console so that the user will see the massage
 
		update.packages(checkBuilt=TRUE, ask=FALSE)
	}
 
	# To quite R ?
	if(quit.R) quit(save = "no")
}

Then you will want to run, on your old R installation, this:

Old.R.RunMe()

And on your new R installation, this:

New.R.RunMe()

Update – simple two line code to run when upgrading R

(Please do not try the following code before reading this post and understanding what it does)

In order to move your R upgrade to the new (simpler) system, do the following:
1) Download and install the new version of R
2) Open your old R and run –

source("http://www.r-statistics.com/wp-content/uploads/2010/04/upgrading-R-on-windows.r.txt")
Old.R.RunMe()

(wait until it finishes)
3) Open your new R and run

source("http://www.r-statistics.com/wp-content/uploads/2010/04/upgrading-R-on-windows.r.txt")
New.R.RunMe()

(wait until it finishes)

Once you do this, then from now on, whenever you will upgrade to a new R, all you will need to do only the following TWO (instead of three) steps:
1) Download and install the new version of R
2) Open your new R and run

source("http://www.r-statistics.com/wp-content/uploads/2010/04/upgrading-R-on-windows.r.txt")
New.R.RunMe()

(wait until it finishes)

And that’s it.

Updates for windows 7 users:
For windows 7 users there are two issues. The first is permissions. The default permissions of the user won’t let you create folders and files under the “program files” directory. ~~To fix this you can either login as the administrator and run the code from there, or change your own user permissions (following the steps described here).~~
There are several fixes for this, the best one (in my view) is to run R with administrator privileges by doing the following steps:

You can do this by following steps (My thanks goes to superuser):

Right click on the R shortcut

Click on Properties

Select the Compatibility tab

At the bottom click “Change settings for all users”

Again at the bottom select to “Run this program as an administrator”

The second issue is that the folder in which R is installed might be different (if you installed the 32 bit version on win 7), in which case you will need to run the following commands (notice the use of the “global.library.folder” paramater)

source("http://www.r-statistics.com/wp-content/uploads/2010/04/upgrading-R-on-windows.r.txt")
# in the old R
Old.R.RunMe(global.library.folder = "C:\\Program Files (x86)\\R\\library")
# in the new R
New.R.RunMe(global.library.folder = "C:\\Program Files (x86)\\R\\library")

* * * *

If you have any more suggestions on how to make this code better – please do share.
~~(After some measure of review will be given to this code, I would upload it to a file for easy running through “source(…)” )~~

Correlation scatter-plot matrix for ordered-categorical data

Tal Galili — Wed, 07 Apr 2010 21:37:26 +0000

When analyzing a questionnaire, one often wants to view the correlation between two or more Likert questionnaire item’s (for example: two ordered categorical vectors ranging from 1 to 5).

When dealing with several such Likert variable’s, a clear presentation of all the pairwise relation’s between our variable can be achieved by inspecting the (Spearman) correlation matrix (easily achieved in R by using the “cor.test” command on a matrix of variables).
Yet, a challenge appears once we wish to plot this correlation matrix. The challenge stems from the fact that the classic presentation for a correlation matrix is a scatter plot matrix – but scatter plots don’t (usually) work well for ordered categorical vectors since the dots on the scatter plot often overlap each other.

There are four solution for the point-overlap problem that I know of:

Jitter the data a bit to give a sense of the “density” of the points
Use a color spectrum to represent when a point actually represent “many points”
Use different points sizes to represent when there are “many points” in the location of that point
Add a LOWESS (or LOESS) line to the scatter plot – to show the trend of the data

In this post I will offer the code for the a solution that uses solution 3-4 (and possibly 2, please read this post comments). Here is the output (click to see a larger image):

And here is the code to produce this plot:

R code for producing a Correlation scatter-plot matrix – for ordered-categorical data

Note that this code will work fine for continues data points (although I might suggest to enlarge the “point.size.rescale” parameter to something bigger then 1.5 in the “panel.smooth.ordered.categorical” function)

# -----------------
# Functions
# -----------------
 
panel.cor.ordered.categorical <- function(x, y, digits=2, prefix="", cex.cor) 
{
 
    usr <- par("usr"); on.exit(par(usr)) 
    par(usr = c(0, 1, 0, 1)) 
 
    r <- abs(cor(x, y, method = "spearman")) # notive we use spearman, non parametric correlation here
    r.no.abs <- cor(x, y, method = "spearman")
 
 
    txt <- format(c(r.no.abs , 0.123456789), digits=digits)[1] 
    txt <- paste(prefix, txt, sep="") 
    if(missing(cex.cor)) cex <- 0.8/strwidth(txt) 
 
    test <- cor.test(x,y, method = "spearman") 
    # borrowed from printCoefmat
    Signif <- symnum(test$p.value, corr = FALSE, na = FALSE, 
                  cutpoints = c(0, 0.001, 0.01, 0.05, 0.1, 1),
                  symbols = c("***", "**", "*", ".", " ")) 
 
    text(0.5, 0.5, txt, cex = cex * r) 
    text(.8, .8, Signif, cex=cex, col=2) 
}
 
 
 
 
panel.smooth.ordered.categorical <- function (x, y, col = par("col"), bg = NA, pch = par("pch"), 
												cex = 1, col.smooth = "red", span = 2/3, iter = 3, 
												point.size.rescale = 1.5, ...) 
{
	#require(colorspace)
    require(reshape)
    z <- merge(data.frame(x,y), melt(table(x ,y)),sort =F)$value
    #the.col <- heat_hcl(length(x))[z]
    z <- point.size.rescale*z/ (length(x)) # notice how we rescale the dots accourding to the maximum z could have gotten
 
    symbols( x, y,  circles = z,#rep(0.1, length(x)), #sample(1:2, length(x), replace = T) ,
			inches=F, bg= "grey",#the.col ,
			fg = bg, add = T)
 
    # points(x, y, pch = pch, col = col, bg = bg, cex = cex)
    ok <- is.finite(x) & is.finite(y)
    if (any(ok)) 
        lines(stats::lowess(x[ok], y[ok], f = span, iter = iter), 
            col = col.smooth, ...)
}
 
 
panel.hist <- function(x, ...)
{
    usr <- par("usr"); on.exit(par(usr))
    par(usr = c(usr[1:2], 0, 1.5) )
    h <- hist(x, plot = FALSE, br = 20)
    breaks <- h$breaks; nB <- length(breaks)
    y <- h$counts; y <- y/max(y)
    rect(breaks[-nB], 0, breaks[-1], y, col="orange", ...)
}
 
 
pairs.ordered.categorical <- function(xx,...)
		{
			pairs(xx , 
					diag.panel = panel.hist ,
					lower.panel=panel.smooth.ordered.categorical,
					upper.panel=panel.cor.ordered.categorical,
					cex.labels = 1.5, ...) 
		}
 
 
 
 
# -----------------
# Example
# -----------------
 
set.seed(666)
a1 <- sample(1:5, 100, replace = T)
a2 <- sample(1:5, 100, replace = T)
a3 <- round(jitter(a2, 7) )
	a3[a3 < 1 | a3 > 5] <- 3
a4 <- 6-round(jitter(a1, 7) )
	a4[a4 < 1 | a4 > 5] <- 3
 
aa <- data.frame(a1,a2,a3, a4)
 
require(reshape)
 
# plotting :)		
pairs.ordered.categorical(aa)

Credits:

The original R code for the correlation matrix plot was taken from R Graph Gallery (The differences are: 1) The use of spearman correlation; 2) The adding of hist panel and; 3) The changing of points sizes
The idea to use symbols for changing the point sizes was offered by Doug Y’barbo.
And also to Dirk Eddelbuettel for offering to use cex (although I ended up not using that)

If you got ideas on how to improve this code (or reproducing it with ggplot2 or lattice), please do so in the comments (or on your own blog, but be sure to let me know )

Quantile LOESS – Combining a moving quantile window with LOESS (R function)

Tal Galili — Thu, 01 Apr 2010 14:27:58 +0000

In this post I will provide R code that implement’s the combination of repeated running quantile with the LOESS smoother to create a type of “quantile LOESS” (e.g: “Local Quantile Regression”).

This method is useful when the need arise to fit robust and resistant ~~(Need to be verified)~~ a smoothed line for a quantile (an example for such a case is provided at the end of this post).

If you wish to use the function in your own code, simply run inside your R console the following line:

source("http://www.r-statistics.com/wp-content/uploads/2010/04/Quantile.loess_.r.txt")

Background

I came a cross this idea in an article titled “High throughput data analysis in behavioral genetics” by Anat Sakov, Ilan Golani, Dina Lipkind and my advisor Yoav Benjamini. From the abstract:

In recent years, a growing need has arisen in different fields, for the development of computational systems for automated analysis of large amounts of data (high-throughput). Dealing with non-standard noise structure and outliers, that could have been detected and corrected in manual analysis, must now be built into the system with the aid of robust methods. [...] we use a non-standard mix of robust and resistant methods: LOWESS and repeated running median.

The motivation for this technique came from “Path data” (of mice) which is

prone to suffer from noise and outliers. During progression a tracking system might lose track of the animal, inserting (occasionally very large) outliers into the data. During lingering, and even more so during arrests, outliers are rare, but the recording noise is large relative to the actual size of the movement. The statistical implications are that the two types of behavior require different degrees of smoothing and resistance. An additional complication is that the two interchange many times throughout a session. As a result, the statistical solution adopted needs not only to smooth the data, but also to recognize, adaptively, when there are arrests. To the best of our knowledge, no single existing smoothing technique has yet been able to fulfill this dual task. We elaborate on the sources of noise, and propose a mix of LOWESS (Cleveland, 1977) and the repeated running median (RRM; Tukey, 1977) to cope with these challenges

If all we wanted to do was to perform moving average (running average) on the data, using R, we could simply use the rollmean function from the zoo package.
But since we wanted also to allow quantile smoothing, we turned to use the rollapply function.

R function for performing Quantile LOESS

Here is the R function that implements the LOESS smoothed repeated running quantile (with implementation for using this with a simple implementation for using average instead of quantile):

# This code relies on the rollapply function from the "zoo" package.  My thanks goes to Achim Zeileis and Gabor Grothendieck for their work on the package.
Quantile.loess<- function(Y, X = NULL, 
							number.of.splits = NULL,
							window.size = 20,
							percent.of.overlap.between.two.windows = NULL,
							the.distance.between.each.window = NULL,
							the.quant = .95,
							window.alignment = c("center"), 
							window.function = function(x) {quantile(x, the.quant)},
							# If you wish to use this with a running average instead of a running quantile, you could simply use:
							# window.function = mean,
							...)
{
	# input: Y and X, and smothing parameters
	# output: new y and x
 
	# Extra parameter "..." goes to the loess	
 
	# window.size ==  the number of observation in the window (not the window length!)
 
	# "number.of.splits" will override "window.size"
	# let's compute the window.size:	
	if(!is.null(number.of.splits)) {window.size <- ceiling(length(Y)/number.of.splits)}
 
	# If the.distance.between.each.window is not specified, let's make the distances fully distinct
	if(is.null(the.distance.between.each.window)) {the.distance.between.each.window <- window.size}
 
	# If percent.of.overlap.between.windows is not null, it will override the.distance.between.each.window 
	if(!is.null(percent.of.overlap.between.two.windows)) 
		{
			the.distance.between.each.window <- window.size * (1-percent.of.overlap.between.two.windows)
		}
 
 
 
	# loading zoo
	if(!require(zoo)) 	
	{
		print("zoo is not installed - please install it.")
		install.packages("zoo")
	}
 
 
	if(is.null(X)) {X <- index(Y)} # if we don't have any X, then Y must be ordered, in which case, we can use the indexes of Y as X.
 
	# creating our new X and Y
	zoo.Y <- zoo(x = Y, order.by = X)
	#zoo.X <- attributes(zoo.Y)$index
 
	new.Y <- rollapply(zoo.Y, width = window.size, 
								FUN = window.function,
								by = the.distance.between.each.window,
								align = window.alignment)
	new.X <- attributes(new.Y)$index	
	new.Y.loess <- loess(new.Y~new.X, family = "sym",...)$fitted 
 
	return(list(y = new.Y, x = new.X, y.loess = new.Y.loess))
}

More on the math of the algorithm can be found in the original article.

Example: Predicting “worst case scenario” Ozone levels using temperature

The following example uses the “airquality” dataset which gives us “Daily air quality measurements in New York, May to September 1973.” With several variables, we will only look at Ozone level and Temperature.
Since high Ozone levels reduces the air quality we breath, I would like to give a prediction of the predicted “worst case” Ozone level (e.g: 95% Ozone level) using to the temperature of the same day.

How would you try to do something like that?

The first solution would be to use the “rq” function from the Quantile Regression R package, but if we where to look at the data, we would see that fitting a straight line is not suitable for our data (since we have a sharp change in slope around the temperature of 80 degrees).
This is a situation where Quantile LOESS (of 95%) might prove to be useful. Here is the code to produce the above plot.

 
data(airquality)
attach(airquality)
 
no.na <- !(is.na(Ozone) | is.na(Temp))
Ozone.2 <- Ozone[no.na]
Temp.2 <- jitter(Temp[no.na])
 
plot(Ozone ~ Temp, main = "Predicting the 95% Ozone level according to Temperature")
 
# fitting the Quantile regression
require(quantreg)
abline(rq(Ozone ~ Temp, tau = .95), col = "red")
 
# fitting the Quantile LOESS
source("http://www.r-statistics.com/wp-content/uploads/2010/04/Quantile.loess_.r.txt")
QL <- Quantile.loess(Y = Ozone.2, X = Temp.2, 
							the.quant = .95,
							window.size = 10,
							window.alignment = c("center"))
points(QL$y.loess ~ QL$x, type = "l", col = "green")
 
legend("topleft",legend = c("95% Quantile regression", "95% Quantile LOESS"), fill = c("red","green"))

Update: I changed in the article’s name from LOWESS to LOESS

After A considerate e-mail from Dirk Eddelbuettel I corrected myself from using LOWESS to LOESS throughout the article. Here’s an explanation to why I did it and also why I corrected it -

Dirk wrote to me:

You have a post entitled ‘quantile lowess’ but you then (correctly) use loess. Do you understand that there are two functions lowess() and loess()?
The former is sort-of a predecessor but nobody but really old books still talks about it. Google for (maybe) ‘Brian Ripley lowess loess’ as he drove
that point home a few times on r-help.

My answer was:

Thanks Dirk, [...]
Regarding the loess != lowess, I noticed that this is indeed the case when I first wrote the post but I was in a predicament:
On the one hand, LOESS is the more modern approach (and what I used in the script). But on the other hand, LOWESS is what the original article’s authors where using. I ended up deciding I would call it the way I did, but after reading what you wrote, I realized I made a mistake.
I went through the article and corrected the lowess to loess, while also adding a paragraph for explain my reasoning.

Update: regarding the method being robust

After Nicholas’s comment I went checking and came across a R-help thread by
Martin Maechler explaining how to update my code from above so that the system will be robust. Martin wrote (My notes are added in []):
One gotcha [when comparing lowess to loess is]– particularly if you were used to the fact that lowess() by default is resistant to outliers {well, in many cases at least} :

lowess() per default has “iter = 3″ which means it uses 3 “robustifying” (also called “huberizing” for Huber (1960)) iterations .
loess() on the other hand has an argument `family’ with possible values “gaussian” and “symmetric” (can be abbreviated) where the *first* one is the default (unfortunately, in my opinion).

I.e., loess() by default is not resistant/robust where as lowess() is. [...] I would however recommend using loess(….., family = “sym”) routinely.

* * *

If you find this code useful, please let me know about it in the comments.

Nutritional supplements efficacy score – Graphing plots of current studies results (using R)

Tal Galili — Thu, 25 Feb 2010 21:17:07 +0000

In this post I showcase a nice bar-plot and a balloon-plot listing recommended Nutritional supplements , according to how much evidence exists for thier benefits, scroll down to see it(and click here for the data behind it)
* * * *
The gorgeous blog “Information Is Beautiful” recently publish an eye candy post showing a “balloon race” image (see a static version of the image here) illustrating how much evidence exists for the benefits of various Nutritional supplements (such as: green tea, vitamins, herbs, pills and so on) . The higher the bubble in the Y axis ~~score (e.g: the bubble size)~~ for the supplement the greater the evidence there is for its effectiveness (But only for the conditions listed along side the supplement).

There are two reasons this should be of interest to us:

This shows a fun plot, that R currently doesn’t know how to do (at least I wasn’t able to find an implementation for it). So if anyone thinks of an easy way for making one – please let me know.
The data for the graph is openly (and freely) provided to all of us on this Google Doc.

The advantage of having the data on a google doc means that we can see when the data will be updated. But more then that, it means we can easily extract the data into R and have our way with it (Thanks to David Smith’s post on the subject)

For example, I was wondering what are ALL of the top recommended Nutritional supplements, an answer that is not trivial to get from the plot that was in the original post.

In this post I will supply two plots that present the data: A barplot (that in retrospect didn’t prove to be good enough) and a balloon-plot for a table (that seems to me to be much better).

Barplot
(You can click the image to enlarge it)

The R code to produce the barplot of Nutritional supplements efficacy score (by evidence for its effectiveness on the listed condition).

 
# loading the data
supplements.data.0 <- read.csv("http://spreadsheets.google.com/pub?key=0Aqe2P9sYhZ2ndFRKaU1FaWVvOEJiV2NwZ0JHck12X1E&output=csv")
supplements.data <- supplements.data.0[supplements.data.0[,2] >2,] # let's only look at "good" supplements
supplements.data <- supplements.data[!is.na(supplements.data[,2]),] # and we don't want any missing data
 
supplement.score <- supplements.data[, 2]
ss <- order(supplement.score, decreasing  = F)	# sort our data
supplement.score <- supplement.score[ss]
supplement.name <- supplements.data[ss, 1]
supplement.benefits <- supplements.data[ss, 4]
supplement.score.col <- factor(as.character(supplement.score))
	levels(supplement.score.col) <-  c("red", "orange", "blue", "dark green")
	supplement.score.col <- as.character(supplement.score.col)
 
# mar: c(bottom, left, top, right) The default is c(5, 4, 4, 2) + 0.1.
par(mar = c(5,9,4,13))	# taking care of the plot margins
bar.y <- barplot(supplement.score, names.arg= supplement.name, las = 1, horiz = T, col = supplement.score.col, xlim = c(0,6.2),
				main = c("Nutritional supplements efficacy score","(by evidence for its effectiveness on the listed condition)", "(2010)"))
axis(4, labels = supplement.benefits, at = bar.y, las = 1) # Add right axis
abline(h = bar.y, col = supplement.score.col , lty = 2) # add some lines so to easily follow each bar

Also, the nice things is that if the guys at Information Is Beautiful will update there data, we could easily run the code and see the updated list of recommended supplements.

Balloon plot
So after some web surfing I came around an implementation of a balloon plot in R (Thanks to R graph gallery)
There where two problems with using the command out of the box. The first one was that the colors where non informative (easily fixed), the second one was that the X labels where overlapping one another. Since there is no “las” parameter in the function, I just opened the function up, found where this was plotted and changed it manually (a bit messy, but that’s what you have to do sometimes…)

Here are the result (you can click the image for a larger image):

And here is The R code to produce the Balloon plot of Nutritional supplements efficacy score (by evidence for its effectiveness on the listed condition).
(it’s just the copy of the function with a tiny bit of editing in line 146, and then using it)

 
require(colorspace)
require(gplots)
 
# I was able to find the function by using
# methods(balloonplot)[1]
# This command: getAnywhere("balloonplot.default") # Wouldn't work...
balloonplot2 <- gplots:::balloonplot.default # This one works :)
 
# now run:
fix(balloonplot2)
# search for 
# y <- ny + 0.75 + (nlabels.x - i + 0.5) * colmar
# And add beneath it the following line:
# y <- rep(y, dim(xlabs)[1]) - c(0,.5,1)
 
supplement.benefits <- tolower(supplement.benefits )
supplement.name		<- tolower(supplement.name)
 
balloonplot2( supplement.name,supplement.benefits, supplement.score, xlab ="supplement", ylab="Benefit",
			show.margins=F, dotsize = 15,fun=function(x)max(x,na.rm=T),			
			rowmar = 7,
			colmar = 7,
			dotcolor = rev(heat_hcl(max( supplement.score)))[ supplement.score-1],
			main = c("Balloon plot of", "Nutritional supplements efficacy score","(by evidence for its effectiveness on the listed condition)", "(2010)"),
			sub = c("Published on www.r-statistics.com")				
			)

Got any good ideas of how else to plot the data? let me know in the comments

Siegel-Tukey: a Non-parametric test for equality in variability (R code)

Tal Galili — Mon, 22 Feb 2010 21:13:51 +0000

Daniel Malter just shared on the R mailing list (link to the thread) his code for performing the Siegel-Tukey (Nonparametric) test for equality in variability.
Excited about the find, I contacted Daniel asking if I could republish his code here, and he kindly replied “yes”.
From here on I copy his note at full.

p.s: (The R function can be downloaded from here)

* * * *

Hi, I recently ran into the problem that I needed a Siegel-Tukey test for equal variability based on ranks. Maybe there is a package that has it implemented, but I could not find it. So I programmed an R function to do it. The Siegel-Tukey test requires to recode the ranks so that they express variability rather than ascending order. This is essentially what the code further below does. After the rank transformation, a regular Mann-Whitney U test is applied. The “manual” and code are pasted below.

Description: Non-parametric Siegel-Tukey test for equality in variability. The null hypothesis is that the variability of x is equal between two groups. A rejection of the null indicates that variability differs between
the two groups.

Usage:

1	siegel.tukey(x,y,id.col=FALSE,adjust.median=FALSE,rnd=8, ...)

Arguments:

x: a vector of data

y: Data of the second group (if id.col=FALSE) or group indicator (if id.col=TRUE). In the latter case, y MUST take 1 or 2 to indicate observations of group 1 and 2, respectively, and x must contain the data for both groups.

id.col: If FALSE (default), then x and y are the data columns for group 1 and 2, respectively. If TRUE, the y is the group indicator.

adjust.median: Should between-group differences in medians be leveled before performing the test? In certain cases, the Siegel-Tukey test is susceptible to median differences and may indicate significant differences in variability that, in reality, stem from differences in medians.

rnd: Should the data be rounded and, if so, to which decimal? The default (-1) uses the data as is. Otherwise, rnd must be a non-negative integer. Typically, this option is not needed. However, occasionally, differences in
the precision with which certain functions return values cause the merging of two data frames to fail within the siegel.tukey function. Only then rounding is necessary. This operation should not be performed if it affects
the ranks of observations.

… arguments passed on to the Wilcoxon test. See ?wilcox.test

Value: Among other output, the function returns rank sums for the two groups, the associated Wilcoxon’s W, and the p-value for a Wilcoxon test on tie-adjusted Siegel-Tukey ranks (i.e., it performs and returns a
Siegel-Tukey test). If significant, the group with the smaller rank sum has greater variability.

References: Sidney Siegel and John Wilder Tukey (1960) “A nonparametric sum of ranks procedure for relative spread in unpaired samples.” Journal of the
American Statistical Association. See also, David J. Sheskin (2004) ”Handbook of parametric and nonparametric statistical procedures.” 3rd
edition. Chapman and Hall/CRC. Boca Raton, FL.

Notes: The Siegel-Tukey test has relatively low power and may, under certain conditions, indicate significance due to differences in medians rather than
differences in variabilities (consider using the argument adjust.median).

Output (in this order)

1. Group medians
2. Wilcoxon-test for between-group differences in median (after the median
adjustment if specified)
3. Unique values of x and their tie-adjusted Siegel-Tukey ranks
4. Xs of group 1 and their tie-adjusted Siegel-Tukey ranks
5. Xs of group 2 and their tie-adjusted Siegel-Tukey ranks
6. Siegel-Tukey test (Wilcoxon test on tie-adjusted Siegel-Tukey ranks)

And here is the code:

siegel.tukey=function(x,y,id.col=FALSE,adjust.median=F,rnd=-1,alternative="two.sided",mu=0,paired=FALSE,exact=FALSE,correct=TRUE,conf.int=FALSE,conf.level=0.95){
 if(id.col==FALSE){
   data=data.frame(c(x,y),rep(c(1,2),c(length(x),length(y))))
   } else {
	data=data.frame(x,y)
   }
 names(data)=c("x","y")
 data=data[order(data$x),]
 if(rnd>-1){data$x=round(data$x,rnd)}
 
 if(adjust.median==T){
	data$x[data$y==1]=data$x[data$y==1]-(median(data$x[data$y==1])-median(data$x[data$y==2]))/2
	data$x[data$y==2]=data$x[data$y==2]-(median(data$x[data$y==2])-median(data$x[data$y==1]))/2
 }
 cat("Median of group 1 = ",median(data$x[data$y==1]),"\n")
 cat("Median of group 2 = ",median(data$x[data$y==2]),"\n","\n")
 cat("Test of median differences","\n")
 print(wilcox.test(data$x[data$y==1],data$x[data$y==y]))
 
 a=rep(seq(ceiling(length(data$x)/4)),each=2)
 b=rep(c(0,1),ceiling(length(data$x)/4))
 rk.up=c(1,(a*4+b))[1:ceiling(length(data$x)/2)]
 rk.down=rev(c(a*4+b-2)[1:floor(length(data$x)/2)])
 
 cat("Performing Siegel-Tukey rank transformation...","\n","\n")
 
 rks=c(rk.up,rk.down)
 unqs=unique(sort(data$x))
 corr.rks=tapply(rks,data$x,mean)
 cbind(unqs,corr.rks)
 rks.data=data.frame(unqs,corr.rks)
 names(rks.data)=c("unique values of x","tie-adjusted Siegel-Tukey rank")
 print(rks.data,row.names=F)
 names(rks.data)=c("unqs","corr.rks")
 data=merge(data,rks.data,by.x="x",by.y="unqs")
 
 rk1=data$corr.rks[data$y==1]
 rk2=data$corr.rks[data$y==2]
 cat("\n","Tie-adjusted Siegel-Tukey ranks of group 1","\n")
 group1=data.frame(data$x[data$y==1],rk1)
 names(group1)=c("x","rank")
 print(group1,row.names=F)
 cat("\n","Tie-adjusted Siegel-Tukey ranks of group 2","\n")
 group2=data.frame(data$x[data$y==2],rk2)
 names(group2)=c("x","rank")
 print(group2,row.names=F)
 cat("\n")
 
 cat("Siegel-Tukey test","\n")
 cat("Siegel-Tukey rank transformation performed.","Tie adjusted ranks computed.","\n")
 if(adjust.median==T) {cat("Medians adjusted to equality.","\n")} else {cat("Medians not adjusted.","\n")}
 cat("Rank sum of group 1 =", sum(rk1),"    Rank sum of group 2 =",sum(rk2),"\n")
 
 
 print(wilcox.test(rk1,rk2,alternative=alternative,mu=mu,paired=paired,exact=exact,correct=correct,conf.int=conf.int,conf.level=conf.level))
}
 
#Example:
 
x=c(4,4,5,5,6,6)
y=c(0,0,1,9,10,10)
 
siegel.tukey(x,y)

Here is the code output:

Median of group 1 = 5

Median of group 2 = 5

Test of median differences

Wilcoxon rank sum test with continuity correction

data: data$x[data$y == 1] and data$x[data$y == y]

W = 1, p-value = 0.4274

alternative hypothesis: true location shift is not equal to 0

Performing Siegel-Tukey rank transformation...

unique values of x tie-adjusted Siegel-Tukey rank

0 2.5

1 5.0

4 8.5

5 11.5

6 8.5

9 6.0

10 2.5

Tie-adjusted Siegel-Tukey ranks of group 1

x rank

4 8.5

5 11.5

6 8.5

Tie-adjusted Siegel-Tukey ranks of group 2

x rank

0 2.5

1 5.0

9 6.0

10 2.5

Siegel-Tukey test

Siegel-Tukey rank transformation performed. Tie adjusted ranks computed.

Medians not adjusted.

Rank sum of group 1 = 57 Rank sum of group 2 = 21

Wilcoxon rank sum test with continuity correction

data: rk1 and rk2

W = 36, p-value = 0.003601

alternative hypothesis: true location shift is not equal to 0

Warning message:

In wilcox.test.default(data$x[data$y == 1], data$x[data$y == y]) :

cannot compute exact p-value with ties

Median of group 1 = 5 Median of group 2 = 5 Test of median differences Wilcoxon rank sum test with continuity correction data: data$x[data$y == 1] and data$x[data$y == y] W = 1, p-value = 0.4274alternative hypothesis: true location shift is not equal to 0 Performing Siegel-Tukey rank transformation... unique values of x tie-adjusted Siegel-Tukey rank 0 2.5 1 5.0 4 8.5 5 11.5 6 8.5 9 6.0 10 2.5 Tie-adjusted Siegel-Tukey ranks of group 1 x rank 4 8.5 4 8.5 5 11.5 5 11.5 6 8.5 6 8.5 Tie-adjusted Siegel-Tukey ranks of group 2 x rank 0 2.5 0 2.5 1 5.0 9 6.0 10 2.5 10 2.5 Siegel-Tukey test Siegel-Tukey rank transformation performed. Tie adjusted ranks computed. Medians not adjusted. Rank sum of group 1 = 57 Rank sum of group 2 = 21 Wilcoxon rank sum test with continuity correction data: rk1 and rk2 W = 36, p-value = 0.003601alternative hypothesis: true location shift is not equal to 0 Warning message:In wilcox.test.default(data$x[data$y == 1], data$x[data$y == y]) : cannot compute exact p-value with ties

(The R function can be downloaded from here)

Post hoc analysis for Friedman’s Test (R code)

Tal Galili — Mon, 22 Feb 2010 09:08:14 +0000

My goal in this post is to give an overview of Friedman’s Test and then offer R code to perform post hoc analysis on Friedman’s Test results. (The R function can be downloaded from here)

Preface: What is Friedman’s Test

Friedman test is a non-parametric randomized block analysis of variance. Which is to say it is a non-parametric version of a one way ANOVA with repeated measures. That means that while a simple ANOVA test requires the assumptions of a normal distribution and equal variances (of the residuals), the Friedman test is free from those restriction. The price of this parametric freedom is the loss of power (of Friedman’s test compared to the parametric ANOVa versions).

The hypotheses for the comparison across repeated measures are:

H0: The distributions (whatever they are) are the same across repeated measures
H1: The distributions across repeated measures are different

The test statistic for the Friedman’s test is a Chi-square with [(number of repeated measures)-1] degrees of freedom. A detailed explanation of the method for computing the Friedman test is available on Wikipedia.

Performing Friedman’s Test in R is very simple, and is by using the “friedman.test” command.

Post hoc analysis for the Friedman’s Test

Assuming you performed Friedman’s Test and found a significant P value, that means that some of the groups in your data have different distribution from one another, but you don’t (yet) know which. Therefor, our next step will be to try and find out which pairs of our groups are significantly different then each other. But when we have N groups, checking all of their pairs will be to perform [n over 2] comparisons, thus the need to correct for multiple comparisons arise.
The tasks:
Our first task will be to perform a post hoc analysis of our results (using R) – in the hope of finding out which of our groups are responsible that we found that the null hypothesis was rejected. While in the simple case of ANOVA, an R command is readily available (“TukeyHSD”), in the case of friedman’s test (until now) the code to perform the post hoc test was not as easily accessible.
Our second task will be to visualize our results. While in the case of simple ANOVA, a boxplot of each group is sufficient, in the case of a repeated measures – a boxplot approach will be misleading to the viewer. Instead, we will offer two plots: one of parallel coordinates, and the other will be boxplots of the differences between all pairs of groups (in this respect, the post hoc analysis can be thought of as performing paired wilcox.test with correction for multiplicity).

R code for Post hoc analysis for the Friedman’s Test

The analysis will be performed using the function (I wrote) called “friedman.test.with.post.hoc”, based on the packages “coin” and “multcomp”. Just a few words about it’s arguments:

formu – is a formula object of the shape: Y ~ X | block (where Y is the ordered (numeric) responce, X is a group indicator (factor), and block is the block (or subject) indicator (factor)
data – is a data frame with columns of Y, X and block (the names could be different, of course, as long as the formula given in “formu” represent that)
All the other parameters are to allow or suppress plotting of the results.

friedman.test.with.post.hoc <- function(formu, data, to.print.friedman = T, to.post.hoc.if.signif = T,  to.plot.parallel = T, to.plot.boxplot = T, signif.P = .05, color.blocks.in.cor.plot = T, jitter.Y.in.cor.plot =F)
{
	# formu is a formula of the shape: 	Y ~ X | block
	# data is a long data.frame with three columns:    [[ Y (numeric), X (factor), block (factor) ]]
 
	# Note: This function doesn't handle NA's! In case of NA in Y in one of the blocks, then that entire block should be removed.
 
 
	# Loading needed packages
	if(!require(coin))
	{
		print("You are missing the package 'coin', we will now try to install it...")
		install.packages("coin")		
		library(coin)
	}
 
	if(!require(multcomp))
	{
		print("You are missing the package 'multcomp', we will now try to install it...")
		install.packages("multcomp")
		library(multcomp)
	}
 
	if(!require(colorspace))
	{
		print("You are missing the package 'colorspace', we will now try to install it...")
		install.packages("colorspace")
		library(colorspace)
	}
 
 
	# get the names out of the formula
	formu.names <- all.vars(formu)
	Y.name <- formu.names[1]
	X.name <- formu.names[2]
	block.name <- formu.names[3]
 
	if(dim(data)[2] >3) data <- data[,c(Y.name,X.name,block.name)]	# In case we have a "data" data frame with more then the three columns we need. This code will clean it from them...
 
	# Note: the function doesn't handle NA's. In case of NA in one of the block T outcomes, that entire block should be removed.
 
	# stopping in case there is NA in the Y vector
	if(sum(is.na(data[,Y.name])) > 0) stop("Function stopped: This function doesn't handle NA's. In case of NA in Y in one of the blocks, then that entire block should be removed.")
 
	# make sure that the number of factors goes with the actual values present in the data:
	data[,X.name ] <- factor(data[,X.name ])
	data[,block.name ] <- factor(data[,block.name ])
	number.of.X.levels <- length(levels(data[,X.name ]))
	if(number.of.X.levels == 2) { warning(paste("'",X.name,"'", "has only two levels. Consider using paired wilcox.test instead of friedman test"))}
 
	# making the object that will hold the friedman test and the other.
	the.sym.test <- symmetry_test(formu, data = data,	### all pairwise comparisons	
						   teststat = "max",
						   xtrafo = function(Y.data) { trafo( Y.data, factor_trafo = function(x) { model.matrix(~ x - 1) %*% t(contrMat(table(x), "Tukey")) } ) },
						   ytrafo = function(Y.data){ trafo(Y.data, numeric_trafo = rank, block = data[,block.name] ) }
						)
	# if(to.print.friedman) { print(the.sym.test) }
 
 
	if(to.post.hoc.if.signif)
		{
			if(pvalue(the.sym.test) < signif.P)
			{
				# the post hoc test
				The.post.hoc.P.values <- pvalue(the.sym.test, method = "single-step")	# this is the post hoc of the friedman test
 
 
				# plotting
				if(to.plot.parallel & to.plot.boxplot)	par(mfrow = c(1,2)) # if we are plotting two plots, let's make sure we'll be able to see both
 
				if(to.plot.parallel)
				{
					X.names <- levels(data[, X.name])
					X.for.plot <- seq_along(X.names)
					plot.xlim <- c(.7 , length(X.for.plot)+.3)	# adding some spacing from both sides of the plot
 
					if(color.blocks.in.cor.plot) 
					{
						blocks.col <- rainbow_hcl(length(levels(data[,block.name])))
					} else {
						blocks.col <- 1 # black
					}					
 
					data2 <- data
					if(jitter.Y.in.cor.plot) {
						data2[,Y.name] <- jitter(data2[,Y.name])
						par.cor.plot.text <- "Parallel coordinates plot (with Jitter)"				
					} else {
						par.cor.plot.text <- "Parallel coordinates plot"
					}				
 
					# adding a Parallel coordinates plot
					matplot(as.matrix(reshape(data2,  idvar=X.name, timevar=block.name,
									 direction="wide")[,-1])  , 
							type = "l",  lty = 1, axes = FALSE, ylab = Y.name, 
							xlim = plot.xlim,
							col = blocks.col,
							main = par.cor.plot.text)
					axis(1, at = X.for.plot , labels = X.names) # plot X axis
					axis(2) # plot Y axis
					points(tapply(data[,Y.name], data[,X.name], median) ~ X.for.plot, col = "red",pch = 4, cex = 2, lwd = 5)
				}
 
				if(to.plot.boxplot)
				{
					# first we create a function to create a new Y, by substracting different combinations of X levels from each other.
					subtract.a.from.b <- function(a.b , the.data)
					{
						the.data[,a.b[2]] - the.data[,a.b[1]]
					}
 
					temp.wide <- reshape(data,  idvar=X.name, timevar=block.name,
									 direction="wide") 	#[,-1]
					wide.data <- as.matrix(t(temp.wide[,-1]))
					colnames(wide.data) <- temp.wide[,1]
 
					Y.b.minus.a.combos <- apply(with(data,combn(levels(data[,X.name]), 2)), 2, subtract.a.from.b, the.data =wide.data)
					names.b.minus.a.combos <- apply(with(data,combn(levels(data[,X.name]), 2)), 2, function(a.b) {paste(a.b[2],a.b[1],sep=" - ")})
 
					the.ylim <- range(Y.b.minus.a.combos)
					the.ylim[2] <- the.ylim[2] + max(sd(Y.b.minus.a.combos))	# adding some space for the labels
					is.signif.color <- ifelse(The.post.hoc.P.values < .05 , "green", "grey")
 
					boxplot(Y.b.minus.a.combos,
						names = names.b.minus.a.combos ,
						col = is.signif.color,
						main = "Boxplots (of the differences)",
						ylim = the.ylim
						)
					legend("topright", legend = paste(names.b.minus.a.combos, rep(" ; PostHoc P.value:", number.of.X.levels),round(The.post.hoc.P.values,5)) , fill =  is.signif.color )
					abline(h = 0, col = "blue")
 
				}
 
				list.to.return <- list(Friedman.Test = the.sym.test, PostHoc.Test = The.post.hoc.P.values)
				if(to.print.friedman) {print(list.to.return)}				
				return(list.to.return)
 
			}	else {
					print("The results where not significant, There is no need for a post hoc test")
					return(the.sym.test)
				}					
	}
 
# Original credit (for linking online, to the package that performs the post hoc test) goes to "David Winsemius", see:
# http://tolstoy.newcastle.edu.au/R/e8/help/09/10/1416.html
}

Example

(The code for the example is given at the end of the post)

Let’s make up a little story: let’s say we have three types of wine (A, B and C), and we would like to know which one is the best one (in a scale of 1 to 7). We asked 22 friends to taste each of the three wines (in a blind fold fashion), and then to give a grade of 1 till 7 (for example sake, let’s say we asked them to rate the wines 5 times each, and then averaged their results to give a number for a persons preference for each wine. This number which is now an average of several numbers, will not necessarily be an integer).

After getting the results, we started by performing a simple boxplot of the ratings each wine got. Here it is:

The plot shows us two things: 1) that the assumption of equal variances here might not hold. 2) That if we are to ignore the “within subjects” data that we have, we have no chance of finding any difference between the wines.

So we move to using the function “friedman.test.with.post.hoc” on our data, and we get the following output:

$Friedman.Test

Asymptotic General Independence Test

data: Taste by

Wine (Wine A, Wine B, Wine C)

stratified by Taster

maxT = 3.2404, p-value = 0.003421

$PostHoc.Test

Wine B – Wine A 0.623935139

Wine C – Wine A 0.003325929

Wine C – Wine B 0.053772757

The conclusion is that once we take into account the within subject variable, we discover that there is a significant difference between our three wines (significant P value of about 0.0034). And the posthoc analysis shows us that the difference is due to the difference in tastes between Wine C and Wine A (P value 0.003). and maybe also with the difference between Wine C and Wine B (the P value is 0.053, which is just borderline significant).

Plotting our analysis will also show us the direction of the results, and the connected answers of each of our friends answers:

Here is the code for the example:

 
source("http://www.r-statistics.com/wp-content/uploads/2010/02/Friedman-Test-with-Post-Hoc.r.txt")  # loading the friedman.test.with.post.hoc function from the internet
 
	### Comparison of three Wine ("Wine A", "Wine B", and
	###  "Wine C") for rounding first base. 
	WineTasting <- data.frame(
		  Taste = c(5.40, 5.50, 5.55,
					5.85, 5.70, 5.75,
					5.20, 5.60, 5.50,
					5.55, 5.50, 5.40,
					5.90, 5.85, 5.70,
					5.45, 5.55, 5.60,
					5.40, 5.40, 5.35,
					5.45, 5.50, 5.35,
					5.25, 5.15, 5.00,
					5.85, 5.80, 5.70,
					5.25, 5.20, 5.10,
					5.65, 5.55, 5.45,
					5.60, 5.35, 5.45,
					5.05, 5.00, 4.95,
					5.50, 5.50, 5.40,
					5.45, 5.55, 5.50,
					5.55, 5.55, 5.35,
					5.45, 5.50, 5.55,
					5.50, 5.45, 5.25,
					5.65, 5.60, 5.40,
					5.70, 5.65, 5.55,
					6.30, 6.30, 6.25),
					Wine = factor(rep(c("Wine A", "Wine B", "Wine C"), 22)),
					Taster = factor(rep(1:22, rep(3, 22))))
 
	with(WineTasting , boxplot( Taste  ~ Wine )) # boxploting 
	friedman.test.with.post.hoc(Taste ~ Wine | Taster ,WineTasting)	# the same with our function. With post hoc, and cool plots

If you find this code useful, please let me know (in the comments) so I will know there is a point in publishing more such code snippets…

Barnard’s exact test – a powerful alternative for Fisher’s exact test (implemented in R)

Tal Galili — Sun, 07 Feb 2010 10:12:10 +0000

(The R code for Barnard’s exact test is at the end of the article, and you could also just download it from here)

About Barnard’s exact test

About half a year ago, I was studying various statistical methods to employ on contingency tables. I came across a promising method for 2×2 contingency tables called “Barnard’s exact test“. Barnard’s test is a non-parametric alternative to Fisher’s exact test which can be more powerful (for 2×2 tables) but is also more time-consuming to compute (References can be found in the Wikipedia article on the subject).

The test was first published by George Alfred Barnard (1945). Mehta and Senchaudhuri (2003) explain why Barnard’s test can be more powerful than Fisher’s under certain conditions:

When comparing Fisher’s and Barnard’s exact tests, the loss of power due to the greater discreteness of the Fisher statistic is somewhat offset by the requirement that Barnard’s exact test must maximize over all possible p-values, by choice of the nuisance parameter, π. For 2 × 2 tables the loss of power due to the discreteness dominates over the loss of power due to the maximization, resulting in greater power for Barnard’s exact test. But as the number of rows and columns of the observed table increase, the maximizing factor will tend to dominate, and Fisher’s exact test will achieve greater power than Barnard’s.

About the R implementation of Barnard’s exact test

After finding about Barnard’s test I was sad to discover that (at the time) there had been no R implementation of it. But last week, I received a surprising e-mail with good news. The sender, Peter Calhoun, currently a graduate student at the University of Florida, had implemented the algorithm in R. Peter had found my posting on the R mailing list (from almost half a year ago) and was so kind as to share with me (and the rest of the R community) his R code for computing Barnard’s exact test. Here is some of what Peter wrote to me about his code:

On a side note, I believe there are more efficient codes than this one. For example, I’ve seen codes in Matlab that run faster and display nicer-looking graphs. However, this code will still provide accurate results and a plot that gives the p-value based on the nuisance parameter. I did not come up with the idea of this code, I simply translated Matlab code into R, occasionally using different methods to get the same result. The code was translated from:

Trujillo-Ortiz, A., R. Hernandez-Walls, A. Castro-Perez, L. Rodriguez-Cardozo. Probability Test. A MATLAB file. URL

http://www.mathworks.com/matlabcentral/fileexchange/loadFile.do?objectId=6198

My goal was to make this test accessible to everyone. Although there are many ways to run this test through Matlab, I hadn’t seen any code to implement this test in R. I hope it is useful for you, and if you have any questions or ways to improve this code, please contact me at calhoun.peter@gmail.com

p.s: I added some minor cosmetics to the code, like allowing the input to be a table/matrix and the output to be a list.

The R function for Barnard’s exact test

# published on: 
# http://www.r-statistics.com/2010/02/barnards-exact-test-a-powerful-alternative-for-fishers-exact-test-implemented-in-r/
 
Barnardextest<-function(Ta,Tb =NULL,Tc =NULL,Td =NULL, to.print = F, to.plot = T)
{
# The first argument (Ta) can be either a table or a matrix of 2X2.
# Or instead, the values of the table can be entered one by one to the function
 
#Barnard's test calculates the probabilities for contingency tables.  It has been shown that for 2x2 tables, Barnard's test
#has a higher power than Fisher's Exact test.  Barnard's test is a non-parametric test that relies upon a computer to generate
#the distribution of the Wald statistic.  Using a computer program, one could find the nuisance parameter that maximizes the 
#probability of the observations displayed from a table.
#Despite giving lower p-values for 2x2 tables, Barnard's test hasn't been used as often as Fisher's test because of its
#computational difficulty.  This code gives the Wald statistic, the nuisance parameter, and the p-value for any 2x2 table.
#The table can be written as:
#			Var.1
#		 ---------------
#		   a		b	 r1=a+b
#	Var.2
#		   c		d	 r2=c+d
#		 ---------------
#		 c1=a+c   c2=b+d	 n=c1+c2
 
#One example would be 
#				Physics
#			 Pass	     Fail
#			 ---------------
#		Crane	   8		14
#  Collage	
#		Egret	   1		3
#			 ---------------
#
#After implementing the function, simply call it by the command:
#Barnardextest(8,14,1,3)
#This will display the results:
 
#"The contingency table is:"
#      [,1] [,2]
#[1,]    8   14
#[2,]    1    3
#"Wald Statistic:"
#0.43944
#"Nuisance parameter:"
#0.9001
#"The 1-tailed p-value:"
#0.4159073
 
#On a side note, I believe there are more efficient codes than this one.  For example, I've seen codes in Matlab that run
#faster and display nicer-looking graphs.  However, this code will still provide accurate results and a plot that gives the
#p-value based on the nuisance parameter.  I did not come up with the idea of this code, I simply translated Matlab code 
#into R, occasionally using different methods to get the same result.  The code was translated from:
#
#Trujillo-Ortiz, A., R. Hernandez-Walls, A. Castro-Perez, L. Rodriguez-Cardozo. Probability Test.  A MATLAB file. URL
#http://www.mathworks.com/matlabcentral/fileexchange/loadFile.do?objectId=6198
#
#My goal was to make this test accessible to everyone.  Although there are many ways to run this test through Matlab, I hadn't
#seen any code to implement this test in R.  I hope it is useful for you, and if you have any questions or ways to improve
#this code, please contact me at calhoun.peter@gmail.com.
 
 
	# Tal edit: choosing if to work with a 2X2 table or with 4 numbers:
	if(is.null(Tb) | is.null(Tc) | is.null(Td) )
	{
		# If one of them is null, then Ta should have an entire table, and we can take it's values
		if(is.table(Ta) | is.matrix(Ta))
		{
			if(sum(dim(Ta) == c(2,2))==2)
			{
				Tb <- Ta[1,2]
				Tc <- Ta[2,1]
				Td <- Ta[2,2]
				Ta <- Ta[1,1]		
			} else {stop("The table is not 2X2, please check it again...") }		
		} else {stop("We are missing value in the table") }		
	}
 
 
	c1<-Ta+Tc
	c2<-Tb+Td
	n<-c1+c2
	pao<-Ta/c1
	pbo<-Tb/c2
	pxo<-(Ta+Tb)/n
	TXO<-abs(pao-pbo)/sqrt(pxo*(1-pxo)*(1/c1+1/c2))
	n1<-prod(1:c1)
	n2<-prod(1:c2)
 
	P<-{}
	for( p in (0:99+.01)/100)
	{
		TX<-{}
		S<-{}
		for( i in c(0:c1))
		{
			for( j in c(0:c2))
			{
				if(prod(1:i)==0){fac1<-1} else {fac1<-prod(1:i)}
				if(prod(1:j)==0){fac2<-1} else {fac2<-prod(1:j)}
				if(prod(1:(c1-i))==0){fac3<-1} else {fac3<-prod(1:(c1-i))}
				if(prod(1:(c2-j))==0){fac4<-1} else {fac4<-prod(1:(c2-j))}
 
				small.s<-(n1*n2*(p^(i+j))*(1-p)^(n-(i+j))/(fac1*fac2*fac3*fac4))
				S<-cbind(S,small.s)
				pa<- i/c1
				pb<-j/c2
				px <- (i+j)/n
				if(is.nan((pa-pb)/sqrt(px*(1-px)*((1/c1)+(1/c2)))))
					{
						tx<-0
					} else {
						tx <- (pa-pb)/sqrt(px*(1-px)*((1/c1)+(1/c2)))
					}
				TX<-cbind(TX,tx)
			}
		}
 
		P<-cbind(P,sum(S[which(TX>=TXO)]))
	}
 
	np<-which(P==max(P))
	p <- (0:99+.01)/100
	nuisance<-p[np]
	pv<-P[np]
 
 
	if(to.print)
	{ 
		print("The contingency table is:")
		print(matrix(c(Ta,Tc,Tb,Td),2,2))
		print("Wald Statistic:")
		print(TXO)
		print("Nuisance parameter:")
		print(nuisance)
		print("The 1-tailed p-value:")
		print(pv)
	}
	if(to.plot)
	{
		plot(p,P,type="l",main="Barnard's exact P-value", xlab="Nuisance parameter", ylab="P-value")
		points(nuisance,pv,col=2)
	}
 
	return(	
			list(
					contingency.table = as.table(matrix(c(Ta,Tc,Tb,Td),2,2)),
					Wald.Statistic = TXO,
					Nuisance.parameter = nuisance,
					p.value.one.tailed = pv					
				)
			)
}
 
 
Barnardextest(matrix(c(8,1,14,3),2,2))
fisher.test(matrix(c(8,1,14,3),2,2))
 
 
Convictions <-
matrix(c(2, 10, 15, 3),
		   nrow = 2,
		   dimnames =
		   list(c("Dizygotic", "Monozygotic"),
				c("Convicted", "Not convicted")))
Convictions
fisher.test(Convictions, alternative = "less")
Barnardextest(Convictions)

Fisher’s Exact Test for Count Data

data: Convictions
p-value = 0.0004652
alternative hypothesis: true odds ratio is less than 1
95 percent confidence interval:
0.0000000 0.2849601
sample estimates:
odds ratio
0.04693661

$contingency.table
A B
A 2 15
B 10 3

$Wald.Statistic
[1] 3.609941

$Nuisance.parameter
[1] 0.4401

$p.value.one.tailed
[1] 0.0001528846

Final note: I would like to thank Peter Calhoun again for sharing his code with the rest of us – Thanks Peter!

Update (21.04.2010): In case you are facing a table with structural zeros (that is, missing values in the table), the package aylmer might be able to help you (it offers a generalization of Fisher’s exact test)