# Code for calculating bivariate departures from natural variability
# NB. for demonstration purposes, this code is accompanied by a subset of the CanESM2 grid covering Eastern USA. However, the code can be run on any standard CMIP5 output. 
# Contents: 
# 1. Custom Functions
# 2. Departure difference and time-of-departure calculation for the grid
# 3. Maps of results
# 4. Results for a single cell: time series and scatterplot of unviariate and bivariate departure from natural variability


# Colin Mahony
# Centre for Forest Conservation Genetics and Department of Forest and Conservation Sciences, 
# University of British Columbia, 3041-2424 Main Mall, Vancouver, British Columbia, Canada V6T1Z4
# c_mahony@alumni.ubc.ca

rm(list=ls())

library(ncdf)
library(raster)
library(adehabitatLT) #provides the chi distribution
library(igraph) #provides running.mean()
library(dichromat) #for color schemes
library(RColorBrewer) #for color schemes
library(scales) #provides alpha transparency
library(maps)
library(MBC)
library(plotrix) #provides draw.ellipse()
library(diagram)


# ------------------------------------------
# import CMIP5 model data (for demonstration purposes, this code is accompanied by a subset of the CanESM2 grid covering Eastern USA)
model <- "CanESM2"
HistNatRuns <- 1:5 # modify as appropriate if other models are used
RCP45Runs <- 1:5 # modify as appropriate if other models are used

setwd(paste("D:\\ClimateDataArchive\\CMIP5\\", model,"\\subset", sep="")) #set the working directory

#import the climate model data for the histNat runs
for(i in HistNatRuns){ #one iteration for each model realization available
  assign(paste("histNat.tx",i, sep="."), brick(list.files(pattern = paste("tasmax", ".*.historicalNat_r",i,".*.nc", sep=""))))
  assign(paste("histNat.pr",i, sep="."), brick(list.files(pattern = paste("pr", ".*.historicalNat_r",i,".*.nc", sep=""))))
  print(i)
}

#import the climate model data for the hist runs
for(i in RCP45Runs){ #one iteration for each model realization available
  assign(paste("hist.tx",i, sep="."), brick(list.files(pattern = paste("tasmax", ".*_historical_r",i,".*.nc", sep=""))))
  assign(paste("hist.pr",i, sep="."), brick(list.files(pattern = paste("pr", ".*_historical_r",i,".*.nc", sep=""))))
  print(i)
}

#import the climate model data for the RCP4.5 runs
for(i in RCP45Runs){ #one iteration for each model realization available
  assign(paste("proj.tx",i, sep="."), brick(list.files(pattern = paste("tasmax", ".*_rcp45_r",i,".*.nc", sep=""))[1]))
  assign(paste("proj.pr",i, sep="."), brick(list.files(pattern = paste("pr", ".*_rcp45_r",i,".*.nc", sep=""))[1]))
  print(i)
}

plot(histNat.tx.1[[1]])
map('world2', add=T)

# ---------------------------------------
# 1. Custom Functions

## univariate normalization using quantile delta mapping normalization function
qdmTransform <- function(data,target){
  m.c <- scale(data) # z-transform nat
  o.c <- qnorm((rank(m.c)-0.5)/(length(m.c))) # normalize nat (empirical)
  m.p <- (target-attr(m.c, 'scaled:center'))/attr(m.c, 'scaled:scale') # z-transform proj
  qdm <- QDM(o.c, m.c, m.p) # equidistant quantile mapping
  return(qdm)
}

