library(TExPosition) add.alpha <- function(col, alpha=0.65){ apply( sapply(col, col2rgb)/255, 2, function(x){ rgb(x[1], x[2], x[3], alpha=alpha) } ) } data.in <- read.csv('DFW_BeerResponses.csv',header=TRUE,row.names=1) ##Sort the data data.sorted <- data.in data.sorted <- data.sorted[order(data.sorted[,1], data.sorted[,2], data.sorted[,3], data.sorted[,4],decreasing=FALSE),] ###Bar plot dev.new() barplot(t(data.sorted),horiz=TRUE,axes=FALSE,col=c('olivedrab','goldenrod','steelblue4','firebrick','grey80','black'),las=1,cex.names=0.5,legend.text=colnames(data.in),args.legend=c(x=210,y=45,horiz=TRUE,cex=.75,box.lty=0),main="Raw values") ##Correspondence Analysis ca.res <- epCA(data.in,graphs=FALSE,symmetric=TRUE) fj.cols <- as.matrix(c('olivedrab','goldenrod','steelblue4','firebrick','grey80','black')) epGraphs(ca.res,contributionPlots=FALSE,fj.col=fj.cols) ##evidence suggests we can combine the data a bit. ##collapse the data. data.collapse <- cbind(data.in[,1:2],data.in[,3]+data.in[,4],data.in[,5]+data.in[,6]) colnames(data.collapse) <- c("A FAVORITE","LIKE","OK-NOT LIKE","NO-NEVER") collapse.res <- epCA(data.collapse,graphs=FALSE) ##then CA plots epGraphs(collapse.res,contributionPlots=FALSE,fj.col=as.matrix(c('olivedrab','goldenrod','firebrick','grey80'))) ##Some stuff for the final pictures. coll.comp1 <- paste0("Component 1 variance: ", round(collapse.res$ExPosition.Data$t[1],digits=3), "%") coll.comp2 <- paste0("Component 2 variance: ", round(collapse.res$ExPosition.Data$t[2],digits=3), "%") ##determine which beer belongs to which response. Dsup <- fastEucCalc(collapse.res$ExPosition.Data$fi[,1:2], collapse.res$ExPosition.Data$fj[,1:2]) minD <- apply(Dsup, 1, min) Group_Assigned <- Re(Dsup == repmat(minD, 1, ncol(Dsup))) beer.cols <- matrix(add.alpha("white",0),nrow(Group_Assigned),1) for(i in 1:nrow(Group_Assigned)){ beer.cols[i,] <- c('olivedrab','goldenrod','firebrick','grey80')[which(Group_Assigned[i,]==1)] } beer.cols <- as.matrix(beer.cols) prettyPlot(collapse.res$ExPosition.Data$fi,col=beer.cols,constraints= collapse.res$Plotting.Data$constraints,pch=20,contributionCircles=TRUE,contributions= collapse.res$ExPosition.Data$ci,xlab=coll.comp1,ylab=coll.comp2,cex=1.5) ###Bar plots again! ###Most favorited. collapse.reorder <- data.collapse collapse.reorder <- collapse.reorder[order(collapse.reorder[,1], collapse.reorder[,2], collapse.reorder[,3],decreasing=FALSE),] dev.new() barplot(t(collapse.reorder),horiz=TRUE,axes=FALSE,col=c('olivedrab','goldenrod','firebrick','grey80'),las=1,cex.names=0.5,legend.text=rownames(collapse.res$ExPosition.Data$fj),args.legend=c(x=210,y=45,horiz=TRUE,cex=.75,box.lty=0),main="Raw values") ###Least disliked. collapse.reorder <- data.collapse collapse.reorder <- collapse.reorder[order(collapse.reorder[,3], collapse.reorder[,2], collapse.reorder[,1],decreasing=TRUE),] collapse.reorder <- collapse.reorder[,c(3,2,1,4)] dev.new() barplot(t(collapse.reorder),horiz=TRUE,axes=FALSE,col=c('firebrick','goldenrod','olivedrab','grey80'),las=1,cex.names=0.5,legend.text=c("OK-NOT LIKE","LIKE","A FAVORITE","NO-NEVER"),args.legend=c(x=210,y=45,horiz=TRUE,cex=.75,box.lty=0),main="Raw values")