## This is the main code for creating the reults from the article. For ## the dendrogram we used code from the nice package "A2R" which ## produces colored trees. The functions are defined in the file ## "myhelper.R". Feel free to adopt the content to your needs. ################################################################################ ## packages needed for the analysis ## some plotting functions and other helper functions source("myhelper.R") ## for a nice color table library("RColorBrewer") ## data.frame manipulation (here to make a matrix out of a vector) library("reshape") ## clustering library to derive silhouette coefficients library("cluster") ## for broken-stick method for amount of PC to reduce dimensionality library("vegan") ## for map plots of loadings library("rworldmap") ## for the nice ellipse-scatterplots library("car") ################################################################################ ## declare directory to print the plots (this directory has to exist!) plotdir <- "/tmp" ################################################################################ ## read in the ENSEMBLES data rcm.df <- read.table("ENSEMBLES.dat") str(rcm.df) head(rcm.df) ## GCM forcings of the individual RCMs gcm.names <- c("C4I" = "HadCM3Q16", "CNRM-4.5" = "ARPEGE", "CNRM-5.1" = "ARPEGE", "DMI_ARPEGE" = "ARPEGE", "DMI_BCM" = "BCM", "DMI_ECHAM5" = "ECHAM5-r3", "ETHZ" = "HadCM3Q0", "ICTP" = "ECHAM5-r3", "KNMI" = "ECHAM5-r3", "METNO_BCM" = "BCM", "METNO_HCQ0" = "HadCM3Q0" , "HCQ0" = "HadCM3Q0", "HCQ16" = "HadCM3Q16", "HCQ3" = "HadCM3Q3", "MPI" = "ECHAM5-r3", "SMHI_BCM" = "BCM", "SMHI_ECHAM5" = "ECHAM5-r3", "SMHI_HCQ3" = "HadCM3Q3", "UCLM" = "HadCM3Q0", "VMGO" = "HadCM3Q0", ## new models "KNMI_ECHAM5-r1_50km" = "ECHAM5-r1", "KNMI_ECHAM5-r2_50km" = "ECHAM5-r2", "KNMI_ECHAM5-r3_50km" = "ECHAM5-r3", "SMHI_ECHAM5_50km" = "ECHAM5-r3", "KNMI_MIROC" = "MIROC" ## , ## "OURANOS" = "CGCM3" ) ## simulations from OURANOS and GKSS do not contain all parameters, ## therefore there are missing value in the data.frame. We exclude ## those simulations to have a complete data set/not too biased. rcm.df <- rcm.df[!row.names(rcm.df) %in% c("OURANOS", "GKSS"), ] ## any missing values? any(is.na(rcm.df)) ################################################################################ ## I) calculate common patterns of climate change ## PCA ccs.pca <- prcomp(rcm.df, scale = TRUE) ## extract the principal components pca.df <- ccs.pca$x ## extract the loadings (alphas) loadings.df <- ccs.pca$rotation ## get a sensible amount of PCs using the broken stick method pdf(paste(plotdir, "brokenstick.pdf", sep = "/")) screeplot(ccs.pca, bstick = TRUE, type = "lines", main = "Variance explained by Principal Components", ylab = "variance") dev.off() ## we consider the first 3 patterns (PCs) for anlysis n.pcas <- 3 x0 <- pca.df[,1:n.pcas] ################################################################################ ## II) visualize patterns of climate change, i.e. the loadings (alpha) ## for each principal components, seperately on maps ## get world map newmap <- getMap(resolution = "low") ## get rectangular shapes (polygons) for subregions for plotting fr <- GetSubregionPolygons(c(-5., 5., 44., 50.), subregion.type ="rectangle")[[1]] me <- GetSubregionPolygons(c(2., 16., 48., 55.), subregion.type ="rectangle")[[1]] ip <- GetSubregionPolygons(c(-10., 3., 36., 44.), subregion.type ="rectangle")[[1]] bi <- GetSubregionPolygons(c(-10., 2., 50., 59.), subregion.type ="rectangle")[[1]] al <- GetSubregionPolygons(c(5., 15., 44., 48.), subregion.type ="rectangle")[[1]] md <- GetSubregionPolygons(c(3., 25., 36., 44.), subregion.type ="rectangle")[[1]] ea <- GetSubregionPolygons(c(16., 30., 44., 55.), subregion.type ="rectangle")[[1]] sc <- GetSubregionPolygons(c(5., 30., 55., 70.), subregion.type ="rectangle")[[1]] ## entire european area wholereg <- GetSubregionPolygons(c(-12., 32., 32., 71.), subregion.type ="rectangle")[[1]] ## To have a nicer plot for each principal component, we transfer the ## vector of loadings (which is a combination of meteorological ## parameters, season and region) to a dataframe (rows being the ## spatial locations and columns the parameters for different ## seasons). ## split the dimension-vector to parameter-season vector and region ## vector. Those two vectors are attached to the loadings matrix of ## all PCs. dimnames <- row.names(loadings.df) dimnames.split <- matrix(unlist(strsplit(dimnames, "_")), ncol=3, byrow = TRUE) dim.parms.seasonal <- paste(dimnames.split[,2], dimnames.split[,3], sep ="_") dim.regions <- dimnames.split[, 1] dim <- as.data.frame(cbind(dim.regions, dim.parms.seasonal)) loadings.df <- cbind(dim, loadings.df) ## sort dataframe by region and by parameters region.order <- c("AL", "MD", "IP", "FR", "BI", "ME", "EA", "SC") parm.order <- c("TAS_DJF", "TAS_JJA", "TAS_MAM", "TAS_SON", "PR_DJF", "PR_JJA", "PR_MAM", "PR_SON", "HURS_DJF", "HURS_JJA", "HURS_MAM", "HURS_SON", "RSDS_DJF", "RSDS_JJA", "RSDS_MAM", "RSDS_SON", "WSS_DJF", "WSS_JJA", "WSS_MAM", "WSS_SON") parm.order <- c(t(matrix(parm.order, nrow=4))) #sort by seasons ## For each PC, expand the vector of loadings to a matrix of loadings df.melt <- melt(loadings.df) wide.df.list <- cast(df.melt, dim.regions ~ dim.parms.seasonal | variable) ## here comes the actual plotting...... ## min and max value to be displayed min <- -.2 max <- .2 ## for each PC we are interested in (here 3)... plot for (pccount in seq(n.pcas)){ filename <- file.path(plotdir, paste("loadings_maps_", pccount, ".pdf", sep = "")) x <- wide.df.list[[pccount]] ColorRamp <- colorRampPalette(c("red", "white","white", "navy"))(256) breaks <- seq(min, max, length=length(ColorRamp)+1) ColorRampExtended <- rep(NA,length(ColorRamp)+2) ColorRampExtended[1] <- ColorRamp[1] ColorRampExtended[length(ColorRampExtended)] <- ColorRamp[length(ColorRamp)] ColorRampExtended[2:(length(ColorRampExtended)-1)] <- ColorRamp ##ColorLevels <- seq(min, max, length=length(ColorRamp)+1) ColorLevels <- c(min, seq(min, max, length=length(ColorRamp)+1), max) pdf(filename, width = 20, height = 20) layout(matrix(seq(25), 5, 5, byrow = TRUE)) ## FOR PARM parms <- c("TAS", "PR", "HURS", "RSDS", "WSS") for (parmcount in seq(along = parms)){ ## parmcount <- 1 parm <- parms[parmcount] x.parm <- x[, grep(parm, names(x))] barplot(c(NA,NA,NA), horiz=TRUE, axes = FALSE, axisnames = FALSE, xlim = c(-10, 10), cex.main = 2.5) text(1,2, parm, cex = 4) ## FOR SEASONS seasons <- c("MAM", "JJA", "SON", "DJF") for (seasonscount in seq(along = seasons)){ seas <- seasons[seasonscount] x.parm.seas <- x.parm[, grep(seas, names(x.parm))] col <- ColorRamp[cut(x.parm.seas, breaks = breaks, labels = FALSE)] subregs <- as.character(x$dim.regions) cat("plotting PC", pccount, parm, seas, "...\n") ## FOR REGIONS if (parm == "TAS") tit <- seas else tit <- NA plot(wholereg, col = "gray" , main = tit, cex.main = 4) plot(me, add = TRUE, col = col[subregs == "ME"], lwd = 5) plot(ip, add = TRUE, col = col[subregs == "IP"], lwd = 5) plot(fr, add = TRUE, col = col[subregs == "FR"], lwd = 5) plot(bi, add = TRUE, col = col[subregs == "BI"], lwd = 5) plot(md, add = TRUE, col = col[subregs == "MD"], lwd = 5) plot(al, add = TRUE, col = col[subregs == "AL"], lwd = 5) plot(ea, add = TRUE, col = col[subregs == "EA"], lwd = 5) plot(sc, add = TRUE, col = col[subregs == "SC"], lwd = 5) plot(newmap, xlim = c(-10, 30), ylim = c(40, 70), asp = 1, add = TRUE) } } cat("saving file...", filename, "...\n") dev.off() } ## legend zlim <- c(min, max) df.wide <- wide.df.list[[1]] filename <- file.path(plotdir, "PC_legend.pdf") pdf(filename, width = 5, height = 30, pointsize = 40) myImagePlotLegend(t(df.wide), title = "" , zlim = zlim ) dev.off() ################################################################################ ## III) calculate model similarity based on the common patterns of climate change ## cluster analysis d.ccs <- dist(x0, "euc") # get euclidean distance in PC space h.ccs <- hclust(d.ccs, method = "ward.D") # hierarchical clustering # using Ward's criterium ## we want to select 5 models, so we split the dataset into 5 clusters n.clust <- 5 ## plot dendrogram filename <- file.path(plotdir, "dendrogram_h5.pdf") pdf(filename, width = 8, height = 10, pointsize = 18) A2Rplot(h.ccs, k = n.clust , boxes = FALSE, col.up = "gray", col.down = brewer.pal(n.clust,"Set1"), type = c("triangle"), lwd.up=3, lwd.down=4, fact.sup=gcm.names, main = "") title("Dendrogram of RCMs with GCM forcings", cex.main = 1) dev.off() ## plot increase of dissimilarity for each merge inerta.gain <- rev(h.ccs$height) names(inerta.gain) <- seq(length(inerta.gain)) cols <- c(rep("gray", n.clust - 1), rep("white", length(inerta.gain) - n.clust + 1)) filename <- file.path(plotdir, "inertia.pdf") pdf(filename) barplot(inerta.gain, col = cols, cex.names = 0.8, axisnames = FALSE, yaxt = "n") dev.off() ################################################################################ ## IV) scatterplots ## cluster analysis ## first create group datasets groups <- data.frame(group = cutree.order(h.ccs, k = n.clust)) groups$rcm <- rownames(groups) pca.g.df <- as.data.frame(ccs.pca$x) pca.g.df$rcm <- rownames(pca.g.df) pca.g.df <- merge(groups, pca.g.df, by = "rcm") pca.g.df$group <- as.factor(pca.g.df$group) cols <- data.frame(cols = brewer.pal(n.clust,"Set1")) cols$group <- rownames(cols) pca.g.df <- merge(cols, pca.g.df) pca.g.df$group <- as.factor(pca.g.df$group) col.pal <- brewer.pal(n.clust,"Set1") ## plot scatterplot (3 times) filename <- file.path(plotdir, "scatterplots_h5.pdf") pdf(filename, width = 12, height = 4, pointsize = 18) par(mfrow = c(1,3)) with(pca.g.df, dataEllipse2(PC2, PC1, group, level=.75, fill=TRUE, fill.alpha=0.1, , center.pch="", ylim=c(-12, 12), xlim=c(-12, 12) , group.labels=seq(8), col = col.pal)) with(pca.g.df, dataEllipse2(PC3, PC1, group, level=.75, fill=TRUE, fill.alpha=0.1, , center.pch="", ylim=c(-12, 12), xlim=c(-12, 12) , group.labels=seq(8), col = col.pal)) with(pca.g.df, dataEllipse2(PC2, PC3, group, level=.75, fill=TRUE, fill.alpha=0.1, , center.pch="", ylim=c(-12, 12), xlim=c(-12, 12) , group.labels=seq(8), col = col.pal)) dev.off() ################################################################################ ## V) barplots filename <- file.path(plotdir, "barplots_h5.pdf") pdf(filename, width = 24, height = 12 , pointsize = 10) par(mfrow = c(5,8)) ## by group rownames(pca.g.df) <- pca.g.df$rcm for (g in levels(pca.g.df$group)){ pca.g.df.tmp <- droplevels(subset(pca.g.df, group == g)) pcas.df <- pca.g.df.tmp[,c("PC1", "PC2", "PC3")] barplot(c(NA,NA,NA), horiz=TRUE, col = cols.stars, axes = FALSE, axisnames = FALSE, xlim = c(-10, 10), cex.main = 2.5) #cluster.ch <- paste("cluster") text(1,2, g, cex = 12, col = levels(pca.g.df.tmp$cols)) for (i in seq(7)) { id <- rownames(pcas.df[i,]) if (id == "NA") main.ch <- "" else main.ch <- id barplot(unlist(pcas.df[i,]), main=main.ch, horiz=TRUE, col = cols.stars, axes = FALSE, axisnames = FALSE, xlim = c(-10, 10), cex.main = 2.5) if(id != "NA") abline(v = 0, lwd = 6) } } dev.off()