## specify sigma dissimilarity function
sigmaDis <- function(data, target){ #"data" is the reference interannual variability (e.g. historicalNat), and "target" is the historical/RCP4.5 time series
  if(sum(!is.na(apply(data,1,mean)))>0){ # error handling for corrupt time series
    #step 1: PCA on reference variability
    pca <- prcomp(data[!is.na(apply(data,1,mean)),])   #the apply() term is there simply to select all years with complete observations. 
    Z.data <- as.data.frame(predict(pca,data)) # rotated data
    Z.target <- as.data.frame(predict(pca,target)) # rotated target
    #step 2: z-standardize the target time series based on the reference time series
    Z.tr <- sweep(Z.target,MARGIN=2,apply(Z.data,2,sd, na.rm=T),`/`)     
    #step 3: calculate Euclidean distance and sigma level for each year. 
    Z.dist <- apply(Z.tr, 1, function(x) sqrt(sum(x^2)))  #squared euclidean distance is just the sum of squares because measuring to the origin
    Z.sigma <- rep(NA, length(Z.dist)) #initiate
    Z.sigma[!is.na(Z.dist)] <- qchi(pchi(Z.dist[!is.na(Z.dist)],df=length(Z.tr)),df=1) #translate distances into sigma levels using the chi distribution with df equal to the dimensionality of the distance measurement. 
    Z.sigma[!is.finite(Z.sigma)] <- 8.2 # very large distances will be undefined due to limited decimal precision of the percentiles of the chi distribution. these undefined values are set to the maximum sigma level. 
    Z.sigma[is.na(Z.dist)] <- NA #reset any NA values to NA (they were set to 8.2 above)
    return(Z.sigma)
  } else return(rep(NA,dim(target)[1]))
}

# --------------------------------------------
# 2. departure difference and time-of-departure calculation for the grid

years <- 1850:2100
histyears <- 1850:2005
projyears <- 2006:2100

# initialize results vectors
ncells <- dim(histNat.tx.1)[1]*dim(histNat.tx.1)[2]
template <- as.data.frame(matrix(rep(NA,ncells*length(RCP45Runs)), nrow=ncells, ncol=length(RCP45Runs)))
names(template) <- paste("r", RCP45Runs, sep="")
departyear.mean <- rep(NA, ncells)
departyear.smtx.mean <- rep(NA, ncells)
departyear.smpr.mean <- rep(NA, ncells)
cor.txpr <- rep(NA, ncells)
maxdiff.mean <- rep(NA, ncells)
angle <- rep(NA, ncells)

for(i in 1:ncells){
  
  #define summer based on latitude
  lat <- xyFromCell(histNat.tx.1, i)[2] 
  sm <- if(lat>0) c(6,7,8) else c(12,1,2)
  
  #compile and transform the summer time series 
  for(variable in c("pr", "tx")){
    # pool the historicalNat summer means for all runs
    hnat <- vector()
    for(j in HistNatRuns){ #one iteration for each model realization available
      temp <- as.vector(extract(get(paste("histNat",variable,j,sep=".")), i))
      hnat1 <- temp[seq(sm[1],length(temp),12)] #first month of summer
      hnat2 <- temp[seq(sm[2],length(temp),12)] #second month of summer
      hnat3 <- temp[seq(sm[3],length(temp),12)] #third month of summer
      if(sm[1]==12) hnat1[2:length(hnat1)] <- hnat1[1:(length(hnat1)-1)] #align december with the following january. (doesn't address the first season in the time series, but this has a negligible effect on the results. )
      hnat <- c(hnat,apply(cbind(hnat1,hnat2,hnat3), 1, mean, na.rm=T)) #calculate summer mean time series
    }
    
    # matrix of historical time series (one column for each GCM run)
    hist <- matrix(rep(NA, length(histyears)*length(RCP45Runs)), ncol=length(RCP45Runs))
    for(j in RCP45Runs){ #one iteration for each model realization available
      temp <- as.vector(extract(get(paste("hist",variable,j,sep=".")), i))
      hist1 <- temp[seq(sm[1],length(temp),12)][1:length(histyears)]   
      hist2 <- temp[seq(sm[2],length(temp),12)][1:length(histyears)]
      hist3 <- temp[seq(sm[3],length(temp),12)][1:length(histyears)]
      if(sm[1]==12) hist1[2:length(hist1)] <- hist1[1:(length(hist1)-1)] 
      hist[,j] <- apply(cbind(hist1,hist2,hist3), 1, mean, na.rm=T)
    } 
    
    # matrix of projected time series (one column for each GCM run)
    proj <- matrix(rep(NA, length(projyears)*length(RCP45Runs)), ncol=length(RCP45Runs))
    for(j in RCP45Runs){ #one iteration for each model realization available
      temp <- as.vector(extract(get(paste("proj",variable,j,sep=".")), i))
      proj1 <- temp[seq(sm[1],length(temp),12)][1:length(projyears)]   
      proj2 <- temp[seq(sm[2],length(temp),12)][1:length(projyears)]
      proj3 <- temp[seq(sm[3],length(temp),12)][1:length(projyears)]
      if(sm[1]==12) proj1[2:length(proj1)] <- proj1[1:(length(proj1)-1)] 
      proj[,j] <- apply(cbind(proj1,proj2,proj3), 1, mean, na.rm=T)
    } 
    
    ## transform the time series using qdmTransform
    qdm <- qdmTransform(hnat, as.vector(rbind(hist,proj)))
    assign(paste("histnat", variable, "tr", sep="."), qdm$mhat.c) 
    assign(paste("histproj", variable, "tr", sep="."), qdm$mhat.p)
    
  }
  
  ## calculate txpr correlation
  data <- data.frame(tx=histnat.tx.tr, pr=histnat.pr.tr)
  cor.txpr[i] <- cor(data[!is.na(apply(data,1,mean)),])[2]
  
  ## calculate orthogonality of climate change trajectory
  pca <- prcomp(data[!is.na(apply(data,1,mean)),], retx=T, scale=T)  #PCA on the interannual variability
  pca.proj <- predict(pca,data.frame(tx=apply(matrix(histproj.tx.tr, ncol=length(RCP45Runs))[which(years<2101),],1,mean),pr=apply(matrix(histproj.pr.tr, ncol=length(RCP45Runs))[which(years<2101),],1,mean)))
  a <- mean(pca.proj[which(years>2050 & years<2101),1], na.rm=T) #pc1 is adjacent side of right triangle. 
  o <- mean(pca.proj[which(years>2050 & years<2101),2], na.rm=T) #pc2 is opposite side
  angle[i] <- atan(o/a)*180/pi

    ## calculate sigma dissimilarity of historical/RCP4.5 time series (note this is done on all model runs as a single vector)
  Z.sigma <- sigmaDis(data=data.frame(tx=histnat.tx.tr, pr=histnat.pr.tr), target=data.frame(tx=as.vector(histproj.tx.tr), pr=as.vector(histproj.pr.tr)))
  
  # time series of bivariate anomalies
  sigma2 <- rep(0,length(Z.sigma)) #initiate a vector to store the 2-sigma exceedances
  sigma2[which(Z.sigma>2)] <- 1 # flag all years that have a 2-sigma exceedance
  sigma2[is.na(Z.sigma)] <- NA # transfer NAs
  sigma2 <- matrix(sigma2, ncol=length(RCP45Runs)) # organize the sigma2 vector into a matrix with one column for each model run. 
  N=30 #number of years in period for calculation of 2-sigma proportion
  threshold=0.25 #threshold 2-sigma proportion 
  years.ma <- years[N:length(years)] #label years as the last year of the moving average window. 
  exc2 <- apply(sigma2, 2, function(x){y <- running.mean(x,N); return(y)}) #moving average to calculate 2-sigma proportion
  departyear.mean[i] <-  years.ma[max(which(apply(exc2, 1, mean)<threshold), na.rm=T)]   #departure year of the mean signal
  
  # time series of univariate anomalies for tx (same annotations as above)
  dist2.smtx <- rep(0,length(histproj.tx.tr))
  dist2.smtx[which(abs(histproj.tx.tr)>2)] <- 1
  dist2.smtx[is.na(histproj.tx.tr)] <- NA
  dist2.smtx <- matrix(dist2.smtx, ncol=length(RCP45Runs))
  exc2.smtx <- apply(dist2.smtx, 2, function(x){y <- running.mean(x,N); return(y)}) 
  departyear.smtx.mean[i] <-  years.ma[max(which(apply(exc2.smtx, 1, mean)<threshold), na.rm=T)]   
  
  # time series of univariate anomalies for pr (same annotations as above)
  dist2.smpr <- rep(0,length(histproj.pr.tr))
  dist2.smpr[which(abs(histproj.pr.tr)>2)] <- 1
  dist2.smpr[is.na(histproj.pr.tr)] <- NA
  dist2.smpr <- matrix(dist2.smpr, ncol=length(RCP45Runs))
  exc2.smpr <- apply(dist2.smpr, 2, function(x){y <- running.mean(x,N); return(y)}) 
  departyear.smpr.mean[i] <-  years.ma[max(which(apply(exc2.smpr, 1, mean)<threshold), na.rm=T)]   
  
  # calculate Maximum departure difference: the maximum difference between the bivariate and univariate 2-sigma proportion time series
  exc2.uni <- pmax(exc2.smtx, exc2.smpr) #selects the maximum 2-sigma proportion of either temperature or precipitation. 
  exc2.mean <- apply(exc2, 1, mean, na.rm=T) #ensemble mean time series of bivariate 2-sigma proportion 
  exc2.uni.mean <- apply(exc2.uni, 1, mean, na.rm=T) #ensemble mean time series of univariate 2-sigma proportion
  exc2.diff.mean <- exc2.mean-exc2.uni.mean #time series of difference between bivariate and univariate
  maxdiff.mean[i] <- max(exc2.diff.mean, na.rm=T) #maximum departure difference
  
  print(i)
}

# -------------------------------------------------
# 3. maps of results
X <- hist.tx.1[[1]]
xl <- 263; yb <- 37; xr <- 265; yt <- 46

x11()
par(mar=c(0.1,0.1,0.1,0.1), mfrow=c(2,2))

## smtxpr correlation
Breakpoints <- c(-1,seq(-0.8,0.8,0.2), 1)
ColScheme <- rev(c(brewer.pal(11,"RdBu")[1:4], rep("grey90",2), brewer.pal(11,"RdBu")[8:11]))
values(X) <- cor.txpr
image(X, main="", breaks=Breakpoints, col=ColScheme, xaxt="n", yaxt="n")
map('world2', add=T)
rect(xl-1.8,  yb-.6,  xr+2.3,  yt+.7,  col=alpha("white",0.75))
rect(xl,  head(seq(yb,yt,(yt-yb)/length(ColScheme)),-1),  xr,  tail(seq(yb,yt,(yt-yb)/length(ColScheme)),-1),  col=ColScheme)
text(rep(xr-.2,length(ColScheme)/2),head(seq(yb,yt,(yt-yb)/length(ColScheme)),-1)[seq(2,length(ColScheme),2)],Breakpoints[seq(2,length(Breakpoints)-1,2)],pos=4,cex=1,font=1)
text(xl-.6, mean(c(yb,yt)), "smtx-smpr correlation      ", srt=90, pos=3, cex=1, font=2)
box()

## maximum difference in frequency of 2-sigma anomalies during the 2005-2100 period
Breakpoints <- c(-1,seq(-0.4,0.4,0.1), 1)
ColScheme <- rev(c(brewer.pal(11,"RdBu")[1:4], rep("grey90",2), brewer.pal(11,"RdBu")[8:11]))
values(X) <- maxdiff.mean
image(X, main="", breaks=Breakpoints, col=ColScheme, xaxt="n", yaxt="n")
map('world2', add=T)
rect(xl-1.8,  yb-.6,  xr+2.3,  yt+.7,  col=alpha("white",0.75))
rect(xl,  head(seq(yb,yt,(yt-yb)/length(ColScheme)),-1),  xr,  tail(seq(yb,yt,(yt-yb)/length(ColScheme)),-1),  col=ColScheme)
text(rep(xr-.2,length(ColScheme)/2),head(seq(yb,yt,(yt-yb)/length(ColScheme)),-1)[seq(2,length(ColScheme),2)],Breakpoints[seq(2,length(Breakpoints)-1,2)],pos=4,cex=1,font=1)
text(xl-.6, mean(c(yb,yt)), "Max. departure difference  ", srt=90, pos=3, cex=1, font=2)
box()

##smtxpr departure year
Breakpoints <- c(1850,seq(1980, 2100, 20),2300)
ColScheme <- rev(brewer.pal(8, "YlGnBu"))
values(X) <- departyear.mean
image(X, main="", breaks=Breakpoints, col=ColScheme, xaxt="n", yaxt="n")
map('world2', add=T)
rect(xl-1.8,  yb-.6,  xr+2.8,  yt+.7,  col=alpha("white",0.75))
rect(xl,  head(seq(yb,yt,(yt-yb)/length(ColScheme)),-1),  xr,  tail(seq(yb,yt,(yt-yb)/length(ColScheme)),-1),  col=ColScheme)
text(rep(xr-.2,length(ColScheme)/2),head(seq(yb,yt,(yt-yb)/length(ColScheme)),-1)[seq(2,length(ColScheme),2)],Breakpoints[seq(2,length(Breakpoints)-1,2)],pos=4,cex=1,font=1)
text(xl-.6, mean(c(yb,yt)), "smtxpr departure year    ", srt=90, pos=3, cex=1, font=2)
box()

## relative timing of departure (Univariate minus bivariate)
Breakpoints <- c(-300,c(-40,-30,-20,-10,-5), c(5,10,20,30,40) ,300)
ColScheme <- c(colorschemes$BluetoOrange.10[1:5], "white", colorschemes$BluetoOrange.10[6:10])
values(X) <- departyear.smtx.mean-departyear.mean
image(X, main="", breaks=Breakpoints, col=ColScheme, xaxt="n", yaxt="n")
map('world2', add=T)
rect(xl-1.8,  yb-.6,  xr+2.3,  yt+.7,  col=alpha("white",0.75))
rect(xl,  head(seq(yb,yt,(yt-yb)/length(ColScheme)),-1),  xr,  tail(seq(yb,yt,(yt-yb)/length(ColScheme)),-1),  col=ColScheme)
text(rep(xr-.2,length(ColScheme)),head(seq(yb,yt,(yt-yb)/length(ColScheme)),-1)[seq(2,length(ColScheme))],Breakpoints[seq(2,length(Breakpoints)-1)],pos=4,cex=1,font=1)
text(xl-.6, mean(c(yb,yt)), "Relative departure (yrs)     ", srt=90, pos=3, cex=1, font=2)
box()

# -------------------------------------------------------
# 4. Results for a single cell: time series and scatterplot of unviariate and bivariate departure from natural variability

i=40 # select the GCM cell to do the analysis on. 

x11(width=12, height=6) # open the plot window

#map the selected cell
par(mar=c(0,0,0,0), mfrow=c(1,2))
plot.new()

par(mar=c(0.1,0.1,0.1,0.1), new = TRUE)
line=-1
X <- histNat.tx.1[[1]]
## base map of maximum departure difference
Breakpoints <- c(-1,seq(-0.4,0.4,0.1), 1)
ColScheme <- rev(c(brewer.pal(11,"RdBu")[1:4], rep("grey90",2), brewer.pal(11,"RdBu")[8:11]))
values(X) <- maxdiff.mean
image(X, main="", breaks=Breakpoints, col=ColScheme, xaxt="n", yaxt="n")
map('world2', add=T)
rect(xl-1.8,  yb-.6,  xr+2.3,  yt+.7,  col=alpha("white",0.75))
rect(xl,  head(seq(yb,yt,(yt-yb)/length(ColScheme)),-1),  xr,  tail(seq(yb,yt,(yt-yb)/length(ColScheme)),-1),  col=ColScheme)
text(rep(xr-.2,length(ColScheme)/2),head(seq(yb,yt,(yt-yb)/length(ColScheme)),-1)[seq(2,length(ColScheme),2)],Breakpoints[seq(2,length(Breakpoints)-1,2)],pos=4,cex=1,font=1)
text(xl-.6, mean(c(yb,yt)), "Max. departure difference  ", srt=90, pos=3, cex=1, font=2)
cell <- xyFromCell(X, i)
points(cell, pch=8, cex=4, lwd=2)
box()

years <- 1850:2100
histyears <- 1850:2005
projyears <- 2006:2100

#define summer based on latitude
lat <- xyFromCell(histNat.tx.1, i)[2]
sm <- if(lat>0) c(6,7,8) else c(12,1,2)

#transform historical/RCP4.5
for(variable in c("pr", "tx")){
  # pool the historicalNat values for all runs
  hnat <- vector()
  for(j in HistNatRuns){ #one iteration for each model realization available
    temp <- as.vector(extract(get(paste("histNat",variable,j,sep=".")), i))
    hnat1 <- temp[seq(sm[1],length(temp),12)]
    hnat2 <- temp[seq(sm[2],length(temp),12)]
    hnat3 <- temp[seq(sm[3],length(temp),12)]
    if(sm[1]==12) hnat1[2:length(hnat1)] <- hnat1[1:(length(hnat1)-1)] #align december with the following january. (doesn't address the first season in the time series, but this will have a negligible effect on the results. )
    hnat <- c(hnat,apply(cbind(hnat1,hnat2,hnat3), 1, mean, na.rm=T))
  }
  
  hist <- matrix(rep(NA, length(histyears)*length(RCP45Runs)), ncol=length(RCP45Runs))
  for(j in RCP45Runs){ #one iteration for each model realization available
    temp <- as.vector(extract(get(paste("hist",variable,j,sep=".")), i))
    hist1 <- temp[seq(sm[1],length(temp),12)][1:length(histyears)]   
    hist2 <- temp[seq(sm[2],length(temp),12)][1:length(histyears)]
    hist3 <- temp[seq(sm[3],length(temp),12)][1:length(histyears)]
    if(sm[1]==12) hist1[2:length(hist1)] <- hist1[1:(length(hist1)-1)] #align december with the following january. (doesn't address the first season in the time series, but this will have a negligible effect on the results. )
    hist[,j] <- apply(cbind(hist1,hist2,hist3), 1, mean, na.rm=T)
  } 
  
  proj <- matrix(rep(NA, length(projyears)*length(RCP45Runs)), ncol=length(RCP45Runs))
  for(j in RCP45Runs){ #one iteration for each model realization available
    temp <- as.vector(extract(get(paste("proj",variable,j,sep=".")), i))
    proj1 <- temp[seq(sm[1],length(temp),12)][1:length(projyears)]   
    proj2 <- temp[seq(sm[2],length(temp),12)][1:length(projyears)]
    proj3 <- temp[seq(sm[3],length(temp),12)][1:length(projyears)]
    if(sm[1]==12) proj1[2:length(proj1)] <- proj1[1:(length(proj1)-1)] #align december with the following january. (doesn't address the first season in the time series, but this will have a negligible effect on the results. )
    proj[,j] <- apply(cbind(proj1,proj2,proj3), 1, mean, na.rm=T)
  } 
  
  ## transform the time series using qdmTransform
  qdm <- qdmTransform(hnat, as.vector(rbind(hist,proj)))
  
  assign(paste("histnat", variable, "tr", sep="."), qdm$mhat.c)
  assign(paste("histproj", variable, "tr", sep="."), qdm$mhat.p)
  
}

## calculate txpr correlation
data <- data.frame(tx=histnat.tx.tr, pr=histnat.pr.tr)
cor.txpr <- cor(data[!is.na(apply(data,1,mean)),])[2]

## calculate orthogonality of climate change trajectory
pca <- prcomp(data[!is.na(apply(data,1,mean)),], retx=T, scale=T)  #PCA on the interannual variability
pca.proj <- predict(pca,data.frame(tx=apply(matrix(histproj.tx.tr, ncol=length(RCP45Runs))[which(years<2101),],1,mean),pr=apply(matrix(histproj.pr.tr, ncol=length(RCP45Runs))[which(years<2101),],1,mean)))
a <- mean(pca.proj[which(years>2050 & years<2101),1], na.rm=T) #pc1 is adjacent side of right triangle. 
o <- mean(pca.proj[which(years>2050 & years<2101),2], na.rm=T) #pc2 is opposite side
angle <- atan(o/a)*180/pi

## calculate sigma dissimilarity of historical/RCP4.5
Z.sigma <- sigmaDis(data=data.frame(tx=histnat.tx.tr, pr=histnat.pr.tr), target=data.frame(tx=as.vector(histproj.tx.tr), pr=as.vector(histproj.pr.tr)))

sigma2 <- rep(0,length(Z.sigma))
sigma2[which(Z.sigma>2)] <- 1
sigma2[is.na(Z.sigma)] <- NA
sigma2 <- matrix(sigma2, ncol=length(RCP45Runs))
N=30  
threshold=0.25   
years.ma <- years[N:length(years)]
exc2 <- apply(sigma2, 2, function(x){y <- running.mean(x,N); return(y)}) #moving average to calculate frequency of years exceeding 2 sigma

dist2.smtx <- rep(0,length(histproj.tx.tr))
dist2.smtx[which(abs(histproj.tx.tr)>2)] <- 1
dist2.smtx[is.na(histproj.tx.tr)] <- NA
dist2.smtx <- matrix(dist2.smtx, ncol=length(RCP45Runs))
exc2.smtx <- apply(dist2.smtx, 2, function(x){y <- running.mean(x,N); return(y)}) #moving average to calculate frequency of years exceeding 2 sigma

dist2.smpr <- rep(0,length(histproj.pr.tr))
dist2.smpr[which(abs(histproj.pr.tr)>2)] <- 1
dist2.smpr[is.na(histproj.pr.tr)] <- NA
dist2.smpr <- matrix(dist2.smpr, ncol=length(RCP45Runs))
exc2.smpr <- apply(dist2.smpr, 2, function(x){y <- running.mean(x,N); return(y)}) #moving average to calculate frequency of years exceeding 2 sigma

exc2.uni <- pmax(exc2.smtx, exc2.smpr)
exc2.mean <- apply(exc2, 1, mean, na.rm=T)
exc2.uni.mean <- apply(exc2.uni, 1, mean, na.rm=T)
exc2.diff.mean <- exc2.mean-exc2.uni.mean

# return histproj to matrix format
histproj.tx.tr <- matrix(histproj.tx.tr, ncol=length(RCP45Runs))
histproj.pr.tr <- matrix(histproj.pr.tr, ncol=length(RCP45Runs))

#plots

#time series of exceedance frequencies
par(mar=c(2,3,0.5,1), mgp=c(1.85,0.25,0), cex=0.8)
plot(0, xlab="", ylab="", yaxs="i", xlim=c(min(years.ma),2100), ylim=c(0,1), xaxs="i", yaxt="n", tck=0)
rect(-9999,-9999, 9999, 9999, col="white")
lines(c(1850,2100), rep(0.046,2), lty=2)
text(2100, 0.025, "null = 0.046", pos=2, cex=0.8)
box()
title(ylab=bquote(2*sigma~proportion~"in"~preceding~30~years~~~~~""))
at=seq(0,1, 0.25);  axis(2, at=at, labels=at, las=2, tck=0)
# rect(0,0,max(years),threshold, col=alpha("gray", 0.4), border=F)
# for(run in 1:dim(exc2)[2]) {
#   lines(years.ma, exc2[,run])
#   lines(years.ma, exc2.uni[,run], col="red")
# }
col.bi <- "red3"
col.uni <- "blue"
polygon(c(min(years.ma):2100, 2100:min(years.ma)) ,
        c(apply(exc2[1:which(years.ma==2100),], 1, min), rev(apply(exc2[1:which(years.ma==2100),], 1, max))), 
        border=alpha(col.bi,0.25),
        col=alpha(col.bi, 0.25))
polygon(c(min(years.ma):2100, 2100:min(years.ma)) ,
        c(apply(exc2.uni[1:which(years.ma==2100),], 1, min), rev(apply(exc2.uni[1:which(years.ma==2100),], 1, max))), 
        border=alpha(col.uni,0.25),
        col=alpha(col.uni, 0.25))
# departyear.mean <- round(mean(departyear),0)
# departyear.uni.mean <- round(mean(departyear.uni),0)
lines(years.ma, apply(exc2,1,mean), col=col.bi, lwd=3)
lines(years.ma, apply(exc2.uni,1,mean), col=col.uni, lwd=3)
# lines(rep(departyear.mean,2), c(0,threshold), lty=2, col=col.bi, lwd=2)
# lines(rep(departyear.uni.mean,2), c(0,threshold), lty=2, col=col.uni, lwd=2)
# text(departyear.mean-1, 0.1, departyear.mean, pos=4, srt=0, font=2, col=col.bi)
# text(departyear.uni.mean-1, 0.04, departyear.uni.mean, pos=4, srt=0, font=2, col=col.uni)
legend(1880, 0.35, legend=c("Univariate (max. of Tx or Pr)", "Bivariate (Tx & Pr)"), cex=1, pch=22, pt.cex=2, pt.bg=alpha(c(col.uni, col.bi), 0.25), col=alpha(c(col.uni, col.bi), 0.25), bty="n")
maxdiff.seq <- which(exc2.diff.mean==max(exc2.diff.mean, na.rm=T))[1]
lines(rep(years.ma[maxdiff.seq], 2),c(exc2.uni.mean[maxdiff.seq], exc2.mean[maxdiff.seq]), lwd=2, lty=2)
points(rep(years.ma[maxdiff.seq], 2),c(exc2.uni.mean[maxdiff.seq], exc2.mean[maxdiff.seq]), col=c(col.uni,col.bi), pch=16, cex=1.5)
iArrows <- igraph:::igraph.Arrows
iArrows(2065, 0.27, years.ma[maxdiff.seq], mean(c(exc2.uni.mean[maxdiff.seq], exc2.mean[maxdiff.seq])), h.lwd=2, sh.lwd=2, sh.col="black", curve=-0.015, width=1, size=0.7)
text(2065, 0.27, paste("Max. departure\ndifference = ", round(max(exc2.diff.mean, na.rm=T), 2), "\nat ", years.ma[maxdiff.seq]-30, "-", years.ma[maxdiff.seq], sep=""), pos=1, cex=0.9)
box()

## scatter plot
par(mar=c(2,1,0,0), mgp=c(1.25,0.2,0), cex=0.8)
par(plt = c(0.125, 0.6, 0.45, 0.975), new = TRUE)
eqscplot(data[,1],data[,2], col="white", xlim=c(-4,4), ylim=c(-3,5), xlab="", ylab="", tck=F, xaxt="n", yaxt="n")
for(at in seq(-2,4,2)){ axis(1, at=at, labels=bquote(.(at)*sigma), tck=0)}
for(at in seq(0,4,2)){ axis(2, at=at, labels=bquote(.(at)*sigma), las=2, tck=0)}
axis(2, at=-2.2, labels="Pr", tck=0, font=2)
axis(1, at=-4, labels="Tx", tck=0, font=2)
#add in ellipse of interannual variability
pca <- prcomp(data[!is.na(apply(data,1,mean)),], retx=T, scale=T)  #PCA on the interannual variability
slope <- pca$rotation[2, 1]/pca$rotation[1, ]; 
d=2
k <- qchi(pchi(d,1), 2) #distance associated with chi sigma level in 2 dimensions
draw.ellipse(mean(data[,1], na.rm=T),mean(data[,2], na.rm=T), a=pca$sdev[1]*k, b=pca$sdev[2]*k, angle=atan(slope[1])*360/2/pi, lty=1, col="gray90", border="gray60")

points(data[,1],data[,2], col="gray40", pch=16, cex=0.75) 
# for(run in 1:dim(exc2)[2]) {
#   target <- data.frame(tx=histproj.tx.tr[,run], pr=histproj.pr.tr[,run])
#   lines(running.mean(target[,1],N),running.mean(target[,2],N), lwd=3, col="dodgerblue")
# }
lines(running.mean(apply(histproj.tx.tr[which(years<2101),],1,mean),N),running.mean(apply(histproj.pr.tr[which(years<2101),],1,mean),N), lwd=3, col="black")
angle <- round(abs(angle),0)
legend("bottomleft", legend=sapply(c(paste("r =", round(cor(data[!is.na(apply(data,1,mean)),])[2],2)),bquote(theta~"="~.(angle)*degree)),as.expression), bty="n", inset=-0.02, cex=0.9, xjust=1)
legend("topright", legend=c("Pooled historicalNat years", "RCP4.5 30-yr running mean"), box.lty=0, box.col="white",pch=c(16,NA), lwd=c(NA,3), col=c("gray40", "black"), cex=1)
text(running.mean(apply(histproj.tx.tr[which(years<2101),],1,mean),N)[c(2,length(years.ma[which(years.ma<2101)]))]+c(0.1, -0.1),running.mean(apply(histproj.pr.tr[which(years<2101),],1,mean),N)[c(2,length(years.ma[which(years.ma<2101)]))], c("1851-1880", "2071\n-2100"), col="black", cex=0.9, font=2, pos=c(2,4))

#add illustration of orthogonality
  r <- 2
  lines(c(0,r*1.25), c(0,-r*1.25), lty=2, lwd=1.5)
  lines(c(0,r), c(0,r), lty=2, lwd=1.5)
  text(r*1.35,-r*1.35,bquote(0*degree), srt=-45)
  text(r+0.3,r+0.3,bquote(90*degree), srt=45)
  # draw.arc(0,0,radius = r, deg1 = -45, deg2=15)
  curvedarrow(c(-r+0.5, -r+0.5), c(r-0.5, r-0.5), lwd=1.5, arr.pos = 0.81, curve=0.5, endhead = T, segment=c(0.5,1), arr.type="simple", arr.length=0.15)
  text(r+0.5, -0.25, bquote(theta), cex=1.3)


box()