diff --git a/AbbreviationsTRISH.odt b/AbbreviationsTRISH.odt new file mode 100644 index 0000000..98d6dc5 Binary files /dev/null and b/AbbreviationsTRISH.odt differ diff --git a/AbbreviationsTRISH.pdf b/AbbreviationsTRISH.pdf new file mode 100755 index 0000000..76843c7 Binary files /dev/null and b/AbbreviationsTRISH.pdf differ diff --git a/CrossValid1.R b/CrossValid1.R new file mode 100644 index 0000000..f03d37c --- /dev/null +++ b/CrossValid1.R @@ -0,0 +1,126 @@ +CrossValid1<- function(X, y, nNeg, nPos, i2) { + # Leave-m-out cross-validation of a previously estimated stepwise regression model. + # D Meko + # last revised 2024-03-08 + # + # IN + # X is matrix of potential predictors + # y is vector of predictand + # nNeg and nPos are the maximum negative and positive lags that were allowed in + # the stepwise regression model of predictand on chronologies. These settings + # are used by function LeaveOut to compute m=1+4*max(nNeg,nPos), the nunber + # of observations to be omitted in each iteration of leave-m-out cross- + # validation + # i2 is order that columns of matrix of potential predictors entered model + # in calling script or function, which is assumed to have applied stepwise + # regression; that order is repeated here in the stepwise cross-validation + # + # OUT + # CV [named list] statistics for maximim-RE model from forward stepwise + # Names self-describing. Includes step of maximum RE; columns of the original + # matrix of potential predictors in the maximum-RE model; reduction of error + # statistic, validation root-mean-square errot, cross-validation predictions, + # cross-validation residuals of the final model; and number of observations + # left out in leave-m-out cross-validation. Also in CV is the numerical + # vector REcvAll of RE at each step of the modeling, and corresponding vector + # RMSEVall or RMSE at each step + # + # NOTES + # + # Absolutely important that input column pointer i1 indicates columns of X + # in order (left to right) as they entered stepwise in the regression assumed + # to have been done before calling this function. + # + # revised 2024-03-08: cosmetic; expansion and clarification of comments + + library("pracma") # needed for emulation of Matlab "backslash" operator through + # QR decomposition + + source(paste(code_dir,"LeaveOut.R",sep="")) # form pointer matrix for leave-m-out cross-validation + + + #--- Build pointer matrix for predictor sets + + X<-as.matrix(X) + mX <-dim(X)[1] + y <- as.matrix(y) + H<-LeaveOut(nNeg,nPos,mX) + Lin <- H$Lin + mOut <- H$NumberLeftOut + + + #### Cross-validation modeling + + #... Storage for models for all steps + E1 <- matrix(NA,mX,length(i2)) # to store cross-valid residuals for all models + P1 <- E1 # to hold cross-validation predictions ... + RMSEvAll <- rep(NA,length(i2)) # to store RMSEv for all models + REall <- RMSEvAll # ... RE ... + + for (k in 1:length(i2)){ + + #--- Storage for various 1-col matrices specific to k-step model + w1 <- matrix(NA,mX,1) # cv predictions + w2 <- w1 # null predictions (equal to calibration means) + ithis <- i2[1:k] + + #--- long-term predictor matrix + Xthis <- as.matrix(X[,ithis]) + a1this <- matrix(1,mX,1) + Xthis <- cbind(a1this,Xthis) + + + for (n in 1:mX){ + + #--- Build predictor matrix + Lthis <- Lin[,n] + Lthis <- as.logical(as.matrix(Lthis)) + nthis <- sum(Lthis) + u <- as.matrix(X[Lthis,ithis]) + a1 <- matrix(1,nthis,1) + U <- cbind(a1,u) # predictor matrix + + # Build predictand as 1-col matrix + v <- as.matrix(y[Lthis]) + + #--- Matrix left division to estimate regression parameters + b <- mldivide(U,v) # [matrix, 1 col, with coefficients, constant term first] + + #--- Estimated predictand for central "left-out" observation + vhat1 <- Xthis[n,] %*% b + w1[n] <- vhat1; + w2[n] <- mean(v) + + } + + #--- Residuals time series + e1<-y-w1 # cross-validation + e2 <- y-w2 # null-model (using calib means as predictions) + + #--- Validaton statistics + SSE1 <- sum(e1*e1) # sum of squares of cross-validation errors + MSE1 <- SSE1/mX # mean square error of cross-validation + RMSEv <- sqrt(MSE1) # root-mean-square error of cross-validation + SSE2 <- sum(e2*e2) # sum of square of null-model residuals + RE <- 1 - SSE1/SSE2 # reduction of error statistic + + #--- Store statistics for model step + E1[,k] <- e1 + P1[,k] <- w1 + RMSEvAll[k]<- RMSEv + REall[k] <-RE + } + #--- Find maximum-RE model and its statistics + kmax <- which.max(REall) # at this step + i2cv <- i2[1:kmax] + REwinner <- REall[kmax] + Pcv <- as.matrix(P1[,kmax]) # cv predictions + Ecv <- as.matrix(E1[,kmax]) # cv errors + RMSEcv <- RMSEvAll[kmax] + + + CV <- list("REmaxStep"=kmax,"ColumnsIn"=i2cv,"REcvAll"=REall,"REcv"=REwinner, + "CVpredictions"=Pcv,"CVresiduals"=Ecv,"RMSEvall"=RMSEvAll,"RMSEcv"=RMSEcv, + "LeftOut"=mOut) + return(CV) +} \ No newline at end of file diff --git a/CrossValid2.R b/CrossValid2.R new file mode 100755 index 0000000..9f22cdc --- /dev/null +++ b/CrossValid2.R @@ -0,0 +1,85 @@ +CrossValid2<- function(X, y, nNeg,nPos) { + # Leave-m-out cross-validation of a regression model. + # D Meko + # last revised 20220104 + # + # IN + # X is matrix of predictors + # y is vector of predictand + # nNeg and nPos are the maximum negative and positive lags that were considered when + # the model was fit. + # + # OUT + # Output [named list] cross-validation statistics: + # REcv (1x1)r cross-validation reduction of error + # CVpredictions [m 1 col]r cross-validation predictions + # CVresidual [m, 1 col]r cross-validation residuals + # RMSEcv (1x1)r root-mean-square error of cross-validation + # LeftOut (1x1)i how many obs left out in each cross-validation model + # + # This is simplified from CrossValid1(), which handles various steps of a model + # previously fit by forward stepwise regression. + + library("pracma") # needed for emulation of Matlab "backslash" operator through + # QR decomposition + + source(paste(code_dir,"LeaveOut.R",sep="")) # form pointer matrix for leave-m-out cross-validation + + #--- Build pointer matrix for cross-validation predictor sets + + X<-as.matrix(X) + mX <-dim(X)[1] + y <- as.matrix(y) + H<-LeaveOut(nNeg,nPos,mX) + Lin <- H$Lin # logical pointer matrix; each col marks obs to use as 1 + mOut <- H$NumberLeftOut + + + #### Cross-validation modeling + + #--- Storage + w1 <- matrix(NA,mX,1) # to hold cv predictions + w2 <- w1 # to hold null predictions (equal to calibration means) + + #--- long-term predictor matrix, with 1's in first col + a1this <- matrix(1,mX,1) + Xthis <- cbind(a1this,X) + + + for (n in 1:mX){ # Loop over observations + + #--- Build predictor matrix + Lthis <- Lin[,n] + Lthis <- as.logical(as.matrix(Lthis)) + nthis <- sum(Lthis) + u <- as.matrix(X[Lthis,]) + a1 <- matrix(1,nthis,1) + U <- cbind(a1,u) # predictor matrix, this cv model + + # Build predictand as 1-col matrix + v <- as.matrix(y[Lthis]) + + #--- Matrix left division to estimate regression parameters + b <- mldivide(U,v) # [matrix, 1 col, with coefficients, constant term first] + + #--- Estimated predictand for central "left-out" observation + vhat1 <- Xthis[n,] %*% b + w1[n] <- vhat1; + w2[n] <- mean(v) + } + + #--- Time series of residuals + e1<-y-w1 # cross-validation + e2 <- y-w2 # null-model (using calib means as predictions) + + #--- Validaton statistics + SSE1 <- sum(e1*e1) # sum of squares of cross-validation errors + MSE1 <- SSE1/mX # mean square error of cross-validation + RMSEcv <- sqrt(MSE1) # root-mean-square error of cross-validation + SSE2 <- sum(e2*e2) # sum of square of null-model residuals + REcv <- 1 - SSE1/SSE2 # reduction of error statistic + + Output <- list("REcv"=REcv,"CVpredictions"=w1,"CVresiduals"=e1,"RMSEcv"=RMSEcv, + "LeftOut"=mOut) + return(Output) +} \ No newline at end of file diff --git a/EffectSS.R b/EffectSS.R new file mode 100755 index 0000000..8d214bf --- /dev/null +++ b/EffectSS.R @@ -0,0 +1,113 @@ +EffectSS <- function(x,y) { + # D. Meko + # Last revised 2022-09-09 + # Effective sample size -- effective number of "independent" observations. + # + # Effective sample size, Nprime, is computed from the lag-1 autocorrelation of a time series + # or pair of series. In univariate mode, Nprime can be applied for adjustment of significance + # of univariate statistics (e.g., uncertainty of the sample mean or variance). In bivariate + # mode, the effecitive sample size can be applied to adjust signficance of the correlation + # coefficient for the two series. + # + #---IN + # + # x: time series matrix or vector without any NA; number of observations mx, number of series nx + # y: ditto; but if passing vector and matrix, make sure y is the vector and x the matrix + # + #---OUT + # + # Output: list with fields + # Nprime: scalar or vector of effective sample size + # Lflag: flag (logical, length 2) + # (1) x or y have at least one NA + # (2) y is not vector and not same col-size as x + # ErrorMessage [vector]c : error message associated with Lflag + # + #---NOTES + # + # If input argument y is NA, Nprime is computed in univariate mode: + # If x is vector, Nprime is the scalar effective sample size + # If x is a matrix, Nprime is the vector of the effective sample sizes of the individual series + # If input argument y is not NA, Nprime is computed in bivariate mode: + # If y is a vector, Nprime is the effective sample size for correlation of y with all + # series in x (Nprime can be scalar or vector, depending on whether x is scalar or vector) + # If y is a matrix with ny>1 columns, ny must equal nx, and Nprime is the effective sample size + # for correlation of each column of x with same column of y (Nprime is a vector) + # Method. In univariate mode, if original sample size is N, effective sample size is + # Nprime = N(1-r1)/(1+r1), where r1 is the lag-1 autocorrelation + # Method. In bivariate mode, for pair of series, x and y, effective sample size is + # Nprime = N(1-r1r2)/(1+r1r2), where r1 is lag-1 autocorrelation of x and r2 is lag-1 + # autocorrelation of y + + source(paste(code_dir,"LagkAcc.R",sep="")) # optional transformation of flows + Lflag <-c(FALSE,FALSE) # initialize as no error flags + ErrorMessage <- "No problems" + Nprime <- NA + + klag <-1 # will only need lag-1 autocorrelation + + if (!all(complete.cases(x)) | (!all(is.na(y)) & !all(complete.cases(y)))){ + # ERROR MESSAGE + Lflag[1]<-TRUE + ErrorMessage <- 'x or y contain a NA' + Output <- list(Lflag=Lflag,ErrorMessage=ErrorMessage,Nprime=Nprime) + return(Output) + } + if (is.vector(x)){ + N <- length(x) + nx <-1 + } else { + N <- dim(x)[1] + nx <- dim(x)[2] + } + if (all(is.na(y))){ + # Univariate mode for effective sample size + ResTemp <- LagkAcc(x,klag) + a <- 1-ResTemp$rk + b <- 1+ResTemp$rk + f <- a/b + Nprime <- floor(f*N) + L <- ResTemp$rk <= 0 + Nprime[L] <- N # if lag-1 r of either series lag-1 autocorr non-positive, Nprime equals N + } else { + # bivariate mode (e.g., for significane adjustment for correlation) + if (is.vector(y)){ + if (nx ==1){ + # both x and y are vectors + ResTemp<- rkGet(x,y,klag) + r1x <- ResTemp$r1x; r1y <- ResTemp$r1y + } else { + # y vector, x matrix + y = matrix(replicate(nx,y),nrow=N) # replicate y to same col-size as x + ResTemp<- rkGet(x,y,klag) + r1x <- ResTemp$r1x; r1y <- ResTemp$r1y + } + } else { + # y and x both matrix + ny <- dim(y)[2] + if (ny != nx){ + # ERROR MESSAGE + Lflag[2]<-TRUE + ErrorMessage <- 'y is matrix and not same col-size as x' + Output <- list(Lflag=Lflag,ErrorMessage=ErrorMessage,Nprime=Nprime) + return(Output) + } + ResTemp<- rkGet(x,y,klag) + r1x <- ResTemp$r1x; r1y <- ResTemp$r1y + } + rr <- r1x * r1y # products of lag-1 autocorrelation + f <- (1-rr)/(1+rr) + Nprime <- floor(f*N) + L <- r1x <=0 | r1y <=0 + Nprime[L] <- N + } + + Output <- list(Nprime=Nprime,Lflag=Lflag,ErrorMessage=ErrorMessage) +} +rkGet <- function(x,y,klag){ + ResTempx <- LagkAcc(x,klag) + ResTempy <- LagkAcc(y,klag) + r1x <- ResTempx$rk + r1y <- ResTempy$rk + Out1 <- list(r1x=r1x,r1y=r1y) +} \ No newline at end of file diff --git a/ForwStep.R b/ForwStep.R new file mode 100755 index 0000000..537575d --- /dev/null +++ b/ForwStep.R @@ -0,0 +1,172 @@ +ForwStep <- function(X,namesX, y) { + # Forward stepwise regression for maximum-adjusted-Rsquared model + # D. Meko + # Last revised 2024-03-04 + # + # The forward stepwise entry is done until all variables are in. The final model + # is selected as the model for step at which adjusted R-square is maximum + # + # INPUT ARGUMENTS + # y [matrix] 1-col of predictand + # X [matrix] one-or-more cols of pool of potential predictors + # namesX [character] vector of ids of potential predictors (what's in cols of X) + # + # OUTPUT + # H: named list, + # names(H)<-c('Model','StepMaxR2adj','ColsInModel','Coefficients', + # 'ColsInOrderEntry','Rsquared','RsquaredAdj','Step', + # 'RsquaredAllSteps','RsquaredAdjAllSteps','Foverall', + # 'Fpvalue') + # Model [lm object] is a special type of R object, and holds many of the + # regression statistics and data, such as the residuals and predicted data. + # R has functions that operate on lm objects. For example, + # summary(H#Model) shows a summary table of the regression + # The Coefficients, combined with ColsInModel would allow a reconstruction to + # be generated from the long time series of potenial predictors X. + # ColsInModel gives the columns of that matrix that the coefficients apply + # to. By plotting RsquaredAllSteps or RsquaredAdjAllSteps agains step, you + # can disply how R-square and adjusted R-square changes with step in the + # stepwise modelin. + # Most of the other list items are obvious from their names. StepMaxR2adj is + # the step at which adjusted R-square reaches a maximum. + # + # revised 2024-03-04: fixed error in "r<-cor(e,X[,ibullpen])" + + #--- ALLOCATE AND INITIALIZE + Np<-dim(X)[2] # size predictor pool + i1<-1:Np # index to predictors in pool + i2<-rep(NA,Np) # index in order of entry + Lin=rep(FALSE,Np) # initial for in model + R2<-rep(NA,Np) + R2a<-rep(NA,Np) + + + #--- FOREWARD STEPWISE REGRESSION + + for (j in 1:Np){ + if (j==1){ + # First, pass pick X correlated highest (absolute R) with y + colnames(X)<-namesX # re-initialize these + r<-cor(y,X) + H<-sort(abs(r),decreasing=TRUE,index.return=TRUE) + iwinner<-H$ix[1] + i2[j]<-iwinner + Lin[iwinner]<-TRUE # Logical to cols of X in model to be estimated + U<-X[,Lin] # culll matrix of those predictors + G<-lm(y~U) # estimate model (G is a "lm" object ) + R2this<-summary(G)$r.squared + R2adjthis<-summary(G)$adj.r.squared + R2[j]<-R2this # store R-squared for this model + R2a[j]<-R2adjthis # store adjusted R-squared ... + e<-as.matrix(G$residuals) # model residuals; + } else { + # iteration after the first. e are the residuals of the previous step. + # At each step, e is correlated with the cols of X not yet in model. + # "Chosen one" is the the col of X with highest correlations + colnames(X)<-namesX # re-initialize these + ibullpen <-i1[!Lin] # cols of X NOT yet in models + r<-cor(e,X[,ibullpen]) + H<-sort(abs(r),decreasing=TRUE,index.return=TRUE) + iwinner<-H$ix[1] # pointer to highes correlated member of sub-matrix + i2[j]<-ibullpen[iwinner] # corresponding column of that member in X + ithis<-ibullpen[iwinner] #... renamed for simplicity + Lin[ithis]<-TRUE # logical of cols of X in current model to be estimated + # Next statements exactly same as those described for first iteration + U<-X[,Lin] + G<-lm(y~U) # estimation + R2this<-summary(G)$r.squared + R2adjthis<-summary(G)$adj.r.squared + R2[j]<-R2this + R2a[j]<-R2adjthis + e<-as.matrix(G$residuals) + } + } + + #--- FIND "BEST" MODEL AND RE-FIT IT + rm(H) + Lin<-rep(FALSE,Np) # re-initialize as no variables in model + + # MAXIMUM ADJUSTED R-SQUARED VERSION + # Commented out code for using maximum adjusted R2 as criterion for best + # model. For large number of variables in pool of potential predictos, and + # with those possibly chosen by correlation screening from larger number + # of possible predictors, this criterion tends to over-fit model. Decided + # to stop entry instead FIRST maximimum of adjusted R2 + # + # s<-sort(R2a,decreasing=TRUE,index.return=TRUE) # sorted adjusted R-squared, dec. + # iwinner<-s$ix[1] # step at which adjusted R-squared highest + # i2a<-i2[1:iwinner] # cols of X in model to be fit + # Lin[i2a]<-TRUE # turn on logical for cols of X in model to be fit + + # FIRST LOCAL MAXIMUM OF ADJUSTED R-SQUARED + + if (length(Lin)==1){ + # only one predictor in pool; only one step + iwinner<-1 + } else { + d<-diff(R2a) # first difference of adjusted R-squared with step in model + if (all(d>=0)){ + # Adjusted R-squared always increasing with step + iwinner<-length(Lin) + } else { + # adjusted R-squared starts dropping at some step (step ithis+1) + ithis<-which(d < 0) # find step of first decline in adjuste R-squared + iwinner<-ithis[1] + } + } + i2a<-i2[1:iwinner] # cols of X in final model + Lin[i2a]<-TRUE # turn on logical for cols of X in model to be fit + + #---- PULL SUBMATRIX OF PREDICTORS AND ESTIMATE MODEL + # if adjR2 begins dropping from 1st step, only 1 series enters matrix... + if(length(i2a)==1){ + U <- matrix(X[,Lin]) + } + else{ + U <- X[,Lin] + } + colnames(X)<-namesX # re-initialize these + colnames(U)<-colnames(X)[Lin] + G<-lm(y~U) # estimation + + + #--- STATISTICS OF FINAL FITTED MODEL + + kstep<-sum(Lin) # final step (max adj R-square) + + H = list() + H[[1]]<-G + H[[2]]<-kstep + H[[3]]<-i1[Lin] + H[[4]]<-G$coefficients + H[[5]]<-i2[1:kstep] + H[[6]]<-summary(G)$r.squared + H[[7]]<-summary(G)$adj.r.squared + jstep<-(1:Np) + H[[8]]<-jstep + H[[9]]<-R2 + H[[10]]<-R2a + H[[11]]<-summary(G)$fstatistic[1] + + # function for p-value of F; from + # https://stackoverflow.com/questions/5587676/pull-out-p-values-and-r-squared-from-a-linear-regression + lmp <- function (modelobject) { + if (class(modelobject) != "lm") stop("Not an object of class 'lm' ") + f <- summary(modelobject)$fstatistic + p <- pf(f[1],f[2],f[3],lower.tail=F) + attributes(p) <- NULL + return(p) + } + p<-lmp(G) + H[[12]]<-1-p # pvalue of overall F + + names(H)<-c('Model','StepMaxR2adj','ColsInModel','Coefficients', + 'ColsInOrderEntry','Rsquared','RsquaredAdj','Step', + 'RsquaredAllSteps','RsquaredAdjAllSteps','Foverall', + 'Fpvalue') + return(H) +} + + + + diff --git a/ForwStep1.R b/ForwStep1.R new file mode 100644 index 0000000..c0f8b59 --- /dev/null +++ b/ForwStep1.R @@ -0,0 +1,228 @@ +ForwStep1 <- function(X,namesX, y,kstop,nNeg,nPos) { + # Forward stepwise regression + # D. Meko + # Last revised 2023-08-16 + # + # The forward stepwise entry is done until all variables are in. The final model + # is selected optionally as the model for step at which adjusted R-square is maximum + # or the cross-validation RE is a maximum + # + # INPUT ARGUMENTS + # y [matrix] 1-col of predictand + # X [matrix] one-or-more cols of pool of potential predictors + # namesX [character] vector of ids of potential predictors (what's in cols of X) + # kstop [numeric] stopping criterion: 1=maximimum adjusted R-squared, + # 2=maximum cross-validation RE + # nNeg [numberic] maximum negative lag on chronologies allowed in modeling + # nPos [numeric] maximum positive...CrossValidStorage + # + # OUTPUT + # H: named list, with elements: + # c('Model','StopCriterion','StoppingStep','ColsInModel','Coefficients', + # 'ColsInOrderEntry','Rsquared','RsquaredAdj','Step', + # 'RsquaredAllSteps','RsquaredAdjAllSteps','Foverall', + # 'Fpvalue', + # 'CrossValidStorage','NleftOutinCV','REcv','RMSEcv', + # 'ModelTable') + # Model [lm object] special type of R object that holds many of the + # regression statistics and data, such as the residuals and predicted data. + # R has functions that operate on lm objects. For example, + # summary(H$Model) shows a summary table of the regression + # StopCriterion: criterion for picking best model (1=max adjusted R-squares; + # 2=maximum cross-validation RE) + # StoppingStep: the step at which stepwise regression stopped according to StopCriterion + # ColsInModel: which columns of input X are in the final model; the order is important, + # and matches the order of coefficients in H$coefficients (after the intercept) + # Coefficients: the regression coefficients, starting with intercept term and then + # in order as in H$ColsInModel.The Coefficients, combined with ColsInModel allow + # a reconstruction to with matrix X. + # ColsInOrderEntry: order in which the columns of X entered the stepwise model. In general, + # this differs from order in H$ColsInModel + # Rsquared,RsquaredAdj: R-squared and adjusted R-squared of the final model + # Step, RsquaredAllSteps,RsquaredAdjAllSteps: step is a numeric vector (1,2, ...) of + # the step in the stepwise process; the other two variables are the R-squared and + # adjusted R-squared at each step + # Foverall,Fpvalue: overall-F of the final regression model and p-value of that F + # CrossValidStorage: a list of detailed cross-validation statistics returned by + # CrossValid1(). No need to dig into this unless curious. See the comments for + # Crossvalid1() for definition of list. + # NleftOutinCV,REcv,RMSEcv: cross-validation statistics. NleftOutCV is the number of + # observations left out at each iteration of cross-validation. With lags, this is + # greater than 1, and set to assure no tree-ring data providing a cross-validation + # predicition was also used to calibrate the prediction model. REcv is the + # reduction-of-error statistic. RMSEcv is the root-mean-square error of cross-validation. + # ModelTable: a table object listing the same coefficients as in H$coefficients, but also + # including the corresponding id of the predictor, cross-referenced to columns of + # input matrix X and indicating if lagged positively or negatively and by how much. + # For example, X7 is the seventh column of X, no lags; and X2P2 is the second column of + # of X lagged +2 years forward from the predictand. + # + # Rev 2023-08-16: cosmetic, to make sure that summary(G) retains + # correct col name when just on predictor, on call to lm() + + source("CrossValid1.R") + + #--- ALLOCATE AND INITIALIZE + Np<-dim(X)[2] # size predictor pool + i1<-1:Np # index to predictors in pool + i2<-rep(NA,Np) # index in order of entry + Lin=rep(FALSE,Np) # initial for in model + R2<-rep(NA,Np) + R2a<-rep(NA,Np) + + + #--- FORWARD STEPWISE REGRESSION + + for (j in 1:Np){ + if (j==1){ + + # First, pass pick X correlated highest (absolute R) with y + colnames(X)<-namesX # re-initialize these + r<-cor(y,X) + H<-sort(abs(r),decreasing=TRUE,index.return=TRUE) + iwinner<-H$ix[1] + i2[j]<-iwinner + Lin[iwinner]<-TRUE # Logical to cols of X in model to be estimated + + U<-X[,Lin,drop="FALSE"] # cull matrix of those predictors + # If only 1 predictor, need next to make sure lm receive col name + if (dim(U)[2]==1){ + colnames(U) <- colnames(X)[Lin] + } + G<-lm(y~U) # estimate model (G is a "lm" object ) + R2this<-summary(G)$r.squared + R2adjthis<-summary(G)$adj.r.squared + R2[j]<-R2this # store R-squared for this model + R2a[j]<-R2adjthis # store adjusted R-squared ... + e<-as.matrix(G$residuals) # model residuals; + } else { + # iteration after the first. e are the residuals of the previous step. + # At each step, e is correlated with the cols of X not yet in model. + # "Chosen one" is the the col of X with highest correlations + colnames(X)<-namesX # re-initialize these + ibullpen <-i1[!Lin] # cols of X NOT yet in models + r<-cor(e,X[,ibullpen]) + H<-sort(abs(r),decreasing=TRUE,index.return=TRUE) + iwinner<-H$ix[1] # pointer to highes correlated member of sub-matrix + i2[j]<-ibullpen[iwinner] # corresponding column of that member in X + ithis<-ibullpen[iwinner] #... renamed for simplicity + Lin[ithis]<-TRUE # logical of cols of X in current model to be estimated + # Next statements exactly same as those described for first iteration + U<-X[,Lin,drop="FALSE"] + G<-lm(y~U) # estimation + R2this<-summary(G)$r.squared + R2adjthis<-summary(G)$adj.r.squared + R2[j]<-R2this + R2a[j]<-R2adjthis + e<-as.matrix(G$residuals) + } + } + + #--- LEAVE-M-OUT CROSS-VALIDATION, STEPWISE + # + # Do regardless of stopping rule + CV <-CrossValid1(X, y, nNeg, nPos, i2) + + #--- FIND "BEST" MODEL AND RE-FIT IT + rm(H) + Lin<-rep(FALSE,Np) # re-initialize as no variables in model + + if (kstop==1){ + # MAXIMUM ADJUSTED R-SQUARED VERSION + # Commented out code for using maximum adjusted R2 as criterion for best + # model. For large number of variables in pool of potential predictors, and + # with those possibly chosen by correlation screening from larger number + # of possible predictors, this criterion tends to over-fit model. Decided + # to stop entry instead FIRST maximimum of adjusted R2 + # + s<-sort(R2a,decreasing=TRUE,index.return=TRUE) # sorted adjusted R-squared, + # from highest to lowest. + iwinner<-s$ix[1] # step at which adjusted R-squared highest + }else{ + # MAXIMUM RE VERSION + iwinner <- CV$REmaxStep # step at which RE highest + } + i2a<-i2[1:iwinner] # cols of X in model to be fit + Lin[i2a]<-TRUE # turn on logical for cols of X in model to be fit + + + #---- PULL SUBMATRIX OF PREDICTORS AND RE-ESTIMATE MODEL + U<-X[,Lin,drop="FALSE"] + colnames(X)<-namesX # re-initialize these + colnames(U)<-colnames(X)[Lin] + G<-lm(y~U) # estimation + + # Do not want variables to be listed U1, U2, etc. Want real IDs + bbnms <- names(G$coefficients) + bbnms1 <- bbnms[-1] # names of terms, without "(Intercept)" + bbnms2 <- colnames(X)[Lin] + names(G$coefficients) <- c(bbnms[1],bbnms2) + rm(bb,bbnms,bbnms1,bbnms2) + + #--- STATISTICS OF FINAL FITTED MODEL + + kstep<-sum(Lin) # final step (max adj R-square) + + if (kstop==1){ + stopHow<-'Max R-squared adjusted' + }else{ + stopHow<-'Max RE' + } + + H = list() + H[[1]]<-G + H[[2]]<-stopHow + H[[3]]<-kstep + H[[4]]<-i1[Lin] + H[[5]]<-G$coefficients + H[[6]]<-i2[1:kstep] + H[[7]]<-summary(G)$r.squared + H[[8]]<-summary(G)$adj.r.squared + jstep<-(1:Np) + H[[9]]<-jstep + H[[10]]<-R2 + H[[11]]<-R2a + H[[12]]<-summary(G)$fstatistic[1] + + # function for p-value of F; from + # https://stackoverflow.com/questions/5587676/pull-out-p-values-and-r-squared-from-a-linear-regression + lmp <- function (modelobject) { + if (class(modelobject) != "lm") stop("Not an object of class 'lm' ") + f <- summary(modelobject)$fstatistic + p <- pf(f[1],f[2],f[3],lower.tail=F) + attributes(p) <- NULL + return(p) + } + p<-lmp(G) + H[[13]]<-p # pvalue of overall F + H[[14]] <- CV + H[[15]] <- CV$LeftOut + if (kstop==2){ + H[[16]] <- CV$REcv + H[[17]] <- CV$RMSEcv + }else{ + # CrossValid1 returns CVREv and RMSEcv as the "best" according to maximum RE, but + # if using maximum adjusted R-squared, want instead to use index iwinner to grab those + # applicable statistics. + H[[16]] <- CV$REcvAll[iwinner] + H[[17]] <- CV$RMSEvall[iwinner] + } + # Build table with regression coeffients opposite variable names + tab<-matrix(t(G$coefficients)) + colnames(tab)<-c('Model') + rownames(tab)<-c('Intercept',namesX[H[[4]]]) + tab<- as.table(tab) + H[[18]]<-tab + + names(H)<-c('Model','StopCriterion','StoppingStep','ColsInModel','Coefficients', + 'ColsInOrderEntry','Rsquared','RsquaredAdj','Step', + 'RsquaredAllSteps','RsquaredAdjAllSteps','Foverall', + 'Fpvalue', + 'CrossValidStorage','NleftOutinCV','REcv','RMSEcv', + 'ModelTable') + return(H) +} + + + + diff --git a/ForwStep2.R b/ForwStep2.R new file mode 100755 index 0000000..696456b --- /dev/null +++ b/ForwStep2.R @@ -0,0 +1,171 @@ +ForwStep2 <- function(X,namesX, y, c1) { + # Forward stepwise regression + # D. Meko + # Last revised 2024-03-04 + # + # The forward stepwise entry is done until all variables are in. The final model + # is selected as the model for step at which adjusted R-square is maximum + # + # INPUT ARGUMENTS + # y [matrix] 1-col of predictand + # X [matrix] one-or-more cols of pool of potential predictors + # namesX [character] vector of ids of potential predictors (what's in cols of X) + # c1 [1x1]r required incremental increase in adjusted R-square to warrant additional + # step in forward stepwise + # + # OUTPUT + # H: named list, + # names(H)<-c('Model','StepMaxR2adj','ColsInModel','Coefficients', + # 'ColsInOrderEntry','Rsquared','RsquaredAdj','Step', + # 'RsquaredAllSteps','RsquaredAdjAllSteps','Foverall', + # 'Fpvalue') + # Model [lm object] is a special type of R object, and holds many of the + # regression statistics and data, such as the residuals and predicted data. + # R has functions that operate on lm objects. For example, + # summary(H#Model) shows a summary table of the regression + # The Coefficients, combined with ColsInModel would allow a reconstruction to + # be generated from the long time series of potenial predictors X. + # ColsInModel gives the columns of that matrix that the coefficients apply + # to. By plotting RsquaredAllSteps or RsquaredAdjAllSteps agains step, you + # can disply how R-square and adjusted R-square changes with step in the + # stepwise modelin. + # Most of the other list items are obvious from their names. StepMaxR2adj is + # the step at which adjusted R-square reaches a maximum. + # + # revised 2024-03-04: corrected error in call to ForwStep2 for stepwise variables entering + # after the first to to enter. At "r<-cor(e,X[,ibullpen])". Error could have resulted in + # MLR regression models picking next variable (not in model) most highlly correlated + # with predictand, y, rather than with residuals, e, from previous step. Change could + # result in model with stronger statistics (e.g., R-squared) + + + + source(paste(code_dir,"Fpvalue.R",sep="")) # p-value of overall-F from lm() [not written by Meko] + + #--- ALLOCATE AND INITIALIZE + Np<-dim(X)[2] # size predictor pool + i1<-1:Np # index to predictors in pool + i2<-rep(NA,Np) # index in order of entry + Lin=rep(FALSE,Np) # initial for in model + R2<-rep(NA,Np) + R2a<-rep(NA,Np) + + + #--- FOREWARD STEPWISE REGRESSION + + for (j in 1:Np){ + if (j==1){ + # First, pass pick X correlated highest (absolute R) with y + colnames(X)<-namesX # re-initialize these + r<-cor(y,X) + H<-sort(abs(r),decreasing=TRUE,index.return=TRUE) + iwinner<-H$ix[1] + i2[j]<-iwinner + Lin[iwinner]<-TRUE # Logical to cols of X in model to be estimated + U<-X[,Lin] # culll matrix of those predictors + G<-lm(y~U) # estimate model (G is a "lm" object ) + R2this<-summary(G)$r.squared + R2adjthis<-summary(G)$adj.r.squared + R2[j]<-R2this # store R-squared for this model + R2a[j]<-R2adjthis # store adjusted R-squared ... + e<-as.matrix(G$residuals) # model residuals; + } else { + # iteration after the first. e are the residuals of the previous step. + # At each step, e is correlated with the cols of X not yet in model. + # "Chosen one" is the the col of X with highest correlations + colnames(X)<-namesX # re-initialize these + ibullpen <-i1[!Lin] # cols of X NOT yet in models + r<-cor(e,X[,ibullpen]) # rev 2024-03-04 + H<-sort(abs(r),decreasing=TRUE,index.return=TRUE) + iwinner<-H$ix[1] # pointer to highes correlated member of sub-matrix + i2[j]<-ibullpen[iwinner] # corresponding column of that member in X + ithis<-ibullpen[iwinner] #... renamed for simplicity + Lin[ithis]<-TRUE # logical of cols of X in current model to be estimated + # Next statements exactly same as those described for first iteration + U<-X[,Lin] + G<-lm(y~U) # estimation + R2this<-summary(G)$r.squared + R2adjthis<-summary(G)$adj.r.squared + R2[j]<-R2this + R2a[j]<-R2adjthis + e<-as.matrix(G$residuals) + } + } + + #--- FIND "BEST" MODEL AND RE-FIT IT + rm(H) + Lin<-rep(FALSE,Np) # re-initialize as no variables in model + + # MAXIMUM ADJUSTED R-SQUARED VERSION + # Commented out code for using maximum adjusted R2 as criterion for best + # model. For large number of variables in pool of potential predictos, and + # with those possibly chosen by correlation screening from larger number + # of possible predictors, this criterion tends to over-fit model. Decided + # to stop entry instead FIRST maximimum of adjusted R2 + # + # s<-sort(R2a,decreasing=TRUE,index.return=TRUE) # sorted adjusted R-squared, dec. + # iwinner<-s$ix[1] # step at which adjusted R-squared highest + # i2a<-i2[1:iwinner] # cols of X in model to be fit + # Lin[i2a]<-TRUE # turn on logical for cols of X in model to be fit + + # FIRST LOCAL MAXIMUM OF ADJUSTED R-SQUARED + + if (length(Lin)==1){ + # only one predictor in pool; only one step + iwinner<-1 + } else { + d<-diff(R2a) # first difference of adjusted R-squared with step in model + if (all(d>=c1)){ + # Adjusted R-squared always increasing by at least c1 with step + iwinner<-length(Lin) + } else { + # adjusted R-squared increases by less than c1 at some step (step ithis+1) + ithis<-which(d < c1) # find step of first "insufficient" increase in adjusted R-squared + iwinner<-ithis[1] + } + } + i2a<-i2[1:iwinner] # cols of X in final model + Lin[i2a]<-TRUE # turn on logical for cols of X in model to be fit + + #---- PULL SUBMATRIX OF PREDICTORS AND ESTIMATE MODEL + # if adjR2 begins dropping from 1st step, only 1 series enters matrix... + if(length(i2a)==1){ + U <- matrix(X[,Lin]) + } + else{ + U <- X[,Lin] + } + colnames(X)<-namesX # re-initialize these + colnames(U)<-colnames(X)[Lin] + G<-lm(y~U) # estimation + + + #--- STATISTICS OF FINAL FITTED MODEL + + kstep<-sum(Lin) # final step (max adj R-square) + + H = list() + H[[1]]<-G + H[[2]]<-kstep + H[[3]]<-i1[Lin] + H[[4]]<-G$coefficients + H[[5]]<-i2[1:kstep] + H[[6]]<-summary(G)$r.squared + H[[7]]<-summary(G)$adj.r.squared + jstep<-(1:Np) + H[[8]]<-jstep + H[[9]]<-R2 + H[[10]]<-R2a + H[[11]]<-summary(G)$fstatistic[1] + p<-Fpvalue(G) + H[[12]]<-p # pvalue of overall F + names(H)<-c('Model','StepMaxR2adj','ColsInModel','Coefficients', + 'ColsInOrderEntry','Rsquared','RsquaredAdj','Step', + 'RsquaredAllSteps','RsquaredAdjAllSteps','Foverall', + 'Fpvalue') + return(H) +} + + + + diff --git a/ForwStep3.R b/ForwStep3.R new file mode 100755 index 0000000..dc720d5 --- /dev/null +++ b/ForwStep3.R @@ -0,0 +1,229 @@ +ForwStep3 <- function(X,namesX, y,kstop,nNeg,nPos,ic) { + # Forward stepwise regression with validation/calibration stopping rules + # D. Meko + # Last revised 2024-03-09 + # + # Initial forward stepwise entry is done until all variables are in. The final model + # is selected optionally as the model for step at which adjusted R-square is "approximately" + # maximum, or at that or a lower step at which cross-validation RE is maximum. + # + # INPUT ARGUMENTS + # y [matrix] 1-col of predictand + # X [matrix] one-or-more cols of pool of potential predictors + # namesX [character] vector of ids of potential predictors (cols of X) + # kstop [numeric] stopping criterion: 1= approximate maximimum adjusted R-squared, + # 2=maximum cross-validation RE + # nNeg [numberic] maximum negative lag on chronologies allowed in modeling + # nPos [numeric] maximum positive...CrossValidStorage + # ic [numeric] critical increment in adjusted R-squared. If kstop=1, entry stops when next step would + # yield increase of adjusted R-squared less than ic. If kstop=2, model could stop at an even earlier + # step if cross-validation RE reaches a maximum before the step of approximate maximum + # adjusted R-squared. + # + # OUTPUT + # H: named list, with elements: + c('Model','StopCriterion','StoppingStep','ColsInModel','Coefficients', + 'ColsInOrderEntry','Rsquared','RsquaredAdj','Step', + 'RsquaredAllSteps','RsquaredAdjAllSteps','Foverall', + 'Fpvalue', + 'CrossValidStorage','NleftOutinCV','REcv','RMSEcv', + 'ModelTable') + # Model [lm object] special type of R object that holds many of the + # regression statistics and data, such as the residuals and predicted data. + # R has functions that operate on lm objects. For example, + # summary(H$Model) shows a summary table of the regression + # StopCriterion: criterion for picking best model (1=max adjusted R-squares; + # 2=maximum cross-validation RE) + # StoppingStep: the step at which stepwise regression stopped according to StopCriterion + # ColsInModel: which columns of input X are in the final model; the order is important, + # and matches the order of coefficients in H$coefficients (after the intercept) + # Coefficients: the regression coefficients, starting with intercept term and then + # in order as in H$ColsInModel.The Coefficients, combined with ColsInModel allow + # a reconstruction when applied to matrix X. + # ColsInOrderEntry: order in which the columns of X entered the stepwise model. In general, + # this differs from order in H$ColsInModel + # Rsquared,RsquaredAdj: R-squared and adjusted R-squared of the final model + # Step, RsquaredAllSteps,RsquaredAdjAllSteps: step is a numeric vector (1,2, ...) of + # the step in the stepwise process; the other two variables are the R-squared and + # adjusted R-squared at each step + # Foverall,Fpvalue: overall-F of the final regression model and p-value of that F + # CrossValidStorage: a list of detailed cross-validation statistics returned by + # CrossValid1(). No need to dig into this unless curious. See the comments for + # Crossvalid1() for definition of list. + # NleftOutinCV,REcv,RMSEcv: cross-validation statistics. NleftOutCV is the number of + # observations left out at each iteration of cross-validation. With lags, this is + # greater than 1, and set to assure no tree-ring data providing a cross-validation + # prediction are also used to calibrate the prediction model. REcv is the + # reduction-of-error statistic. RMSEcv is the root-mean-square error of cross-validation. + # ModelTable: a table object listing the same coefficients as in H$coefficients, but also + # including the corresponding id of the predictor, cross-referenced to columns of + # input matrix X and indicating if lagged positively or negatively and by how much. + # For example, X7 is the seventh column of X, no lags; and X2P2 is the second column of + # of X lagged +2 years forward from the predictand. + # + # revised 2024-03-09: 1) fixed code error that under some circumstances could + # result too few stepwise steps being allow based on maximum REcv. Fix may + # give a stronger (higher R-squared) model, with more predictors; + # 2)cosmetic. Comments cleaned up for typos and clarity. + + source(paste(code_dir,"CrossValid1.R",sep="")) # leave-m-out cross-validation + + #--- ALLOCATE AND INITIALIZE + Np<-dim(X)[2] # size predictor pool + i1<-1:Np # index to predictors in pool + i2<-rep(NA,Np) # index in order of entry + Lin=rep(FALSE,Np) # initial for in model + R2<-rep(NA,Np) + R2a<-rep(NA,Np) + + + #--- FOREWARD STEPWISE REGRESSION + + for (j in 1:Np){ + if (j==1){ + # First pass pick X correlated highest (absolute R) with y + colnames(X)<-namesX # re-initialize these + r<-cor(y,X) + H<-sort(abs(r),decreasing=TRUE,index.return=TRUE) + iwinner<-H$ix[1] + i2[j]<-iwinner + Lin[iwinner]<-TRUE # Logical to cols of X in model to be estimated + U<-X[,Lin,drop="FALSE"] # cull matrix of those predictors + G<-lm(y~U) # estimate model (G is a "lm" object ) + R2this<-summary(G)$r.squared + R2adjthis<-summary(G)$adj.r.squared + R2[j]<-R2this # store R-squared for this model + R2a[j]<-R2adjthis # store adjusted R-squared ... + e<-as.matrix(G$residuals) # model residuals; + } else { + # iterations after the first. e are the residuals of the previous step. + # At each step, e is correlated with the cols of X not yet in model. + # "Chosen one" is the the col of X with highest correlation + colnames(X)<-namesX # re-initialize these + ibullpen <-i1[!Lin] # cols of X NOT yet in models + r<-cor(e,X[,ibullpen]) + H<-sort(abs(r),decreasing=TRUE,index.return=TRUE) + iwinner<-H$ix[1] # pointer to highest correlated member of sub-matrix + i2[j]<-ibullpen[iwinner] # corresponding column of that member in X + ithis<-ibullpen[iwinner] #... renamed for simplicity + Lin[ithis]<-TRUE # logical of cols of X in current model to be estimated + # Next statements exactly same as those described for first iteration + U<-X[,Lin,drop="FALSE"] + G<-lm(y~U) # estimation + R2this<-summary(G)$r.squared + R2adjthis<-summary(G)$adj.r.squared + R2[j]<-R2this + R2a[j]<-R2adjthis + e<-as.matrix(G$residuals) + } + } + + #--- FIND "BEST" MODEL AND RE-FIT IT + rm(H) + Lin<-rep(FALSE,Np) # re-initialize as no variables in model + + if (kstop==1){ + # MAXIMUM ADJUSTED R-SQUARED VERSION + # Commented out code for using maximum adjusted R2 as criterion for best + # model. For large number of variables in pool of potential predictos, and + # with those possibly chosen by correlation screening from larger number + # of possible predictors, this criterion tends to over-fit model. Decided + # to stop entry instead FIRST maximimum of adjusted R2 + # + s<-sort(R2a,decreasing=TRUE,index.return=TRUE) # sorted adjusted R-squared, + # from highest to lowest. + iwinner<-s$ix[1] # step at which adjusted R-squared highest + }else{ + # MAXIMUM RE VERSION + CV <-CrossValid1(X, y, nNeg, nPos, i2) + iwinner <- CV$REmaxStep # revised 2024-03-09 + } + + i2a<-i2[1:iwinner] # cols of X in model to be fit + Lin[i2a]<-TRUE # turn on logical for cols of X in model to be fit + + #---- PULL SUBMATRIX OF PREDICTORS AND ESTIMATE MODEL + U<-X[,Lin,drop="FALSE"] + colnames(X)<-namesX # re-initialize these + colnames(U)<-colnames(X)[Lin] + G<-lm(y~U) # estimation + + # Fix names of coefficients so not prefixed with "U" + # Cosmetic, so that when user types "G$coefficients" at terminal he + # is not bothered by that "U" + bb <- G$coefficients # Regression coefficients + bbnms <- names(bb) + bbnms1 <- bbnms[-1] # names of terms, without "(Intercept)" + bbnms2 <- substring(bbnms1,2) + names(G$coefficients) <- c(bbnms[1],bbnms2) + rm(bb,bbnms,bbnms1,bbnms2) + + + #--- STATISTICS OF FINAL FITTED MODEL + + kstep<-sum(Lin) # final step (max adj R-square) + + if (kstop==1){ + stopHow<-'Approximate maximum of adsjusted R-squared' + }else{ + stopHow<-'Maximum cross-validation RE' + } + + H = list() + H[[1]]<-G + H[[2]]<-stopHow + + H[[3]]<-kstep + H[[4]]<-i1[Lin] + H[[5]]<-G$coefficients + H[[6]]<-i2[1:kstep] + H[[7]]<-summary(G)$r.squared + H[[8]]<-summary(G)$adj.r.squared + jstep<-(1:Np) + H[[9]]<-jstep + H[[10]]<-R2 + H[[11]]<-R2a + H[[12]]<-summary(G)$fstatistic[1] + + # function for p-value of F; from + # https://stackoverflow.com/questions/5587676/pull-out-p-values-and-r-squared-from-a-linear-regression + lmp <- function (modelobject) { + if (class(modelobject) != "lm") stop("Not an object of class 'lm' ") + f <- summary(modelobject)$fstatistic + p <- pf(f[1],f[2],f[3],lower.tail=F) + attributes(p) <- NULL + return(p) + } + p<-lmp(G) + H[[13]]<-p # pvalue of overall F + + if (kstop==2){ + H[[14]] <- CV + H[[15]] <- CV$LeftOut + H[[16]] <- CV$REcv + H[[17]] <- CV$RMSEcv + }else{ + H[[14]] <- NA + H[[15]] <- NA + H[[16]] <- NA + H[[17]] <- NA + } + # Build table with regression coeffients opposite variable names + tab<-matrix(t(G$coefficients)) + colnames(tab)<-c('Model') + rownames(tab)<-c('Intercept',namesX[H[[4]]]) + tab<- as.table(tab) + H[[18]]<-tab + + names(H)<-c('Model','StopCriterion','StoppingStep','ColsInModel','Coefficients', + 'ColsInOrderEntry','Rsquared','RsquaredAdj','Step', + 'RsquaredAllSteps','RsquaredAdjAllSteps','Foverall', + 'Fpvalue', + 'CrossValidStorage','NleftOutinCV','REcv','RMSEcv', + 'ModelTable') + return(H) +} + + + + diff --git a/Fpvalue.R b/Fpvalue.R new file mode 100755 index 0000000..cd20620 --- /dev/null +++ b/Fpvalue.R @@ -0,0 +1,21 @@ +Fpvalue <- function(modelobject) { + # p-value of overall-F of regression + # Adoped, 2022-01-04 + # + # modelobject [special]: must have been generated by R function lm, and computed by + # statement such as ModelObkect= yrv[1] & yrU <= yrv[length(v)] + X <- H[L1,] # Distance matrix for overlap of U and v + yrX <- yrU[L1] + + #--- SORT THE DISTANCE SUB-MATRIX FROM NEAREST TO FARTHEST + Sort1 <- function(x){ + y <- sort(x,method='quick',index.return=TRUE) + } + A <- apply(X,2,Sort1) + # A is a list, with A[[1]]$x a vector of the sorted neighbor values of v for yrU[1] + # and A[[1]]$ix a vector of the corresponding year + # yrv[A[[1]]$ix] is a vector of the corresponding analog year s for yrU[1] + + #-- ALLOCATE SOME MATRICES FOR RESULTS + Y1 <- matrix(data=NA,nrow=mU,ncol=kNN+1) # for analog data + Y2 <- Y1 # for analog years + Y3 <- Y1 # for analog distances + Y4 <- matrix(data=NA,nrow=mU,ncol=4) # for year, blended analog recon, analog year, and whether + # from nearest or second-nearest neighbor + nY1 <- kNN+1; nY2 <- nY1; nY3 <- nY1 # number of columns in Y1, Y2, Y3 + Y1[,1]=yrU; Y2[,1] <- yrU; Y3[,1] <- yrU; Y4[,1] <- yrU; # first col of these tsm's is year + + + #--- FILL MATRICES Y1, Y2 AND Y3 + + for (n in 1:mU){ + y1 <- v[A[[n]]$ix[1:kNN]] # vector of analog values from v + y2 <- yrv[A[[n]]$ix[1:kNN]] # vector of analog years + y3 <- A[[n]]$x[1:kNN] # vector of kNN distances + Y1[n,2:nY1] <- y1 + Y2[n,2:nY2] <- y2 + Y3[n,2:nY3] <- y3 + } + + #--- FILL MATRIX Y4 + + # Initialize with all years using nearest neighbor + Y4[,2] <- Y1[,2]; + Y4[,3] <- Y2[,2] + Y4[,4] <- 1 + + # But second nearest for overlap of U and v + Y4[L1,2] <- Y1[L1,3] + Y4[L1,3] <- Y2[L1,3] + Y4[L1,4] <- 2 + + + #=== NEAREST-OBSERVED ANALYSIS + # + # Fill a vector w with the values of v closest to those in each yrv. + V <- matrix(replicate(length(v),v),nrow=length(v)) #replicate cols of v + W <- t(V) + D <- abs(V-W) + A <- apply(D,1,Sort1) # sort rows + # A is a list, with A[[1]]$x a vector of the sorted neighbor values of v for yrv[1] + # and A[[1]]$ix a vector of pointer to the corresponding year in yrv + # yrv[A[[1]]$ix] is a vector of the corresponding nearest-observed years for yrv[1] + + W <- matrix(data=NA,nrow=mv,ncol=4) # for year, v, nearest-observed v, + # and year of nearest observd v + W[,1]=yrv; W[,2]=v + for (n in 1:mv){ + X <- A[[n]] + irow <- X$ix[2] + W[n,3] <- v[irow]; W[n,4] <- yrv[irow] + } + + #=== OUTPUT LIST + + Output <- list(YearsAnalog=Y2,DataAnalog=Y1,Distance=Y3,Recon=Y4, + NearestObserved=W) + return(Output) +} diff --git a/LagModel2Char.R b/LagModel2Char.R new file mode 100755 index 0000000..562af8c --- /dev/null +++ b/LagModel2Char.R @@ -0,0 +1,43 @@ +LagModel2Char<- function(i1,k) { + # Build string represntation of a lagged stepwise regression model. + # D Meko + # last revised 20220105 + # + # IN + # i1 [v]jk) || any(i1<0) + L3 <- (k %% 2)==0 + if (L1 || L2 || L3) { + stop("i1 and k must be integers>0; i1 must be odd length with all elements <=k") + } + + #---Fill a numeric vector version of desired string + ni1 <- length(i1) + ModelCoded<-vector(mode<-"numeric",length=k) # initialize as vector of zeros + for (n in (1:ni1)){ + islot<-i1[n] + ModelCoded[islot]<-n # ModelCoded, still numeric vector + } + s1<-as.character(ModelCoded) # convert numweric vector to character + s1<-paste(s1, sep = '', collapse = '') # concatenate + return(s1) +} \ No newline at end of file diff --git a/LagModel2Sign.R b/LagModel2Sign.R new file mode 100755 index 0000000..150942d --- /dev/null +++ b/LagModel2Sign.R @@ -0,0 +1,60 @@ +LagModel2Sign<- function(i1,k,b) { + # Build string representation of signs of regression coefficient in lagged stepwise regression model. + # D Meko + # last revised 2024-03-04 + # IN + # i1 [v]jk) || any(i1<0) + L3 <- (k %% 2)==0 + if (L1 || L2 || L3) { + stop("i1 and k must be integers>0; i1 must be odd length with all elements <=k") + } + + #--- Initialize length-k vector with zeros, meaning lag not in model + # Fill string with "0" + si <- rep('0',k); + + # Change some elements of si to "P" or "N" depending on sign of coefficient + # Coefficients in b are in col-order of s1 according to pointer i1 + b <- b[-1] # strip constant term off model, leaving coefficients + + # Positive + L <- b>0 + iP <- i1[L] + si[iP] <- 'P' + + # Negative + L <- b<0 + iN <- i1[L] + si[iN] <- 'N' + + si<-paste(si, sep = '', collapse = '') # concatenate + return(si) +} \ No newline at end of file diff --git a/LagReOrder.R b/LagReOrder.R new file mode 100755 index 0000000..cfef147 --- /dev/null +++ b/LagReOrder.R @@ -0,0 +1,37 @@ +LagReOrder<- function(X){ + # Reorder columnms of lagged tree-ring index + # D. Meko; last revised 2021-12-31 + # + # X, [m]r lagged matrix of time series, assumed L to R to have unlagged, followed by + # negative lags 1,2,3, ... followed by positive lags 1,2, 3, For example; + # [t t-1 t-2 t+1 t+2] + # + # Returns a matrix X: + # X [m]r reordered version of input X. From L to R have highest negative to highest + # positive lag. For example, [t-2 t-1 t t+1 t+2]. + # + # Why? Utility function to organize matrix of lagged tree-ring chronology to form needed by reconsw4(). + # This utility function intended for input X representing lagged values of a single time series, not + # of, say, multiple chronologies. The context is single-site reconstruction (SSR). + + #--- CHECK INPUT + + if (!is.matrix(X)) {stop('X should be matrix')} + ncols <- dim(X)[2] + if ((ncols %% 2)==0 ) {stop('X must have odd number of columns')} + + #--- REORDER + + jc <- 1 # col number in original of of central col in target + jLeft <- rev(1 + (1:nNeg)) # negative lags ordered L to R highest to lowest + jRight <- (2+nNeg):ncols # positive lags ordered L to R lowest to highest + j <- c(jLeft,jc,jRight) + + + Output <- X[,j] + + return(Output) +} + + + \ No newline at end of file diff --git a/LagYear.R b/LagYear.R new file mode 100755 index 0000000..9790730 --- /dev/null +++ b/LagYear.R @@ -0,0 +1,162 @@ +LagYear<- function(X,tGo,tSp,nNeg=0,nPos=0,ktrim){ + # Create a lagged verson of a time series matrix + # D. Meko; last revised 2021-12-31 + # + # X, [matrix] the time series; no time column; could be a single series, or many + # tGo,tSp:[numeric] first and last times (e.g., years) + # nNeg [numeric] : maximum negative lag, >=0 + # nPos[numeric] : maximum positive lag,>=0 + # ktrim (1x1)i: option for trimming of leading and trailing rows of lagged tsm + # ==1 lagged tsm trimmed to exclude any leading or trailing years with a NA + # (all-NA are trimmed off regardless of ktrim) + # ==2 lagged tsm not so trimmed + # + # Returns a named list, with parts: + # X [matrix] lagged version of input X; first the unlagged variables, + # then negative lags, then positive lags + # tGo, tSp [numeric] start and end times of lagged matrix + # ids [character] variable names, coded by column in input X and by lag + # Exampple: "X1" "X1N1" "X1N2" "X1P1" "X1P2" + # + # Why? Utility function to prepare matrix of chronologies, or a single + # chronology as predictors for reconstruction modeling. Climate can influence + # growth in multiple years, and so the information on the current + # year's climate from the current ring may be conditional on past rings. + # Likewise, climate can directly influence growth in multiple years, and so + # we expect that positive lags of the tree-ring index might improve the + # signal on current year's climate beyond what is available from just the + # current ring. + # + # Accepts X with one or more time series + # Allows posive and/or negative lags, and accepts no lags + # + # revised 2021-12-30: include new input arg ktrim, which will affect year coverage of output tsm + # revised 2021-12-31: tgo and tsp to "tGo" & "tSp": tsp is a built in R function + + #--- Code specific to whether one or more time series in input matrix + if (dim(X)[2]==1) { + mX<-nrow(X) + nX<-ncol(X) + X0<-X + mX0<-mX + nX0<-nX + + a<-NA + # Negative lags + if (nNeg>0){ + jset<-1:nNeg + for (j in jset){ + X1<-matrix(a,j,byrow=TRUE) + X2<-X0[1:(mX-j),] + X2<-as.matrix(X2) + X3<-rbind(X1,X2) + X<-cbind(X,X3) + } + } + # Positive lags + if (nPos>0){ + jset<-1:nPos + for (j in jset){ + X2<-matrix(a,j,byrow=TRUE) + X1<-X0[(j+1):(mX),] + X1<-as.matrix(X1) + X3<-rbind(X1,X2) + X<-cbind(X,X3) + } + } + } else { + # Mulitple serie in input matrix + mX=dim(X)[1] + nX=dim(X)[2] + X0<-X + mX0=mX + nX0=nX + + # Negative lags + if (nNeg>0){ + jset<-1:nNeg + for (j in jset){ + X1<-matrix(NA,j,nX) + X2<-X0[(1):(mX-j),] + X3<-rbind(X1,X2) + X<-cbind(X,X3) + } + } + # Positive lags + if (nPos>0){ + jset<-1:nPos + for (j in jset){ + X2<-matrix(NA,j,nX) + X1<-X0[(j+1):(mX),] + X3<-rbind(X1,X2) + X<-cbind(X,X3) + } + } + } + + #--- Trim leading and trailing rows, and refresh start and end year + + if (ktrim==1){ + if (nNeg>0){ + X<-X[-(1:nNeg),]; + } + if (nPos>0){ + n1<-nrow(X) + X<-X[1:(n1-nPos),] + } + tGo<-tGo+nNeg + tSp <- tSp-nPos + + } else { + # no action needed + } + mX=nrow(X) + nX=ncol(X) + + + #--- Build series ids (column headings + + # lag 0 + c1<-c('a') + jset <- 1:nX0 + for (j in jset){ + c1[j]<- sprintf("X%s", j) + } + + # negative lags + if (nNeg>0){ + for (k in 1:nNeg){ + for (j in jset){ + kslot<-nX0+(k-1)*nX0+j + c1[kslot]<- sprintf("X%sN%s", j,k) + } + } + } + + # positive lags + if (nPos>0){ + for (k in 1:nPos){ + for (j in jset){ + kslot<-nX0+nNeg*nX0+(k-1)*nX0+j + c1[kslot]<- sprintf("X%sP%s", j,k) + } + } + } + + #--- TRIM OFF ANY ALL-NA ROWS + + + L <- (rowSums(is.na(X))) == nX + X <- X[!L,] + yrX <- tGo:tSp + yrX <- yrX[!L] + tGo=yrX[1]; tSp <- yrX[length(yrX)] + + + + Output<-list(X=X,tGo=tGo,tSp=tSp,ids=c1) + return(Output) +} + + + \ No newline at end of file diff --git a/LagkAcc.R b/LagkAcc.R new file mode 100755 index 0000000..9af0d2f --- /dev/null +++ b/LagkAcc.R @@ -0,0 +1,60 @@ +LagkAcc <- function(X,k) { + # D. Meko + # Last revised 2022-09-5 + # Lag-k autocorrelation coefficient(s) of a time series matrix or vector. + # + # Converts matrix or vector to z-scores, shifts one version k slots relative to the other, + # and computes the average product of the first and last mX-k observations of each series, + # where mX is number of rows, or observations, in X + # + #---IN + # + # X: matrix or vector without any NA; number of observations mX + # k: the lag of the desired autocorrelation; require k< mX/4 + # + #---OUT + # + # Output: list with fields + # rk: lag-k autocorrelation coefficient(s) [scalar or vector] + # k: lag + # Lflag: flag (logical, length 2) + # (1) X has at least one NA + # (2) k >= 1/4 the number of observations in X + # ErrorMessage [vector]c : error message associated with Lflag + + Lflag <-c(FALSE,FALSE) # initialize as no error flags + ErrorMessage <- "No problems" + + # Error message; No NA allowed + if (!all(complete.cases(X))){ + Lflag[1]<-TRUE + ErrorMessage <- 'X contains a NA' + Output <- list(Lflag=Lflag,ErrorMessage=ErrorMessage) + return(Output) + } + + if (is.vector(X)){ + X <- matrix(X) + } else { + # no action needed; X is matrix + } + Z <- scale(X,center=TRUE,scale<-TRUE) # time series matrix to zscores + mZ<- dim(Z)[1] + + # Error message; lag k must be less than 1/4 mZ + if (k>=mZ/4){ + Lflag[2]<-TRUE + ErrorMessage <- 'Lag k must be less than 1/4 the number of obs in X' + Output <- list(Lflag=Lflag,ErrorMessage=ErrorMessage) + return(Output) + } + nZ<- dim(Z)[2] + Zhead <- head(Z,mZ-k) + Ztail <- tail(Z,mZ-k) + Z1 <- Zhead * Ztail # products of standardized departures; + # These standardized departures were computed using the means and standard + # deviations for the full mZ observation in X + rk <- colMeans(Z1) + txt1 <- paste('Lag-',as.character(k),'autocorrelations',sep='') + Output <- list(rk=rk,lag=k,Lflag=Lflag,ErrorMessage=ErrorMessage) +} \ No newline at end of file diff --git a/LeaveOut.R b/LeaveOut.R new file mode 100755 index 0000000..f9e626d --- /dev/null +++ b/LeaveOut.R @@ -0,0 +1,49 @@ +LeaveOut<-function(nNeg, nPos, mA) { + # Build pointer matrix for use in leave-m-out cross-validation + # D Meko + # Last revised 2021 May 25 + # + # Returns logical pointer matrix whose jth column points to the predictor cols + # for calibration of a model to supply the jth observation + # + # nNeg [numberic]: maximum negative lag to be considered on tree rings + # nPos [numeric]: maximum positive lag ... + # mA [numeric] # number of of observations in calibration period + # + # Note that nNeg should be a positive number (e.g., 2 indicates + # lage upt to -2) + # + # Leave-m-out cross-validation ensures that if lags are in the regression model + # no tree-ring observations used to predict the "left-out" observation are also + # used in calibration of the model that supplied the prediction (Meko 1997) + + m <- 1+ 4*max(nNeg,nPos) # leave this many out + mhalf <- (m-1)/2 + i1 <- mhalf+1 + i2 <- mA-mhalf + + A<-matrix(1,mA,mA) + + for (j in 1:mA){ + a <- rep(1,mA) + if (ji2) { + igo<-j-mhalf + isp<-mA + a[igo:isp]<-0 + A[,j]<-a + } else { + igo<-(j-mhalf) + isp<-(j+mhalf) + a[igo:isp]<-0 + A[,j]<-a + } + } + Lin<-A + Leave <- list("Lin"=Lin,"NumberLeftOut"=m) + return(Leave) +} \ No newline at end of file diff --git a/ListFilesTRISH01.txt b/ListFilesTRISH01.txt new file mode 100755 index 0000000..9ff64db --- /dev/null +++ b/ListFilesTRISH01.txt @@ -0,0 +1,68 @@ +/home/dave/AAAtrish2/ReconAnalog.R +/home/dave/Data/RlibraryMeko/c13toc3.R +/home/dave/Data/RlibraryMeko/CrossValid1.R +/home/dave/Data/RlibraryMeko/CrossValid2.R +/home/dave/Data/RlibraryMeko/EffectSS.R +/home/dave/Data/RlibraryMeko/emssgUNH.R +/home/dave/Data/RlibraryMeko/ForwStep1.R +/home/dave/Data/RlibraryMeko/ForwStep2.R +/home/dave/Data/RlibraryMeko/ForwStep3.R +/home/dave/Data/RlibraryMeko/ForwStep.R +/home/dave/Data/RlibraryMeko/Fpvalue.R +/home/dave/Data/RlibraryMeko/KnnAnalog.R +/home/dave/Data/RlibraryMeko/LagkAcc.R +/home/dave/Data/RlibraryMeko/LagModel2Char.R +/home/dave/Data/RlibraryMeko/LagModel2Sign.R +/home/dave/Data/RlibraryMeko/LagReOrder.R +/home/dave/Data/RlibraryMeko/LagYear.R +/home/dave/Data/RlibraryMeko/LeaveOut.R +/home/dave/Data/RlibraryMeko/mannken1.R +/home/dave/Data/RlibraryMeko/NashSutt.R +/home/dave/Data/RlibraryMeko/PeriodCommon.R +/home/dave/Data/RlibraryMeko/PrewhitenChrons.R +/home/dave/Data/RlibraryMeko/RecMLR1.R +/home/dave/Data/RlibraryMeko/reconsw4.R +/home/dave/Data/RlibraryMeko/RecPCR1.R +/home/dave/Data/RlibraryMeko/RecSLR1.R +/home/dave/Data/RlibraryMeko/SeasClim.R +/home/dave/Data/RlibraryMeko/SignalDrop1.R +/home/dave/Data/RlibraryMeko/ssValid.R +/home/dave/Data/RlibraryMeko/stem1.R +/home/dave/Data/RlibraryMeko/stemACF.R +/home/dave/Data/RlibraryMeko/Table1Column.R +/home/dave/Data/RlibraryMeko/TablePCA1.R +/home/dave/Data/RlibraryMeko/TableWrite1.R +/home/dave/Data/RlibraryMeko/TabSepTsm1.R +/home/dave/Data/RlibraryMeko/TabSepTsm2.R +/home/dave/Data/RlibraryMeko/TabSepTsm3.R +/home/dave/Data/RlibraryMeko/ties1.R +/home/dave/Data/RlibraryMeko/TranFlow.R +/home/dave/Data/RlibraryMeko/trimnan.R +/home/dave/Data/RlibraryMeko/trimRowNA.R +/home/dave/Data/RlibraryMeko/TrimTsm1.R +/home/dave/Data/RlibraryMeko/Tsm2Scores1.R +/home/dave/Data/RlibraryMeko/tsmExtend.R +/home/dave/Data/RlibraryMeko/xyCI.R +/home/dave/Projects/ba2/TRISHvisual/AbbreviationsTRISH.pdf +/home/dave/Projects/ba2/TRISHvisual/siteData_Katun.txt +/home/dave/Projects/ba2/TRISHvisual/siteMeta_Katun.txt +/home/dave/Projects/ba2/TRISHvisual/hydroData_Katun.txt +/home/dave/Projects/ba2/TRISHvisual/Recon.init +/home/dave/Projects/ba2/TRISHvisual/Recon_Katun.init +/home/dave/Projects/ba2/TRISHvisual/PackagesNeeded.txt +/home/dave/Projects/ba2/TRISHvisual/TrishOutputDescribeAnalog.pdf +/home/dave/Projects/ba2/TRISHvisual/TrishOutputDescribeMLR1-noPCA.pdf +/home/dave/Projects/ba2/TRISHvisual/TrishOutputDescribeMLR1-PCA.pdf +/home/dave/Projects/ba2/TRISHvisual/TrishOutputDescribeSLR1.pdf +/home/dave/Projects/ba2/TRISHvisual/Running_Instructions_ReconAnalog.pdf +/home/dave/Projects/ba2/TRISHvisual/Recon_init_explanation.pdf +/home/dave/Projects/ba2/TRISHvisual/readme.pdf +/home/dave/Projects/ba2/TRISHvisual/ListFilesTRISH01.txt +/home/dave/Projects/ba2/TRISHvisual/AbbreviationsTRISH.odt +/home/dave/Projects/ba2/TRISHvisual/TrishOutputDescribeAnalog.docx +/home/dave/Projects/ba2/TRISHvisual/TrishOutputDescribeMLR1-noPCA.docx +/home/dave/Projects/ba2/TRISHvisual/TrishOutputDescribeMLR1-PCA.docx +/home/dave/Projects/ba2/TRISHvisual/TrishOutputDescribeSLR1.docx +/home/dave/Projects/ba2/TRISHvisual/Running_Instructions_ReconAnalog.odt +/home/dave/Projects/ba2/TRISHvisual/Recon_init_explanation.odt +/home/dave/Projects/ba2/TRISHvisual/readme.odt diff --git a/NashSutt.R b/NashSutt.R new file mode 100644 index 0000000..ba8b558 --- /dev/null +++ b/NashSutt.R @@ -0,0 +1,127 @@ +NashSutt<- function(y, yh, yry, ycMean, kplot, outputDir,gFileType) { + # Nash-Suttcliffe efficiency + # D Meko + # last revised 20230726 + # + # IN + # y: vector of observed + # yry: year vector for y and yh + # yh: vector or reconstructed (or predicted) for same observations + # ycMean: (1x1): calibration-period mean of y + # kplot (1x1): plot option + # 1= plot on current device + # 2= plot a graphics file of with suffix "gFileType" to folder "outputDir" + # 3= skip plot + # outputDir: folder to write plot file to (ignored unless kplot=2) + # gFileType: type of graphics file (e.g., "png") -- ignored unless kplot=2 + # + # OUT + # Output [named list] + # NSE (1x1)r Nash-Suttcliffe efficiency + # RE (1x1)r reduction of error statistic + # rTest: list with result of correlation (#Pearson) test for IV period: + # $estimate = correlation + # $parameter = df + # $p,vaue = pvalue for test + # e: vector of errors (observed minus predicted) + # yMean: mean y (for Nash-Suttcliffe period) + # ycMean: mean y for calibration period on which prediction based (echo of input) + # SSE: sum of squares of e + # SSEnull1: sum of squares of departures (y-yMean) + # SSEnull2: sum of squares of departures (y-ycMean) + # + # Notes + # + # The NSE and RE are similarly computed from ratios of sum-of-squares terms. NSE uses the validation period + # mean as the null prediction, giving SSEnull1. RE uses the calibration period means as the null prediction, + # giving SSEnull2. Equations are + # + # SSE = 1 - (SSE/SSEnull1) + # RE = 1 - (SSE/SSEnull2) + library("pracma") # needed for emulation of Matlab "backslash" operator through + # QR decomposition + + source(paste(code_dir,"LeaveOut.R",sep="")) # form pointer matrix for leave-m-out cross-validation + + #--- CHECK INPUT + # y and yh should be same-length numeric vectors + + if (!is.vector(y) || (!is.vector(yh))){ + stop('y and yh must be vectors') + } else { + } + + if (!is.numeric(y) || (!is.numeric(yh))){ + stop('y and yh must be numeric') + } else { + } + + L <- length(y) == length(yh) + if (!L){ + stop('y and yh must be same length') + } + + #--- COMPUTE STATISTICS + + yMean <- mean(y) # verification-period observed mean (null prediction for NSE) + e <- y-yh # validation period errors + e1 <- y-yMean # errors for null prediction of validation mean + e2 <- y-ycMean # errors for null prediction of calibration mean + + SSE <- sum(e*e) # sum of squares, recon errors + SSEnull1 <- sum(e1*e1) # sum of squares, reconstruction consisting of validation mean each year + SSEnull2 <- sum(e2*e2) # sum of squares, reconstruction consisting of calibration mean each year + + NSE <- 1 - (SSE/SSEnull1) # Nash-Suttcliffe efficiency + RE <- 1 - (SSE/SSEnull2) # Reduction of error statistic + + rTest <- cor.test(y,yh) + r <- rTest$estimate # Pearson r + df <- rTest$parameter + p <- rTest$p.value + + + #--- PLOT + + # Expand right side of clipping rect to make room for the legend + par(xpd=T, mar=par()$mar+c(0,0,0,6)) + + # ylim + yhi <- max(c(max(yh),max(y))) + ylo <- min(c(min(yh),min(y))) + ylims <- c(ylo,yhi) + yhi <- yhi+0.1*diff(ylims) + ylims <- c(ylo,yhi) + xlims <- c(yry[1]-1,yry[length(yry)]+1) + + str_r <- paste('NSE=',sprintf('%5.2f',NSE),'; RE=',sprintf('%5.2f',RE),'; r=',sprintf('%5.2f',r), ' (N=',as.character(df), + ', p=',sprintf('%6g',p),')',sep='') + str_tit <- paste('Independent verification, ',as.character(yry[1]),'-', + as.character(yry[length(yry)]),'\n',str_r) + plot(yry,y,type='b',ylim=ylims,xlim=xlims, + xlab='Year',ylab='Data value',main=str_tit) # main plot of obs + lines(yry,yh,col='red') # Line for reconstruction + points(yry,yh,col='red',pch=2) + # Null prediction -- the observed mean for indep period + lines(xlims,c(yMean,yMean),col='black') + # Null prediction by calib mean + lines(xlims,c(ycMean,ycMean),col='black',lty='dashed',lwd=2) + #abline(h=ycMean,col='black',lty='dashed') + # The reconstructed mean for independent period + lines(xlims,c(mean(yh),mean(yh)),col='red') + #abline(h=mean(yh),col='red') + + # In legend below, "26" ignored as a plot character. This is not an error. + legend(xlims[2]+1,ylims[2], legend=c("Observed","Recon","ObsMeanV","ObsMeanC","RecMeanV"), + col=c("black","red", "black","black","red"), + lty=c(1,1,1,2,1),pch=c(1,2,26,26,26),lwd=c(1,1,1,2,1), cex=0.9) + + # Restore default clipping rect + par(mar=c(5, 4, 4, 2) + 0.1) + + + #--- OUTPUT + + Output <- list("NSE"=NSE,"RE"=RE,"rTest"=rTest,"Errors"=e) + return(Output) +} \ No newline at end of file diff --git a/PackagesNeeded.txt b/PackagesNeeded.txt new file mode 100755 index 0000000..6ddc3ef --- /dev/null +++ b/PackagesNeeded.txt @@ -0,0 +1,20 @@ +ReconAnalog assumes that several R packages have been installed. Here is a list of the required packages, and the version number under which ReconAnalog runs successfully on Meko's laptop. + +car (v3.1.2) +gplots (v3.1.3.1) +nortest (v1.0.4) +pracma (v2.4.4) +rjson (v0.2.21) +ggplot1 (v3.5.1) +resample (v0.6) + +versions of Rstudio and R on Meko's laptop: + +R version 4.1.2 (2021-11-01) +RStudio 2023.06.0 Build 421 + +Operating system on Meko's laptop: +Ubuntu 22.04.4 LTS + + + diff --git a/PeriodCommon.R b/PeriodCommon.R new file mode 100755 index 0000000..bb6b72a --- /dev/null +++ b/PeriodCommon.R @@ -0,0 +1,66 @@ +PeriodCommon <- function(X, Y) { + # Common period of a time series with time series matrix + # D Meko, Last revised 2021-05-17 + # + # X [matrix] multiple time series; time vector as column 1 + # Y [matrix] single time series; time vector as column 1 + # + # Returns list with parts + # X, Y [matrix] like input X, Y, but for years in which no data are + # missing in Y or in any of the series in X + # Beware that time (e.g., year) is first column of these matrices + # tgo, tsp [numeric]: start and ending times (e.g., years) of X and Y + # + # Why? Written to facilitate organization of predictors and predicand for + # calls to regression functions. + X<-as.matrix(X) + Y<-as.matrix(Y) + + # Y ; Separate time column; + y1 <- Y[,-1] + yry1 <-Y[,1] + yrX1<-X[,1] + X1<-X[,-1] + + # In case of X having just one series + X1<-as.matrix(X1) + yrX1<-as.matrix(yrX1) + + #--- BUILD NA MTX TO HOLD ALL OF AND X AND Y + nA<-ncol(X1)+1 + ton<-min(yry1[1],yrX1[1]) + toff<-max(yry1[length(yry1)],yrX1[dim(X1)[1]]) + mA<-toff-ton+1 + + A<-matrix(NA,mA,nA) + yrA<-(ton:toff) + + + #--- FILL COLS OF A, PREDICTAND IN COL 1 if applicable + + irow<-yry1-ton+1 # row indices of tarter slots in A for y + A[irow,1]=y1; + irow<-yrX1-ton+1 # row indices of tarter slots in A for X1 + A[irow,2:nA]=X1 + + + #-- FIND ROWS WITH NO NA'S AND PULL SEGMENT + + L=complete.cases(A) + A<-A[L,] + yrA<-yrA[L] + mA<-nrow(A) + nA<-ncol(A) + + # error message if time vector does not increment by 1 + L<-all(diff(yrA)==1) + if(!L) stop('year column of A does not increment by 1') + + Ynew <- cbind(yrA,A[,1]) + Xnew <- cbind(yrA,A[,2:nA]) + tgo<-yrA[1] + tsp<-yrA[mA] + Output<-list(X=Xnew,Y=Ynew,tgo=tgo,tsp=tsp) +} + + diff --git a/PrewhitenChrons.R b/PrewhitenChrons.R new file mode 100755 index 0000000..047a97e --- /dev/null +++ b/PrewhitenChrons.R @@ -0,0 +1,106 @@ +PrewhitenChrons <- function(X,p,outputDir){ + # Convert tsm of chronologies to prewhitened matrix using AR model order p + # D. Meko; last revised 2023-01-21 + # + #--- INPUT + # + # X: [data frame] tsm of chronologies, year as column 1. All series need not + # cover all years of X + # p: scalar: prewhiten using AR model of order p (allowable are p=1, 2, or 3) + # outputDir: any error message generated will go to this system folder + # + # + #--- OUTPUT + # + # Output: named list with revised data frame. Will start p years later than X + # and data columns with AR(p)-whitened versions of original columns. + # Xwhitened -- data frame of AR-whitened versions of input X + # + # + #---NOTES + # + # For each series, mean is subtracted first, AR modeling is done, and residuals are + # shifted to have same mean as original data over the years covered by residuals + # + # Output data frame inherits column names of input data frame, and has row names + # as a character vector of years. This even though first data column is also the year. + + source(paste(code_dir,"emssgUNH.R",sep="")) # write error file to system, specified output folder + + L <- !is.data.frame(X) | !any(p==c(1,2,3)) + if (L){ + emssg <- 'PrewhitenChrons: X must be data frame, and AR order p must be one of {1,2,3}' + ResTemp<-emssgUNH(emssg,outputDir) + stop(emssg) + } + + # ALLOCATING + # Allocate Y same row-size as X, but without year column + nY = dim(X)[2]-1 # number of time series in X + mY = dim(X)[1] # number of years in matrix X + Y <- matrix(NA,nrow=mY,ncol=nY) + + k <- 1:mY # nominal year of X and Y, equivalent to row number + + # Loop over time series in X, fitting AR model, getting residuals, + # restoring mean; place in column of Y + for (n in 1:(nY)){ + j1 <- n+1 + x <- X[,j1] + L <- complete.cases(x) + ix <- k[L] # in X, these would be rows with data + ilast<- ix[length(ix)] # last value of whitened series + # should be in this row of X and Y + x <- x[L] # the time series, w/o flanking NA + + # SET UP REGRESSION + # + # Put predictand in v, predictor(s) on W + mx <-length(x) + j=(p+1):mx + v <- x[j] # predictand for AR modeling + mv <- length(v) + J = matrix(rep(j,p), ncol = p) + mJ <- dim(J)[1] + + # Build matrix to subtract + j1 = 1:p + J1 <- matrix(j1, nrow=mJ, ncol=length(j1), byrow=TRUE) # row-dupe to mJ rows + + # Subtract indices + J2 <- J-J1 + # each col of J2 is a vector index into x + + W = matrix(NA,nrow =mv,ncol=p) + for (kk in 1:p){ + jthis <- J2[,kk] + w = x[jthis] + W[,kk]=w + } + + # Regress + M <- lm(v ~ W) + y <- M$residuals+mean(v) # the prewhitened chronology + + # Re-insert + i2 <- ilast; i1 <- ilast - length(y)+1 # start and end row + Y[i1:i2,n]=y + } + yrY <- X[,1] + + # Trim off all-NA rows + N1 <-rowSums(!is.na(Y)) # vector with number of non-NA in each row of Y + L <- N1>0 + Y <- Y[L,]; yrY <- yrY[L] + + # Add year col, give col names, make as data frame + Y <- cbind(yrY,Y) + rownames(Y) <- as.character(yrY) + colnames(Y) <- names(X) + Y <- as.data.frame(Y) + + # STORE OUTPUT + Output <- list("Xwhitened"=Y) + return(Output) +} + diff --git a/RecMLR1.R b/RecMLR1.R new file mode 100755 index 0000000..2fe94ad --- /dev/null +++ b/RecMLR1.R @@ -0,0 +1,1678 @@ +RecMLR1 <- function(D) { + # Multi-site reconstruction (MSR) by multiple linear regression on SSRs or their PCs + # D. Meko + # Last revised 2024-03-06 + # + # Called from a script or function (e.g., ReconAnalog1) that has generated the SSRs. + # Consider the predictand, y, and predictor matrix, X. Here, y is regressed on + # either the matrix of screened SSRs or PCs of that matrix. The method uses + # stepwise forward multiple linear regression. + # + # D is list with members: + # Text (1x4)s: symbol for y label; units of y, in parens; longer name of y; name of y season; Example: + # "RO","(mm)","Runoff", "12-month season ending in month 9" + # U, yrU: matrix of screened SSRs (matrix); matrix of years (1-col matrix) + # nmsU: names of screened SSRs (vector) + # jScreened: pointer from columns of screened SSRs to site number in original user network + # v, yrv: numeric and integer; predictand and years + # yrsC (1x2)d first and last year of desired calibration period; if NaN, default to first or last + # available year of overlap of u and v + # yrEnd (1x1)d desired last year of provided time series output of reconstruction and of plot of + # reconstruction with 50% error bar + # nNeg, nPos: integer (both positive) of max negative and possitive lag allowed by calling function in + # SSR modeling. This affects m in leave-m-out cross-validation + # incR2a: the stwp of "approximate" maximum adjusted R-squared is the before which the increase + # in adjusted R-squared is less than incR2a. I have used 0.01, figuring that, say, an + # increase in adjusted R-squared from 0.50 to 0.5099 is not worth a more complicated model + # kstop: stopping rule for forward stepwise. + # =1 at approximate maximum adjusted R-squared + # =2 at maximum cross-validation RE, but at no higher step than that of approximate maximum adjusted R-squared + # NcMin: minimum acceptable number of years for calibration of MSR model + # PCoption: option for building pool of potential predictors from scores of PCs of SSRs + # 1: specify k most important PCs, for example from viewing scree plot + # 2: the m + # + # Notation below uses "<>" to indicate "default" values of input specifications. For example, + # means the default for variable f is 0.10. Or, with options 1 and 2, <2> indicates that + # the default option is "2." + # + # Revision + # Rev 2023-02-09. Minor, to avoid fatal error in in a listing annotated on a figure. + # Rev 2023-03-29. format '-3d' to '3.0f' in response to error with analog method call for calb table + # Rev 2023-04-03. To handle special case in which specified start and end years of calibration for + # SSR models are incompatible with data available for MSR model + # Rev 2023-04-15. Typo "nPCskeep" corrected + # Rev 2023-05-08. Cosmetic, to figure summarizing calibration statistics. Switched to using layout() + # for screen splitting to allow sub-windows to be of different width. Formerly used split.screen. + # Rev 2023-05-16. yrEnd newly provided input argument, for truncation of final reconstruction + # Rev 2023-06-02. remove error message and automatic bail when user specifies a calibration period impossible + # for the time coverage of tree-ring and hydro data. Now the calibration period is simply truncated + # to be as long as possible, and program allowed to proceed. + # Rev 2023-11-26. (1) To used input arg yrEnd as last year of desired reconstruction output rather + # than compute yrEnd internally. (2) To fix a fatal error when running in "analog" mode + # revised 2024-03-06. Cosmetic change for labeling of figure showing ACFs of reconstruction for calibration + # and earlier years + + # (methMSR=3) + library(car) + library(nortest) + library(gplots) + library(pracma) + source(paste(code_dir,"CrossValid2.R",sep="")) # leave-m-out cross-validation + source(paste(code_dir,"ssValid.R",sep="")) # split-sample validation + source(paste(code_dir,"mannken1.R",sep="")) # time plot and trend test of reg. resids + source(paste(code_dir,"stemACF.R",sep="")) # stem plot of acf, with CI & annotaton + source(paste(code_dir,"xyCI.R",sep="")) # compute polygon (for shaded CI) from lower and upper CI + source(paste(code_dir,"Table1Column.R",sep="")) # write a table file with just 1 data column + source(paste(code_dir,"TabSepTsm1.R",sep="")) # write a tab-sep file with obs, recon, 50% CI + source(paste(code_dir,"TabSepTsm2.R",sep="")) # write a tab-sep file with model input data, 50% CI + source(paste(code_dir,"Tsm2Scores1.R",sep="")) # time series matrix to scores of PCsI + source(paste(code_dir,"ForwStep3.R",sep="")) # stepwise regression to get stopping step + source(paste(code_dir,"LagkAcc.R",sep="")) # lag-k autocorrelation(s) of vector or matrix + source(paste(code_dir,"TablePCA1.R",sep="")) # write tailored tab-sep table of PCA loadings + source(paste(code_dir,"TableWrite1.R",sep="")) # write multi-column table + source(paste(code_dir,"EffectSS.R",sep="")) # effective sample size (adjusted for autocorrelation) + source(paste(code_dir,"TabSepTsm3.R",sep="")) # for time series output of PC scores + source(paste(code_dir,"KnnAnalog.R",sep="")) # nearest neighbor analogs + source(paste(code_dir,"emssgUNH.R",sep="")) # write error file to system, specified output folder + + #====== HARD CODE + + cBlue1 <- "#3399FF"; cMagenta1 <- '#FF00FF'; cGreen <- '#00FF00' + + flagBail<-0 # flag for bailing out of function + # 0 = no problems + # 1 = fatal error; message returned and program aborts + # 2 = no abortion, but calibration period had to be modified to suit coverage of climate + # series and SSR matrix; message is returned to calling program + flagMsg<-'No problems' + minLength1 <-130 # if length of series > minLength1 in reconstruction time series plot, line + # without plot characters is plotted; otherwise line with symbols + + # 1 specified calibration period too short or inconsistent with data coverage + # + #======================= UNLOAD LIST, AND RENAME SOME VARIABLES + + U <-D$U ; yrU<-D$yrU # full tsm of screened pf SSRs + + nmsU <- D$nmsU # ids of screened SSRs + jScreened <- D$jScreened # pointer from screened SSRs to user-database site number + v <-D$v ; yrv<-D$yrv # full length predictand + yrgo1<-D$yrsC[1]; yrsp1<-D$yrsC[2] # desired start and end year of calib period of MSR model + yrEnd = D$yrEnd; # final reconstruction to be truncated at this year + nNeg<-D$nNeg; nPos<-D$nPos # max neg and pos lags allowed in SSR modeling + incR2<-D$incR2a # stepwise in MSR will not choose a model whose increase in adjusted + # R-squared from the previous step is less than incR2 + kstop <-D$kstop # stopping rule for stepwise + N1 <- D$NcMin # mimimum acceptable number of years for calibration of MSR model + PCoption <- D$PCoption # how pool of potential predictors to be filled: + # 1 Use will specify to use most important K PCs after viewing scree plot + # <2> The m + alphaR <- D$alphaR # for analog method, PCs retained only if correlated with y at this alpha level + ScreenAnalogPCs <- D$ScreenAnalogPCs # whether or not to screen the analog PCs with correlation + PCApredictors <- D$PCApredictors # TorF for using PCs of SSRs as the predictors + methMSR <- D$methMSR # method of MSR: 1=SLR1, 2=MLR1-PCA or MLR1-noPCA, 3= Analog + PdfDescribe <- D$PdfDescribe # string referring to pdf file that describes recon. method + nPCsKeep <- D$nPCsKeep # user-specified number of PCs to include in pool of potential predictors + kHowPCA <- D$kHowPCA # 1= on correlation mtx, 2=on covariance mtx + NextFigNumber <-D$NextFigNumber # start naming figures as Figure0?.png, where ? is NextFigNumber + outputDir <-D$outputDir # outut to be written to this system folder + # Note that outputDir is also defined in the global environment. So, I think that I would + # not actually need to pass outputDir as argument to functions + HydroName <- D$Text[3] # name of hydrologic variable (e.g., "Runoff") + HydroLabel <- D$Text[1] # label of hydro variable, for plots (e.g., "RO) + HydroUnits <- D$Text[2] # units of hydro varialbe with parens, (e.g., "(mm + HydroUnits2 <- substr(HydroUnits,2,(nchar(HydroUnits)-1)) # units w/o pare s + HydroSeason <- D$Text[4] # season of hydro variable (e.g., ""12-month season ending in month 9" ) + strTailPart1 <- PdfDescribe + if (methMSR==3){ + RecMethod<- paste('Method: Analog years of observed',HydroLabel,'from PC scores of SSRs') + } else { + if (PCApredictors) { + RecMethod<- paste('Method: stepwise regression of observed',HydroLabel,'on PC scores of SSRs') + } else{ + RecMethod<- paste('Method: stepwise regression of observed',HydroLabel,'on SSRs') + } + } + rm(D) + # all of the above are numeric or integer, except that yru is 1-col matrix + + #============= GET CALIBRATION DATA AND CHECK THAT CALIBRATION PERIOD LONG ENOUGH + + # Compute longest possible calibration period given the overlap of U and v + yrgo2 <- max(yrU[1],yrv[1]) # earliest overlap year of U and v + yrsp2 <- min(yrU[dim(U)[1]],yrv[length(v)]) # earliest overlap year of U and v + + # Return error message and fail if overlap of screened SSRs (U) and available hydro series v yrsp2 + if (L2){ + yrsp1 <- yrsp2 + } + L <- L1 || L2 + + # Following commented out because decided to just truncate the calibration period to years supported + # by the data. User will have to live with it. + # if (L){ + # flagBail<-2 + # flagMsg<-paste('RecMLR1 message: MSR calibration period forced to ',as.character(yrgo1),'-', + # as.character(yrsp1), ' in response to available time covrage of vector of ', + # ' hydro data and matrix of screened SSRs',sep='') + # } + + U0 <- U # save the original SSRs for debugging + + #========================= OPTIONAL CONVERSION OF SSRs to PCs + + if (methMSR==3 | isTRUE(PCApredictors)){ + D <- rep(NA,4) # make empty list; "D" otherwise ia some kind R function + DinPCA <- list("X"=U,"yrX"=yrU,"nmsX"=nmsU,"khow"=kHowPCA) + ResPCA <- Tsm2Scores1(DinPCA) + + # Loadings + LoadPC <- ResPCA$Loadings + row.names(LoadPC)<-nmsU # assign chronology ids as row names + namesX <- colnames(LoadPC) + + # Replace SSRs of U with the PC scores + U <- ResPCA$Scores + + #====================== FIGURE 1x1 SCREE PLOT + # + # Figure files are numbered within this function with first figure as figure01.png. where + # In general, figure files are named Figure?? is a number built from NextFigNumber+jFigAdd. jFigAdd + # will start at 0 but increment for later figures + jFigAdd <- 0 + FigNumber <- NextFigNumber+jFigAdd # for naming this png + if (FigNumber<10){ + fileOut <- paste(outputDir,'Figure0', as.character(FigNumber),'-PCA1','.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure', as.character(FigNumber),'-PCA1','.png',sep="") + } + + # Blocks for plot + nPC <- length(namesX) + j <- 1:nPC # for x axis, PC# + + # Pct variance annotation for up to first 7 PCs + if (nPC<=7){ + nListPct <- nPC + str1 <- paste('Pctg variance of the ',as.character(nPC),' SSRs explained by PCs') + } else { + nListPct <-7 # will list variance explained for only first 7 Pcs + str1 <- paste('Pctg variance of the ',as.character(nPC),' SSRs explained by first 7 PCs') + } + str1 <-paste(str1,'\nPC %Var Cum%\n') + B <- matrix(nrow=nListPct,ncol=2) + B[,1] <- ResPCA$PctVar[1:nListPct]; B[,2] <- ResPCA$CumPctVar[1:nListPct] # rev 2023-02-09 + + for (n in 1:nListPct){ + str1a <- paste(as.character(n),' ',sprintf('%5.0f %5.0f\n',B[n,1],B[n,2])) + str1 <- paste(str1,str1a) + } + rm(str1a,B,nListPct) + + # Plot figure + png(filename=fileOut, width = 960, height = 480) + par(mar=c(5,5,5,1),cex.main=1.4,cex.axis=1.5, cex.lab=1.5, cex.main=1.5) + plot(j,ResPCA$EigValues,type="b",pch=1,col="blue", + xlab="PC Number",ylab="Eigenvalue", + main=paste('Scree Plot of Eigenvalues', + '\n(dashed red line at mean)')) + abline(h=mean(ResPCA$EigValues),col='red',lty=2) + text(nPC/2,max(ResPCA$EigValues),str1,adj=c(0,1),cex=1.3) + dev.off() + + + + #====================== FIGURE 1x1 HEAT MAP OF LOADING OF PCS ON SSRS + # + jFigAdd=jFigAdd+1 + FigNumber <- NextFigNumber+jFigAdd # for naming this png + if (FigNumber<10){ + fileOut <- paste(outputDir,'Figure0', as.character(FigNumber),'-PCA2','.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure', as.character(FigNumber),'-PCA2','.png',sep="") + } + png(filename=fileOut, width = 960, height = 480) + par(mar=c(5,6,5,2),cex.main=1.4,cex.axis=1.5, cex.lab=1.3, cex.main=1.5) + + heatmap.2(LoadPC,Rowv = NA, Colv = NA,trace='none',key=TRUE, + dendrogram='none', + margins=c(5,8), + lhei=c(1.5,5),lwid=c(1,5), + keysize=1.0,key.title=NA,key.ylab=NA,key.xlab='Loading', + key.ytickfun = NULL,density.info="none", + main='PC Loadings on SSRs') + + dev.off() + rm(str1) + } else { + # mode np-PCA + namesX <- nmsU + } + + #========================= PULL CALIBRATION DATA + L <- yrU>=yrgo1 & yrU<=yrsp1 + U1 <- U[L,]; yrU1<- yrU[L] + L <- yrv>=yrgo1 & yrv<=yrsp1 + v1 <- v[L]; yrv1<- yrv[L] + ncalib <- length(v1) # length of MSR calibration period + # Status. U1 is matrix; yrU1, v1 and yrv are vector. + + + #========================= CORRELATION OF HYDRO SERIES WITH SSRs OR THEIR PCS; LAG-1 + # AUTOCORRELATIONS OF SAME + + #--- Check on desired threshold correlation + alphaRR <- c(0.10, 0.05, 0.01) # acceptable alpha levels (2 tailed) + Siggys <- c('90%','95%','99%') + alphaTemp <- 1-alphaRR/2 + ThreshsR <- qnorm(alphaTemp) + L <- alphaR == alphaRR + if (!any(L)){ + emssg <- 'Invalid setting for critical alpha for correlation screening; must be one of {0.10,0.05 ,0.01}' + ResTemp<-emssgUNH(emssg,outputDir) + stop(emssg) + } + ThreshSiggy <- ThreshsR[L] # this over sqrt(N-2) gives 2=tailed confidence interval + Siggy <- Siggys[L] + rm(L,alphaRR,Siggys,alphaTemp,ThreshsR) + rThresh <- ThreshSiggy/sqrt(length(v1)-2) # threshold level of correlation + + #--- Correlations + rv1U1 <- cor(v1,U1) + rCI = rThresh # rename for convenience; threshold correlation for confidence interval + + #--- Lag-1 autocorrelations + ResLag1 <- LagkAcc(v1,1) + r1v1 <- ResLag1$rk + ResLag1 <- LagkAcc(U1,1) + r1U1 <- ResLag1$rk + rm(ResLag1) + + + + #====================== FIGURE 1x1 BAR CHART OF R OF HYDRO SERIES WITH SSRs or THEIR PCS + + tit1 <- c(paste('Correlation with ',Siggy,' CI (blue) and autocorrelation (magenta),', + as.character(yrgo1),'-',as.character(yrsp1)), + paste('\n(magenta horizontal line is r(1) of ',HydroLabel,')',sep="")) + if (methMSR==3 | PCApredictors){ + xlab1 <- 'PC #' + legText <- c(paste('r of',HydroLabel,'with PCs'), + 'r(1) of PCs') + jFigAdd <- jFigAdd+1 + } else { + xlab1 <- 'SSR # (in order as in matrix of screened SSRs)' + legText <- c(paste('r of',HydroLabel,'with SSRs'), + 'r(1) of SSR') + jFigAdd <- 0 + } + + FigNumber <- NextFigNumber+jFigAdd # for naming this png + if (FigNumber<10){ + fileOut <- paste(outputDir,'Figure0', as.character(FigNumber),'-MSRcalibration1','.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure', as.character(FigNumber),'-MSRcalibration1','.png',sep="") + } + png(filename=fileOut, width = 960, height = 480) + par(mar=c(5,6,5,2),cex.main=1.0,cex.axis=1.5, cex.lab=1.3, cex.main=1.5) + h <- t(cbind(t(rv1U1),r1U1)) + + barplot(h,ylim=c(-1,1),beside=TRUE,main=tit1,xlab=xlab1,ylab='r', + width=c(1.0,0.5),names.arg=as.character(1:dim(U1)[2]), + col=c(cBlue1,cMagenta1)) + legend(x=dim(U1)[2],y=1,xjust=1,yjust=1,legend=legText,fill=c(cBlue1,cMagenta1), + cex=1.3) + abline(h=0,col='black') + abline(h=c(rCI, -rCI), col=cBlue1, lty=2, lwd=4) + abline(h=r1v1,col=cMagenta1,lty=1,lwd=2) + + dev.off() + # axis(1, at =(1:length(rv1U1)),labels = nmsU) + + #========== POSSIBLE REDUCTION OF POOL OF POTENTIAL PREDICTORS OR ANALOG SET OF PC'S + # + # Input arg f gives a fraction, which if multiplied times the number of observations in + # the calibration period of the MSR model, puts an upper limit on the allowable number + # of variables in the pool of potential predictors. + # + # The pool must be less than fN, where N is the length of the calibration period. How this + # constraint is applied depends on if the MSR is done using the SSRs or their PCs as + # predictors. If using the SSRs, the pool is reduced so that it includes only the + # m nmax) { + emssg <- paste('You instructed to retain more than',sprintf('%g',nmax),'PCs; too many!') + ResTemp<-emssgUNH(emssg,outputDir) + stop(emssg) + } else { + # Assign as pool the first nPCsKeep PCs of the SSRs + jU2toU1 <- 1:nPCsKeep # pointer to cols of U1 + U2 <- U1[,(1:nPCsKeep)] # pool of potential predictors + yrU2 <- yrU1; + namesU2 <- namesX[jU2toU1] + } + } else { + # Predictors could be SSRs or their PCs, and correlation with y to be used, if needed, + # to keep pool small. + # Correlate columns of U1 with y and compute absolute correlation for retaining predictors + # Threshold is two-tailed test, no adjustment for autcorrelation; input alphaR must be one of + # [0.10 0.05 0.01] + rThese <- cor(v1,U1) # vector of correlations of SSRs or PCs with predictand + if (methMSR==3){ + if (ScreenAnalogPCs){ + # Analog method; retain only the PCs with correlation significance greater than threshold + Lkeep <- abs(rThese)>rThresh + if (!any(Lkeep)){ + # ERROR MESSAGE + emssg <- paste('No PCs passed screening for correlation with',HydroLabel, + 'at alpha=',sprintf('%g',alphaR)) + ResTemp<-emssgUNH(emssg,outputDir) + stop(emssg) + } else { + U2 <- U1[,Lkeep]; yrU2 <- yrU1 + jU2toU1 <- which(Lkeep) # pointer of U2 back to U1, cols + namesU2 <- namesX[Lkeep] + } + } else { + # no screening of analog PCs + U2 <- U1; yrU2 <- yrU1; namesU2 <- namesX; jU2toU1 <- 1:dim(U1)[2] + } + } else { + # Not analog method; will screen to avoid too large a pool + if (dim(U1)[2]>nmax) { #if pool too large + # --- Correlation screening + rSort <- sort(abs(rThese),decreasing=TRUE,index.return=TRUE) + rCut <- rSort$x[nmax] # PCs or SSRs with smaller absolute r will be dropped + Lkeep <- abs(rThese)>=rCut + U2 <- U1[,Lkeep]; yrU2 <- yrU1 + jU2toU1 <- which(Lkeep) + namesU2 <- namesX[Lkeep] + } else { + # No problem with size of pool; use them all + U2 <- U1; yrU2 <- yrU1 # pool of potential predictors + jU2toU1 <- 1:dim(U1)[2] # pointer of U2 back to U1, cols + namesU2 <- namesX + } + } + } + + # In case U2 has just 1 column, make sure U2 is a matrix + U2 <- as.matrix(U2) + + + #================ EUCLIDEAN DISTANCE + # + # If methMSR==3, find instrumental-period first-k nearest neighbors in yrv1 for + # every year of to every year in U. Compute Euclidean distances for vectors of + # PC scores. Build 2-dim time series matrices of the years and of the "analog y" + # + # Also build time series of "nearest-observed" y and compute statistics of + # accuracy if such a series were used as the reconstruction + + + if (methMSR == 3){ + kNN <- 2 # Want kNN nearest neighbors from yrv1, v1 for every year of U + ResKNN <- KnnAnalog(U[,jU2toU1],yrU,v1,yrv1,kNN) + # Among outputs is ResKNN$Recon, with "reconstruction" in col 2 and the corresponding + # analog years in col 3. Col 4 tells if recon is nearest or 2nd nearest neighbor + # Also has "NearestObserved," which is a null reconstruction using as the + # reconstruction in any year of yrv1 the nearest v to the value of v in yrv1 + # + + #--- ASSESSMENT OF ACCURACY OF ANALOG AND "NEAREST-OBSERVED" RECONS + L <- ResKNN$Recon[,4] == 2 + # Analog predictions + Fits <- ResKNN$Recon[L,2] + yrFits <- yrv1 + # Nearest-observed predictions + FitsNO <- ResKNN$NearestObserved[,3] + yrFitsNO <- yrv1 + + #--- SOS terms-- Analog + Efits <- v1-Fits; # error, or obs minus recon + SSE <- sum(Efits*Efits) # sum of squares of errors + SSv1 <- sum((v1-mean(v1)) * (v1-mean(v1))) # sos of departures of v1 from its mean + REtemp <- 1-SSE/SSv1 + rtemp <- cor(v1,Fits) + + #--- SOS terms-- Nearest-observed + EfitsNO <- v1-FitsNO; # error, or obs minus nearest-observed + SSENO <- sum(EfitsNO*EfitsNO) # sum of squares of errors + REtempNO <- 1-SSENO/SSv1 + rtempNO <- cor(v1,FitsNO) + + #--- STORE + Analog <- list(Fits=Fits,yrFits=yrFits,Resids=Efits,Correl=rtemp,RE=REtemp, + DataKnn=ResKNN$DataAnalog,YearsKnn=ResKNN$YearsAnalog, + DistanceKnn=ResKNN$Distance,ReconNN12=ResKNN$Recon, + RMSE=sqrt(mean(SSE)), + FitsNO=FitsNO,yrFitsNO=yrFitsNO,ResidsNO=EfitsNO,CorrelNO=rtempNO,RENO=REtempNO, + RMSENO = sqrt(mean(SSENO))) + rm(rtemp,REtemp,SSv1,SSE,Efits,Fits,yrFits,L,ResKNN, + rtempNO,REtempNO,SSENO,EfitsNO,FitsNO) + } + + + if (methMSR != 3){ + #========================= STEPWISE REGRESSION + # + # To select forward stepwise from pool of potential predctors and do an initial + # fit of model + # + # Status. + # U2, yrU2: pool of potential predictors + # iU1: pointer (cols) of U2 back to U1 and to long matrix U + # v1, yrv1: predictand vector + ResMLR1a <- ForwStep3(U2,namesU2, v1,kstop,nNeg,nPos, incR2a) + inmodelU3 <- ResMLR1a$ColsInModel + npred <- length(inmodelU3) # number of predictors in MSR model + U3 <- U2[,inmodelU3]; yrU3 <-yrU2 + namesU3 <- namesU2[inmodelU3] # names of predictors in model + jU3toU1 <- jU2toU1[inmodelU3] # pointer (col) back to full U and to original calibration U1 + Fits <- ResMLR1a$Model$fitted.values # calib period predictions + ModelSummary <- summary(ResMLR1a$Model) + RMSEc <- ModelSummary$sigma + + #========================= RE-FIT REGRESSION WITH LM FUNCTION (for debugging only) + # + # Function lm gives comprehensive statistics. Can uncomment the three lines, and check that the + # statistics returned exactly match those in ResMLR1a + # M <- lm(v1~U3) # model object + # M1<-summary(M) + + + #========================= STORE CALIBRATION STATISTICS + + # Significance of overall F + # M1$fstatistic has F, dfnum, dfdenom in 1-3 + pF <-ResMLR1a$Fpvalue + + + OutputCal<-list('flag'=flagBail,'Msg'=flagMsg,'lmModel'=ResMLR1a$Model,'yearGoCal'=yrgo1,'yearSpCal'=yrsp1, + 'coefficients'=ResMLR1a$Coefficients,'Rsquared'=ResMLR1a$Rsquared,'F'=ResMLR1a$Foverall,'pF'=pF, + 'RsquaredAdj'=ResMLR1a$RsquaredAdj,'RMSEc'=RMSEc) + + } else { + # Analog method + } + + #====================== FIGURE CALIBRATION2 + # + + #--- Build some strings for use in plots + strCalPd <- paste(' Calibration period: ',sprintf('%d',yrgo1),'-',sprintf('%d',yrsp1), + ' (N=', sprintf('%d',length(yrv1)),' yr)',sep='') + + #--- Build Tit1 figure png filename + + if (methMSR==3){ + Fits <- Analog$Fits + strPart1 <- '\nNumber of: screened SSRs / PCs for analogs' + strPart2 <- paste('\nPCA on years ',as.character(yrU[1]),'-',as.character(yrU[length(yrU)]), + paste('\nAnalogs from years ',as.character(yrv1[1]),'-',as.character(yrv1[length(v1)]),sep=''),sep='') + txtCommon <- c('Common','common') + } else { + txtCommon <- c('Calibration','calbration') + if (PCApredictors){ + strPart1 <- '\n # screened PCs in pool / # PCs in final model' + strPart2 <- ' (see Table 8 for model coefficients)' + } else { + strPart1 <- '\n # screened SSRs in pool / # in final model' + strPart2 <- ' (see Table 6 for model coefficients)' + } + } + jFigAdd<-jFigAdd+1 + FigNumber <- NextFigNumber+jFigAdd # for naming this png + if (FigNumber<10){ + fileOut <- paste(outputDir,'Figure0', as.character(FigNumber),'-MSRcalibration2.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure', as.character(FigNumber),'-MSRcalibration2.png',sep="") + } + # Build figure + png(filename=fileOut, width = 960, height = 480) + layout.matrix <- matrix(c(1,2,3,3),nrow=2,byrow=TRUE) + layout(layout.matrix,heights=c(2,2),widths=c(1,2)) + + # Scatter + par(mar=c(4,5,2,3)) + r<-cor(Fits,v1) + strTit <- paste('Recon vs Obs ',HydroName,', r=',as.character(round(r,digits=2))) + plot(v1,Fits,ylab=paste('Recon',HydroLabel,HydroUnits), + xlab=paste('Obs',HydroLabel,HydroUnits),main=strTit) + abline(lm(Fits~v1),col="red") + + + # Stats table + par(mar=c(0,0,0,0)) + plot(1,1,xaxt="n",yaxt="n",bty="n",pch="",ylab="",xlab="", main="", sub="", + xlim=c(0,1),ylim=c(0,1)) + if (methMSR==3){ + strText <-paste(RecMethod,strPart1, + '\n ',sprintf('%g',dim(U1)[2]), + ' / ',sprintf('%g',dim(U2)[2]),strPart2,sep='') + text(x=0.05,y=0.95,'Model Statistics',adj=c(0,1),cex=1.5,font=2) + text(x=0.05,y=0.8,strText,adj=c(0,1),cex=1.2) + } else { + if (npred==1){ + U3 <- as.matrix(U3) # if happen to be only 1 predictor in final model, still want U3 as matrix + } + strText <-paste(RecMethod,strPart1, + '\n ',sprintf('%g',dim(U2)[2]), + ' / ',sprintf('%g',dim(U3)[2]),strPart2, + '\n',strCalPd, + '\n R-squared =',sprintf('%5.2f',ResMLR1a$Rsquared), + '\n F=',sprintf('%.5g',ResMLR1a$Foverall),'(p=',sprintf('%.4g',pF),')', + '\n RMSE=',sprintf('%g',RMSEc),HydroUnits2,' (equivalent to std error of the estimate)') + if (methMSR==3){ + text(x=0.05,y=0.95,'Analog Model Statistics',adj=c(0,1),cex=1.5,font=2) + } else { + text(x=0.05,y=0.95,'Calibration Statistics',adj=c(0,1),cex=1.5,font=2) + } + text(x=0.05,y=0.8,strText,adj=c(0,1),cex=1.4) + } + + # Time plots, obs and rec + zx <- c(yrgo1,yrsp1) + zy <- c(mean(v1),mean(v1)) + + ylims <- c(min(v1,Fits),max(v1,Fits)) + ylimsInc <- 0.05 * diff(ylims) + ylims <- c(ylims[1]-ylimsInc,ylims[2]+ylimsInc) + rm (ylimsInc) + + par(mar=c(4,5,3,2),cex.axis=1.5, cex.lab=1.5, cex.main=1.5) + plot(yrv1,v1,type="b",pch=1,col="blue",xlim=c(yrgo1,yrsp1),ylim=ylims, + ylab=paste(HydroLabel,HydroUnits),xlab="Year", + main=paste(txtCommon[1],'Period Observed (blue) and Reconstructed (red)',HydroName)) + lines(yrv1,Fits,type="b",pch=2,col="red") + lines(zx,zy) + h<-par("usr"); yoffset<- (h[4]-h[3])/100; ytop <- h[4]-yoffset + # legend(yrgo1+1,ytop,legend=c("Obs", "Recon"), + # col=c("blue", "red"), lty=1, cex=1.2) + + dev.off() + rm (strPart1,strPart2,strText,strTit,r,h) + + + #====================== FIGURE: CALIBRATION3 + # + # CW from LL: histogram of yhat; hist of obs y; acf of obs y, acf of yhat + + #--- same xlims for all histograms + xlo = min(c(min(v1),min(Fits))) + xhi = max(c(max(v1),max(Fits))) + xinc <- 0.05*(xhi-xlo) + xlims <- c(xlo-xinc,xhi+xinc) + rm(xlo,xhi,xinc) + #xlims <-c((c(min(v1),min(Fits))), (c(max(v1),max(Fits)))) + + + #--- Build figure png filename + jFigAdd <- jFigAdd+1 + FigNumber <- NextFigNumber+jFigAdd # for naming this png + if (FigNumber<10){ + fileOut <- paste(outputDir,'Figure0', as.character(FigNumber),'-MSRcalibration3.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure', as.character(FigNumber),'-MSRcalibration3.png',sep="") + } + # Build figure + png(filename=fileOut, width = 960, height = 480) + # Create the layout + nf <- layout( matrix(c(1,2,3,4), ncol=2) ) + + nbin <- floor(5*log10(length(v1))) # Panofsky rule of thumb for number of bins + xtweak1 <- 0.00001* (max(v1)-min(v1)); + xtweak2 <- 0.00001* (max(Fits)-min(Fits)); + brks1 = seq(min(v1)-xtweak1,max(v1)+xtweak1,length.out=(nbin+1)) + brks2 = seq(min(Fits)-xtweak2,max(Fits)+xtweak2,length.out=(nbin+1)) + xlab1 <- paste(HydroLabel,HydroUnits) + MaxLag <- floor(length(v1)/4) + + par(mar=c(5,6,2,2),cex.axis=1.5, cex.lab=1.5, cex.main=1.5) + Tit1 <- paste('Histogram, Observed',HydroLabel,'(N=',sprintf('%d',length(v1)),'yr)') + hist(v1,main=Tit1,breaks=brks1,xlim=xlims,xlab=xlab1) + + par(mar=c(5,6,2,2)) + Tit1 <- paste('Histogram, Reconstructed',HydroLabel,'(N=',as.character(length(v1)),'yr)') + hist(Fits,main=Tit1,breaks=brks2,xlim=xlims,xlab=xlab1) + + par(mar=c(5,5,4,2)) + Tit1 <- paste('ACF, Observed',HydroLabel,',with 95% CI') + acf(v1,lag.max=MaxLag,type='correlation',main=Tit1) + + par(mar=c(5,5,4,2)) + Tit1 <- paste('ACF, Reconstructed',HydroLabel,', with 95% CI') + acf(Fits,lag.max=MaxLag,type='correlation',main=Tit1) + dev.off() + + + #========================= ANALYSIS OF RESIDUALS (local 3,4,5) + # + # Will need the regression residuasl. First figure (1x2) will be histogram and + # scatter of residuals on predicted values. Second figure (1x1) will be time plot of + # the residuals with a fitted (non-parametric fit) trend line and annotated result + # of Mann-Kendall trend test. The significance will be adjusted as needed for autocorrelation + # of the residuals over and above that in a linear trend. The third figure (1x1) will be + # the acf of residuals, with annotated DW test results + + + #============= FIGURE: ANALYSI OF RESIDUALS: HISTORGRAM & CONSTANCY OF VARIANCE + # + # 1st of 3 analysis of residuals plots + + if (methMSR==3){ + Resids <- Analog$Resids + } else { + Resids <- ResMLR1a$Model$residuals + } + + # Lilliefors test of normality of residuals + hLillie <- lillie.test(Resids); + if (methMSR==3){ + Tit1 <- paste('Residuals, E, of analog reconstruction of',HydroName, + '\n (p=',sprintf('%.2g',hLillie$p.value),'for H0 that E normal, from Lilliefors Test)') + } else { + Tit1 <- paste('Residuals, E, of regression of',HydroName,'on tree rings', + '\n (p=',sprintf('%.2g',hLillie$p.value),'for H0 that E normal, from Lilliefors Test)') + } + + + # Breusch-Pagan test for heterogeneity of regression residuals + if (methMSR==3){ + BP <-NA + Tit2 <- paste('Scatter of Residuals on Fitted Values','\n') + } else { + BP <- ncvTest(ResMLR1a$Model) + Tit2 <- paste('Scatter of Residuals on Fitted Values', + '\n (p=',sprintf('%.2g',BP$p),' for H0 that E homoscedastic)', + '\n(from Breusch-Pagan Test)') + } + + # Buld filename for plot + jFigAdd <- jFigAdd+1 + FigNumber <- NextFigNumber+jFigAdd # for naming this png + if (FigNumber<10){ + fileOut <- paste(outputDir,'Figure0', as.character(FigNumber),'-AnalysisResiduals1.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure', as.character(FigNumber),'-AnalysisResiduals1.png',sep="") + } + + # Figure size and margins + png(filename=fileOut, width = 960, height = 480) + layout.matrix <- matrix(c(1,2), nrow = 1, ncol = 2) + layout(layout.matrix,heights=2,widths=c(1,1)) + + # Left plot + + par(mar = c(5.1, 4.5, 5.1, 2.1),cex.axis=1.1, cex.lab=1.5, cex.main=1.3) + hist(Resids,xlab=paste('Residual',HydroUnits),ylab='Frequency',main=Tit1) + + # # right plot + par(mar = c(5.1, 4.1, 6.1, 2.1),cex.axis=1.1, cex.lab=1.5, cex.main=1.3) + plot(Fits,Resids,xlab=paste('Predicted',HydroUnits), + ylab=paste('Residual',HydroUnits), + main=Tit2) + abline(h=0,lty=2,col='#808080') # dash gray + dev.off() + + + #--- TIME PLOT OF REGRESSION RESIDUALS, WITH MANN-KENDAL TREND TEST (1X1) + + if (methMSR==3){ + RegWord <- 'Model' + } else { + RegWord <- 'Regression' + } + + jFigAdd <- jFigAdd+1 + FigNumber <- NextFigNumber +jFigAdd + + # Prepare input for mannken1 + X <- cbind(yrv1,Resids) # matrix with year and regression or analog residuals + + kopt<- c(2,1) # want plot; want adjustment of significance of Mann-Kendall statistic + # for autocorrelation if warranted + kplot <-2 # for TRISH, the time plot of residuals, with annotated MK test results + # and non-parametric-fit straight line fit to trend + ylabTemp1 <- paste('Residual',HydroUnits) + ylabTemp2 <- paste('Detrended Residual',HydroUnits) + textPlot <- c('Regression Residuals with Nonparametric-Fit Trend Line,','Year',ylabTemp1, + ylabTemp2) + Din <- list(X=X,kopt=kopt,kplot=kplot,NextFigNumber=FigNumber,textPlot=textPlot,outputDir=outputDir) + + # mannken1 to get statistics and plot + ResMK <- mannken1(Din) + rm(Din) + + + #--- ACF OF REGRESSION RESIDUALS, INCLUDING 95% Ci + + jFigAdd <- jFigAdd+1 + FigNumber <- NextFigNumber +jFigAdd + + # acf and its 95% CI + lagsPlot <- floor(min(ncalib/4,20)) + acfMy <- acf(Resids, lag.max=lagsPlot, type = "correlation", + plot = FALSE) + k <- acfMy$lag # lags + w <- acfMy$acf # acf + + # DW statistic of the regression residuals + if (methMSR==3){ + strDW <- 'Durbin-Watson not computed (inappropriate for analog method)' + } else { + DW <- durbinWatsonTest(ResMLR1a$Model) + strDW <- paste('p=',sprintf('%g',DW$p), + ': Durbin-Watson test (2-sided) of H0 that population lag-1 autocorrelation is zero', + sep='') + } + # Text for plot + Tit1 <- paste('ACF of Residuals with 95% CI (N=',sprintf('%g',ncalib),' yr)') + textPlot <- c(Tit1,'Lag(yr)','r',strDW,'-AnalysisResiduals3') + + # Store inputs required by stemACF in a list (see opening comments there) + Din <- list(x=k,y=w,nsize=ncalib,kAlpha=1,FigNumber=FigNumber, + outputDir=outputDir,linecol1='#0022CC',linecol2='#696969', + linecol3='#E60000',textPlot=textPlot) + ResNull <- stemACF(Din) + + #========================= VALIDATE AND STORE STATISTICS + + #ResCV <- CrossValid2(u1, v1, nNeg,nPos) # cross-validation + + # Split-sample validation -- not if analog method + if (methMSR==3){ + # Analog method: no split-sample validation. + # For analog method, the model residuals can be considered validation residuals, because + # no model has been fit and no tuning to improve estimates for the overlap period + # wit climate. The stored Analog$RMSE can therefore be used in place of RMSEcv. + # For analog method there is also no "RE" statistic. But a pseudo-RE is computed as + # 1-SSE1/SSE2, where SSE is the sum-of-squares of residuals for the overlap period + # with y, and SSE2 is the sum-of-squares of departures of observed y from its mean. + # This RE is therefore a skill statistic comparing errors for the reconstruction with errors + # of a null reconstruction consisting of the observed mean for each year. + OutputVal<-list('RE'=Analog$RE,'RMSE'=Analog$RMSE,'Correlation'=Analog$Correl) + } else { + + iAstop <- ceiling(length(v1)/2) # end row index in v1 of first half of data, assumed longer than + # longer of the two halves if length of v1 odd + iBgo <- iAstop+1 # start row of second half + iA <- 1:iAstop # row indices of first half of full calib period + iB <- iBgo:length(v1) # ... of second half + + #--- Calibrate on early, validate on late, then reverse + ical<-iA; ival<-iB + i1 <- 1:dim(U3)[2]; # all columns of U3 are the predictors in the final model + ResSS1=ssValid(v1,U3,ical,ival,i1); + REa1<-ResSS1$RE # RE for calib on early, valid on late + ical<-iB; ival<-iA + ResSS2=ssValid(v1,U3,ical,ival,i1); + REb1<-ResSS1$RE # RE for calib on late, valid on early + OutputVal<-list('mLeaveOutCV'=ResMLR1a$CrossValidStorage$LeftOut, + 'REcv'=ResMLR1a$CrossValidStorage$REcv,'RMSEcv'=ResMLR1a$CrossValidStorage$RMSEcv, + 'REcalEarlyValLate'=REa1,'REcalLateValEarly'=REb1) + } + + + #====================== FIGURE Validation: time plots of obs y, recon, y, cv predictions of y; with observed mean line + # + # Completely different figures is made for analog vs other methods (methMSR) + # + #--- Build figure png filename + jFigAdd <- jFigAdd+1 + FigNumber <- NextFigNumber+jFigAdd # for naming this png + if (FigNumber<10){ + fileOut <- paste(outputDir,'Figure0', as.character(FigNumber),'-Validation1.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure', as.character(FigNumber),'-Validation1.png',sep="") + } + + ylims <- c(min(v,Fits),max(v1,Fits)) + ylims <- c(ylims[1]-0.05*diff(ylims),ylims[2]+0.05*diff(ylims)) + if (methMSR==3){ + # Recall: v1, yrv1 is observed predictand; Fits, yrFits are analog-reconstructed + # predictand, which is 2nd nearest neighbor; + # Build figure, time plot at left, window at right + + # Figure size and margins + png(filename=fileOut, width = 960, height = 480) + layout.matrix <- matrix(c(1,2), nrow = 1, ncol = 2) + layout(layout.matrix,heights=2,widths=c(4,1)) + + par(mar=c(4,4,5,1),cex.main=1.4) + plot(yrv1,v1,ylim=ylims,type="b",pch=1,col="blue",xlim=c(yrgo1,yrsp1), + ylab=paste(HydroLabel,HydroUnits),xlab="Year", + main=paste('Observed (blue) and Analog-Predicted (red)',HydroName, + '\n(Years=',sprintf('%d',yrgo1),'-',sprintf('%d',yrsp1), + '; black line at observed mean; green * at nearest observed)')) + lines(yrv1,Fits,type="b",pch=2,col="red") + lines(yrv1,Analog$FitsNO,type="p",pch=8,col=cGreen) + abline(h=mean(v1)) + + #--- Stats window + par(mar = c(0,0,0,0)) + xlims <- c(0,1); ylims <- c(0,1) + plot(0,type='n',axes=FALSE,ann=FALSE,xlim=xlims,ylim=ylims) + + # Analog + strText <-paste('\n Analog', + '\n \n RMSE=',sprintf('%g',Analog$RMSE),HydroUnits2, + '\n RE=',sprintf('%.2g',Analog$RE), + '\n r=',sprintf('%.2g',Analog$Correl)) + text(x=0.01,y=0.95,'Validation statistics',adj=c(0,1),cex=1.3,font=2) + text(x=0.01,y=0.9,strText,adj=c(0,1),cex=1.2) + + # Nearest Observed + strText <-paste('\n Best Possible','\n (Nearest Observed)', + '\n\n RMSE=',sprintf('%g',Analog$RMSENO),HydroUnits2, + '\n RE=',sprintf('%.4g',Analog$RENO), + '\n r=',sprintf('%.4g',Analog$CorrelNO)) + text(x=0.01,y=0.65,strText,adj=c(0,1),cex=1.2) + dev.off() + } else { + # Build figure + png(filename=fileOut, width = 960, height = 480) + par(mar=c(4,4,5,1),cex.main=1.4) + plot(yrv1,v1,ylim=ylims,type="b",pch=1,col="blue",xlim=c(yrgo1,yrsp1), + ylab=paste(HydroLabel,HydroUnits),xlab="Year", + main=paste('Time Plots of Observed, Reconstructed, and Cross-Validation-Predicted',HydroName,'(',sprintf('%d',yrgo1),'-',sprintf('%d',yrsp1),')', + '\n(black line at observed mean)')) + lines(yrv1,Fits,type="b",pch=2,col="red") + lines(yrv1,ResMLR1a$CrossValidStorage$CVpredictions,type="b",pch=17,col="#990099") + lines(zx,zy) + h<-par("usr"); yoffset<- (h[4]-h[3])/100; ytop <- h[4]-yoffset + legend(yrgo1+1,ytop,legend=c("Obs", "Recon","CVpred"), + col=c("blue", "red","#990099"),pch=c(1,2,17),lty=1, cex=1.2) + dev.off() + } + + #====================== FIGURE VALIDATION2 + # + # Does not apply to analog method + # Text strings for cross-validation + strAnPd <- strCalPd # built for earlier plot: gives calib period and length + if (methMSR!=3){ + jFigAdd <- jFigAdd+1 + FigNumber <- NextFigNumber+jFigAdd # for naming this png + if (FigNumber<10){ + fileOut <- paste(outputDir,'Figure0', as.character(FigNumber),'-Validation2.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure', as.character(FigNumber),'-Validation2.png',sep="") + } + # Lilliefors test of normality of CV residuals + hLillie <- lillie.test(ResMLR1a$CrossValidStorage$CVresiduals); + Tit1 <- paste('Cross-Validation Residuals', + '\n(p=',sprintf('%.2g',hLillie$p.value),', H0: normally distributed', + ' [Lilliefors Test])',sep='') + + # Text strings for split-sample validation + yrtemp <- yrv1[iA] # year vector, early split + yrgoA <- yrtemp[1]; yrspA <- yrtemp[length(yrtemp)] + yrtemp <- yrv1[iB] # year vector, late split + yrgoB <- yrtemp[1]; yrspB <- yrtemp[length(yrtemp)] + rm(yrtemp) + strSplitA <- paste(' A: ',sprintf('%d',yrgoA),'-',sprintf('%d',yrspA), + ' (N=', sprintf('%d',length(iA)),' yr)',sep='') + strSplitB <- paste(' B: ',sprintf('%d',yrgoB),'-',sprintf('%d',yrspB), + ' (N=', sprintf('%d',length(iB)),' yr)',sep='') + + + # Figure size and margins + png(filename=fileOut, width = 960, height = 480) + layout.matrix <- matrix(c(1,2), nrow = 1, ncol = 2) + layout(layout.matrix,heights=2,widths=c(1,1)) + strText <-paste('\nCross-validation (cv) method: leave-',as.character(ResMLR1a$CrossValidStorage$LeftOut),'out', + '\n',strAnPd, + '\n RMSEcv=',sprintf('%g',ResMLR1a$CrossValidStorage$RMSEcv),HydroUnits2, + '\n REcv=',sprintf('%.2g',ResMLR1a$CrossValidStorage$REcv), + '\n\nSplit-sample validation', + '\n',strSplitA, + '\n',strSplitB, + '\n RE{A}=',sprintf('%.2g',ResSS1$RE),' (calibrated on A, validated on B)', + '\n RE{B}=',sprintf('%.2g',ResSS2$RE),' (calibrated on B, validated on A)') + + # Left plot histogram + par(mar = c(5.1, 4.5, 5.1, 2.1),cex.axis=1.1, cex.lab=1.5, cex.main=1.3) + hist(ResMLR1a$CrossValidStorage$CVresiduals,xlab=paste('Residual',HydroUnits),ylab='Frequency', + main=Tit1) + + # right plot, stats + par(mar = c(0,0,0,0)) + xlims <- c(0,1); ylims <- c(0,1) + plot(0,type='n',axes=FALSE,ann=FALSE,xlim=xlims,ylim=ylims) + text(x=0.05,y=0.95,'Validation statistics',adj=c(0,1),cex=1.5,font=2) + text(x=0.05,y=0.8,strText,adj=c(0,1),cex=1.2) + #plot(1,1,pch=1,xlim=xlims,ylim=ylims) + dev.off() + } + + #========================= RECONSTRUCTION WITH 50% CI + if (methMSR ==3){ + Xr <- as.matrix(U[,jU2toU1]) # matrix,long-term scores of PCs used to find analogs + L<-complete.cases(Xr) + Xr <- as.matrix(Xr[L,]) ; yrXr <- as.matrix(yrU[L,]) + mXr <- dim(Xr)[1] + yrgo3 <- yrXr[1,1]; yrsp3 <- yrXr[mXr,1] # start and end year of recon + yh <- Analog$ReconNN12[,1:2] # year and reconstructed y, full recon + + # Delta y for 50% CI + xStdNorm75 <-qnorm(0.75, mean = 0, sd = 1, lower.tail = TRUE, log.p = FALSE) + deltaRec50 <- xStdNorm75 * Analog$RMSE + yhLo <- yh[,2]-deltaRec50; yhHi <-yh[,2]+deltaRec50 + yh <- cbind(yh,yhLo,yhHi) # matrix with year, recon, lower 50 upper 50 + } else { + #Xr <- as.matrix(U[,inmodelU3]) # matrix, long-term predictors; INCORRECT + Xr <- as.matrix(U[,jU3toU1]) # matrix, long-term predictors + L<-complete.cases(Xr) + yrXr <- as.matrix(yrU[L,]) + # Add ones column and reconstruct + mXr <- dim(Xr)[1] + Xones<-matrix(1,nrow=mXr,ncol=1) + Xr <- cbind(Xones,Xr) + yrgo3 <- yrXr[1,1]; yrsp3 <- yrXr[mXr,1] # start and end year of recon + yh <- Xr %*% ResMLR1a$Coefficients # reconstruction as 1-col matrix + yh <- cbind(yrXr,yh) # year and recon y, as generated from the reg coefficients + + # Delta y for 50% CI + xStdNorm75 <-qnorm(0.75, mean = 0, sd = 1, lower.tail = TRUE, log.p = FALSE) + deltaRec50 <- xStdNorm75 * ResMLR1a$CrossValidStorage$RMSEcv + yhLo <- yh[,2]-deltaRec50; yhHi <-yh[,2]+deltaRec50 + yh <- cbind(yh,yhLo,yhHi) # matrix with year, recon, lower 50 upper 50 + } + + # Truncate reconstruction matrix yh to end with yrEnd, which is the last year of the + # quantile-extended matrix of SSRs. Beware that some of the most recent years of + # the reconstruction may be based on extended SSRs + Ltemp <- yh[,1] <= yrEnd # marks rows of yh to be retained + yh <- yh [Ltemp,] # truncate tsm yh + rm(Ltemp) + + + # Quality control check that "fitted values" from calibration period match + # the reconstruction for that period arrived at by applying regression coefficients to + # selected columns of predictor matrix. This check not applicable for analog method. + if (methMSR!=3){ + yfit1<-ResMLR1a$Model$fitted.values # from the regression model + L<- yh[,1]>=yrgo1 & yh[,1]<=yrsp1 + yfit2 <- yh[L,2] + dtemp = abs(yfit2 - yfit1) + bigTemp <- max(c(max(abs(yfit1)),max(abs(yfit1)))); # largest absolute value of recon + # during calib period, by either way of generating (regression output of manual application + # of coefficients to columns (correct, presumabley) of predictor matrix) + L= dtemp>1E-9 *bigTemp # maximum difference in the two versions of calib-period recon + # different by more than 1 billionth the largest value? + + if (any(L)){ + emmsg <- paste('ResMLR1a$Model$fitted.values for at least one year of calibration', + 'period differ from reconstruction stored in yh by more than 1E-8 times largest absolute', + 'reconstructed value in either of those series -- error from RecMLR1.R') + ResTemp<-emssgUNH(emssg,outputDir) + stop(emssg) + } +} else { + # no check for analog method +} + + #====================== FIGURE (local 8): 1x1 TSP OF FULL RECON WITH 50% CI + + # time series for plot and CI + y <- yh[,2]; yry <- yh[,1] # for time series + + # Compute shaded polygon x and y + Xtemp <- yh[,-2] # matrix with year as col 1, lower CI as col 2, upper CI as col 2 + ResTemp <- xyCI(Xtemp) + xP <- ResTemp$x; yP <- ResTemp$y + + # Limits for plot + yLo <- min(yh[,2:4]) + yHi <- max(yh[,2:4]) + ynudge <- 0.02 * (yHi-yLo) + ylims = c(yLo-ynudge, yHi+ynudge) + xlims = c(yrXr[1]-1,yrEnd+1) + + # Strings for plot + strRecYrs <- paste(sprintf('%d',yrXr[1]),'-',sprintf('%d',yrEnd),sep='') + Tit1 <- paste('Reconstructed ',HydroName,', ',strRecYrs, + '\n(50% CI shaded; dashed line at reconstructed mean)',sep='') + ylab1 <- paste(HydroLabel,HydroUnits) + + #--- Build figure filename + jFigAdd <- jFigAdd+1 + FigNumber <- NextFigNumber+jFigAdd # for naming this png + if (FigNumber<10){ + fileOut <- paste(outputDir,'Figure0', as.character(FigNumber),'-Reconstruction1.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure', as.character(FigNumber),'-Reconstruction1.png',sep="") + } + + # Build figure + png(filename=fileOut, width = 960, height = 480) + par(mar=c(5,5,5,1),cex.main=1.4,cex.axis=1.2,cex.lab=1.2) + if (length(y)>minLength1){ + plot(yry,y,type="l",col="blue",xlim=xlims,ylim=ylims, + ylab=ylab1,xlab='Year',main=Tit1) + } else { + plot(yry,y,type="b",pch=1,col="blue",xlim=xlims,ylim=ylims, + ylab=ylab1,xlab='Year',main=Tit1) + } + abline(h=mean(y),lty=2,col='#808080') # dash gray + adjustcolor("red",alpha.f=0.5) + #polygon(yryP,yP,col='#FFEE99') # flavescent + polygon(xP,yP, col=rgb(1.00,0,0,0.1),border=NA) # mustard + dev.off() + + + + #====================== FIGURE: Reconstruction analysis : 2x2. + # + # At left, top and bottom are ACFs of recon for calib years and earlier + # At right is single frame with box plots or recon for same + + + #--- Pull recon for calib perod and for earlier + # w1, w2 will the reconsturction for those period + # Already have y, yry as full length recon + L <- yry >= yrgo1; # calib pd + w1 <-y[L]; yrw1<- yry[L] + L <- yry < yrgo1 + w2 <- y[L]; yrw2 <-yry[L] + + #---Make some strings for use in plots + strPd1<- paste(sprintf('%d',yrgo1),'-',sprintf('%d',yrsp1), + ' (N=', sprintf('%d',length(w1)),' yr)',sep='') + strPd2<- paste(sprintf('%d',yrgo3),'-',sprintf('%d',yrgo1-1), + ' (N=', sprintf('%d',length(w2)),' yr)',sep='') + strAnnote1 <- paste('A: ',strPd1) + strAnnote2 <- paste('B: ',strPd2) + + Tit1 <-'ACF of Reconstruction with 95% CI, Calibration Period' + Tit2 <- 'ACF of Reconstruction with 95% CI, Earlier Years' + Tit3 <- paste('Distribution of Reconstructed',HydroLabel) + + #--- Build figure filename + jFigAdd <- jFigAdd+1 + FigNumber <- NextFigNumber+jFigAdd # for naming this png + if (FigNumber<10){ + fileOut <- paste(outputDir,'Figure0', as.character(FigNumber),'-Reconstruction2.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure', as.character(FigNumber),'-Reconstruction2.png',sep="") + } + + + # Figure size and margins + png(filename=fileOut, width = 960, height = 480) + layout.matrix <- matrix(c(1,2,3,3), nrow = 2,byrow=FALSE) + #layout(layout.matrix,heights=2,widths=c(1,1)) + layout(layout.matrix)#,heights=2,widths=c(1,1)) + par(mar=c(5,5,5,1),cex.main=1.4,cex.axis=1.2,cex.lab=1.2) + + #--- Upper left, acf of recon for calib pd + + MaxLag <- floor(length(w1)/4) + MaxLag <- min(c(MaxLag),20) + + par(mar=c(5,5,4,2)) + acf(w1,lag.max=MaxLag,ylim=c(-1,1),type='correlation',main=Tit1) + text(MaxLag,1,strAnnote1,adj=c(1,1),cex=1.5) + + #---Lower left, acf of recon for years before start of calib pd + + MaxLag <- floor(length(w2)/4) + MaxLag <- min(c(MaxLag),20) + + par(mar=c(5,5,4,2)) + acf(w2,lag.max=MaxLag,ylim=c(-1,1),type='correlation',main=Tit2) + text(MaxLag,1,strAnnote2,adj=c(1,1),cex=1.5) + + + #---Right -- side by side box plots of recon for calib period and prior + + par(mar=c(5,8,4,1),cex.lab=1.3) + namesBP<-c('Period A','Period B') + boxplot(w1,w2,notch=FALSE,ylab=xlab1, + main=Tit3,names=namesBP) + dev.off() + + + #=== TABLE: CALIBRATION1 + + #--- Header + if (PCApredictors | methMSR==3){ + TableTitle <- "Table5-Calibration1" + } else { + TableTitle <- "Table3-Calibration1" + } + if (methMSR==3){ + TitleAdd <- 'Statistics of analog MSR model' + } else { + TitleAdd <- 'Calibration statistics of MSR model' + } + SSRdef <- ' (SSR: "single-site reconstruction")' + textH<- c(TableTitle,TitleAdd, + paste("Predictand:",HydroName,"for",HydroSeason), + RecMethod,SSRdef) + # --- Body (this includes the variable labels that go in first column) + if (methMSR==3){ + PCsUsed <- namesU2[1] + if (length(PCsUsed)>1){ + for (n in 2:length(namesU2)){ + PCsUsed <- paste(PCsUsed,namesU2[n]) + } + } else { + } + textB <-c("YearGo","YearStop","Npool","alphaR","Npredictors","RSME","RE","r") + TfmtB <- '%-11s\t' # format for name of variable; size for longest + # debug DfmtsB <- c('%-4d\n','%-4d\n','%-3d\n','%-6.2f\n','%-3d\n','%-8.3g\n','%-6.2f\n','%-6.2f\n') + DfmtsB <- c('%-4.0f\n','%-4.0f\n','%-3.0f\n','%-6.2f\n','%-3.0f\n','%-8.3g\n','%-6.2f\n','%-6.2f\n') + dataB <- c(yrgo1,yrsp1,dim(U1)[2],alphaR,dim(U2)[2],Analog$RMSE, + Analog$RE,Analog$Correl) + textT <- c(paste('Units of RMSE: ',HydroUnits2), + paste('PCs used for analogs: ',PCsUsed), + strTailPart1) + } else { + textB <-c("YearGo","YearStop","Npool","Npredictors","R2","F","pF","R2adj","RMSEc") + TfmtB <- '%-10s\t' # format for name of variable; size for longest + DfmtsB <- c('%-4.0f\n','%-4.0f\n','%-3.0f\n','%-3.0f\n','%-6.2f\n','%-8.3g\n','%-8.3g\n','%-6.2f\n','%-10g\n') + dataB <- c(yrgo1,yrsp1,dim(U2)[2],npred,OutputCal$Rsquared,OutputCal$F,OutputCal$pF, + OutputCal$RsquaredAdj,OutputCal$RMSEc) + #---Tail + textT <- c(paste('Units of RMSEc: ',HydroUnits2),strTailPart1) + } + D1 <- list(textH=textH,textB=textB,TfmtB=TfmtB,dataB=dataB,DfmtsB=DfmtsB, + textT=textT,outDir =outputDir) + + #---Function call for table + + ResTemp <- Table1Column(D1) + rm(D1,textT,dataB,DfmtsB,TfmtB,textB,textH,TableTitle) + + + + #=== TABLE AnalysisOfResiduals + + #--- Header + if (PCApredictors | methMSR==3){ + TableTitle <- "Table6-AnalysisResiduals1" + } else { + TableTitle <- "Table4-AnalysisResiduals1" + } + + if (methMSR==3){ + TitleAdd <- 'Normality and trend' + } else { + TitleAdd <- 'Normality, autocorrelation, trend, heteroskedasticity' + } + textH<- c(TableTitle,TitleAdd) + + if (methMSR==3){ + # --- Body + textB <-c("YearGo","YearStop","pNormal","TrendSlope","pTrend") + TfmtB <- '%-10s\t' # format for name of variable; size for longest + DfmtsB <- c('%-4.0f\n','%-4.0f\n','%-8.3g\n','%-8.5g\n','%-8.3g\n') + dataB <- c(yrgo1,yrsp1,hLillie$p.value,ResMK$b,ResMK$pvalue) + #---Tail + textT <- c('Tests applied include: Lilliefors for trend and Mann-Kendall, for trend', + paste('Units of TrendSlope: ',HydroUnits2,' per year',sep=""), + strTailPart1) + } else { + #I SCREWED UP HERE AND DELETED CODE + # --- Body + textB <-c("YearGo","YearStop","pNormal","DW","pDW","TrendSlope","pTrend","BP","dfBP","pBP") + TfmtB <- '%-10s\t' # format for name of variable; size for longest + DfmtsB <- c('%-4.0f\n','%-4.0f\n','%-8.3g\n','%-8.4g\n','%-8.5g\n','%-8.5g\n','%-8.3g\n', + '%-8.3g\n','%-8.5g\n','%-8.3g\n') + dataB <- c(yrgo1,yrsp1,hLillie$p.value,DW$dw,DW$p,ResMK$b,ResMK$pvalue,BP$ChiSquare,BP$Df,BP$p) + #---Tail + textT <- c('Tests applied include: Lilliefors for trend; Durbin-Watson for autocorrelation, Mann-Kendall for trend', + '\n and Breusch-Pagan for constancy of variance\n', + paste('Units of TrendSlope: ',HydroUnits2,' per year',sep=""), + strTailPart1) + + } + D1 <- list(textH=textH,textB=textB,TfmtB=TfmtB,dataB=dataB,DfmtsB=DfmtsB, + textT=textT,outDir =outputDir) + + #---Function call for table + ResTemp <- Table1Column(D1) + rm(D1,textT,dataB,DfmtsB,TfmtB,textB,TableTitle,textH) + + + + #=== TABLE Validation1 + + if (methMSR==3){ + # Table not applicable + } else { + + #--- Header + if (PCApredictors){ + TableTitle <- "Table7-Validation1" + } else { + TableTitle <- "Table5-Validation1" + } + + TitleAdd <- 'Cross-validation and split-sample validation' + textH<- c(TableTitle,TitleAdd) + + # --- Body + textB <-c("NleaveOut","RMSEcv","REcv","YearGoA","YearStopA","YearGoB","YearStopB", + "REsplitA","REsplitB") + TfmtB <- '%-9s\t' # format for name of variable; size for longest + DfmtsB <- c('%-3.0f\n','%-8.5g\n','%-5.2f\n','%-4.0f\n','%-4.0f\n', + '%-4.0f\n','%-4.0f\n','%-5.2f\n','%-5.2f\n') + dataB <- c(ResMLR1a$CrossValidStorage$LeftOut,ResMLR1a$CrossValidStorage$RMSEcv, + ResMLR1a$CrossValidStorage$REcv,yrgoA,yrspA,yrgoB,yrspB,ResSS1$RE,ResSS2$RE) + + #---Tail + + textT <- c('"NleaveOut" is number of observatations left out in cross-validation (cv).', + 'RMSE and RE refer to root-mean-square error and reduction-of-error.', + 'Start and end years are listed for split-sample early (A) and late (B) parts.', + paste('Units of RMSEcv: ',HydroUnits2,sep=""), + strTailPart1) + + D1 <- list(textH=textH,textB=textB,TfmtB=TfmtB,dataB=dataB,DfmtsB=DfmtsB, + textT=textT,outDir =outputDir) + + #---Function call for table + ResTemp <- Table1Column(D1) + rm(D1,textT,dataB,DfmtsB,TfmtB,textB,TableTitle,textH,ResTemp) + } + + + + #=== TABLE MSR coefficients + + if (methMSR==3){ + # table not applicable for analog method + } else { + #--- Title + if (PCApredictors){ + TableTitle <- "Table8-CoefficientsMSR" + } else { + TableTitle <- "Table6-CoefficientsMSR" + } + + TitleAdd <- 'Coefficients of MSR regression model' + textH<- c(TableTitle,TitleAdd) + + # --- Body + + textB <- names(ResMLR1a$Coefficients) # vector of strings with names of predictors + # if only one predictors names(ResMLR1a$Coefficients) from lm does not list the name + # of the predictor; first entry is "(Intercept)" and second is "" + if (npred==1){ + textB[2] <- namesU3[1] + } + TfmtB <- '%-12s\t' # format for name of variable; size for longest + DfmtsB <- rep('%-12.8g\n',npred+1) + dataB <- ResMLR1a$Coefficients + + #dataB <- c(M$coefficients[1],M$coefficients[2]) + + #---Tail + textT <- c(strTailPart1) + + D1 <- list(textH=textH,textB=textB,TfmtB=TfmtB,dataB=dataB,DfmtsB=DfmtsB, + textT=textT,outDir=outputDir) + + #---Function call for table + ResTemp <- Table1Column(D1) + rm(D1,textT,dataB,DfmtsB,TfmtB,textB,TableTitle,textH,ResTemp) + } + + + + #=== TABLE PCA loadings + + if (PCApredictors | methMSR==3){ + + #--- Title + TableTitle <- "Table3-PCA1" + + TableSubTitle <- "Loadings of principal components of single-site reconstructions" + + #--- Heading + c1=vector() + for (n in 1:nPC){ + c1[n] <- paste('PC',as.character(n),sep='') + } + c1 <- c('N','Site#','SiteID',c1) + textH<- list(Title=TableTitle,SubTitle=TableSubTitle,Heading=c1) + + # longest id & fmt to accommodate + nbig1 <- 8 + nbig <- max(c(nchar(nmsU),nbig1)) + fmtID <- paste('%',as.character(nbig),'s\t',sep='') + rm(c1,nbig,nbig1) + + # --- Body + nwide1=12; + nwide2 =5; + nwide3=3; + + fmtPCa <- paste('%',as.character(nwide1),'s\t',sep='') # for headers of PC cols, except last + fmtPCb <- paste('%',as.character(nwide1),'s\n\n',sep='') # ... last + fmtPC1 <- paste('%',as.character(nwide1),'.5g\t',sep='') # for loadings, except last + fmtPC2 <- paste('%',as.character(nwide1),'.5g\n',sep='') # for loadings, last + fmtPct1 <- paste('%',as.character(nwide1),'.3g\t',sep='') # for loadings, except last + fmtPct2 <- paste('%',as.character(nwide1),'.3g\n',sep='') # for loadings, last + + textB <- list(SiteID=rownames(LoadPC),Lower=c('EV','%','Cum%')) # text for body + TfmtB1 <- c('%4s\t','%5s\t',fmtID) # for first 3 cols + #TfmtB2 <- c(rep('%8s\t',nPC-1),'%8s\n\n') # for the rest -- vectors of loadngs + TfmtB2 <- c(rep(fmtPCa,nPC-1),fmtPCb) # for the rest -- vectors of loadngs + TfmtB <- list(Left=TfmtB1,Right=TfmtB2) + DfmtB1 <- c('%4d\t','%5d\t',fmtID) + #DfmtB2 <- c(rep('%8.5g\t',nPC-1),'%8.5g\n') # for the rest -- vectors of loadngs + DfmtB2 <- c(rep(fmtPC1,nPC-1),fmtPC2) # for the rest -- vectors of loadngs + #DfmtB3 <- c(rep('%8.3g\t',nPC-1),'%8.3g\n') # for pctg amd cum pctg + DfmtB3 <- c(rep(fmtPct1,nPC-1),fmtPct2) # for pctg amd cum pctg + + + DfmtB <- list(Left=DfmtB1,Right=DfmtB2,Pctg=DfmtB3) + dataB <- list(ResPCA=ResPCA,jScreened=jScreened,SiteID=rownames(LoadPC)) + + #---Tail + textT <- paste('Loadings are graphically shown by heat map in Figure 06\n', + strTailPart1,sep='') + + # Line to go above and below table (cosmetic only). No need to change this, but you + # can if you want the width of line to perfectly match width of table as viewed in + # some text editor. Would first need to view tabel in the text editor, draw the + # track to desired width, and replace the line in the following statement. + BunnyTrack <- strrep('=',(nPC+3)*(nwide1+4)) # 4 for the tabs; 3 for the cols before loading + + + D1 <- list(textH=textH,textB=textB,TfmtB=TfmtB,dataB=dataB,DfmtB=DfmtB, + textT=textT,BunnyTrack=BunnyTrack,outDir=outputDir) + + #---Function call for table + + ResTemp <- TablePCA1(D1) + rm(D1,textT,dataB,DfmtB,TfmtB,textB,TableTitle,textH,ResTemp,BunnyTrack) + + + + #=== TABLE PCA CORRELATION WITH HYDRO + # + # Recall: rv1U1, r1U1, r1V1 are: vector of correlations of hydro with PCs, + # vector of lag-1 autocorrelations of U1, and scalar of lag-1 autocorrelation + # of v1. Refer bar plots in Figure 7 + # + # This table will, for each PC, list the following + # 1) PC#, 2) r with y, 3) r(1) of PC, 4) r(1) of y, threshold1, threshold2 + # Threshold1 is alpha=alphaR (e.g., 0.05) two-tailed, significance threshold, neglecting autocorrelation + # Threshold2 is similar threshold, but using an adjustment to effective sample size: + # Nprime = N(1-r1r2)/(1+r1r2), where N is samples size, Nprime is effective + # sample size, r1, r2 are lag-1 autocorrelations of the pair of variables. If + # either r1 or r2 are non-positve, no adjustment is made (Nprime=N) + #--- Title to Headings + + # Compute autocorrelation-adjusted critical levels for correlations of v1 with U1 + ResEff <- EffectSS(U1,v1) # if matrix and vector, matrix must be the first arg + Nprime <- ResEff$Nprime # vector of effective sample sizes for correlaitons + rCI1 = ThreshSiggy/sqrt(Nprime-2) # adjusted Siggy (e.g. 95%) CI + rm(ResEff,Nprime) + textH <- c('Table4-PCA2', + paste('Correlation of PC scores with ',HydroName,' (',as.character(yrgo1), + '-',as.character(yrsp1),')',sep=''), + 'PC#','Corr','Thresh1','Thresh2','r(1)') + # Formats + fmt1<-c('%4s\t','%6s\t','%7s\t','%7s\t','%7s\n') + fmt2<-c('%4s\t','%6.2f\t','%7.2f\t','%7.2f\t','%7.2f\n') + fmtHB <- list(Head=fmt1,Body=fmt2) + + # Body and tail + dataB <- list(PC=colnames(U),r=rv1U1,Thresh1=rep(rCI,nPC),Thresh2=rCI1, + r1PC=r1U1) + textT <- paste('Listed are the correlations (Corr) of ',HydroName,' with PC scores,', + paste('\nthresholds for',Siggy,'significance of correlation neglecting (Thresh1)'), + '\nand accounting for (Thresh2) lag-1 autcorrelation in the two series,', + '\nand the lag-1 autocorrelations (r(1)) of the PCs. The two thresholds', + '\ndiffer only if both series have positive autocorrelation. For ',HydroName,',', + '\nlag-1 autocorrelation is r(1)=',sprintf('%5.2f',r1v1),'. A correlation of ',HydroName, + '\nwith a PC is judged "significant" only if the absolute value of', + '\ncorrelation is greater than the threshold.', + '\n\nSee Wilks (2019) for autocorrelation adjustment.',sep='', + '\n',PdfDescribe) + + #--- Function call to write table + BunnyTrack <- '=============================================================' + D = list(outputDir=outputDir,textH=textH,dataB=dataB,fmtHB=fmtHB,textT=textT, + BunnyTrack=BunnyTrack) + ResTemp <- TableWrite1(D) + } + + + + #=== TIME SERIES DATA: FULL-LENGTH SCREENED SSRS OR THEIR PCS + # + # Recall that ResPCA$Scores and ResPCA$yrScores are the data needed if PCApredictors + # Recall than for noPCA mode, long-terms screened SSRs are in U, yrU, and ids in nmsU2 + + # Title and data + if (PCApredictors | methMSR==3){ + TableTitle <- "PCscoresTimeSeries" + dataB <- cbind(ResPCA$yrScores,ResPCA$Scores) # Data + fmtsB <- c('%6g\t',rep('%8.5g\t',(nPC-1)),'%8.5g\n') + # Headings + textH <- c('Year',colnames(LoadPC)) # text + germFmt <- '%8s\t' + c1 <- rep(germFmt,(nPC-1)); c1 <-c (c1,'%8s\n') + fmtsH <- c('%6s\t',c1) # format for text of headings + # Tail + if (methMSR==3){ + textT <- paste('Scores of principal components of single-site reconstructions (SSRs).', + '\nNot all of these these PCs may have been used in selecting analog', + '\nyears (see table note for Table 5).',sep='') + } else { + textT <- paste('Scores of principal components of single-site reconstructions (SSRs).', + '\nNot all of these these PCs may have been selected as predictors for the ', + '\nMSR model (see Table 8)',sep='') + } + } else { + TableTitle <- "ScreenedSSRtimeSeries" + dataB <- cbind(yrU,U) # Data + fmtsB <- c('%6g\t',rep('%8.5g\t',(dim(U)[2]-1)),'%8.5g\n') + textH <- c('Year',namesX) # text + germFmt <- '%8s\t' + c1 <- rep(germFmt,(dim(U)[2]-1)); c1 <-c (c1,'%8s\n') + fmtsH <- c('%6s\t',c1) # format for text of headings + # Tail + textT <- paste('Screened single-site reconstructions (SSRs).', + '\nNot all of these these SSRs may have been selected as predictors for the ', + '\nMSR model (see Table 6)',sep='') + } + D1 <- list(outDir=outputDir,filename=TableTitle,textH=textH,dataB=dataB, + textT=textT,fmtsH=fmtsH,fmtsB=fmtsB) + ResTemp <- TabSepTsm3(D1) + + + + #=== TIME SERIES DATA" REGRESSION MODEL INPUT (DOES NOT APPLY TO ANALOG MODEL) + if (methMSR != 3){ + + # ResMLR1a$Model$model -- model inputs, y first, then predictors in order of how coefficients listed + # yrv1 -- years (a vector) + + #--- Title + TableTitle <- "RegressionInputTimeSeries" + textTitle<- c(TableTitle) + + #--- Head + textH <- c('Year', + paste(HydroLabel,HydroUnits), + namesU3) + nmaxH <- max(nchar(textH)) # length of longest header string + if (nmaxH<12){ + nmaxH <-12 + } + nH <- length(textH) # number of headers + fmtH1 <- paste('%-',as.character(nmaxH),'s\t',sep='') + fmtH2 <- paste('%-',as.character(nmaxH),'s\n',sep='') + fmtsH <- rep(fmtH1,(nH-1)) + fmtsH <- c(fmtsH,fmtH2) + + # --- Body + fmtsB <- c('%-12.0f\t','%-12.8g\t',rep('%-12.8g\t',(npred-1)),'%-12.8g\n') + dataB <- cbind(as.matrix(yrv1),ResMLR1a$Model$model) + + #---Tail + textT <- c("In the MSR model, second column is regressed on remaining columns.", + strTailPart1) + D1 <- list(filename=TableTitle,textH=textH,fmtsH=fmtsH,dataB=dataB, + fmtsB=fmtsB,textT=textT,outDir=outputDir) + + #---Function call for write + ResTemp <- TabSepTsm2(D1) + rm(D1,textTitle,TableTitle,textH,fmtH1,fmtH2,fmtsH,dataB,fmtsB,textT,ResTemp) + } + + + + #=== TIME SERIES DATA: AnalogYearsTimeSeries (applies only to analog method) + + if (methMSR==3){ + W <- Analog$ReconNN12 # year, reon y, analog year, indicator if nearest neighbor or second-nearest + + #--- Title + TableTitle <- "AnalogYearsTimeSeries" + textTitle<- c(TableTitle) + + #--- Head + textH <- c('Year', + paste(HydroLabel,HydroUnits), + 'Analog Year','Neighbor') + nmaxH <- max(nchar(textH)) # length of longest header string + if (nmaxH<12){ + nmaxH <-12 + } + nH <- length(textH) # number of headers + fmtH1 <- paste('%-',as.character(nmaxH),'s\t',sep='') + fmtH2 <- paste('%-',as.character(nmaxH),'s\n',sep='') + fmtsH <- rep(fmtH1,(nH-1)) + fmtsH <- c(fmtsH,fmtH2) + + # --- Body + fmtsB <- c('%-12.0f\t','%-12.8g\t','%-12.5g\t','%-12.0g\n') + dataB <- W + + #---Tail + textT <- c(paste(' Analog year (col 3) observed ',HydroName,' supplies reconstruction for year in col 1.',sep=''), + 'Col 4 indicates if analog year is nearest (1) or second-nearest (2) neighbor to year of reconstruction', + strTailPart1) + D1 <- list(filename=TableTitle,textH=textH,fmtsH=fmtsH,dataB=dataB, + fmtsB=fmtsB,textT=textT,outDir=outputDir) + + #---Function call for write + ResTemp <- TabSepTsm2(D1) + rm(D1,textTitle,TableTitle,textH,fmtH1,fmtH2,fmtsH,dataB,fmtsB,textT,ResTemp) + } + + + + #=== TIME SERIES DATA: Reconstruction with 50% confidence interval + # + # Status. + # yh: 4 column tsm with year, recon, lower50%, upper 50% (matrix) + # v, yrv: observed predictand and years (vectors) + # v might have more recent data than yh because SSRs by lagged regression cannot extend + # beyond m years before the end of the tree-ring data, where m is maximum lag allowed + # in reconstruction model. + # In formats, make sure that field lengths for header and data match and that the length of + # non-year columns is at least as long as the longest header element + fmtsH <- c('%6s\t','%10s\t','%10s\t','%10s\t','%10s\n') # for header lin + fmtsD <- c('%6g\t','%10g\t','%10g\t','%10g\t','%10g\n') # for data matrix + + D1 <- list(header=c("Year",paste("Obs",HydroLabel,HydroUnits), + "Reconstructed","Lower 50% CI","Upper 50% CI"), + observed=cbind(yrv,v), recon=yh,outDir=outputDir, + fmtsH=fmtsH, fmtsD=fmtsD, + filename="ReconstructionWithConfidenceIntervalTimeSeries") + ResTemp <- TabSepTsm1(D1) + + + #=== ORGANIZE DATA FOR RETURN TO CALLING FUNCTION + + if (methMSR==3){ + ResCV <- NA + CalData <- list('Year'=yrv1,'y'=v1,'yhat'=Fits,'PCscores' <- U2, 'Residuals'=Analog$Resids) + CalMtx <- cbind(Analog$ReconNN12) # year, recon, analog year, whether analog year + OutputCal <- list('flag'=flagBail,'Msg'=flagMsg) + } else { + + # calib period: year, obs, rec, CVpredictions, e_cal, e_cv + + ResCV <- ResMLR1a$CrossValidStorage # Renaming list for convenience so that can + # use code copied from RecSLR1 + + CalData <- list('Year'=yrv1,'y'=v1,'yhat'=Fits,'yhatCV'=ResCV$CVpredictions, + 'Residuals'=ResMLR1a$residuals,'ResidualsCV'=ResCV$CVresiduals, + 'PredictorMtx'=Xr) + CalMtx <- cbind(yrv1,v1,Fits,ResCV$CVpredictions,ResMLR1a$residuals,ResCV$CVresiduals) + } + OutputRec <- list('yearGoRec'=yrgo3,'yearSpRec'=yrsp3,'xStdNorm75'=xStdNorm75, + 'deltaRec50'=deltaRec50,'yhat'=yh,'CalibrationData'=CalData,'CalibrationMtx'=CalMtx) + + + #=== OUTPUT BACK TO CALLING FUNCTIONS + + Output <- c(OutputCal,OutputVal,OutputRec) + + return(Output) +} \ No newline at end of file diff --git a/RecPCR1.R b/RecPCR1.R new file mode 100755 index 0000000..420f233 --- /dev/null +++ b/RecPCR1.R @@ -0,0 +1,793 @@ +RecPCR1 <- function(D) { + # Multi-site reconstruction (MSR) by regression on PCs of single-site reconstructions (SSRs) + # D. Meko + # Last revised 2022-08-28 + # + # Called from a script or function (e.g., ReconAnalog1) that has generated the SSRs. + # Consider the predictand, y, and predictor matrix, X. Here, y is regressed on the mean of the + # SSRs in X. The method therefore is simple linear regression. + # + # D is list with members: + # Text (1x4)s: symbol for y label; units of y, in parens; longer name of y; name of y season; Example: + # "RO","(mm)","Runoff", "12-month season ending in month 9" + # U, yrU: matrix of screened SSRs (matrix); matrix of years (1-col matrix) + # nmsU: names of screened SSRs (vector) + # v, yrv: numeric and integer; predictand and years + # yrsC (1x2)d first and last year of desired calibraiton period; if NaN, default to first or last + # available year of overlap of u and v + # nNeg, nPos: integer (both positive) of max negative and possitive lag allowed by calling function in + # SSR modeling. This affects m in leave-m-out cross-validation + # NcMin: minimum acceptable number of years for calibration of MSR model + # PCoption: option for building pool of potential predictors from scores of PCs of SSRs + # 1: specify k most important PCs, for example from viewing scree plot + # 2: the m + # + # Notation below uses "<>" to indicate "default" values of input specifications. For example, + # means the default for variable f is 0.10. Or, with options 1 and 2, <2> indicates that + # the default option is "2." + + library(car) + library(nortest) + source(paste(code_dir,"CrossValid2.R",sep="")) # leave-m-out cross-validation + source(paste(code_dir,"ssValid.R",sep="")) # split-sample validation + source(paste(code_dir,"mannken1.R",sep="")) # time plot and trend test of reg. resids + source(paste(code_dir,"stemACF.R",sep="")) # stem plot of acf, with CI & annotaton + source(paste(code_dir,"xyCI.R",sep="")) # compute polygon (for shaded CI) from lower and upper CI + source(paste(code_dir,"Table1Column.R",sep="")) # write a table file with just 1 data column + source(paste(code_dir,"TabSepTsm1.R",sep="")) # write a tab-sep file with obs, recon, 50% CI + source(paste(code_dir,"TabSepTsm2.R",sep="")) # write a tab-sep file with model input data, 50% CI + + flagBail<-0 # flag for bailing out of function + flagMsg<-'No problems' + minLength1 <-130 # if length of series > minLength1 in reconstruction time series plot, line + # without plot characters is plotted; otherwise line with symbols + + # 1 specified calibration period too short or inconsistent with data coverage + # + #======================= UNLOAD LIST, AND RENAME SOME VARIABLES + + U <-D$U ; yrU<-D$yrU # full tsm of screened pf SSRs + v <-D$v ; yrv<-D$yrv # full length predictand + yrgo1<-D$yrsC[1]; yrsp1<-D$yrsC[2] # desired start and end year of calib period of MSR model + nNeg<-D$nNeg; nPos<-D$nPos # max neg and pos lags allowed in SSR modeling + N1 <- D$NcMin # mimimum acceptable number of years for calibration of MSR model + PCoption <- D$PCoption # how pool of potential predictors to be filled: + # 1 Use will specify to use most important K PCs after viewing scree plot + # <2> The m + NextFigNumber <-D$NextFigNumber # start naming figures as Figure0?.png, where ? is NextFigNumber + outputDir <-D$outputDir # outut to be written to this system folder + # Note that outputDir is also defined in the global environment. So, I think that I would + # not actually need to pass outputDir as argument to functions + HydroName <- D$Text[3] # name of hydrologic variable (e.g., "Runoff") + HydroLabel <- D$Text[1] # label of hydro variable, for plots (e.g., "RO) + HydroUnits <- D$Text[2] # units of hydro varialbe with parens, (e.g., "(mm + HydroUnits2 <- substr(HydroUnits,2,(nchar(HydroUnits)-1)) # units w/o pare s + HydroSeason <- D$Text[4] # season of hydro variable (e.g., ""12-month season ending in month 9" ) + RecMethod<- paste('Method: stepwise regression of observed',HydroLabel,'on PC scores of SSRs') + rm(D) + # all of the above are numeric or integer, except that yru is 1-col matrix + + + #============= GET CALIBRATION DATA AND CHECK THAT CALIBRATION PERIOD LONG ENOUGH + + # Compute longest possible calibration period given the overlap of U and v + yrgo2 <- max(yrU[1],yrv[1]) # earliest overlap year of U and v + yrsp2 <- min(yrU[dim(U)[1]],yrv[length(v)]) # earliest overlap year of U and v + + # If specified calibration start or end is NA, replace with earliest possible start, + # latest possible end. + if (is.na(yrgo1)){ + yrgo1<-yrgo2 # start calibration as early as possible if yrgo1 is NA + } + if (is.na(yrsp1)){ + yrsp1<-yrsp2 # end calibration as late as possible if yrgo1 is NA + } + + #---- Bail with error if calibration period too short or if specified calibration period not + # possible with time coverage of U and v + L <- (yrgo1yrsp2) || ((yrsp1-yrgo1+1)=yrgo1 & yru<=yrsp1 + u1 <- u[L]; yru1<- yru[L] + + L <- yrv>=yrgo1 & yrv<=yrsp1 + v1 <- v[L]; yrv1<- yrv[L] + + M <- lm(v1~u1) # model object + M1<-summary(M) + ncalib <- length(v1) + + #========================= STORE CALIBRATION STATISTICS + + # Significance of overall F + # M1$fstatistic has F, dfnum, dfdenom in 1-3 + pF <-pf(M1$fstatistic[1],M1$fstatistic[2],M1$fstatistic[3],lower.tail=FALSE) + + OutputCal<-list('flag'=flagBail,'Msg'=flagMsg,'lmModel'=M,'yearGoCal'=yrgo1,'yearSpCal'=yrsp1, + 'coefficients'=M$coefficients,'Rsquared'=M1$r.squared,'F'=M1$fstatistic[1],'pF'=pF, + 'RsquaredAdj'=M1$adj.r.squared,'RMSEc'=M1$sigma) + + #====================== FIGURE (local 1): 1x2 CALIBRATION PERIOD TIME PLOTS AND STATISTICS + # + # Figure files are numbered within this function with first figure as figure01.png. where + # In general, figure files are named Figure?? is a number built from NextFigNumber+jFigAdd. jFigAdd + # will start at 0 but increment for later figures + + #--- Build some strings for use in plots + strCalPd <- paste(' Calibration period: ',sprintf('%d',yrgo1),'-',sprintf('%d',yrsp1), + ' (N=', sprintf('%d',length(yrv1)),' yr)',sep='') + + #--- BuildTit1 figure png filename + jFigAdd <- 0 + FigNumber <- NextFigNumber+jFigAdd # for naming this png + if (FigNumber<10){ + fileOut <- paste(outputDir,'Figure0', as.character(FigNumber),'.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure', as.character(FigNumber),'.png',sep="") + } + + # Build figure + png(filename=fileOut, width = 960, height = 480) + split.screen(c(2,1)) # Makes Screen 1 and 2 + split.screen(c(1,2), screen=1) # Makes Screen 3 and 4 + + # time plots, obs and rec + screen(2) + zx <- c(yrgo1,yrsp1) + zy <- c(mean(v1),mean(v1)) + par(mar=c(4,4,3,1)) + plot(yrv1,v1,type="b",pch=1,col="blue",xlim=c(yrgo1,yrsp1), + ylab=paste(HydroLabel,HydroUnits),xlab="Year", + main=paste('Calibration Period Observed and Reconstructed',HydroName)) + lines(yrv1,M$fitted.values,type="b",pch=2,col="red") + lines(zx,zy) + h<-par("usr"); yoffset<- (h[4]-h[3])/100; ytop <- h[4]-yoffset + legend(yrgo1+1,ytop,legend=c("Obs", "Recon"), + col=c("blue", "red"), lty=1, cex=1.2) + + screen(3) + par(mar=c(4,4,2,8)) + r<-cor(M$fitted.values,v1) + strTit <- paste('Recon vs Obs ',HydroName,', r=',as.character(round(r,digits=2))) + plot(v1,M$fitted.values,ylab=paste('Recon',HydroLabel,HydroUnits), + xlab=paste('Obs',HydroLabel,HydroUnits),main=strTit) + abline(lm(M$fitted.values~v1),col="red") + + + screen(4) + par(mar=c(0,0,0,0)) + strText <-paste(RecMethod,'\n',strCalPd, + '\n R-squared =',sprintf('%.2g',M1$r.squared), + '\n F=',sprintf('%.5g',M1$fstatistic[1]),'(p=',sprintf('%.4g',pF),')', + '\n RMSE=',sprintf('%g',M1$sigma),HydroUnits2,' (equivalent to std error of the estimate)') + text(x=0.05,y=0.95,'Calibration Statistics',adj=c(0,1),cex=1.5,font=2) + text(x=0.05,y=0.8,strText,adj=c(0,1),cex=1.2) + + dev.off() + + #====================== FIGURE (local 2): 2x2 DISTRIBUTIONS AND ACFS + # + # CW from LL: histogram of yhat; hist of obs y; acf of obs y, acf of yhat + #--- Uniform xlims for histograms + xlo = min(c(min(v1),min(M$fitted.values))) + xhi = max(c(max(v1),max(M$fitted.values))) + xinc <- 0.05*(xhi-xlo) + xlims <- c(xlo-xinc,xhi+xinc) + rm(xlo,xhi,xinc) + xlims <-c((c(min(v1),min(M$fitted.values))), (c(max(v1),max(M$fitted.values)))) + + #--- Build figure png filename + jFigAdd <- jFigAdd+1 + FigNumber <- NextFigNumber+jFigAdd # for naming this png + if (FigNumber<10){ + fileOut <- paste(outputDir,'Figure0', as.character(FigNumber),'.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure', as.character(FigNumber),'.png',sep="") + } + # Build figure + png(filename=fileOut, width = 960, height = 480) + # Create the layout + nf <- layout( matrix(c(1,2,3,4), ncol=2) ) + + nbin <- floor(5*log10(length(v1))) # Panofsky rule of thumb for number of bins + brks1 = seq(min(v1)*.99999,max(v1)*1.00001,length.out=(nbin+1)) + brks2 = seq(min(M$fitted.values)*.99999,max(M$fitted.values)*1.00001,length.out=(nbin+1)) + xlab1 <- paste(HydroLabel,HydroUnits) + MaxLag <- floor(length(v1)/4) + + par(mar=c(5,6,2,2),cex.axis=1.5, cex.lab=1.5, cex.main=1.5) + Tit1 <- paste('Histogram, Observed',HydroLabel,'(N=',sprintf('%d',length(v1)),'yr)') + hist(v1,main=Tit1,breaks=brks1,xlim=c(150,450),xlab=xlab1) + + par(mar=c(5,6,2,2)) + Tit1 <- paste('Histogram, Reconstructed',HydroLabel,'(N=',as.character(length(v1)),'yr)') + hist(M$fitted.values,main=Tit1,breaks=brks2,xlim=c(150,450),xlab=xlab1) + + par(mar=c(5,5,4,2)) + Tit1 <- paste('ACF, Observed',HydroLabel,',with 95% CI') + acf(v1,lag.max=MaxLag,type='correlation',main=Tit1) + + par(mar=c(5,5,4,2)) + Tit1 <- paste('ACF, Reconstructed',HydroLabel,', with 95% CI') + acf(M$fitted.values,lag.max=MaxLag,type='correlation',main=Tit1) + + dev.off() + + #========================= ANALYSIS OF RESIDUALS (local 3,4,5) + # + # Will need the regression residuasl. First figure (1x2) will be histogram and + # scatter of residuals on predicted values. Second figure (1x1) will be time plot of + # the residuals with a fitted (non-parametric fit) trend line and annotated result + # of Mann-Kendall trend test. The significance will be adjusted as needed for autocorrelation + # of the residuals over and above that in a linear trend. The third figure (1x1) will be + # the acf of residuals, with annotated DW test results + + + #--- HISTOGRAM AND SCATTER OF RESIDS ON PREDICTED (1X) + # + # 1st of 3 analysis of residuals plots + + # Lilliefors test of normality of residuals + hLillie <- lillie.test(M$residuals); + Tit1 <- paste('Residuals, E, of regression of',HydroName,'on tree rings', + '\n (p=',sprintf('%.2g',hLillie$p.value),' for H0 that E normal, from Lilliefors Test)') + + # Breusch-Pagan test for heterogeneity of regresson residuals + BP <- ncvTest(M) + Tit2 <- paste('Scatter of Residuals on Fitted Values', + '\n (p=',sprintf('%.2g',BP$p),' for H0 that E homoscedastic)', + '\n(from Breusch-Pagan Test)') + + # Buld filename for plot + jFigAdd <- jFigAdd+1 + FigNumber <- NextFigNumber+jFigAdd # for naming this png + if (FigNumber<10){ + fileOut <- paste(outputDir,'Figure0', as.character(FigNumber),'.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure', as.character(FigNumber),'.png',sep="") + } + + # Figure size and margins + png(filename=fileOut, width = 960, height = 480) + layout.matrix <- matrix(c(1,2), nrow = 1, ncol = 2) + layout(layout.matrix,heights=2,widths=c(1,1)) + + # Left plot + + par(mar = c(5.1, 4.5, 5.1, 2.1),cex.axis=1.1, cex.lab=1.5, cex.main=1.3) + hist(M$residuals,xlab=paste('Residual',HydroUnits),ylab='Frequency',main=Tit1) + + # # right plot + par(mar = c(5.1, 4.1, 6.1, 2.1),cex.axis=1.1, cex.lab=1.5, cex.main=1.3) + plot(M$fitted.values,M$residuals,xlab=paste('Fitted Values',HydroUnits), + ylab=paste('Residual',HydroUnits), + main=Tit2) + abline(h=0,lty=2,col='#808080') # dash gray + dev.off() + + + #--- TIME PLOT OF REGRESSION RESIDUALS, WITH MANN-KENDAL TREND TEST (1X1) + + jFigAdd <- jFigAdd+1 + FigNumber <- NextFigNumber +jFigAdd + + # Prepare input for mannken1 + X <- cbind(yrv1,M$residuals) # matrix with year and regression residuals + + kopt<- c(2,1) # want plot; want adjustment of significance of Mann-Kendall statistic + # for autocorrelation if warranted + kplot <-2 # for TRISH, the time plot of residuals, with annotated MK test results + # and non-parametric-fit straight line fit to trend + ylabTemp1 <- paste('Residual',HydroUnits) + ylabTemp2 <- paste('Detrended Residual',HydroUnits) + textPlot <- c('Regression Residuals with Nonparametric-Fit Trend Line,','Year',ylabTemp1, + ylabTemp2) + Din <- list(X=X,kopt=kopt,kplot=kplot,NextFigNumber=FigNumber,textPlot=textPlot,outputDir=outputDir) + + # mannken1 to get statistics and plot + ResMK <- mannken1(Din) + rm(Din) + + + #--- ACF OF REGRESSION RESIDUALS, INCLUDING 95% Ci + + jFigAdd <- jFigAdd+1 + FigNumber <- NextFigNumber +jFigAdd + + # acf and its 95% CI + lagsPlot <- floor(min(ncalib/4,20)) + acfMy <- acf(M$residuals, lag.max=lagsPlot, type = "correlation", + plot = FALSE) + k <- acfMy$lag # lags + w <- acfMy$acf # acf + + # DW statistic of the regression residuals + DW <- durbinWatsonTest(M) + strDW <- paste('p=',sprintf('%g',DW$p), + ': Durbin-Watson test (2-sided) of H0 that population lag-1 autocorrelation is zero', + sep='') + + # Text for plot + Tit1 <- paste('ACF of Residuals with 95% CI (N=',sprintf('%g',ncalib),' yr)') + textPlot <- c(Tit1,'Lag(yr)','r',strDW) + + # Store inputs required by stemACF in a list (see opening comments there) + Din <- list(x=k,y=w,nsize=ncalib,kAlpha=1,FigNumber=FigNumber, + outputDir=outputDir,linecol1='#0022CC',linecol2='#696969', + linecol3='#E60000',textPlot=textPlot) + ResNull <- stemACF(Din) + + + #========================= VALIDATE AND STORE STATISTICS + + ResCV <- CrossValid2(u1, v1, nNeg,nPos) # cross-validation + + # Split-sample validation + + iAstop <- ceiling(length(v1)/2) # end row index in v1 of first half of data, assumed longer than + # longer of the two halves if length of v1 odd + iBgo <- iAstop+1 # start row of second half + iA <- 1:iAstop # row indices of first half of full calib period + iB <- iBgo:length(v1) # ... of second half + + #--- Calibrate on early, validate on late, then reverse + ical<-iA; ival<-iB + i1 <- 1; # col 1 of u1 is predictor; moot because here u1 is vector + ResSS1=ssValid(v1,u1,ical,ival,i1); + REa1<-ResSS1$RE # RE for calib on early, valid on late + ical<-iB; ival<-iA + ResSS2=ssValid(v1,u1,ical,ival,i1); + REb1<-ResSS1$RE # RE for calib on late, valid on early + + OutputVal<-list('mLeaveOutCV'=ResCV$LeftOut,'REcv'=ResCV$REcv,'RMSEcv'=ResCV$RMSEcv, + 'REcalEarlyValLate'=REa1,'REcalLateValEarly'=REb1) + + #====================== FIGURE (local 6): time plots of obs y, recon, y, cv predictions of y; with observed mean line + # + #--- Build figure png filename + jFigAdd <- jFigAdd+1 + FigNumber <- NextFigNumber+jFigAdd # for naming this png + if (FigNumber<10){ + fileOut <- paste(outputDir,'Figure0', as.character(FigNumber),'.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure', as.character(FigNumber),'.png',sep="") + } + + # Recall + # v1,yrv1 is observed; M$fittedvalues is recon; ResCV$CVpredictions is cv-prdicted + # zx,zy are 1x2s that allow for line at observd mean; yrgo1,yrsp1 are 1st & last of calib years + + # Build figure + png(filename=fileOut, width = 960, height = 480) + par(mar=c(4,4,5,1),cex.main=1.4) + plot(yrv1,v1,type="b",pch=1,col="blue",xlim=c(yrgo1,yrsp1), + ylab=paste(HydroLabel,HydroUnits),xlab="Year", + main=paste('Time Plots of Observed, Reconstructed, and Cross-Validation-Predicted',HydroName,'(',sprintf('%d',yrgo1),'-',sprintf('%d',yrsp1),')', + '\n(black line at observed mean)')) + lines(yrv1,M$fitted.values,type="b",pch=2,col="red") + lines(yrv1,ResCV$CVpredictions,type="b",pch=17,col="#990099") + lines(zx,zy) + h<-par("usr"); yoffset<- (h[4]-h[3])/100; ytop <- h[4]-yoffset + legend(yrgo1+1,ytop,legend=c("Obs", "Recon","CVpred"), + col=c("blue", "red","#990099"),pch=c(1,2,17),lty=1, cex=1.2) + dev.off() + + + #====================== FIGURE (local 7): 1x2 VALIDATION PLOTS AND STATISTICS + + # Lilliefors test of normality of CV residuals + hLillie <- lillie.test(ResCV$CVresiduals); + Tit1 <- paste('Cross-Validation Residuals', + '\n(p=',sprintf('%.2g',hLillie$p.value),', H0: normally distributed', + ' [Lilliefors Test])',sep='') + + # Text strings for cross-validation + strAnPd <- strCalPd # built for earlier plot: gives calib period and length + + # Text strings for split-sample validation + yrtemp <- yrv1[iA] # year vector, early split + yrgoA <- yrtemp[1]; yrspA <- yrtemp[length(yrtemp)] + yrtemp <- yrv1[iB] # year vector, late split + yrgoB <- yrtemp[1]; yrspB <- yrtemp[length(yrtemp)] + rm(yrtemp) + strSplitA <- paste(' A: ',sprintf('%d',yrgoA),'-',sprintf('%d',yrspA), + ' (N=', sprintf('%d',length(iA)),' yr)',sep='') + strSplitB <- paste(' B: ',sprintf('%d',yrgoB),'-',sprintf('%d',yrspB), + ' (N=', sprintf('%d',length(iB)),' yr)',sep='') + + + #--- Build figure filename + jFigAdd <- jFigAdd+1 + FigNumber <- NextFigNumber+jFigAdd # for naming this png + if (FigNumber<10){ + fileOut <- paste(outputDir,'Figure0', as.character(FigNumber),'.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure', as.character(FigNumber),'.png',sep="") + } + + # Figure size and margins + png(filename=fileOut, width = 960, height = 480) + layout.matrix <- matrix(c(1,2), nrow = 1, ncol = 2) + layout(layout.matrix,heights=2,widths=c(1,1)) + + # Left plot histogram + + par(mar = c(5.1, 4.5, 5.1, 2.1),cex.axis=1.1, cex.lab=1.5, cex.main=1.3) + hist(ResCV$CVresiduals,xlab=paste('Residual',HydroUnits),ylab='Frequency',main=Tit1) + + # right plot, stats + + par(mar = c(0,0,0,0)) + xlims <- c(0,1); ylims <- c(0,1) + plot(0,type='n',axes=FALSE,ann=FALSE,xlim=xlims,ylim=ylims) + #plot(1,1,pch=1,xlim=xlims,ylim=ylims) + strText <-paste('\nCross-validation (cv) method: leave-',as.character(ResCV$LeftOut),'out', + '\n',strAnPd, + '\n RMSEcv=',sprintf('%g',ResCV$RMSEcv),HydroUnits2, + '\n REcv=',sprintf('%.2g',ResCV$REcv), + '\n\nSplit-sample validation', + '\n',strSplitA, + '\n',strSplitB, + '\n RE{A}=',sprintf('%.2g',ResSS1$RE),' (calibrated on A, validated on B)', + '\n RE{B}=',sprintf('%.2g',ResSS2$RE),' (calibrated on B, validated on A)') + text(x=0.05,y=0.95,'Validation statistics',adj=c(0,1),cex=1.5,font=2) + text(x=0.05,y=0.8,strText,adj=c(0,1),cex=1.2) + + + dev.off() + + + #========================= RECONSTRUCTION AND 50% CI + + Xr <- as.matrix(u) # matrix, 1 col, of long-term mean of SSRs + L<-complete.cases(Xr) + Xr <- as.matrix(Xr[L,]) ; yrXr <- as.matrix(yru[L,]) + mXr <- dim(Xr)[1] + yrgo3 <- yrXr[1,1]; yrsp3 <- yrXr[mXr,1] # start and end year if recon + + # Add ones column and reconstruct + Xones<-matrix(1,nrow=mXr,ncol=1) + Xr <- cbind(Xones,Xr) + yh <- Xr %*% M$coefficients # reconstruction as 1-col matrix + yh <- cbind(yrXr,yh) + + # Delta y for 50% CI + xStdNorm75 <-qnorm(0.75, mean = 0, sd = 1, lower.tail = TRUE, log.p = FALSE) + deltaRec50 <- xStdNorm75 * ResCV$RMSEcv + yhLo <- yh[,2]-deltaRec50; yhHi <-yh[,2]+deltaRec50 + yh <- cbind(yh,yhLo,yhHi) # matrix with year, recon, lower 50 upper 50 + + + #====================== FIGURE (local 8): 1x1 TSP OF FULL RECON WITN 50% CI + + # time series for plot and CI + y <- yh[,2]; yry <- yh[,1] # for time series + + # Compute shaded polygon x and y + Xtemp <- yh[,-2] # matrix with year as col 1, lower CI as col 2, upper CI as col 2 + ResTemp <- xyCI(Xtemp) + xP <- ResTemp$x; yP <- ResTemp$y + + # Limits for plot + yLo <- min(yh[,2:4]) + yHi <- max(yh[,2:4]) + ynudge <- 0.02 * (yHi-yLo) + ylims = c(yLo-ynudge, yHi+ynudge) + xlims = c(yrXr[1]-1,yrXr[length(yrXr)]+1) + + # Strings for plot + strRecYrs <- paste(sprintf('%d',yrXr[1]),'-',sprintf('%d',yrXr[length(yrXr)]),sep='') + Tit1 <- paste('Reconstructed ',HydroName,', ',strRecYrs, + '\n(50% CI shaded; dashed line at reconstructed mean)',sep='') + ylab1 <- paste(HydroLabel,HydroUnits) + + #--- Build figure filename + jFigAdd <- jFigAdd+1 + FigNumber <- NextFigNumber+jFigAdd # for naming this png + if (FigNumber<10){ + fileOut <- paste(outputDir,'Figure0', as.character(FigNumber),'.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure', as.character(FigNumber),'.png',sep="") + } + + # Build figure + png(filename=fileOut, width = 960, height = 480) + par(mar=c(5,5,5,1),cex.main=1.4,cex.axis=1.2,cex.lab=1.2) + if (length(y)>minLength1){ + plot(yry,y,type="l",col="blue",xlim=xlims,ylim=ylims, + ylab=ylab1,xlab='Year',main=Tit1) + } else { + plot(yry,y,type="b",pch=1,col="blue",xlim=xlims,ylim=ylims, + ylab=ylab1,xlab='Year',main=Tit1) + } + abline(h=mean(y),lty=2,col='#808080') # dash gray + adjustcolor("red",alpha.f=0.5) + #polygon(yryP,yP,col='#FFEE99') # flavescent + polygon(xP,yP, col=rgb(1.00,0,0,0.1),border=NA) # mustard + dev.off() + + + #====================== FIGURE (local 9): 2x2. + # + # At left, top and bottom are ACFs of recon for calib years and earlier + # At right is single frame with box plots or recon for same + + + #--- Pull recon for calib perod and for earlier + # w1, w2 will the reconsturction for those period + # Already have y, yry as full length recon + L <- yry >= yrgo1; # calib pd + w1 <-y[L]; yrw1<- yry[L] + L <- yry < yrgo1 + w2 <- y[L]; yrw2 <-yry[L] + + #---Make some strings for use in plots + strPd1<- paste(sprintf('%d',yrgo1),'-',sprintf('%d',yrsp1), + ' (N=', sprintf('%d',length(w1)),' yr)',sep='') + strPd2<- paste(sprintf('%d',yrgo3),'-',sprintf('%d',yrgo1-1), + ' (N=', sprintf('%d',length(w2)),' yr)',sep='') + strAnnote1 <- paste('A: ',strPd1) + strAnnote2 <- paste('B: ',strPd2) + + Tit1 <-'ACF of Reconstruction with 95% CI, Calibration Period' + Tit2 <- 'ACF of Reconstruction with 95% CI, Earlier Years' + Tit3 <- paste('Distribution of Reconstructed',HydroLabel) + + #--- Build figure filename + jFigAdd <- jFigAdd+1 + FigNumber <- NextFigNumber+jFigAdd # for naming this png + if (FigNumber<10){ + fileOut <- paste(outputDir,'Figure0', as.character(FigNumber),'.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure', as.character(FigNumber),'.png',sep="") + } + + # Figure size and margins + png(filename=fileOut, width = 960, height = 480) + layout.matrix <- matrix(c(1,2,3,3), nrow = 2,byrow=FALSE) + #layout(layout.matrix,heights=2,widths=c(1,1)) + layout(layout.matrix)#,heights=2,widths=c(1,1)) + par(mar=c(5,5,5,1),cex.main=1.4,cex.axis=1.2,cex.lab=1.2) + + #--- Upper left, acf of recon for calib pd + + MaxLag <- floor(length(w1)/4) + MaxLag <- min(c(MaxLag),20) + + par(mar=c(5,5,4,2)) + acf(w1,lag.max=MaxLag,ylim=c(-1,1),type='correlation',main=Tit1) + text(MaxLag,1,strAnnote1,adj=c(1,1),cex=1.5) + + #---Lower left, acf of recon for years before start of calib pd + + MaxLag <- floor(length(w2)/4) + MaxLag <- min(c(MaxLag),20) + + par(mar=c(5,5,4,2)) + acf(w2,lag.max=MaxLag,ylim=c(-1,1),type='correlation',main=Tit2) + text(MaxLag,1,strAnnote2,adj=c(1,1),cex=1.5) + + #---Right -- side by side box plots of recon for calib period and prior + + par(mar=c(5,8,4,1),cex.lab=1.3) + namesBP<-c('Period A','Period B') + boxplot(w1,w2,notch=FALSE,ylab=xlab1, + main=Tit3,names=namesBP) + dev.off() + + + #=== TABLE Table3-MSR-LR1, summarizing calibration of model + + #--- Header + TableTitle <- "Table3-MSR-LR1-Calibration" + SSRdef <- ' (SSR: "single-site reconstruction")' + textH<- c(TableTitle, + paste("Predictand:",HydroName,"for",HydroSeason), + RecMethod,SSRdef) + + # --- Body + textB <-c("YearGo","YearStop","R2","F","pF","R2adj","RMSEc") + TfmtB <- '%-10s\t' # format for name of variable; size for longest + DfmtsB <- c('%-4d\n','%-4d\n','%-6.2f\n','%-8.3g\n','%-8.3g\n','%-6.2f\n','%-10g\n') + dataB <- c(yrgo1,yrsp1,OutputCal$Rsquared,OutputCal$F,OutputCal$pF,OutputCal$RsquaredAdj, + OutputCal$RMSEc) + + #---Tail + textT <- c(paste('Units of RMSEc: ',HydroUnits2), + "See TrishOutputDescribeLR1.pdf for definitions of variables in column 1") + D1 <- list(textH=textH,textB=textB,TfmtB=TfmtB,dataB=dataB,DfmtsB=DfmtsB, + textT=textT,outDir =outputDir) + + #---Function call for table + ResTemp <- Table1Column(D1) + + rm(D1,textT,dataB,DfmtsB,TfmtB,textB,textH,TableTitle) + + + + #=== TABLE Table4-MSR-LR1-AnalysisOfResiduals + + #--- Header + TableTitle <- "Table4-MSR-LR1-AnalysisOfResiduals" + textH<- c(TableTitle) + + # --- Body + textB <-c("YearGo","YearStop","pNormal","DW"," pDW","TrendSlope"," pTrend", + "BP Test ChiSq"," dfBP"," pBP") + TfmtB <- '%-13s\t' # format for name of variable; size for longest + DfmtsB <- c('%-4d\n','%-4d\n','%-8.3g\n','%-5.2g\n','%-8.3g\n','%-8.5g\n','%-8.3g\n', + '%-8.5g\n','%-4d\n','%-8.3g\n') + dataB <- c(yrgo1,yrsp1,hLillie$p.value,DW$dw,DW$p,ResMK$b,ResMK$pvalue, + BP$ChiSquare,BP$Df,BP$p) + + #---Tail + + textT <- c(paste('Units of TrendSlope: ',HydroUnits2,' per year',sep=""), + "See TrishOutputDescribeLR1.pdf for definitions of variables in column 1") + + D1 <- list(textH=textH,textB=textB,TfmtB=TfmtB,dataB=dataB,DfmtsB=DfmtsB, + textT=textT,outDir =outputDir) + + #---Function call for table + ResTemp <- Table1Column(D1) + rm(D1,textT,dataB,DfmtsB,TfmtB,textB,TableTitle,textH) + + + + #=== TABLE Table5-MSR-LR1-Validation + + #--- Header + TableTitle <- "Table5-MSR-LR1-Validation" + textH<- c(TableTitle) + + # --- Body + textB <-c("NleaveOut","RMSEcv","REcv","YearGoA","YearStopA","YearGoB","YearStopB", + "REsplitA","REsplitB") + TfmtB <- '%-9s\t' # format for name of variable; size for longest + DfmtsB <- c('%-3d\n','%-8.5g\n','%-5.2f\n','%-4d\n','%-4d\n', + '%-4d\n','%-4d\n','%-5.2f\n','%-5.2f\n') + dataB <- c(ResCV$LeftOut,ResCV$RMSEcv,ResCV$REcv, + yrgoA,yrspA,yrgoB,yrspB,ResSS1$RE,ResSS2$RE) + + #---Tail + + textT <- c(paste('Units of RMSEcv: ',HydroUnits2,sep=""), + "See TrishOutputDescribeLR1.pdf for definitions of variables in column 1") + + D1 <- list(textH=textH,textB=textB,TfmtB=TfmtB,dataB=dataB,DfmtsB=DfmtsB, + textT=textT,outDir =outputDir) + + #---Function call for table + ResTemp <- Table1Column(D1) + rm(D1,textT,dataB,DfmtsB,TfmtB,textB,TableTitle,textH,ResTemp) + + + #=== TABLE Table6-MSR-LR1-Coefficients + + #--- Title + TableTitle <- "Table6-MSR-LR1-Coefficients" + textH<- c(TableTitle) + + # --- Body + textB <- c("Intercept","meanSSR") # headings of cols + TfmtB <- '%-12s\t' # format for name of variable; size for longest + DfmtsB <- c('%-12.8g\n','%-12.8g\n') + dataB <- c(M$coefficients[1],M$coefficients[2]) + + #---Tail + textT <- c("See TrishOutputDescribeLR1.pdf for definitions of variables in column 1") + + D1 <- list(textH=textH,textB=textB,TfmtB=TfmtB,dataB=dataB,DfmtsB=DfmtsB, + textT=textT,outDir=outputDir) + + #---Function call for table + ResTemp <- Table1Column(D1) + rm(D1,textT,dataB,DfmtsB,TfmtB,textB,TableTitle,textH,ResTemp) + + + #=== TIME SERIES DATA" RegressionInput + + #--- Title + TableTitle <- "RegressionInputTimeSeries" + textTitle<- c(TableTitle) + + #--- Head + textH <- c('Year', + paste(HydroLabel,HydroUnits),'meanSSD') + nmaxH <- max(nchar(textH)) # length of longest header string + if (nmaxH<12){ + nmaxH <-12 + } + nH <- length(textH) # number of headers + fmtH1 <- paste('%-',as.character(nmaxH),'s\t',sep='') + fmtH2 <- paste('%-',as.character(nmaxH),'s\n',sep='') + fmtsH <- rep(fmtH1,(nH-1)) + fmtsH <- c(fmtsH,fmtH2) + + # --- Body + fmtsB <- c('%-12.0f\t','%-12.8g\t','%-12.8g\n') + dataB <- cbind(as.matrix(yrv1),M$model) + + #---Tail + textT <- c("For the LR1 regression model, second column is regressed on third", + "See TrishOutputDescribeLR1.pdf for definitions of columns") + D1 <- list(filename=TableTitle,textH=textH,fmtsH=fmtsH,dataB=dataB, + fmtsB=fmtsB,textT=textT,outDir=outputDir) + + #---Function call for write + ResTemp <- TabSepTsm2(D1) + rm(D1,textTitle,TableTitle,textH,fmtH1,fmtH2,fmtsH,dataB,fmtsB,textT,ResTemp) + + + #=== TIME SERIES DATA: Reconstruction with 50% confidence interval + + # Status. + # yh: 4 column tsm with year, recon, lower50%, upper 50% (matrix) + # v, yrv: observed predictand and years (vectors) + # v might have more recent data than yh because SSRs by lagged regression cannot extend + # beyond m years before the end of the tree-ring data, where m is maximum lag allowed + # in reconstruction model. + # In formats, make sure that field lengths for header and data match and that the length of + # non-year columns is at least as long as the longest header element + fmtsH <- c('%6s\t','%10s\t','%10s\t','%10s\t','%10s\n') # for header lin + fmtsD <- c('%6g\t','%10g\t','%10g\t','%10g\t','%10g\n') # for data matrix + + D1 <- list(header=c("Year",paste("Obs",HydroLabel,HydroUnits), + "Reconstructed","Lower 50% CI","Upper 50% CI"), + observed=cbind(yrv,v), recon=yh,outDir=outputDir, + fmtsH=fmtsH, fmtsD=fmtsD, + filename="ObservedAndReconstructedTimeSeries") + + ResTemp <- TabSepTsm1(D1) + + + + + + #=== ORGANIZE DATA FOR RETURN TO CALLING FUNCTION + # + # calib period: year, obs, rec, CVpredictions, e_cal, e_cv + + CalData <- list('Year'=yrv1,'y'=v1,'yhat'=M$fitted.values,'yhatCV'=ResCV$CVpredictions, + 'Residuals'=M$residuals,'ResidualsCV'=ResCV$CVresiduals, + 'PredictorMtx'=Xr) + CalMtx <- cbind(yrv1,v1,M$fitted.values,ResCV$CVpredictions,M$residuals,ResCV$CVresiduals) + + OutputRec <- list('yearGoRec'=yrgo3,'yearSpRec'=yrsp3,'xStdNorm75'=xStdNorm75, + 'deltaRec50'=deltaRec50,'yhat'=yh,'CalibrationData'=CalData,'CalibrationMtx'=CalMtx) + + + + + + + + #=== OUTPUT BACK TO CALLING FUNCTIONS + + Output <- c(OutputCal,OutputVal,OutputRec) + + return(Output) +} \ No newline at end of file diff --git a/RecSLR1.R b/RecSLR1.R new file mode 100755 index 0000000..7131d43 --- /dev/null +++ b/RecSLR1.R @@ -0,0 +1,843 @@ +RecSLR1 <- function(D) { + # Multi-site reconstruction (MSR) by simple linear regression on mean of single-site reconstructions (SSRs) + # D. Meko + # Last revised 2023-11-22 + # + # Called from a script or function (e.g., ReconAnalog1) that has generated the SSRs. + # Consider the predictand, y, and predictor matrix, X. Here, y is regressed on the mean of the + # SSRs in X. The method therefore is simple linear regression. + # + # D is list with members: + # PdfDescribe: string referring to a pdf file describing reconstruction method + # This string is used in table notes + # Text (1x4)s: symbol for y label; units of y, in parens; longer name of y; name of y season; Example: + # "RO","(mm)","Runoff", "12-month season ending in month 9" + # u, yru: numeric time series of mean of SSRs; corresponding years (as 1-col matrix) + # v, yrv: numeric and integer; predictand and years + # yrsC (1x2)d first and last year of desired calibraiton period; if NaN, default to first or last + # available year of overlap of u and v + # yrEnd (1x1)d last year of provided time series output of reconstruction and of plot of + # reconstruction with 50% error bar + # nNeg, nPos: integer (both positive) of max negative and possitive lag allowed by calling function in + # SSR modeling. This affects m in leave-m-out cross-validation + # NcMin: minimum acceptable number of years for calibration of MSR model + # NextFigNumber [i] # start naming figures as Figure0?.png, where ? is NextFigNumber + # + # Notation below uses "<>" to indicate "default" values of input specifications. For example, + # means the default for variable f is 0.10. Or, with options 1 and 2, <2> indicates that + # the default option is "2." + # + # revised 2023-05-08: cosmetic. Switched from using split.screen() to layout() for multi-plots. This + # was applied the figure showing a window with calibration statistics. Before change some text was + # was truncate at right because split.screen does not allow subfigure widths to vary. + # revised 2023-05-16. yrEnd newly provided input argument, for truncation of final reconstruction + # revised 2023-06-02. remove error message and automatic bail when user specifies a calibration period impossible + # for the time coverage of tree-ring and hydro data. Now the calibration period is simpley truncated + # to be as long as possible, and program allowed to proceed. + # revised 2023-11-22. To use the input argument yrEnd instead of computing yrEnd internally to mark + # last year of generated and plotted final reconstruction time series + + + library(car) + library(nortest) + source(paste(code_dir,"CrossValid2.R",sep="")) # leave-m-out cross-validation + source(paste(code_dir,"ssValid.R",sep="")) # split-sample validation + source(paste(code_dir,"mannken1.R",sep="")) # time plot and trend test of reg. resids + source(paste(code_dir,"stemACF.R",sep="")) # stem plot of acf, with CI & annotaton + source(paste(code_dir,"xyCI.R",sep="")) # compute polygon (for shaded CI) from lower and upper CI + source(paste(code_dir,"Table1Column.R",sep="")) # write a table file with just 1 data column + source(paste(code_dir,"TabSepTsm1.R",sep="")) # write a tab-sep file with obs, recon, 50% CI + source(paste(code_dir,"TabSepTsm2.R",sep="")) # write a tab-sep file with model input data, 50% CI + + flagBail<-0 # flag for bailing out of function + # 0 = no problems + # 1 = fatal error; message returned and program aborts + # 2 = no abortion, but calibration period had to be modified to suit coverage of climate + # series and SSR matrix; message is returned to calling program + flagMsg<-'No problems' + minLength1 <-130 # if length of series > minLength1 in reconstruction time series plot, line + # without plot characters is plotted; otherwise line with symbols + + # 1 specified calibration period too short or inconsistent with data coverage + # + #======================= UNLOAD LIST, AND RENAME SOME VARIABLES + + PdfDescribe <- D$PdfDescribe # string to be used to reference methods description file + u <-D$u ; yru<-D$yru # full length mean of SSRs + v <-D$v ; yrv<-D$yrv # full length predictand + yrgo1<-D$yrsC[1]; yrsp1<-D$yrsC[2] # desired start and end year of calib period of MSR model + yrEnd = D$yrEnd; # final reconstruction to be truncated at this year + nNeg<-D$nNeg; nPos<-D$nPos # max neg and pos lags allowed in SSR modeling + N1 <- D$NcMin # mimimum acceptable number of years for calibration of MSR model + NextFigNumber <-D$NextFigNumber # start naming figures as Figure0?.png, where ? is NextFigNumber + outputDir <-D$outputDir # outut to be written to this system folder + # Note that outputDir is also defined in the global environment. So, I think that I would + # not actually need to pass outputDir as argument to functions + HydroName <- D$Text[3] # name of hydrologic variable (e.g., "Runoff") + HydroLabel <- D$Text[1] # label of hydro variable, for plots (e.g., "RO) + HydroUnits <- D$Text[2] # units of hydro varialbe with parens, (e.g., "(mm + HydroUnits2 <- substr(HydroUnits,2,(nchar(HydroUnits)-1)) # units w/o pare s + HydroSeason <- D$Text[4] # season of hydro variable (e.g., ""12-month season ending in month 9" ) + RecMethod<- paste('Method: simple linear regression of observed',HydroLabel,'on mean SSR') + rm(D) + # all of the above are numeric or integer, except that yru is 1-col matrix + + + #============= GET CALIBRATION DATA AND CHECK THAT CALIBRATION PERIOD LONG ENOUGH + + # Compute longest possible calibration period given the overlap of u and v + yrgo2 <- max(yru[1],yrv[1]) # earliest overlap year of u and v + yrsp2 <- min(yru[length(u)],yrv[length(v)]) # earliest overlap year of u and v + + # Return error message and fail if overlap of screened SSRs (U) and available hydro series v yrsp2 + if (L2){ + yrsp1 <- yrsp2 + } + L <- L1 || L2 +# Following message commented out. User will have to live with fact we truncated calibration period to +# where compatible with data coverage + # if (L){ + # flagBail<-2 + # flagMsg<-paste('RecMLR1 message: MSR calibration period forced to ',as.character(yrgo1),'-', + # as.character(yrsp1), ' in response to available time covrage of vector of ', + # ' hydro data and matrix of screened SSRs',sep='') + # } + + #========================= PULL CALIBRATION DATA AND REGRESS + + L <- yru>=yrgo1 & yru<=yrsp1 + u1 <- u[L]; yru1<- yru[L] + + L <- yrv>=yrgo1 & yrv<=yrsp1 + v1 <- v[L]; yrv1<- yrv[L] + + M <- lm(v1~u1) # model object + M1<-summary(M) + ncalib <- length(v1) + Fits <- M$fitted.values + + #========================= STORE CALIBRATION STATISTICS + + # Significance of overall F + # M1$fstatistic has F, dfnum, dfdenom in 1-3 + pF <-pf(M1$fstatistic[1],M1$fstatistic[2],M1$fstatistic[3],lower.tail=FALSE) + + OutputCal<-list('flag'=flagBail,'Msg'=flagMsg,'lmModel'=M,'yearGoCal'=yrgo1,'yearSpCal'=yrsp1, + 'coefficients'=M$coefficients,'Rsquared'=M1$r.squared,'F'=M1$fstatistic[1],'pF'=pF, + 'RsquaredAdj'=M1$adj.r.squared,'RMSEc'=M1$sigma) + + #====================== FIGURE (local 1): 1x2 CALIBRATION PERIOD TIME PLOTS AND STATISTICS + # + # Figure files are numbered within this function with first figure as figure01.png. where + # In general, figure files are named Figure?? is a number built from NextFigNumber+jFigAdd. jFigAdd + # will start at 0 but increment for later figures + + #--- Build some strings for use in plots + strCalPd <- paste(' Calibration period: ',sprintf('%d',yrgo1),'-',sprintf('%d',yrsp1), + ' (N=', sprintf('%d',length(yrv1)),' yr)',sep='') + + #--- Build Tit1 figure png filename + + jFigAdd <- 0 # This will be the first plot added from this function + FigNumber <- NextFigNumber+jFigAdd # for naming this png + if (FigNumber<10){ + fileOut <- paste(outputDir,'Figure0',as.character(FigNumber),'-Calibration1','.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure',,as.haracter(FigNumber),'-Calibration1','.png',sep="") + } + + # Build figure + png(filename=fileOut, width = 960, height = 480) + layout.matrix <- matrix(c(1,2,3,3),nrow=2,byrow=TRUE) + layout(layout.matrix,heights=c(2,2),widths=c(1,2)) + + # Scatter + par(mar=c(4,4,2,8)) + r<-cor(M$fitted.values,v1) + strTit <- paste('Recon vs Obs ',HydroName,', r=',as.character(round(r,digits=2))) + plot(v1,M$fitted.values,ylab=paste('Recon',HydroLabel,HydroUnits), + xlab=paste('Obs',HydroLabel,HydroUnits),main=strTit) + abline(lm(M$fitted.values~v1),col="red") + + + # Statistics window + par(mar=c(0,0,0,0)) + plot(1,1,xaxt="n",yaxt="n",bty="n",pch="",ylab="",xlab="", main="", sub="", + xlim=c(0,1),ylim=c(0,1)) + strText <-paste(RecMethod,'\n',strCalPd, + '\n R-squared =',sprintf('%.2g',M1$r.squared), + '\n F=',sprintf('%.5g',M1$fstatistic[1]),'(p=',sprintf('%.4g',pF),')', + '\n RMSE=',sprintf('%g',M1$sigma),HydroUnits2,' (equivalent to std error of the estimate)') + text(x=0.05,y=0.95,'Calibration Statistics',adj=c(0,1),cex=1.5,font=2) + text(x=0.05,y=0.8,strText,adj=c(0,1),cex=1.4) + + + # time plots, obs and rec + ylims <- c(min(v1,Fits),max(v1,Fits)) + ylimsInc <- 0.05 * diff(ylims) + ylims <- c(ylims[1]-ylimsInc,ylims[2]+ylimsInc) + rm (ylimsInc) + + zx <- c(yrgo1,yrsp1) + zy <- c(mean(v1),mean(v1)) + par(mar=c(4,4,3,1)) + plot(yrv1,v1,type="b",pch=1,col="blue",xlim=c(yrgo1,yrsp1),ylim=ylims, + ylab=paste(HydroLabel,HydroUnits),xlab="Year", + main=paste('Calibration Period Observed (blue) and Reconstructed (red)',HydroName)) + lines(yrv1,M$fitted.values,type="b",pch=2,col="red") + lines(zx,zy) + h<-par("usr"); yoffset<- (h[4]-h[3])/100; ytop <- h[4]-yoffset + #legend(yrgo1+1,ytop,legend=c("Obs", "Recon"), col=c("blue", "red"), lty=1, cex=1.2) + + dev.off() + + + + #====================== FIGURE (local 2): 2x2 DISTRIBUTIONS AND ACFS + # + # CW from LL: histogram of yhat; hist of obs y; acf of obs y, acf of yhat + #--- Uniform xlims for histograms + xlo = min(c(min(v1),min(Fits))) + xhi = max(c(max(v1),max(Fits))) + xinc <- 0.05*(xhi-xlo) + xlims <- c(xlo-xinc,xhi+xinc) + rm(xlo,xhi,xinc) + #xlims <-c((c(min(v1),min(M$fitted.values))), (c(max(v1),max(M$fitted.values)))) + + #--- Build figure png filename + jFigAdd <- jFigAdd+1 + FigNumber <- NextFigNumber+jFigAdd # for naming this png + if (FigNumber<10){ + fileOut <- paste(outputDir,'Figure0', as.character(FigNumber),'-Calibration2.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure', as.character(FigNumber),'-Calibration2.png',sep="") + } + # Build figure + png(filename=fileOut, width = 960, height = 480) + # Create the layout + nf <- layout( matrix(c(1,2,3,4), ncol=2) ) + nbin <- floor(5*log10(length(v1))) # Panofsky rule of thumb for number of bins + # brks1 = seq(min(v1)*.99999,max(v1)*1.00001,length.out=(nbin+1)) + # brks2 = seq(min(M$fitted.values)*.99999,max(M$fitted.values)*1.00001,length.out=(nbin+1)) + xtweak1 <- 0.00001* (max(v1)-min(v1)); + xtweak2 <- 0.00001* (max(Fits)-min(Fits)); + brks1 = seq(min(v1)-xtweak1,max(v1)+xtweak1,length.out=(nbin+1)) + brks2 = seq(min(Fits)-xtweak2,max(Fits)+xtweak2,length.out=(nbin+1)) + xlab1 <- paste(HydroLabel,HydroUnits) + MaxLag <- floor(length(v1)/4) + + par(mar=c(5,6,2,2),cex.axis=1.5, cex.lab=1.5, cex.main=1.5) + Tit1 <- paste('Histogram, Observed',HydroLabel,'(N=',sprintf('%d',length(v1)),'yr)') + hist(v1,main=Tit1,breaks=brks1,xlim=xlims,xlab=xlab1) + + par(mar=c(5,6,2,2)) + Tit1 <- paste('Histogram, Reconstructed',HydroLabel,'(N=',as.character(length(v1)),'yr)') + hist(M$fitted.values,main=Tit1,breaks=brks2,xlim=xlims,xlab=xlab1) + + par(mar=c(5,5,4,2)) + Tit1 <- paste('ACF, Observed',HydroLabel,',with 95% CI') + acf(v1,lag.max=MaxLag,type='correlation',main=Tit1) + + par(mar=c(5,5,4,2)) + Tit1 <- paste('ACF, Reconstructed',HydroLabel,', with 95% CI') + acf(M$fitted.values,lag.max=MaxLag,type='correlation',main=Tit1) + + dev.off() + + #========================= ANALYSIS OF RESIDUALS (local 3,4,5) + # + # Will need the regression residuasl. First figure (1x2) will be histogram and + # scatter of residuals on predicted values. Second figure (1x1) will be time plot of + # the residuals with a fitted (non-parametric fit) trend line and annotated result + # of Mann-Kendall trend test. The significance will be adjusted as needed for autocorrelation + # of the residuals over and above that in a linear trend. The third figure (1x1) will be + # the acf of residuals, with annotated DW test results + + + #--- HISTOGRAM AND SCATTER OF RESIDS ON PREDICTED (1X) + # + # 1st of 3 analysis of residuals plots + + # Lilliefors test of normality of residuals + hLillie <- lillie.test(M$residuals); + Tit1 <- paste('Residuals, E, of regression of',HydroName,'on tree rings', + '\n (p=',sprintf('%.2g',hLillie$p.value),' for H0 that E normal, from Lilliefors Test)') + + # Breusch-Pagan test for heterogeneity of regresson residuals + BP <- ncvTest(M) + Tit2 <- paste('Scatter of Residuals on Fitted Values', + '\n (p=',sprintf('%.2g',BP$p),' for H0 that E homoscedastic)', + '\n(from Breusch-Pagan Test)') + + # Buld filename for plot + jFigAdd <- jFigAdd+1 + FigNumber <- NextFigNumber+jFigAdd # for naming this png + if (FigNumber<10){ + fileOut <- paste(outputDir,'Figure0', as.character(FigNumber),'-AnalysisResiduals1.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure', as.character(FigNumber),'-AnalysisResiduals1.png',sep="") + } + + # Figure size and margins + png(filename=fileOut, width = 960, height = 480) + layout.matrix <- matrix(c(1,2), nrow = 1, ncol = 2) + layout(layout.matrix,heights=2,widths=c(1,1)) + + # Left plot + + par(mar = c(5.1, 4.5, 5.1, 2.1),cex.axis=1.1, cex.lab=1.5, cex.main=1.3) + hist(M$residuals,xlab=paste('Residual',HydroUnits),ylab='Frequency',main=Tit1) + + # # right plot + par(mar = c(5.1, 4.1, 6.1, 2.1),cex.axis=1.1, cex.lab=1.5, cex.main=1.3) + plot(M$fitted.values,M$residuals,xlab=paste('Fitted Values',HydroUnits), + ylab=paste('Residual',HydroUnits), + main=Tit2) + abline(h=0,lty=2,col='#808080') # dash gray + dev.off() + + + #--- TIME PLOT OF REGRESSION RESIDUALS, WITH MANN-KENDAL TREND TEST (1X1) + + jFigAdd <- jFigAdd+1 + FigNumber <- NextFigNumber +jFigAdd + if (FigNumber<10){ + fileOut <- paste(outputDir,'Figure0', as.character(FigNumber),'.-AnalysisResiduals3.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure', as.character(FigNumber),'-AnalysisResiduals3.png',sep="") + } + + + # Prepare input for mannken1 + X <- cbind(yrv1,M$residuals) # matrix with year and regression residuals + + kopt<- c(2,1) # want plot; want adjustment of significance of Mann-Kendall statistic + # for autocorrelation if warranted + kplot <-2 # for TRISH, the time plot of residuals, with annotated MK test results + # and non-parametric-fit straight line fit to trend + ylabTemp1 <- paste('Residual',HydroUnits) + ylabTemp2 <- paste('Detrended Residual',HydroUnits) + textPlot <- c('Regression Residuals with Nonparametric-Fit Trend Line,','Year',ylabTemp1, + ylabTemp2) + Din <- list(X=X,kopt=kopt,kplot=kplot,NextFigNumber=FigNumber,textPlot=textPlot,outputDir=outputDir) + + # mannken1 to get statistics and plot + ResMK <- mannken1(Din) + rm(Din) + + + #--- ACF OF REGRESSION RESIDUALS, INCLUDING 95% Ci + + jFigAdd <- jFigAdd+1 + FigNumber <- NextFigNumber +jFigAdd + + # acf and its 95% CI + lagsPlot <- floor(min(ncalib/4,20)) + acfMy <- acf(M$residuals, lag.max=lagsPlot, type = "correlation", + plot = FALSE) + k <- acfMy$lag # lags + w <- acfMy$acf # acf + + # DW statistic of the regression residuals + DW <- durbinWatsonTest(M) + strDW <- paste('p=',sprintf('%g',DW$p), + ': Durbin-Watson test (2-sided) of H0 that population lag-1 autocorrelation is zero', + sep='') + + # Text for plot + Tit1 <- paste('ACF of Residuals with 95% CI (N=',sprintf('%g',ncalib),' yr)') + textPlot <- c(Tit1,'Lag(yr)','r',strDW,'-AnalysisResiduals3') + + # Store inputs required by stemACF in a list (see opening comments there) + Din <- list(x=k,y=w,nsize=ncalib,kAlpha=1,FigNumber=FigNumber, + outputDir=outputDir,linecol1='#0022CC',linecol2='#696969', + linecol3='#E60000',textPlot=textPlot) + ResNull <- stemACF(Din) + + + #========================= VALIDATE AND STORE STATISTICS + + ResCV <- CrossValid2(u1, v1, nNeg,nPos) # cross-validation + + # Split-sample validation + + iAstop <- ceiling(length(v1)/2) # end row index in v1 of first half of data, assumed longer than + # longer of the two halves if length of v1 odd + iBgo <- iAstop+1 # start row of second half + iA <- 1:iAstop # row indices of first half of full calib period + iB <- iBgo:length(v1) # ... of second half + + #--- Calibrate on early, validate on late, then reverse + ical<-iA; ival<-iB + i1 <- 1; # col 1 of u1 is predictor; moot because here u1 is vector + ResSS1=ssValid(v1,u1,ical,ival,i1); + REa1<-ResSS1$RE # RE for calib on early, valid on late + ical<-iB; ival<-iA + ResSS2=ssValid(v1,u1,ical,ival,i1); + REb1<-ResSS1$RE # RE for calib on late, valid on early + + OutputVal<-list('mLeaveOutCV'=ResCV$LeftOut,'REcv'=ResCV$REcv,'RMSEcv'=ResCV$RMSEcv, + 'REcalEarlyValLate'=REa1,'REcalLateValEarly'=REb1) + + #====================== FIGURE (local 6): time plots of obs y, recon, y, cv predictions of y; with observed mean line + # + #--- Build figure png filename + jFigAdd <- jFigAdd+1 + FigNumber <- NextFigNumber+jFigAdd # for naming this png + if (FigNumber<10){ + fileOut <- paste(outputDir,'Figure0', as.character(FigNumber),'-Validation1.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure', as.character(FigNumber),'-Validation1.png',sep="") + } + + # Recall + # v1,yrv1 is observed; M$fittedvalues is recon; ResCV$CVpredictions is cv-prdicted + # zx,zy are 1x2s that allow for line at observd mean; yrgo1,yrsp1 are 1st & last of calib years + + # Build figure + png(filename=fileOut, width = 960, height = 480) + par(mar=c(4,4,5,1),cex.main=1.4) + plot(yrv1,v1,type="b",pch=1,col="blue",xlim=c(yrgo1,yrsp1), + ylab=paste(HydroLabel,HydroUnits),xlab="Year", + main=paste('Time Plots of Observed, Reconstructed, and Cross-Validation-Predicted',HydroName,'(',sprintf('%d',yrgo1),'-',sprintf('%d',yrsp1),')', + '\n(black line at observed mean)')) + lines(yrv1,M$fitted.values,type="b",pch=2,col="red") + lines(yrv1,ResCV$CVpredictions,type="b",pch=17,col="#990099") + lines(zx,zy) + h<-par("usr"); yoffset<- (h[4]-h[3])/100; ytop <- h[4]-yoffset + legend(yrgo1+1,ytop,legend=c("Obs", "Recon","CVpred"), + col=c("blue", "red","#990099"),pch=c(1,2,17),lty=1, cex=1.2) + dev.off() + + + #====================== FIGURE (local 7): 1x2 VALIDATION PLOTS AND STATISTICS + + # Lilliefors test of normality of CV residuals + hLillie <- lillie.test(ResCV$CVresiduals); + Tit1 <- paste('Cross-Validation Residuals', + '\n(p=',sprintf('%.2g',hLillie$p.value),', H0: normally distributed', + ' [Lilliefors Test])',sep='') + + # Text strings for cross-validation + strAnPd <- strCalPd # built for earlier plot: gives calib period and length + + # Text strings for split-sample validation + yrtemp <- yrv1[iA] # year vector, early split + yrgoA <- yrtemp[1]; yrspA <- yrtemp[length(yrtemp)] + yrtemp <- yrv1[iB] # year vector, late split + yrgoB <- yrtemp[1]; yrspB <- yrtemp[length(yrtemp)] + rm(yrtemp) + strSplitA <- paste(' A: ',sprintf('%d',yrgoA),'-',sprintf('%d',yrspA), + ' (N=', sprintf('%d',length(iA)),' yr)',sep='') + strSplitB <- paste(' B: ',sprintf('%d',yrgoB),'-',sprintf('%d',yrspB), + ' (N=', sprintf('%d',length(iB)),' yr)',sep='') + + + #--- Build figure filename + jFigAdd <- jFigAdd+1 + FigNumber <- NextFigNumber+jFigAdd # for naming this png + if (FigNumber<10){ + fileOut <- paste(outputDir,'Figure0', as.character(FigNumber),'-Valdation2.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure', as.character(FigNumber),'-Validation2.png',sep="") + } + + # Figure size and margins + png(filename=fileOut, width = 960, height = 480) + layout.matrix <- matrix(c(1,2), nrow = 1, ncol = 2) + layout(layout.matrix,heights=2,widths=c(1,1)) + + # Left plot histogram + + par(mar = c(5.1, 4.5, 5.1, 2.1),cex.axis=1.1, cex.lab=1.5, cex.main=1.3) + hist(ResCV$CVresiduals,xlab=paste('Residual',HydroUnits),ylab='Frequency',main=Tit1) + + # right plot, stats + + par(mar = c(0,0,0,0)) + xlims <- c(0,1); ylims <- c(0,1) + plot(0,type='n',axes=FALSE,ann=FALSE,xlim=xlims,ylim=ylims) + #plot(1,1,pch=1,xlim=xlims,ylim=ylims) + strText <-paste('\nCross-validation (cv) method: leave-',as.character(ResCV$LeftOut),'out', + '\n',strAnPd, + '\n RMSEcv=',sprintf('%g',ResCV$RMSEcv),HydroUnits2, + '\n REcv=',sprintf('%.4g',ResCV$REcv), + '\n\nSplit-sample validation', + '\n',strSplitA, + '\n',strSplitB, + '\n RE{A}=',sprintf('%.2g',ResSS1$RE),' (calibrated on A, validated on B)', + '\n RE{B}=',sprintf('%.2g',ResSS2$RE),' (calibrated on B, validated on A)') + text(x=0.05,y=0.95,'Validation statistics',adj=c(0,1),cex=1.5,font=2) + text(x=0.05,y=0.8,strText,adj=c(0,1),cex=1.2) + + + dev.off() + + + #========================= RECONSTRUCTION AND 50% CI + + Xr <- as.matrix(u) # matrix, 1 col, of long-term mean of SSRs + L<-complete.cases(Xr) + Xr <- as.matrix(Xr[L,]) ; yrXr <- as.matrix(yru[L,]) + mXr <- dim(Xr)[1] + yrgo3 <- yrXr[1,1]; yrsp3 <- yrXr[mXr,1] # start and end year if recon + + # Add ones column and reconstruct + Xones<-matrix(1,nrow=mXr,ncol=1) + Xr <- cbind(Xones,Xr) + yh <- Xr %*% M$coefficients # reconstruction as 1-col matrix + yh <- cbind(yrXr,yh) + + # Delta y for 50% CI + xStdNorm75 <-qnorm(0.75, mean = 0, sd = 1, lower.tail = TRUE, log.p = FALSE) + deltaRec50 <- xStdNorm75 * ResCV$RMSEcv + yhLo <- yh[,2]-deltaRec50; yhHi <-yh[,2]+deltaRec50 + yh <- cbind(yh,yhLo,yhHi) # matrix with year, recon, lower 50 upper 50 + + # Truncate reconstruction matrix yh to end with yrEnd + Ltemp <- yh[,1] <= yrEnd # marks rows of yh to be retained + yh <- yh [Ltemp,] # truncate tsm yh + rm(Ltemp) + + + #====================== FIGURE (local 8): 1x1 TSP OF FULL RECON WITN 50% CI + + # time series for plot and CI + y <- yh[,2]; yry <- yh[,1] # for time series + + # Compute shaded polygon x and y + Xtemp <- yh[,-2] # matrix with year as col 1, lower CI as col 2, upper CI as col 2 + ResTemp <- xyCI(Xtemp) + xP <- ResTemp$x; yP <- ResTemp$y + + # Limits for plot + yLo <- min(yh[,2:4]) + yHi <- max(yh[,2:4]) + ynudge <- 0.02 * (yHi-yLo) + ylims = c(yLo-ynudge, yHi+ynudge) + xlims = c(yrXr[1]-1,yrEnd+1) + + # Strings for plot + strRecYrs <- paste(sprintf('%d',yrXr[1]),'-',sprintf('%d',yrEnd),sep='') + Tit1 <- paste('Reconstructed ',HydroName,', ',strRecYrs, + '\n(50% CI shaded; dashed line at reconstructed mean)',sep='') + ylab1 <- paste(HydroLabel,HydroUnits) + + #--- Build figure filename + jFigAdd <- jFigAdd+1 + FigNumber <- NextFigNumber+jFigAdd # for naming this png + if (FigNumber<10){ + fileOut <- paste(outputDir,'Figure0', as.character(FigNumber),'-Reconstruction1.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure', as.character(FigNumber),'-Reconstruction1.png',sep="") + } + + # Build figure + png(filename=fileOut, width = 960, height = 480) + par(mar=c(5,5,5,1),cex.main=1.4,cex.axis=1.2,cex.lab=1.2) + if (length(y)>minLength1){ + plot(yry,y,type="l",col="blue",xlim=xlims,ylim=ylims, + ylab=ylab1,xlab='Year',main=Tit1) + } else { + plot(yry,y,type="b",pch=1,col="blue",xlim=xlims,ylim=ylims, + ylab=ylab1,xlab='Year',main=Tit1) + } + abline(h=mean(y),lty=2,col='#808080') # dash gray + adjustcolor("red",alpha.f=0.5) + #polygon(yryP,yP,col='#FFEE99') # flavescent + polygon(xP,yP, col=rgb(1.00,0,0,0.1),border=NA) # mustard + dev.off() + + + + #====================== FIGURE (local 9): 2x2. + # + # At left, top and bottom are ACFs of recon for calib years and earlier + # At right is single frame with box plots or recon for same + + + #--- Pull recon for calib perod and for earlier + # w1, w2 will the reconsturction for those period + # Already have y, yry as full length recon + L <- yry >= yrgo1; # calib pd + w1 <-y[L]; yrw1<- yry[L] + L <- yry < yrgo1 + w2 <- y[L]; yrw2 <-yry[L] + + #---Make some strings for use in plots + strPd1<- paste(sprintf('%d',yrgo1),'-',sprintf('%d',yrsp1), + ' (N=', sprintf('%d',length(w1)),' yr)',sep='') + strPd2<- paste(sprintf('%d',yrgo3),'-',sprintf('%d',yrgo1-1), + ' (N=', sprintf('%d',length(w2)),' yr)',sep='') + strAnnote1 <- paste('A: ',strPd1) + strAnnote2 <- paste('B: ',strPd2) + + Tit1 <-'ACF of Reconstruction with 95% CI, Calibration Period' + Tit2 <- 'ACF of Reconstruction with 95% CI, Earlier Years' + Tit3 <- paste('Distribution of Reconstructed',HydroLabel) + + #--- Build figure filename + jFigAdd <- jFigAdd+1 + FigNumber <- NextFigNumber+jFigAdd # for naming this png + if (FigNumber<10){ + fileOut <- paste(outputDir,'Figure0', as.character(FigNumber),'-Reconstruction2.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure', as.character(FigNumber),'-Reconstruction2.png',sep="") + } + + # Figure size and margins + png(filename=fileOut, width = 960, height = 480) + layout.matrix <- matrix(c(1,2,3,3), nrow = 2,byrow=FALSE) + #layout(layout.matrix,heights=2,widths=c(1,1)) + layout(layout.matrix)#,heights=2,widths=c(1,1)) + par(mar=c(5,5,5,1),cex.main=1.4,cex.axis=1.2,cex.lab=1.2) + + #--- Upper left, acf of recon for calib pd + + MaxLag <- floor(length(w1)/4) + MaxLag <- min(c(MaxLag),20) + + par(mar=c(5,5,4,2)) + acf(w1,lag.max=MaxLag,ylim=c(-1,1),type='correlation',main=Tit1) + text(MaxLag,1,strAnnote1,adj=c(1,1),cex=1.5) + + #---Lower left, acf of recon for years before start of calib pd + + MaxLag <- floor(length(w2)/4) + MaxLag <- min(c(MaxLag),20) + + par(mar=c(5,5,4,2)) + acf(w2,lag.max=MaxLag,ylim=c(-1,1),type='correlation',main=Tit2) + text(MaxLag,1,strAnnote2,adj=c(1,1),cex=1.5) + + #---Right -- side by side box plots of recon for calib period and prior + + par(mar=c(5,8,4,1),cex.lab=1.3) + namesBP<-c('Period A','Period B') + boxplot(w1,w2,notch=FALSE,ylab=xlab1, + main=Tit3,names=namesBP) + dev.off() + + + #=== TABLE: Calibration1: summary statistics of MSR model + + #--- Header + TableTitle <- "Table3-Calibration1" + TitleAdd <- 'Calibration statistics of MSR model' + SSRdef <- ' (SSR: "single-site reconstruction")' + textH<- c(TableTitle,TitleAdd, + paste("Predictand:",HydroName,"for",HydroSeason), + RecMethod,SSRdef) + + # --- Body + textB <-c("YearGo","YearStop","R2","F","pF","R2adj","RMSEc") + TfmtB <- '%-10s\t' # format for name of variable; size for longest + DfmtsB <- c('%-4d\n','%-4d\n','%-6.2f\n','%-8.3g\n','%-8.3g\n','%-6.2f\n','%-10g\n') + dataB <- c(yrgo1,yrsp1,OutputCal$Rsquared,OutputCal$F,OutputCal$pF,OutputCal$RsquaredAdj, + OutputCal$RMSEc) + + #---Tail + textT <- c(paste('Units of RMSEc: ',HydroUnits2),PdfDescribe) + D1 <- list(textH=textH,textB=textB,TfmtB=TfmtB,dataB=dataB,DfmtsB=DfmtsB, + textT=textT,outDir =outputDir) + + #---Function call for table + ResTemp <- Table1Column(D1) + + rm(D1,textT,dataB,DfmtsB,TfmtB,textB,textH,TableTitle) + + + #=== TABLE Table4- AnalysisResiduals1 + + #--- Header + + TableTitle <- "Table4-AnalysisResiduals1" + TitleAdd <- 'Normality, autocorrelation, trend, heteroskedasticity' + textH<- c(TableTitle,TitleAdd) + + # --- Body + textB <-c("YearGo","YearStop","pNormal","DW"," pDW","TrendSlope"," pTrend", + "BP Test ChiSq"," dfBP"," pBP") + TfmtB <- '%-13s\t' # format for name of variable; size for longest + DfmtsB <- c('%-4d\n','%-4d\n','%-8.3g\n','%-5.2g\n','%-8.3g\n','%-8.5g\n','%-8.3g\n', + '%-8.5g\n','%-4d\n','%-8.3g\n') + dataB <- c(yrgo1,yrsp1,hLillie$p.value,DW$dw,DW$p,ResMK$b,ResMK$pvalue, + BP$ChiSquare,BP$Df,BP$p) + + #---Tail + + textT <- c('Tests applied include: Lilliefors, for trend; Durbin-Watson,', + 'for autocorrelation; Mann-Kendall, for trend; and Breusch-Pagan, for', + 'constancy of variance', + paste('Units of TrendSlope: ',HydroUnits2,' per year',sep=""), + PdfDescribe) + + D1 <- list(textH=textH,textB=textB,TfmtB=TfmtB,dataB=dataB,DfmtsB=DfmtsB, + textT=textT,outDir =outputDir) + + #---Function call for table + ResTemp <- Table1Column(D1) + rm(D1,textT,dataB,DfmtsB,TfmtB,textB,TableTitle,textH) + + + #=== TABLE Table5-Validation1 + + #--- Header + TableTitle <- "Table5-Validation1" + TitleAdd <- 'Cross-validation and split-sample validation' + textH<- c(TableTitle,TitleAdd) + + # --- Body + textB <-c("NleaveOut","RMSEcv","REcv","YearGoA","YearStopA","YearGoB","YearStopB", + "REsplitA","REsplitB") + TfmtB <- '%-9s\t' # format for name of variable; size for longest + DfmtsB <- c('%-3d\n','%-8.5g\n','%-5.2f\n','%-4d\n','%-4d\n', + '%-4d\n','%-4d\n','%-5.2f\n','%-5.2f\n') + dataB <- c(ResCV$LeftOut,ResCV$RMSEcv,ResCV$REcv, + yrgoA,yrspA,yrgoB,yrspB,ResSS1$RE,ResSS2$RE) + + #---Tail + + textT <- c('"NleaveOut" is number of observatations left out in cross-validation (cv).', + 'RMSE and RE refer to root-mean-square error and reduction-of-error.', + 'Start and end years are listed for split-sample early (A) and late (B) parts.', + paste('Units of RMSEcv: ',HydroUnits2,sep=""), + PdfDescribe) + + D1 <- list(textH=textH,textB=textB,TfmtB=TfmtB,dataB=dataB,DfmtsB=DfmtsB, + textT=textT,outDir =outputDir) + + #---Function call for table + ResTemp <- Table1Column(D1) + rm(D1,textT,dataB,DfmtsB,TfmtB,textB,TableTitle,textH,ResTemp) + + + #=== TABLE Table6-MSR-SLR1-Coefficients + + #--- Heading + TableTitle <- "Table6-CoefficientsMSR" + TitleAdd <- 'Coefficients of MSR regression model' + textH<- c(TableTitle,TitleAdd) + + # --- Body + textB <- c("Intercept","meanSSR") # headings of cols + TfmtB <- '%-12s\t' # format for name of variable; size for longest + DfmtsB <- c('%-12.8g\n','%-12.8g\n') + dataB <- c(M$coefficients[1],M$coefficients[2]) + + #---Tail + textT <- c(PdfDescribe) + + D1 <- list(textH=textH,textB=textB,TfmtB=TfmtB,dataB=dataB,DfmtsB=DfmtsB, + textT=textT,outDir=outputDir) + + #---Function call for table + ResTemp <- Table1Column(D1) + rm(D1,textT,dataB,DfmtsB,TfmtB,textB,TableTitle,textH,ResTemp) + + + #=== TIME SERIES DATA" RegressionInput + + #--- Title + TableTitle <- "RegressionInputTimeSeries" + textTitle<- c(TableTitle) + + #--- Head + textH <- c('Year', + paste(HydroLabel,HydroUnits),'meanSSD') + nmaxH <- max(nchar(textH)) # length of longest header string + if (nmaxH<12){ + nmaxH <-12 + } + nH <- length(textH) # number of headers + fmtH1 <- paste('%-',as.character(nmaxH),'s\t',sep='') + fmtH2 <- paste('%-',as.character(nmaxH),'s\n',sep='') + fmtsH <- rep(fmtH1,(nH-1)) + fmtsH <- c(fmtsH,fmtH2) + + # --- Body + fmtsB <- c('%-12.0f\t','%-12.8g\t','%-12.8g\n') + dataB <- cbind(as.matrix(yrv1),M$model) + + #---Tail + textT <- c("For the SLR1 regression model, second column is regressed on third", + PdfDescribe) + D1 <- list(filename=TableTitle,textH=textH,fmtsH=fmtsH,dataB=dataB, + fmtsB=fmtsB,textT=textT,outDir=outputDir) + + #---Function call for write + ResTemp <- TabSepTsm2(D1) + rm(D1,textTitle,TableTitle,textH,fmtH1,fmtH2,fmtsH,dataB,fmtsB,textT,ResTemp) + + + #=== TIME SERIES DATA: Reconstruction with 50% confidence interval + # Status. + # yh: 4 column tsm with year, recon, lower50%, upper 50% (matrix) + # v, yrv: observed predictand and years (vectors) + # v might have more recent data than yh because SSRs by lagged regression cannot extend + # beyond m years before the end of the tree-ring data, where m is maximum lag allowed + # in reconstruction model. + # In formats, make sure that field lengths for header and data match and that the length of + # non-year columns is at least as long as the longest header element + fmtsH <- c('%6s\t','%10s\t','%10s\t','%10s\t','%10s\n') # for header lin + fmtsD <- c('%6g\t','%10g\t','%10g\t','%10g\t','%10g\n') # for data matrix + + D1 <- list(header=c("Year",paste("Obs",HydroLabel,HydroUnits), + "Reconstructed","Lower 50% CI","Upper 50% CI"), + observed=cbind(yrv,v), recon=yh,outDir=outputDir, + fmtsH=fmtsH, fmtsD=fmtsD, + filename="ReconstructionWithConfidenceIntervalTimeSeries") + + ResTemp <- TabSepTsm1(D1) + + + #=== ORGANIZE DATA FOR RETURN TO CALLING FUNCTION + # + # calib period: year, obs, rec, CVpredictions, e_cal, e_cv + + CalData <- list('Year'=yrv1,'y'=v1,'yhat'=M$fitted.values,'yhatCV'=ResCV$CVpredictions, + 'Residuals'=M$residuals,'ResidualsCV'=ResCV$CVresiduals, + 'PredictorMtx'=Xr) + CalMtx <- cbind(yrv1,v1,M$fitted.values,ResCV$CVpredictions,M$residuals,ResCV$CVresiduals) + + OutputRec <- list('yearGoRec'=yrgo3,'yearSpRec'=yrsp3,'xStdNorm75'=xStdNorm75, + 'deltaRec50'=deltaRec50,'yhat'=yh,'CalibrationData'=CalData,'CalibrationMtx'=CalMtx) + + + + + + + + #=== OUTPUT BACK TO CALLING FUNCTIONS + + Output <- c(OutputCal,OutputVal,OutputRec) + + return(Output) +} \ No newline at end of file diff --git a/Recon.init b/Recon.init new file mode 100644 index 0000000..da49474 --- /dev/null +++ b/Recon.init @@ -0,0 +1,30 @@ +{ + "code_dir" : "/home/dave/Data/RlibraryMeko/", + "pdf_dir" : "/home/dave/Projects/ba2/TRISHvisual/", + "tr_file" : "siteData_Katun.txt", + "trM_file" : "siteMeta_Katun.txt", + "cl_file" : "hydroData_Katun.txt", + "outputDir" : "/home/dave/AAAtrish2/test_out/", + "NameNetwork": "ems1", + "PrewhitenOrder" : 0, + "LallowLags" : true, + "NsitesUserNetwork" : 38, + "YearScreen" : [1786,1994], + "NafterYearScreen" : 38, + "NafterPolygon" : 38, + "HydroVariable" : "RO", + "ClimDatSet" : "CRU", + "HydroSeason" : [9,12], + "yrgoc" : 1940, + "yrspc": 1990, + "ktran" : 1, + "methMSR" : 2, + "PCApredictors" : true, + "kHowPCA" : 2, + "PCoption" : 1, + "nPCsKeep" : 1, + "f" : 0.10, + "alphaR" : 0.05, + "Lcausal" : true, + "RequireStable": true +} diff --git a/ReconAnalog.R b/ReconAnalog.R new file mode 100644 index 0000000..a6052d4 --- /dev/null +++ b/ReconAnalog.R @@ -0,0 +1,1462 @@ +################################################################################ +# +# ReconAnalog.R +# Runoff reconstruction by analog and non-analog methods, all two-stage +# D Meko +# Last revised 2024-04-19 +# +# This script and functions it calls are the reconstruction framework for TRISH +# (Tree-Ring Integrated System for Hydrology), a web-based tool developed by a +# team of researchers from the University of New Hampshire (UNH) and University +# of Arizona (UA). TRISH interactively builds the reconstruction predictand from +# a global water balance model using climatic inputs from various alternative climate +# products. ReconAnalog can also be run standalone from the R prompt or in Rstudio +# with a predictand time series (e.g., a gaged flow record) supplied by the user. +# +# ReconAnalog run standalone requires a javascript object notation (json) initialization file, +# recon.init, that specifies inputs, directories, and program settings. TRISH builds this json +# file from user input at web screens. The typical user will not need to change any code in +# ReconAnalog. +# +# ReconAnalog can optionally do reconstructions by four different statistical methods, each of which +# by a pdf file written by ReconAnalog to a system output folder. +# +#================ TREE RING INPUT +# +# ReconAnalog requires input time series of tree-ring chronologies and a predictand +# seasonal hyrdrologic or climatological variable. ReconAnalog also requires metadata +# for the chronologies and specifications for the reconstruction. How ReconAnalog gets +# all this data depends on whether ReconAnalog is run within TRISH or standalone from +# your laptop in Rstudio. TRISH culls the tree-ring data from its internally stored time +# series and metadata, and prepares the predictand seasonal hydroclimatic predictand from +# monthly data via the UNM water balance model. In standalone mode, you supply the +# data files of tree-ring chronologies and metadata, and the time series of predictand +# hydroclimate data in tab-separated files with format described below. For example, +# the tree-ring time series matrix and metadata read by statements: +# +# U <- read.table(tr_file,sep="\t",header=TRUE) # input chronologies +# Tmeta <- read.table(trM_file,sep="\t",header=TRUE) # input chronologies +# +# The tree-ring time series data provided by TRISH will already have been screened for +# time coverage and geographic domain before ReconAnalog is called. Outside of TRISH, all +# chronologies in the provided file of chronologies are available for use. The time series +# and metadata used outside of TRISH should have the following form. +# +# 1) Time series. Tab-separared matrix of chronologies. The year is column 1 and the time +# series are in remaining columns. All chronologies should have data in the first year,# +# but chronologies are allowed to end in different years (e.g., NaN-filled on recent end). +# Row 1 must contain tab-separated headers, beginning with "Year" for column 1. Remaining +# headers are site ids with maximum allowed length of 12 characters, Avoid spaces or +# hyphens ("-") in site codes. +# 2) Metadata. Tab-separated metadata for the sites in the data matrix. Rows, after header row, +# should correspond to the columns of the data matrix, in the same order. +# 1 sequential number (1 to however many are in the time series matrix) +# 2 site number corresponding to the column of the chronology in the network the +# the user uploaded to UNH +# 3 site code (1-12 characters, no spaces, and maybe some other rules we should specify) +# 4 longitude east (decimal degrees; negative if west) +# 5 latitude north (decimal degrees; negatve if southern hemispher) +# 6 elevation (m above msl) +# 7 species code (4-letter code, following ITRDB convention) +# 8 data-type (1 letter code): R=total ring width, E=earlywood width, L=latewood width, +# X=maximum density. +# 9 First and last year that chronology had valid data. +# Here is and example line: +# 7 45 BUT 93.367000 64.283000 113 LAGM R 1723 1999 +# +# +# +############# JSON INITIALIZATION FILE +# +# ReconAnalog was revised in Nov 2022 so that user-settable inputs are no longer modified +# by revising lines of code, but instead by changing settings of an input JSON file (e.g., +# Recon.init). The JSON file has 28 inputs, described in some detail here. Default +# settings from Meko's trial run outside of TRISH on a Linux laptop are included. Below, for +# brevity "flow" refers to the predictand hydroclimate time series. Actually, this could be +# some other type of variable (e.g., precipitation). "SSR" and "MSR" refer to "single-site" +# reconstruction (reconstruction of flow separately from each chronology) and "multi-site" +# reconstruction (combination of the SSRs into a single final reconstruction). TRISH users do +# not need to be concerned about preparing a json init file because the json file is generated +# by TRISH by user inputs at the TRISH screens. +# +# "code_dir" : "/home/dave/Data/RlibraryMeko/", +# Directory with user-written R functions that ReconAnalog must be able to access +# "pdf_dir" : /home/dave/Projects/ba2/TRISHvisual/", +# Directory with four pdfs describing in detail the alternative reconstruction methods. +# Pdf files are copied from this directory to the output directory on the system running TRISH +# "tr_file" : "treeData.txt", +# Name of the tab-separated file with time series of tree-ring chronologies. +# "trM_file" : "treeMeta.txt", +# Name of file with tree-ring metadata. Likewise, this file is generated by TRISH from user-uploaded +# data. +# "cl_file" : "hydroData.txt", +# Name of tab-separated file with time series (year and value) of predictand climatic or +# hydroclimatic predictand. +# "outputDir" : "/home/dave/AAAtrish2/test_out/", +# The system folder to which the output will be written +# "NameNetwork": "Kyzyl", +# The name of the tree-ring network. Standalone users can set this to whatever name +# desireable; it has now effect on the computations or labeling. +# "PrewhitenOrder" : 0, +# Whether or not to prewhiten chronologies with AR model before use in regression modeling. +# If "0", do not prewhiten. If "1", "2", or "3," prewhiten with that order of AR model. Note +# that this is prewhitening at the site-chronology level, which is different from "residual" +# chronologies, which apply AR modeling to index time series from individual cores and then +# combine those. +# "LallowLags" : true +# Whether to allow lags in the models. If "false," only lag-0 models are allowed. +# If "true," lags t-2 to t+2 from the predictand are allowed in pool of potential predictors +# "NsitesUserNetwork" : 274, +# The number of sites in the network provided to TRISH by the user. Standalone, set this equal +# to the number of chronologies in the input matrix "trm_file" (see above). The column "N2" in +# file "trm_file" is a convenience allowing the user to cross-reference the time series in +# "tr_file" to an outside database of user chronologies. +# "YearScreen" : [1700,1997], +# Start and end year of mandatory common period of coverage by all chronologies +# to be used in the reconstruction. Others will be ignored by TRISH in culling the +# user's supplied tree-ring data. All culled chronologies are required to have +# complete (no missing) data for the inclusive period bracketed by "YearScreen". +# TRISH lets user input these two years and does the screening. Standalone, "YearScreen" +# has no effect, and can be set to the first and last year of the matrix in "tr_file". +# "NafterYearScreen" : 36, +# Number of chronologies remaining after screening for "YearScreen." Standalone, +# this should be set to the number of time series in the tab-separated time series +# matrix "tr_file" +# "NafterPolygon" : 36, +# Number of chronologies remaining after screening for sites being in the specified +# geographic domain (e.g., polygon drawn interactively to mark tree-ring site domain +# in TRISH ). Outside of TRISH, "NafterPolygon" is ignored, and can be set identical +# to "NafterYearScreen" and "NafterPolygon" +# "HydroVariable" : "RO", +# Code for the hydrclimatic variable represented by the predictand. Must be a member of +# a recognized set of codes. TRISH uses this code for determining how to compute seasonalized +# data (e.g., precip as a sum, temperature as a mean). The code is also used for building +# labels for figures and assigning units. From time to time, new hydrological variables +# are supported. Search for line starting "Dtypes <-" to see the currently accepted codes. +# "ClimDatSet" : "CRU", +# The source of the climate data used by UNH water balance model and TRISH to compute the +# seasonalized predictand. Must be a member of a recognized set of codes. TRISH lets the +# user select this from a dropdown menu. Outside of TRISH, "ClimDatSet" has no effect, +# and is ignored; you can set it to "CRU", for example. +# "HydroSeason" : [9,12], +# Ending month (1=jan, 12=dec) and number of months in season of predictand. "HydroSeason" +# tells TRISH how to seasonalize the target predictand from monthly data. Outside of +# of TRISH, "HydroSeason" defines the season of the input hydrologic time series predictand, +# and, should match whatever the season is of your input data in "cl_file" +# "yrgoc" : -99999, +# Desired start of y data to be used for calibrating SSR models and final (MSR) +# model. If -99999, use earliest possible year. Here, -99999 is used instead of +# NA because JSON does not handle NA. "yrgoc" should be in the range of years +# covered by the input data in "cl_file". If outside the range, "yrgoc" is forced +# to the first year of that data. +# "yrspc": -99999 +# Desired stop of y data to be used for calibrating SSR models and MSR model; If -99999, +# use latest possible year. Analogous conditions regarding NA, etc., apply as for yrgoc +# Setting both "yrgoc" and "yrspc" to -99999 lets the SSR models adapt to the +# variable overlap of chronologies with flow. Programs gives an error message if +# your setting for yrspc is inconsistent with the ending year of available predictand, the +# ending year of the most-recent-ending tree-ring chronology SSR-modeled, and the setting for +# LallowLags. Of course, yrspc cannot be set later than the ending year of the predictand. +# But it also cannot be set later than the ending year of the most-recent ending +# chronology if lags are not allowed, and no later than two years before that if lags +# are allowed. Note that the chronology constraint on yrspc is base only on the most-recent- +# ending chronology. The SSR modeling automatically truncates the calibration period to +# end earlier if some chronology has ends before the most-recent-ending chronology. +# "ktran" : 1, +# Optional transformation of the predictand, y, before reconstruction. +# None (1), square root(2) or log10 (3). The resulting reconstruction will be in units +# of transformed flow. TRISH issues error messages if the selected transformation +# is inconsistent with the data (e.g., log10 transformaton when there are flows +# of zero) +# "methMSR" : 2, +# Method for MSR reconstruction. This and PCApredictors effectively specifies the +# method to be used. (1) Simple Linear regression (SLR), (2) MLR (multiple linear regression) +# on SSRs or their PCs, (3)) Analog nearest-neighbor PCA +# "PCApredictors" : true, +# Whether PCs of the SSRs (true) or the SSRs themselves (false) comprise the pool of +# potential predictors for the MSR. +# kHowPCA <-2 # if PCA, is it done on the correlation (1) or covariance (2) matrix +# of the SSRs. Covariance matrix makes more sense if differences in the variances +# of individual time series on which the PCA is run are important. Because ReconAnalog +# runs PCA on SSRs, and because the variance of an SSR reflects its calibration accuracy, +# the best selection here is kHowPCA=2. However, the option is available to do the PCA +# on the correlation matrix. +# "PCoption" : 2, +# If reconstruction method is MLR of y on PCs of the SSRs (methMSR=2, +# PCApredictors=TRUE), PCoption specifies how many and which PCs should be in the +# pool of potential predictors. If a different reconstruction method, "PCoption" +# has no effect. Options are 1) directly specify the number of PCs, and 2) use the +# m 0) { ### AlexP addition to use input from command line argument list + json_file = as.character(inputArgs[1]) ### AlexP addition to use input from command line argument list + myData <- fromJSON(file=json_file) ### AlexP addition to use input from command line argument list +} else { + myData <- fromJSON(file="Recon.init") ### DaveM so that assumes this json name if no args in command line +} + +naJSON <- -99999 # regard -99999 as NA +X<- myData +for (j in 1:length(X)){ + a <- names(X)[j] + b <- paste(a,'<-X$',a,sep='') + s <- paste(a,'<-',b) + eval(parse(text=s)) +} +rm(a,b,s) +if (yrgoc == naJSON){ + yrgoc <- NA +} +if (yrspc == naJSON){ + yrspc <- NA +} + +### PROGRESS BAR -- FUNCTION AND FIRST CALL +# +# TRISH online tool writes a progress bar, which requires a one-line output message at various +# stages of the analysis reporting the percentage of run completed. For now, these messages are +# all writting in this main calling script ReconAnalog. We estimate that 15% of the time is taken up +# by TRISH before calling ReconAnalog -- so, the starting 15% complete. +#{ "message": "Starting the analysis...", "percent": 15 } + +# For UNH server, must use a different target path/filename for the progress update file than in Rstudio +# on laptop +if (length(inputArgs) > 0){ + pfProg <- paste(outputDir,'../status.js',sep='') # this if on UNH server +} else { + pfProg <- paste(outputDir,'ProgressTRISH.txt',sep='') # this if not on UNH server +} +pctDone <- 15; pctInc <- 0 # starting pctg done and increment of pctg to be apply next +mssgProg <- "Starting the analysis..." +ProgTrack <- function(pfProg,mssgProg,pctDone,pctInc) { + pctDone <- pctDone + pctInc + mssgThis <- paste('{ \"message\": \"',mssgProg,'\", \"percent\": ',as.character(pctDone),' }',sep='') + fprintf('%s',mssgThis,file=pfProg,append="FALSE") + return (pctDone) +} +pctDone <- ProgTrack(pfProg,mssgProg,pctDone,pctInc) + + +######## SOURCE THE FUNCTIONS ReconAnalog DEPENDS ON + +source(paste(code_dir,"TranFlow.R",sep="")) # optional transformation of flows +source(paste(code_dir,"trimnan.R",sep="")) # get indices to allow trimming of leading and trailing NA +source(paste(code_dir,"emssgUNH.R",sep="")) # write error file to system, specified output folder +source(paste(code_dir,"reconsw4.R",sep="")) # single-site reconstruction (SSR) by distributed-lag stepwise regres +source(paste(code_dir,"TrimTsm1.R",sep="")) # trim tree-ring time series matrix in preparation for SSR +source(paste(code_dir,"trimRowNA.R",sep="")) # row indices of a matrix after trimming off leading and trailing all-NA rows +source(paste(code_dir,"tsmExtend.R",sep="")) # extend time series matrix on recent end +source(paste(code_dir,"RecSLR1.R",sep="")) # Reconstruction by simple linear regression of y on mean of SSRs +source(paste(code_dir,"RecMLR1.R",sep="")) # Reconstruction by multiple linear regression or analog method +source(paste(code_dir,"SignalDrop1.R",sep="")) # drop in maximum accuracy as tree-ring network thins in recent years +source(paste(code_dir,"PrewhitenChrons.R",sep="")) # convert tsm of chronologies to prewhitened chronologies + +MinCalibLength <- 30 # hard-coded minimum allowable length of calibration period for SSR models + +########## READ FILES OF PREDICTAND, TREE-RING TIME SERIES, TREE-RING METADATA + +V <- read.table(cl_file,sep="\t",header=TRUE) # input flow; UNH will not read this in because +# user picks the hydroData variable interactively in TRISH +U <- read.table(tr_file,sep="\t",header=TRUE,check.names=FALSE) # input chronologies +Tmeta <- read.table(trM_file,sep="\t",header=TRUE) # input chronologies +# Status. U is tsm of chronologies and Tmeta is table of corresponding metadata. So far +# the chronologies in the tsm and metadata table are those satisfying (1) in polygon, and (2) complete + +# Update progress bar +mssgProg <- "Data read in..." + + +########## OPTIONAL PREWHITENING OF CHRONOLOGIES +# +# Option to prewhiten (remove autocorrelation from) chronologies using autoregressive model +# of order 1, 2, or 3 (AR(1),AR(2), AR(3)). Order 0 instructs to not prewhiten. +# Prewhitening essentially allows user to check whether "residual" chronologies might have +# stronger signal than standard chronologies for y. If so, user may want to develop +# residual chronologies as separate network and submit those to TRISH for testing. +# Prewhitened chronologies are not exactly the same as residual chronologies because with +# prehitening the autoregressive modeling is done on the site chronology, but with +# residual chronologies (as defined in dendro literature) the modeling is done on the +# standard core indices before averaging those into a site chronology. But experience +# has shown the two versions (prewhitened and residual) are very similar. + +if (PrewhitenOrder==0){ + # No action needed + PWtext <- 'Not prewhitened' + } else { + if (any(PrewhitenOrder==c(1,2,3))){ + # Call function to covert U to prewhitened chronologies + # If order p, will end up converting first p values of chronology to NA (lose p leading years) + PWtext <- paste('Prewhitened with AR(',as.character(PrewhitenOrder),') model',sep='') + ResTemp <- PrewhitenChrons(U,PrewhitenOrder,outputDir) + U <- ResTemp$Xwhitened + mssgProg <- "Data read in and chronologies whitened..." + } else { + # Invalid order (must be 1,2,or 4); stop with error message + # Write error file + emssg <- 'Allowable AR(p) prewhitening models are p=0,1,2 or 3' + ResTemp<-emssgUNH(emssg,outputDir) + stop(emssg) + } + } + +# Update progress bar +pctInc <- 5 +pctDone <- ProgTrack(pfProg,mssgProg,pctDone,pctInc) +# pctDone is 20% to her + + +# Get first and last year of the tree-ring TSM. It is assumed that this matrix has +# no all-NA rows +yrTree <- U[,1] +yrgoTree <- yrTree[1]; yrspTree <- yrTree[length(yrTree)] + + +### Check that ending year of most-recent-ending tree-ring chronology consistent with input specified +# end year of calibration period. If lags allowed, tree-ring series must extend at least 2 years +# beyond end of specified calibration period. If most-recent-ending chronology has too early an end year, +# all of the chronologies will similarly have too early an end year. Best in that case to abort here. Later, +# checks are done in function reconsw4 on individual tree ring chronologies. + +nExtra <- 0 # initialize how many years tree ring series must extend beyond yrspc +# If lags enabled, it is assumed that maximum negative and positive lag is 2 years. +# Will therefore need 2 years of tree-ring chronology after specified yrspc ending +# year of the calibration period to satisfy the +2 lag on predictors +if (LallowLags){ + nExtra <- 2 +} + +if (!is.na(yrspc)){ + L1 = yrspc > (yrspTree-nExtra) + if (L1){ + emssg <- paste('For tree matrix ending in ', as.character(yrspTree), + ', the specified last year of calibration cannot be later than ', as.character(yrspTree-nExtra), + '\n (two additional years needed for lagged model)',sep='') + ResTemp<-emssgUNH(emssg,outputDir) + stop(emssg) + } + rm(L1) +} + + +# Check that input yrgoc and yrspc -- when both are specified rather than NA -- +# are consistent with hard-coded minimum allowable length of calibration period of SSR models. +# If one or both of yrgoc and yrspc are input as NA (-99999 in Recon.init), the +# check is done series by series within function reconsw4. +L1 <- (!is.na(yrgoc) & !is.na(yrspc)) +if (L1){ + ntemp <- yrspc-yrgoc+1 + if (ntemp < MinCalibLength) { + emssg <- paste('Specified calibration years ',as.character(yrgoc), ' and ', as.character(yrspc), + ' mark a calibration period fewer than the minimum allowable ',as.character(MinCalibLength), + ' years.', sep='') + ResTemp<-emssgUNH(emssg,outputDir) + stop(emssg) + } +} + + +########## CHECK NUMBER OF SERIES IN TREE-RING MATRIX + +nms1<-colnames(U[-1]) # chronology ids; if using TRISH, for all chronologies from polygon screening +nchron<-length(nms1) # number of chrons from polygon screening +if (NafterYearScreen != nchron){ + # Write error file + emssg <- 'Number of data columns of input tree-ring matrix inconsistent with nAfterPolygon' + ResTemp<-emssgUNH(emssg,outputDir) + stop(emssg) +} + +######### BUILD SOME STRINGS TO BE USED LATER IN LABELS + +ClimDataSet <- c('CRU','Delaware','Reanalyis') # input climate data used by UNH WBM in TRISH +# This variable is included here for information only. When ReconAnalog is used +# within TRISH, the user has a dropdown window that allows selection of the input +# data. But ReconAnalog does not care about the input data set and works only with +# whatever processed WBM output or seasonalized climate series is provided. Also, +# seasonalizing monthly data is done ahead of calling ReconAnalog (either in TRISH or +# outside of TRISH), there is no need to specify that a particular variable is summed (e.g., P) +# vs averaged (T) to generate seasonal data from monthly data. +# +# Note that TRISH so far deals with only the first four Dtypes below. Other types are +# included for use of ReconAnalog outside of TRISH. For example, F1 is volume flow of a +# river in thousand acre feet (kaf). These extra types are needed so that graphics +# have properly labeled axes. Axes labels use DtypesLabel rather than Dtypes +# (e.g., "Flow (kaf)" rather than "Flow1 (kaf)". + +# Discharge, Runoff, Soil Moisture, Temperature, Precip +Dtypes <- c('Q','RO','SM','T','P','Flow1') +DtypesLabel <- c('Seasonal Q','Seasonal RO','Seasonal SM','Seasonal T','Seasonal P','Seasonal Flow') +LabsUnits <- c('(cms)','(mm)','(mm)','(Deg C)','(mm)','(kaf)') +HydNames <- c('Discharge','Runoff','Soil Moisture','Temperature','Precipitation','Flow') +ithis = which(Dtypes==HydroVariable) +if (isempty(ithis)){ + emssg<-paste(HydroVariable, ' is not one of: ', paste(Dtypes,collapse=' '),sep='') + ResTemp<-emssgUNH(emssg,outputDir) + stop(emssg) +} +Dtype<-DtypesLabel[ithis]; LabUnits<-LabsUnits[ithis]; HydName<-HydNames[ithis] + +# Text to be used in reminding user of the selected season; annotated on one of the SSR figures +MonthsOfYear <- c('Jan','Feb','Mar','Apr','May','June','July','Aug','Sept','Oct','Nov','Dec') +LabelSeason1 <- paste('Ending Month of Season = ',MonthsOfYear[HydroSeason[1]],sep='') +LabelSeason2 <- paste('Season length = ',as.character(HydroSeason[2]),' Months',sep='') + + + +########## RENAME A VARIABLE; SET UP MENU OF METHODS + +n1<- NsitesUserNetwork # number of sites in the full user-supplied network; +# system must provide this; renamed here for convenience +msrMethods <- c('SLR1','MLR1-PCA','MLR1-noPCA','Analog') + + +########## BUILD FILENAME FOR PDF DESCRIBING MSR METHOD TO BE USED +# +# This pdf will we written to system output folder. User and refer to the pdf for +# details on the method used, including definitions of downloaded output files + +if (methMSR==1){ + jMethod <- 1 +} else if (methMSR==3) { + jMethod <-4 +} else { + if (isTRUE(PCApredictors)) { + jMethod <-2 + } else { + jMethod <- 3 + } +} +PdfFile <- paste('TrishOutputDescribe',msrMethods[jMethod],'.pdf',sep='') +PdfDescribe <- paste('See',PdfFile,'for more',sep=' ') +rm(jMethod) + + +########## CLEAR OUTPUT DIRECTORY AND COPY PDF DESCRIBING MSR METHOD THERE + +PathClean <- paste(outputDir,'*',sep='') +unlink(PathClean,recursive=F,force=F) +file.copy(from=paste(pdf_dir,PdfFile,sep=''),to=paste(outputDir)) +rm(PathClean) + +############# HARD CODED SETTINGS +# +# These setting not to be changed by casual user. Can be used by developer to explore +# possibilities for extending or modifying ReconAnalog. TRISH users cannot change +# these setting from TRISH menus. Standalone users could change setttings, but run the +# risk of unintended consequences. + +nNeg<-2 #$ maximum negative lag allowed on chronologies for SSR models +nPos<-2 # maximum positive lag allowed on chronologies for SSR models +# ReconAnalog() was written to specifically apply lagged regression with maximum of +# 2 negative and positive lags on the chronology. Accordingly, leaving 9 out in +# cross-validation guarantees that cross-validation estimated do not depend on +# any of the tree-ring data that are used also in calibrating the cross-validation +# model. +# yrgo1 and yrsp1 best both set to NA. This lets the time coverage of the tree-ring data itself +# determine the time comverage of the reconstruction. In some early trialsl I played with varying +# yrgo1 and yrsp1, but decided makes more sense to go with NA +yrgo1<-yrgoTree+nNeg # desired start year of reconstruction; actual reconstruction coverage will depend on +# coverage of tree-ring chronologies in final model +yrsp1<-yrspTree-nPos # desired end year of reconstruction (including through calibration period) +# yrgo1 and yrsp1 are the desired start and end years of reconstructed flow. +# The tree-ring matrix supplied by TRISH will be trimmed in ReconAnalog() to include only +# those chronologies with data in year yrgo1-2 (allows for two negative lags in +# single-site regression). +# This will eliminate from consideration any chronologies that start at a later year. +# The tree-ring matrix will be trimmed to end in the earlier of (yrsp1+2) and (the last year +# of data for any site passing the screening for yrgo1). If yrgo1=NA, the matrix is trimmed to +# start with the first year for which all sites in the basin domain have data. If yrsp1=NA, +# the matrix is trimmed to end with the last year of data at any one of the sites. +N1 <- 50 # in forward extension of SSR matrix, common period of all SSRs must be +# at least N1 year (e.g., 50 +N2 <- 100 # in forward extension of SSR matrix, series needing an extension in year +# i must overlap by N>=N2 years with some other series that does have a value in +# year i. +N3 <- 30 # minimum acceptable number of years for calibration on MSR. Allows 15/15, which is +# ridiculously low, for split-sample validation. +incR2a<-0.01 # Critical increment in adjusted R-squared of MSR model. Stepwise model is assumed to reach +# "approximate maximum" when next step would yield increase in adjusted R-squared less than inR2a. +# Stepwise models in SSRs and MSR are not allowed to proceed beyond the approximate maximum of +# adjusted R-squared. Further, depending on "kstop" (see nex), the model may stop an an even +# earlier step to satisfy constraints on cross-validation. +kstop <-2 # Stepwise forced to stop at either the maximum adjusted R-squared (kstop=1) or at some earlier +# step if cross-validation RE reaches a maximum at an earlier step (kstop=2) +ScreenAnalogPCs <- TRUE # Screen the PCs used in analog reconstruction (methMSr=3) +# by correlation with predictand. If TRUE, only those PCs whose correlations with y +# are significant at alpha-level alphaR (see earlier) are used to identify analogs + +######### MAKE FLOWS MATRIX; TRIM OFF ANY LEADING OR TRAILING NA; STOP IF INTERNAL NA + +V<-as.matrix(V) +v<-as.matrix(V[,2]) +v <- as.numeric(v) # in case any NA in v +v <- as.matrix(v) +yrv <- V[,1,drop=FALSE] +yrv <- as.matrix(as.numeric(yrv)) + +i1<-trimnan(v) # row indices of v with leading and trailing NAs stripped +vTemp <- v[i1] +yrvTemp <- yrv[i1] + +# Check that no internal NA in the nan-trimmed time series of seasonalized climate +L<- any(is.na(vTemp)) +if (L) { + emssg<-'Internal NA (missing value) in the vector of seasonalized climate time series' + ResTemp<-emssgUNH(emssg,outputDir) + stop(emssg) +} + +# Check that the year increments by 1 in the seasonalized climate series +# (i.e., in case there is a row missing, but no internal NA) +d = diff(yrvTemp) +L<-!all(d==1) +if (L) { + emssg<-'Year for seasonal climate input does not increment by 1' + ResTemp<-emssgUNH(emssg,outputDir) + rm(ResTemp) + stop(emssg) +} + +# Row index i1 OK; re-grab vectors of the climate series and its year +V<-V[i1,,drop=FALSE] # trim the matrix of leading and trailing NAs +v <- v[i1,,drop=FALSE]; yrv<-yrv[i1,,drop=FALSE] +rm(L,d,i1,vTemp,yrvTemp) + +# Check that specified desired start and end year of calibration period consistent with time coverage of +# predictand, v. +if (!is.na(yrgoc)){ + L <- yrgoc < yrv[1] + if (L){ + emssg<-paste('Specified yrgoc=',as.character(yrgoc),' is earlier than start (',as.character(yrv[1]), + ') of seasonalized hydro series v',sep='') + ResTemp<-emssgUNH(emssg,outputDir) + rm(ResTemp) + stop(emssg) + } + rm(L) +} +if (!is.na(yrspc)){ + L <- yrspc > yrv[length(yrv)] + if (L){ + emssg<-paste('Specified yrspc=',as.character(yrspc),' is later than end (',as.character(yrv[length(yrv)]), + ') of seasonalized hydro series v',sep='') + ResTemp<-emssgUNH(emssg,outputDir) + rm(ResTemp) + stop(emssg) + } + rm(L) +} + + +############### TRANSFORM FLOWS (OPTIONAL) +# Allowed are square root or log10. Call a function to do the transform. If transform +# not reasonable physically, function called returns a flag that prompts this script +# to abort and also prints a message to outputDir + +kBogus<-FALSE +Transformed<-FALSE +if (ktran==1){ + # If not call TranFlow, set ResTf to empty list + ResTf<-vector(mode = "list", length = 0) +} else if (ktran==2 || ktran==3) { + ResTf <- TranFlow(v,ktran) +} else { + kbogus<-TRUE +} + +#--- UNH HANDLING OF TRANSFORM MESSAGE +emssg<-'None' # initialize error message +if (kBogus){ + emssg<-'Invalid specified ktran: option must be 1, 2 or 3' +} +if (length(ResTf)==0){ + sTran<-'' +} else { + if (ResTf$flag==0){ + sTran<-ResTf$sTran + V[,2]<-ResTf$x + + } else if (ResTf$flag==1) { + sTran<-'' + emssg<-'Sqrt transform invalid;
series has negative values' + } else if (ResTf$flag==2) { + emssg<- 'Log10 transform invalid;
series not all-positive' + } +} + +# Conditional error message to OutputDir +if (emssg=='None'){ +} else { + # Write error file + ResTemp<-emssgUNH(emssg,outputDir) + stop(emssg) +} + +# Depending on transform, modify y units, and store with other information applicable to +# all four MSR methods. First might have to modify label for units of y +if (ktran==1){ + # no transform, units OK +} else if (ktran==2) { + LabUnits<-paste('[sqrt',LabUnits,']') +} else if (ktran==3){ + LabUnits<-paste('[log10',LabUnits,']') +} +txtSeas <- paste0(as.character(HydroSeason[2]),'-month season ending in month ',as.character(HydroSeason[1])) +RecListx<-c(Dtype,LabUnits,HydName,txtSeas) # general list for calls to MSR recon + + +###### CHECK FOR INTERNAL NA IN TREE-RING SERIES, ABORT WITH MESSAGE IF FOUND + +emssg<-'None' +for (n in 1:nchron){ + j<-n+1 + u <- as.matrix(U[,j]) + ResTemp<-trimnan(u) # index to rows of nan-trimmed u + u1<-u[ResTemp] + L<-any(is.na(u1)) + if (L){ + emssg<-paste('Internal NA in tree-rng series ',as.character(n),': ',nms1[n]) + ResTemp<-emssgUNH(emssg,outputDir) + stop(emssg) + } +} + +################################################################################ +# +# TRIM TREE-RING MATRIX TO COVER JUST THE PERIOD NEEDED FOR SSR'S; COL-TRIM AS +# NEEDED SO THAT TSM INCLUDES ONLY THE CHRONS THAT COULD PROVIDE THE RECONSTRUCTION +# TIME COVERAGE; ALSO ROW-TRIM THE TREE-RING METADATA TABLE ACCORDINGLY +# +# See earlier comments for inputs yrgo1 and yrsp1 +# +# The reconstruction method allows lags t-2 to t+2 on tree ring. Therefore, if you +# specify you want the reconstruction to start in year t0, all series must have +# data in year t0-2. This next section may therefore reduce the number of colunns in +# the tree ring matrix by removing those without data in year to-2. The matrix will +# be row-truncated to begin in year yrgo1-2 and to stop in the earlier of +# [year yrsp1+2 and the last year with data for any chronology] + +mlead<-2; # this many leading tree-ring values are needed to produce first reconstructed value +ResTrim1 <- TrimTsm1(U,yrgo1,yrsp1,nNeg,nPos) +X<-ResTrim1$X # tsm of tree-ring chronologies to be converted by SSR +ix2 <- ResTrim1$ix # index of series in X to the columns of tsm of map-screened chronologies +# provided by system +nms2 <- nms1[ix2] # column names of the (possibly) column-reduced tree-ring matrix +# These ids are identically equal to the colnames (after Year) of X, as returned +# by TrimTsm1() + +# Metadata trimming,and check for exact match of column headers of chronology tsm with +# Ids in the metadata +Tmeta <- Tmeta[ix2,] # row-trim +IdMeta=Tmeta$Id +IdMeta <- gsub(" ", "", IdMeta, fixed = TRUE) +L<-identical(IdMeta,nms2) +#--- Bomb message if not exact match +emsg1 <- c('Ids in header row of time series matrix of chronologies do not exactly match Ids in metadata') +if (!L){ + eBomb<-emssgUNH(emsg1,outputDir) + stop(eBomb) +} + +#--- Compute last allowable end year for SSR calibration. Could be limited by last +# yeqr of available tree rings or last year of available predictand. And must consider if +# lags allowed on tree rings. +yrT <- X[,1] # year vector for tree-ring matrix of those chronologies to be SSR modeled +yrTend <- yrT[length(yrT)]# last year of the SSR-capable tree-ring matrix +if (LallowLags){ + yrspcLimitT <- yrTend-2 # limit on end year of SSR calibration imposed by tree-ring coverage +} else { + yrspcLimitT <- yrTend +} +yrspcLimitv <- yrv[length(yrv)] # limit on end year of SSR calibration imposed by predictand coverage +end +yrspcLimit <- min(c(yrspcLimitT,yrspcLimitv)) # SSR calib period cannot end later than this year + +################################################################################ +# +# CONVERT TREE-RING SERIES TO SINGLE-SITE RECONSTRUCTIONS (SSR's) OF FLOW +# +# All series in X will be converted. The regression statistics and the SSRs will be +# stored. Only a subset of those SSRs, depending on the calibration and validation +# statistics, will ultimately be used in the PCA analysis and final reconstruction. +# The SSR statistics will include a "reject" flag, which will be used to screen out +# bad tree-ring sites. A site will be rejected if any of the following are true: +# 1) p-value of overall F of regression model >=0.05 +# 2) REcv (Reduction of error statistic from leave-9-out cross-validation) <=0 +# 3) RE from either half of split-sample cross-validation <=0 +# 4) Model uses just past tree-ring index to reconstruct current y (optional, see Lcausal input) +# +# SSR modeling is done by reconsw4(), and comments there have more details on the method. +# Essentially, y(t) (flow in year t) is regressed stepwise forward on tree-ring +# {x(t-2), x(t-1), x(t), x(t+1),x(t+2)}. Entry of variables is stopped if no increase +# in validation skill, or very small in increase in adjusted R-squared (see input ktop) + +# SSR time series will be in matrix Y1; these will be the full set of estimated SSRs +nchron2 <- dim(X)[2]-1 # number of chronologies after screening for time coverage +nY1<-nchron2; +mY1 <- dim(X)[1] # Y1 will store the SSRs, and will initially be same size as X +Y1 <- matrix(data=NA,nrow=mY1,ncol=nchron2) # to hold the SSRs +yrY1 <- matrix(X[,1]) +yrgoY1<-yrY1[1,1] +yrspY1<-yrY1[mY1,1] + + +#--- Table of statistics of all models passing the spatial-temporal screening. +# The data frame SSRdf1 is the summary table, described below. A second table, +# SSRdf2, has a similar structure, but includes only those site passing statistical +# screening for a strong, validated, temporally stable signal for flow. + +SSRdf1 <- data.frame(matrix(nrow = nchron2, ncol = 16)) +names(SSRdf1) <- c("N1", "N2","Site","StartC","EndC","Model","Sign","R2adj","Fp", +"REcv","REa","REb","Refit","StartR","EndR","Reject") +# N1, N2, are sequential number in this table, and in the user's full network. +# Site is a site id; StartC & EndC are first and last years of calibration period; +# Model is a coded string indicated which of lags t-2 to t+2 are in final model +# and the order of entry; Sign is a similar string indicating sign of regression +# coefficients +# R2adj is regression adjusted R-square; Fp is the p-value of overall F of the +# regression (pF<0.05 means significant model); +# REcv is th reduction-of-error statistic from leave-9-out cross-validation; REa +# and REb are reduction-of-error for split-sample calibration/validation (e.g., +# REa is for validation on first half when model is fit to second half; +# Refit is a logical (0 0r 1) indicating whether the final selectio of lags +# allowed refitting of the model to a slightly longer calibration period than +# possible if all lags t-2 to t+2 are in model; +# StartR and EndR are the start and end years of the reconstruction (SSR for this site) +# Reject is a logical (0 or 1) indicating if site was rejected for further use in +# in reconstruction. Note that only sites not rejected are used in the later +# PCA step. Numbering n3 therefore goes with sites having a 0 in this column. + + +#--- Generate SSRs +# +# Function reconsw4() is called in a loop over all chronologies in the drawn polygon +# that covers the minimum acceptable reconstruction interval input at the TRISH window. +# Each chronology is converted to an individual estimate of flow by lagged stepwise +# forward regression. Five lagged values, lagged t-2 to t+2 from the year of flow, are +# considered as potential predictors. The forward stepwise process is stopped when an +# an additional step would result in less than c1 increase in adjusted R squared. +# Leave-9-out cross-validation and split-sample calibration/validation are then applied +# to test the skill of prediction and to possibly simplify the model. Input option +# "LallowLags" lets you forgo the lags, and in that case also uses leave-1-out +# cross-validation, +# +# Status: V and X are data frames with prepared flows and tree-ring chronologies + +timeGo<-proc.time() # start timer to check cpu time and clock time for running +yrsCalWindow <- c(yrgoc,yrspc) # calibration of model will consider flows only within this +# window + +SSRprelim<-vector(mode="list",nchron2) # to hold lists from preliminary SSR modeling for each chronology +SSRlags1 <- vector(); SSRlags2<-vector() # initialize empty vectors to hold concatenated lags +# in models (all SSRs for1 ; those passing final screening for 2) +# Fill list SSRdf1 members with network site numbers and site IDs as supplied in list treeMeta +SSRdf1[,2]<-Tmeta$N2 +SSRdf1[,3]<-IdMeta + +# Progress bar strategy. Know have 20 % done and will allocate additional 65% to SSR modeling, which +# can be time consuming, especially when there are many chronologies Will update +# progress every 20 chronologies. If 20 or few chronologies only one updated needed +nslabs <- ceil(nchron2/20) # will divide the available 45% into nslabs increments such than +# percentage work required for SSR modeling will not exceed 45% +pctInc <- floor(65/nslabs) +rm(nslabs) + +iprogress <- 0 # for updating progress bar every 20 SSRs + + +for (n in 1:nchron2){ # loop over tree-ring chronologies + x <- as.matrix(X[,c(1,(n+1))]) # 2-col data frame with year and chronology + + # #debug on test reconsw4 + # # Uncomment block after debugging + # if (n==26){ + # save(x,V,nNeg,nPos,yrsCalWindow,incR2a,Lcausal,LallowLags,MinCalibLength,RequireStable, + # file = "a1.RData") + # } + # #debug off + + ResSSR <- reconsw4(x,V,nNeg,nPos,yrsCalWindow,incR2a,Lcausal,LallowLags, + MinCalibLength,RequireStable) + SSRprelim[[n]]<-ResSSR + SSRdf1[n,1]<-n + SSRdf1[n,4]<-ResSSR$yearsCal[1] + SSRdf1[n,5]<-ResSSR$yearsCal[2] + SSRdf1[n,6]<-ResSSR$ModelCoded + SSRdf1[n,7]<-ResSSR$ModelSign + SSRdf1[n,8]<-ResSSR$RsquaredAdj + SSRdf1[n,9]<-ResSSR$Fp + SSRdf1[n,10]<-ResSSR$REcv + SSRdf1[n,11]<-ResSSR$REa + SSRdf1[n,12]<-ResSSR$REb + SSRdf1[n,13]<-ResSSR$Lrefit + SSRdf1[n,14]<-ResSSR$yearsRec[1] + SSRdf1[n,15]<-ResSSR$yearsRec[2] + SSRdf1[n,16]<-ResSSR$Lreject + + # Build vector of lags in models (1=t-2... 5=t+2) + # Make two versions: one for all SSRs, the other for those passing screeing. + # Result (SSRlags1, SSRlags2) are vectors with the concatenated lags in models. + # Values 1,2,3,4,5 correspond to lags t-2,t-2,t,t+1,t+2 + + SSRlags1 <- c(SSRlags1,ResSSR$Model) + if (!ResSSR$Lreject){ + SSRlags2 <- c(SSRlags2,ResSSR$Model) + } + + #---Store this SSR in matrix of SSRs + irow <- ResSSR$yhat[,1]-yrgoY1[1]+1 # target rows in Y1 + Y1[irow,n]=ResSSR$yhat[,2,drop=FALSE] + + # Update progress if have run through 20 + iprogress <- iprogress + 1 + if (iprogress >= 20){ + # Update progress bar + mssgProg <- paste(as.character(n),'/',as.character(nchron2),' SSR models completed...',sep='') + pctDone <- ProgTrack(pfProg,mssgProg,pctDone,pctInc) + iprogress <- 0 # re-initialize counter + } else { + } +} + +# Progress bar message about SSR modeling complete +if (pctDone>85){ + error('Programming error: pctDone should be less than 85% after SSR modeling') +} +mssgProg <- "SSR modeling completed..." +pctDone <- 85; pctInc <-0 # Move progress to 85% when all SSR modeling done +pctDone <- ProgTrack(pfProg,mssgProg,pctDone,pctInc) + +#---Trim off any all-NA rows of SSR matrix Y1 +i1<- trimRowNA(Y1) +if (is.vector(i1)){ + Y1<-Y1[i1,,drop=FALSE] + yrY1<- yrY1[i1,,drop=FALSE] +} +rm(i1) + +mSSRdf1<-nrow(SSRdf1) # number of rows in the table + + + +#--- Write SSR results for all chronologies models to a file using fprintf +pf1<-file.path(outputDir,paste("Table1-SSR1",".txt",sep="")) +if (file.exists(pf1)){file.remove(pf1)} # must remove old versio of file +fmt1<-"%4s%4s%8s%7s%5s%8s%8s%6s%9s%8s%6s%6s%7s%6s%6s%7s\n" +fmt2<-"%4d%4d%8s%7d%5d%8s%8s%6.2f%9.2G%8.2f%6.2f%6.2f%7s%6d%6d%7s\n" +TitleLine <- 'Table1-SSR1 - Statistics of single site reconstruction (SSR) models' +fprintf('%s\n\n',TitleLine,file=pf1,append=FALSE) +fprintf(fmt1,"N1","N2","Site","Goc","Endc", "Model","Sign", "R2a", "pF", "REcv", "REa", + "REb", "Refit", "Gor", "Endr", "Reject",file=pf1,append=TRUE) +for (n in 1:mSSRdf1){ + fprintf(fmt2,SSRdf1[n,1],SSRdf1[n,2],SSRdf1[n,3],SSRdf1[n,4],SSRdf1[n,5], + SSRdf1[n,6],SSRdf1[n,7],SSRdf1[n,8],SSRdf1[n,9],SSRdf1[n,10], + SSRdf1[n,11],SSRdf1[n,12],SSRdf1[n,13],SSRdf1[n,14],SSRdf1[n,15], + SSRdf1[n,16],file=pf1,append=TRUE) +} +fprintf('%s\n\n','',file=pf1,append=TRUE) +fprintf('%s\n','This table applies to chronologies before screening for hydrologic signal', + file=pf1,append=TRUE) +fprintf('%s\n',paste('Chronologies:',PWtext),file=pf1,append=TRUE) +fprintf('%s\n',PdfDescribe,file=pf1,append=TRUE) + + +#--- Make second table, SSRdf2, a data frame that is a subset of SSRdf1 with just those +# chronologies not rejected according to the Lreject criterion. +Lreject<-SSRdf1[,16] + +# If no chronologies have stable signal for flow, bail, with suggestions to user +if (all(Lreject)){ + emssgThis<- paste('ReconAnalog aborted:', + '\nNo chronology has a stable signal for ', HydName,'.', + '\nSome things you can try: ', + '\n1) turn off \"Reject non-stable\" in "Reconstruction Model Specifications" section;', ### AlexP change + '\n2) use a different climate variable or season;', + '\n3) try a different climate polygon or screening of the tree-ring network.', + sep='') + eBomb<-emssgUNH(emssgThis,outputDir) + stop(eBomb) +} + +# If only one chronology has as stable signal and you have called for PCA, punt +nGood <- sum(!Lreject,na.rm=TRUE) +if ((nGood == 1) && (methMSR==2 | methMSR==3) ){ + emssgThis<- paste('ReconAnalog aborted:', + '\nOnly one chronology has a stable signal for ', HydName,'.', + '\nThe selected multivariabe reconstruction method does not apply. You can try this: ', + '\n1) to get a reconstruction from this one site, select \"SLR\" as reconstruction \"Method\"', + '\n2) try a different climate variable or season;', + '\n3) try a different climate polygon or screening of the tree-ring network.', + sep='') + eBomb<-emssgUNH(emssgThis,outputDir) + rm(nGood) + stop(eBomb) +} + + +ix3 <- ix2[!Lreject] # col-pointer of "accepted" series to original tree-ring matrix +nms3 <- nms2[!Lreject] # ids of series passing screening +SSRdf2<-SSRdf1[!Lreject,] +mSSRdf2<-nrow(SSRdf2) # number of rows in the table +j1<- 1:mSSRdf2 +SSRdf2[,1]=j1 + +pf2<-file.path(outputDir,paste("Table2-SSR2",".txt",sep="")) +if (file.exists(pf2)){file.remove(pf2)} # must remove old version of file +fmt1<-"%4s%4s%8s%7s%5s%8s%8s%6s%9s%8s%6s%6s%7s%6s%6s%7s\n" +fmt2<-"%4d%4d%8s%7d%5d%8s%8s%6.2f%9.2G%8.2f%6.2f%6.2f%7s%6d%6d%7s\n" + +TitleLine <- 'Table2-SSR2 - Statistics of screened single site reconstruction (SSR) models' +fprintf('%s\n\n',TitleLine,file=pf2,append=FALSE) + +fprintf(fmt1,"N1","N2","Site","Goc","Endc", "Model","Sign", "R2a", "pF", "REcv", "REa", + "REb", "Refit", "Gor", "Endr", "Reject",file=pf2,append=TRUE) +for (n in 1:mSSRdf2){ + fprintf(fmt2,SSRdf2[n,1],SSRdf2[n,2],SSRdf2[n,3],SSRdf2[n,4],SSRdf2[n,5], + SSRdf2[n,6],SSRdf2[n,7],SSRdf2[n,8],SSRdf2[n,9],SSRdf2[n,10], + SSRdf2[n,11],SSRdf2[n,12],SSRdf2[n,13],SSRdf2[n,14],SSRdf2[n,15], + SSRdf2[n,16],file=pf2,append=TRUE) +} +fprintf('%s\n\n','',file=pf2,append=TRUE) +fprintf('%s\n','This table applies to chronologies passing screening for hydrologic signal', + file=pf2,append=TRUE) +fprintf('%s\n',paste('Chronologies:',PWtext),file=pf2,append=TRUE) +fprintf('%s\n',PdfDescribe,file=pf2,append=TRUE) + +#--- Make time series matrix of SSRs passing signal for screening (n0n-rejects) +Y2 <- Y1[,!Lreject,drop=FALSE] +yrY2 <-yrY1 + +#---Trim off any all-NA rows of SSR matrix Y2 +i1<- trimRowNA(Y2) +if (is.vector(i1)){ + Y2<-Y2[i1,,drop=FALSE] + yrY2<- yrY2[i1,,drop=FALSE] +} +mY2<-dim(Y2)[1] # number of rows in Y2 +jScreened=SSRdf2$N2 # pointer from cols of screened SSRs +# to columns in original users tree-ring network + +Tcpu<- (proc.time()-timeGo)[1] #...... processing time +Tclock<- (proc.time()-timeGo)[3] #...... clock time + + +################################################################################ +# +# ANALOG EXTENSION OF SCREENED SSR'S ON RECENT END +# +# This extension is included to allow use of as long a calibration period as possible +# for the MSR model when tree-ring chronologies have variable ending year. For an +# example of why this extension might be useful, consider a matrix of 10 tree-ring +# chronologies, 9 of which end in year 2022 and the other in 1998. Say you are using +# a PCA-based reconstruction method, which dictates that the ending year of the +# reconstruction is no later than the earliest-ending chronology. The method described +# here works with the SSRs, or the single-site reconstructions generated from individual +# chronologies, and extends the SSR of the earliest-ending SSR so that it ends in 2022 instead +# of 1995. This extension gives 28 additional years to the calibration period of the +# MSR model. +# +# Have, say, N SSRs. Have a target end year that you want all series to cover. +# The first step is to find the common period for all N SSRs and compute the +# correlation matrix (Spearman) for that common period. +# Loop over all N SSRs, each time defining the current series as "key" and the +# rest as "others." Loop over key series: (1) Spearman r of key with others, and +# sorting of others from most correlated to least. (2) Proceed for next steps going +# from most to least correlated. (3) Pull full overlap of the two series -- this could +# generally be longer than the common period used for the Spearman correlation matrix. +# (4) Loop over the years of key series needing filled in. (5) Fill in all that are possible +# from this member of others. (6) If still values to fill, proceed over more +# of the others, in sequence from the member of others most correlated with key to the +# member least correlated. The analog values is computed as folows. +# +# Analog method used, assuming have a key series and a predictor and the data +# for the full overlap of the two series. Sort the two series from smallest to largest for +# that overlap. Have the value, x, of the predictor series for the year with data missing +# at key series. Compute the non-exceedance probability of that value in the predictor +# series for the overlap. Assign the estimate as the interpolated value of the +# kwy series with the same non-exceedance probability in the overlap. + +# Truncate matrix Y2, yrY2 on early end so that first row has no NA. After that truncation, +# Y2 should have no NAs on early end, but generally will have NAs in some cols on recent end +i1 <- which(complete.cases(Y2)) +Y2 <- Y2[i1[1]:mY2,,drop=FALSE] +yrY2 <- yrY2[i1[1]:mY2,,drop=FALSE] + +#--- Call function to extend tree-ring matrix on recent end +ResME <- tsmExtend(Y2,yrY2,yrsp1,N1,N2) # returns named list with Y, yrY + +#--- Bomb out messages from tsmExtend() +emsgs2 <- c('No need to extend','OK, but yrsp later than last year of data in X', + 'No problem','tsmExtend aborted: common period of all series too short', + 'tsmExtend aborted: insufficient common period of predictor and predictand', + 'tsmExtend aborted: yrX not continuous','tsmExtend aborted: first year of X has some NA') +khow<-ResME$khow +if (khow>3){ + emsg2<-emsgs2[[khow]] + eBomb<-emssgUNH(emsg2,outputDir) + stop(eBomb) +} + +Y3 <- ResME$Y; yrY3 <- ResME$yrY # forward-extend tree-ring matrix +if (any(is.na(Y3))){ + eBomb<-emssgUNH('ReconAnalog() aborted: matrix Y3 has a NA',outputDir) + stop(eBomb) +} + +# Revision 2023-05-16, th en re-revised 2023-11-22, to set the end year for the reconstructed y as the last year +# of the quantile-extended matrix of SSRs. The user should be aware that the recent end of the +# reconstruction could be be based on statistically extended tree-ring data for some chronologies. +# This could be very bad if, for example, the most recent chronology has a weak SSR signal. One of the +# SSR plots shows the drop in strongest SSR signal as chronologies drop out. This plot can be used +# as a guide for the last you should trust the reconstruction. +yrEnd <- yrY3[length(yrY3)] + + +################################################################################ +# +# FIGURES FOR SINGLE-SITE RECONSTRUCTIONS +# +# Idea is that in TRISH user can use radio button choose from 1) bar chart of site-screening, +# 2) boxplot summaries of model statistics, 3) line plot of time coverage of SSRs, and +# 4) z-score time-series plot (annual and smoothed on one set of axes; mean of the SSRs +# after converting to z-scores) +n2 <-nchron # number of sites returned by polygon screening +n3 <- length(ix2) # number of chronologies after screening for reconstruction window +n4 <- dim(Y3)[2] # number of chronologies passing final screening for hydrologic signal + + +#----FIGURE 01. 1x2 OF 1)BAR PLOT SUMMARIZING NUMBER OF CHRONOLOGIES, ORIGINAL AND SCREENED, +# AND 2) ADJUSTED R-SQUARED OF ALL FITTED SSR MODELS AND OF THOSE PASSING FINAL +# SCREENING FOR HYDROLOGIC SIGNAL + + +#--- Numbers of chronologies (bar chart) + +# Preliminaries +xtemp <- c(n1,n2,n3,n4) +DeltaTemp<- 0.1*(max(xtemp)-min(xtemp)) + +#yhi <- 0.1*(max(xtemp)-min(xtemp)) + max(xtemp) +yhi <- DeltaTemp + max(xtemp) +ylo <- 0 +ylims <- c(ylo,yhi) +ylims2 <- ylims +ylims2[2]<-ylims2[2]+0.4*ylims2[2] +DeltaTemp2 <- ylims2[2]/30 + +barnames <- c('N1','N2','N3','N4') + +strAnnote1<-paste('\nN1: source network','\nN2: polygon-selected', + '\nN3: SSR-modeled','\nN4: Passed screening') + +png(filename=paste(outputDir,"Figure01-SSR1.png",sep=""), width = 960, height = 480) +layout.matrix <- matrix(c(1,2), nrow = 1, ncol = 2) +layout(layout.matrix,heights=2,widths=c(2,1)) +par(mar=c(5,4,4,4),cex.main=1.3) + +bp <- barplot(xtemp,ylim=ylims2,xlab='Screening Stage',col='Pink',border=TRUE, + names.arg=barnames,main='Number of Chronologies',cex.lab=1.3) +text(bp,xtemp+DeltaTemp2,labels=xtemp) +abline(h=0) + +# Annotate meaning of N1, N2, N3, N4 +xtemp <- 3.65; ytemp <- ylims2[2] +text(xtemp,ytemp,strAnnote1,adj=c(0,1),cex=1.2) + +rm(xtemp,barnames,ylims,ylims2,bp,DeltaTemp2) + +#--- Adjusted R squared + +#screen(2) +par(mar=c(5,4,4,1),cex.main=1.3) + +namesBP<-c('N3','N4') +boxplot(SSRdf1[,8],SSRdf2[,8],notch=FALSE, + ylab = "Adj R-squared of SSR Models", + main="Adjusted R-squared",names=namesBP, + cex.lab=1.2) +dev.off() + +#----FIGURE 02. 1x2 OF HISTOGRAMS OF WHICH LAGS ARE IN THE SSR MODELS. 1) ALL SSRS, AND +# 2) THOSE SSRS PASSING SCREENING FOR HYDROLOGIC SIGNAL. EACH SSR MODEL MAY HAVE +# FROM 1-5 LAGS, RANGING FROM t-2 to t+2 YEARS FROM THE YEAR OF FLOW. THE HISTOGRAMS +# SUM OVER MODELS, SO THA THE GRAND TOTAL NUMBER OF LAGS IN THE HISTOGRAM IS +# GREATER THAN THE NUMBER OF MODELS. + + +#--- Left: Histogram of lags, all N3 SSRs + +png(filename=paste(outputDir,"Figure02-SSR2.png",sep=""), width = 960, height = 480) +layout.matrix <- matrix(c(1,2), nrow = 1, ncol = 2) +layout(layout.matrix,heights=2,widths=c(1,1)) + +# Left histpgram +par(mar=c(5,4,4,1),cex.main=1.4) +hBreaks<-c(0.5,1.5,2.5,3.5,4.5,5.5) +# Changing x axis +xTicks<-seq(1, 5, by=1) +xTickLabs <- c('-2','-1','0','+1','+2') +n3a<-length(SSRlags1) +title1<-paste('Histogram of Lags (',n3,'N3 Models,',n3a,'Total Lags)') +hist(SSRlags1,breaks=hBreaks,xlim=c(0.5,5.5),xaxt='n', + main=title1,xlab='',cex.lab=1.2) +vtemp<-par('usr') +mtext('Lag (yr)',side=1,line=1.5,cex=1.2) +for (k in 1:5){ + mtext(xTickLabs[k], side = 1, line = 0, outer = FALSE, + at = k, adj = NA, padj = NA, cex = NA, col = NA, + font = NA) +} + + +#--- Right: Histogram of lags, SSRs passing screening for hydro signal + +ylims<-c(vtemp[3],vtemp[4]) # same y limits as previuous +par(mar=c(5,4,4,1)) +hBreaks<-c(0.5,1.5,2.5,3.5,4.5,5.5) +# Changing x axis +xTicks<-seq(1, 5, by=1) +xTickLabs <- c('-2','-1','0','+1','+2') +n4a<-length(SSRlags2) +title2<-paste('Histogram of Lags (',n4,'N4 Models,',n4a,'Total Lags)') +hist(SSRlags2,breaks=hBreaks,xlim=c(0.5,5.5),ylim=ylims,xaxt='n', + main=title2,xlab='',yaxs='i',cex.lab=1.2) +mtext('Lag (yr)',side=1,line=1.5,cex=1.2) +for (k in 1:5){ + mtext(xTickLabs[k], side = 1, line = 0, outer = FALSE, + at = k, adj = NA, padj = NA, cex = NA, col = NA, + font = NA) +} +dev.off() + +#----FIGURE 03. 1x1. TWO-Y-AXIS TIME PLOT TO HELP GUIDE USER IN CHOICE OF +# CALIRATION PERIOD FOR MULTI-SITE-RECONSTRUCTION (MSR) MODEL. +# +# Before extension by tsmEndtend, the signal-screened SSRs generally end in +# different years. These time plots cover the tail years of the SSRs: from +# the last year with data for all SSRs through the last year of the SSR with +# most recent data. One plot is the maximum adjusted R-squared of available +# SSRs. The other plot is the number of available SSRs. Annotated on the plot +# is also the ending year of the observed hydro variable. The user will eventually +# need to select the end year of calibration of the MSR model. This year +# cannot be later than the last year of the observed hydro series. The year could +# be as late as the last year SSR at any site, but this may not be a good +# idea if the adjusted R-squared of the most recent SSR is small. +# +# It is also possible that the last available hydro data for calibration ends +# before the ending year of the earliest-ending SSR. In that case this plot of drop +# in R-squared as chronologies drop out toward the present be just a curiosity because +# the end year of the calibration period cannot be later than the end year of the +# hydro series + +#--- Prepare data needed for the plots +# +# Status. Have full-length observed hydro in 1-col matrices, yrv, v. +# Have the adjusted R-squared of signal-screened models in SSRdf2[,8]. +# Have the corresponding end years of the SSRs in SSRdf2$EndR. +# Have time series of SSRs in matrices Y3,yrY3 +ResSD <- SignalDrop1(SSRdf2$EndR,SSRdf2[,8]) +x1 <- ResSD$x1; x2 <- ResSD$x2; yrx1 <- ResSD$yrx1; yrx2 <- ResSD$yrx1; + +# Want x axis to start year before and end year after the relevant period +yrsEnd <- unique(SSRdf2$EndR) # unique ending years of screened SSRs +xHead <- max(yrv) # head of arrow here; also is last year of available hydro series +#yrLo <- min(yrsEnd) +yrLo <- min(min(yrsEnd),xHead-5) # xHead-5 in case hydro series ends before end of any SSR +yrHi <- (xHead - yrLo) + xHead +yrHi <- max(yrHi,max(yrsEnd)+2) +xlims <- c(yrLo-0.05,yrHi+0.05) # limits for x axis +ylims <- c(min(x1)-0.2,max(x1)+0.2) # limits for y axis + +# Arrow +yHead <- ylims[1]+ diff(ylims)/2 +yTail <- yHead + diff(ylims)/10 +xTail <- xHead+ (xlims[2]-xHead)/2 # x position of tail + +#--- yyplot +png(filename=paste(outputDir,"Figure03-SSR3.png",sep=""), width = 960, height = 480) +par(mar=c(5,5,4,5),cex.main=1.4) +plot(yrx1,x1,xaxt='n',yaxt='n',type="b",pch=1,col='red3',xlim=xlims,ylim=ylims,cex=1, + main='Drop in Signal Strength with Loss of SSRs (Chronologies) on Recent End',xlab='Year', + ylab='Number of SSRs',cex.lab=1.2) +# vertical line at last year of hydro series +axis(1,at=seq(yrLo,yrHi,1)) +axis(2,at=seq(min(x1),max(x1),1)) +abline(v=max(yrv),col='Magenta',lty=2) + +# arrow to the vertical line +arrows(xTail,yTail,xHead,yHead) +txtTemp<- paste('Last year of',Dtype) + +# annotate seasons and end year of specified calibration of recon models +# Calibration period of SSR could end sooner if chronology ends sooner, but +# period not allow to extend more recent than specified year. + +# String for calibration period end year. NA indicates let the data +# determindx the end year, which will depend on then end year of chronology, end year +# of y, and whether lags allowed. +strEnd <- paste(as.integer(yrspc),'=','specified calib. end year',sep=' ') + +# String for latest feasible end year of calibration period. Depends on on end years of +# y and of chronologies, and also on whether lags allowed. The key chronology for this determination +# is the one ending most recently, because ReconAnalog automatically extends SSRs by a quantile +# extension algorithm to the year of the most-recent ending SSR. The actual calibration periods for +# individual SSRs can end earlier than this last feasible end year, because the function reconsw4 +# will trim back the calibration period end year if is not possible given the end year of the +# chronology and the optional lagging. +if (LallowLags){ + yrspF <- yrspcLimit # last feasible end year for SSR calibration period; + strF1 <- ' (assuming lags allowed)' +}else{ + yrspF <- yrspcLimitv # last feasible end year for SSR calibration period; + strF1 <- ' (assuming lags allowed)' +} +strEndF <- paste(as.integer(yrspF),'=','latest feasible calib. end year',sep=' ') + + +txtTemp2 <- paste('\n ',HydroVariable,'=',HydName, + '\n ',LabelSeason1, + '\n ',LabelSeason2, + '\n ',strEnd, + '\n ',strEndF, + '\n ',strF1) +text(xTail,yTail,txtTemp,adj=c(0,0.5),cex=1.4) +text(xHead,yHead,txtTemp2,adj=c(0,1),cex=1.3) + +par(new = T) +plot(yrx2,x2, pch=16, type='b',lty=0,axes=F, xlab=NA, ylab=NA, xlim=xlims, + cex.lab=1.3,cex.axis=1.2) +axis(side = 4) +mtext(side = 4, line = 3, 'Maximum adjusted R-squared') +legend("topright", + legend=c("N of SSRs","Max Adj R-squared"), + lty=c(1,0), pch=c(1, 16), col=c("red3", "black"),cex=1.3) +dev.off() +rm(strEnd,strEndF,strF1) +#rm(txtTemp,txtTemp2,xTail,xHead,yTail,yHead,yrsEnd,yrLo,yrHi,xlims,ylims,x1,x2,yrx1,yrx2) + + + +#----FIGURE 04. 1x1. SCATTERPLOT OF OBSERVED HYDRO (SEASONALIZED HYDROLOGIC SERIES) ON THE +# MEAN OF THE SIGNAL-SCREENED SSRS. THIS PLOT WILL HELP USER DECIDE WHAT TO CHOOSE AS METHOD +# FOR THE MULTI-SITE RECONSTRUCTION (MSR) +# +# Status. +# Y3, yrY3 are matrices with the screened SSRs +# V is matrix of hydro series, with year as col 1 and data as col 2 + +# Prepare the two series for the scatterplot +w <-rowMeans(Y3, na.rm=TRUE) # average of the SSRs (vector) +yrw = yrY3 # +W<- as.matrix(cbind(yrw,w)) # bind yrw and w into a time series matrix +ResPC<- PeriodCommon(W,V)# get common period of W and V +yrgo1 <- ResPC$tgo; yrsp1 <- ResPC$tsp # start and end years of common period +w1 <- ResPC$X[,2]; yrw1 <- ResPC$X[,1]; # mean-SSR and its year, as vectors, for common period +# with observed hydro +v1 <- ResPC$Y[,2]; yrv1 <- ResPC$Y[,1]; # observed hydro and its year, as vectors, for common period + +# Pearson correlation of observed hydro with mean of SSRs +r = cor(v1,w1) +rStr<- paste('r=',toString(round(r,digits=2))) +strMain=paste('Scatter of Mean of',as.character(n4), + 'Single-Site Reconstructions (SSRs) of',Dtype,'on Observed',Dtype, + '\n(Fits are straight-line (red) and loess (blue))') # plot title +rm(r) + +# Strings for plots +ylabTemp <- paste('Mean SSR',LabUnits) + + +#--- scatterplot +png(filename=paste(outputDir,"Figure04-SSR4.png",sep=""), width = 760, height = 480) +par(mar=c(5,5,6,4)) +# Call function from package car for the scatterplot. This function as called will regress w1 on +# v1 and plot the lease-squared-fit straight line. Also plotted is a loess (local regression) curve +# and loess curves to represent variance of the loess estimate. The loess curves use a a span of 2/3 and +# are estimated by R function loess.R. For the error bars, the negative and positive departures from +# the loess estimate of the mean are squared and themselves fit wit a loess curve. The plotted lines are +# at the square root of those squared-departure fits. Because the two bordering smoothed line represent the +# typical positive and negative departure, the confidence interval can be heuristically considered +# a 50% confidence interval. +scatterplot(v1,w1,boxplots=FALSE, + regLine=list(method=lm, lty=1, lwd=2, col="red"), + ylab=ylabTemp, + xlab=paste('Observed',Dtype,LabUnits), + main=strMain,cex.lab=1.2) +text(min(v1),max(w1),rStr,adj=c(0,1),cex=2) +dev.off() +rm (ylabTemp) + + +################################################################################ +# +# COMBINE SSR'S INTO A FINAL MULTI-SITE RECONSTRUCTION (MSR +# Method depends on settings for methMSR and PCApredictors. If PCA is involved in +# reconstruction, method might also depend on settings of nkHowPCA, PCoption +# and nPCsKeep +# +# methMSR has three possible values: (1) simple linear regression, +# (2) stepwise multiple linear regression on SSRs (PCApredictors=false) or their +# PCs (PCApredictors=true), and (3) PCA analog +# +# Simple linear regression is done by calling function RecSLR1 +# The other methods ared done by calling function RecMLR1 + +ReconMethods <- c("Simple linear regression of y on mean of SSRs", + "Multiple linear regression of y on SSRs or their PCs", + "Principal component analog nearest neighbor") +ReconMethod <- ReconMethods[methMSR] +NextFigNumber<-5 # because SSR has already produced figure files Figure01.png to Figure04.png + +# Set calibraton period of MSR to start with latest of [yrgoc;d first available year of hydro series; first available year of mean SSR[ +# Set period to end with earliest of [yrgoc; last available year of hydro series' last available year of mean SSR] +if (methMSR==1){ + # Recon by simple linear regression, using RecSLR1(). + SpecListSLR1 <- list("PdfDescribe"=PdfDescribe,"Text"=RecListx,"u"=w,"yru"=yrw, + "v"=V[,2],"yrv"=V[,1],"yrsC"=yrsCalWindow,"yrEnd"=yrEnd,"nNeg"=nNeg,"nPos"=nPos, + "NcMin"=N3,"NextFigNumber"=NextFigNumber,"outputDir"=outputDir) + # Until RecSLR1() finished, will not code the call with the above inputs; will just have that + # function read MyData from wd. + #save(SpecListLR,file="MyData") + #---- stop + + # Progress bar update + mssgProg <- "SSRs prepared for multi-site reconstruction modeling..." + pctInc <- 10; + pctDone <- ProgTrack(pfProg,mssgProg,pctDone,pctInc) + + + # Call to function for method RecSLR1 + save(SpecListSLR1,file=paste(outputDir,"MyDataSLR1.dat",sep="")) + Z <- RecSLR1(SpecListSLR1) + if (Z$flag>0){ + emssg<-Z$Msg + ResTemp<-emssgUNH(emssg,outputDir) + stop(emssg) + } +} else if (methMSR==2 | methMSR==3){ + # Recon by regression on sreened SSRs or their PCs, with call to RecMLR1 + #save(SpecListMLR1,file="MyData"). Note that lags have been dealt with at the SSR step. No + # lags are included in the MSR model. But, nPos and nNeg are used in the MSR model to set + # m in leave-m-out cross-validation, on grounds that the SSRs did use lagging. + SpecListMLR1 <- list("Text"=RecListx,"U"=Y3,"yrU"=yrY3,"nmsU"=nms3,"jScreened"=jScreened,"v"=V[,2],"yrv"=V[,1], + "yrsC"=yrsCalWindow,"yrEnd"=yrEnd,"nNeg"=nNeg,"nPos"=nPos,"incR2a"=incR2a,"kstop"=kstop, + "NcMin"=N3, "PCoption"=PCoption,"f"=f,"PCApredictors"=PCApredictors, + "methMSR"=methMSR,"PdfDescribe"=PdfDescribe, "nPCsKeep"=nPCsKeep,"alphaR"=alphaR, + "ScreenAnalogPCs"=ScreenAnalogPCs, "kHowPCA"=kHowPCA,"NextFigNumber"=NextFigNumber, + "outputDir"=outputDir) + save(SpecListMLR1,file=paste(outputDir,"MyDataMLR1.dat",sep="")) + Z <- RecMLR1(SpecListMLR1) + if (Z$flag == 1){ + emssg<-Z$Msg + ResTemp<-emssgUNH(emssg,outputDir) + stop(emssg) + } +} +# Progress bar update +mssgProg <- "Reconstruction modeling completed!" +pctInc <- 0; +pctDone <- 100 +pctDone <- ProgTrack(pfProg,mssgProg,pctDone,pctInc) + +print("Done!") ### AlexP addition to print status to the STDOUT diff --git a/Recon_Katun.init b/Recon_Katun.init new file mode 100644 index 0000000..a8840d5 --- /dev/null +++ b/Recon_Katun.init @@ -0,0 +1,30 @@ +{ + "code_dir" : "/home/dave/GitWork/TRISH-R", + "pdf_dir" : "/home/dave/GitWork/TRISH-R", + "tr_file" : "siteData_Katun.txt", + "trM_file" : "siteMeta_Katun.txt", + "cl_file" : "hydroData_Katun.txt", + "outputDir" : "/home/dave/AAAtrish2/test_out/", + "NameNetwork": "ems1", + "PrewhitenOrder" : 0, + "LallowLags" : true, + "NsitesUserNetwork" : 38, + "YearScreen" : [1786,1994], + "NafterYearScreen" : 38, + "NafterPolygon" : 38, + "HydroVariable" : "RO", + "ClimDatSet" : "CRU", + "HydroSeason" : [9,12], + "yrgoc" : 1940, + "yrspc": 1990, + "ktran" : 1, + "methMSR" : 2, + "PCApredictors" : true, + "kHowPCA" : 2, + "PCoption" : 1, + "nPCsKeep" : 1, + "f" : 0.10, + "alphaR" : 0.05, + "Lcausal" : true, + "RequireStable": true +} diff --git a/Recon_init_explanation.odt b/Recon_init_explanation.odt new file mode 100644 index 0000000..e5a1ec6 Binary files /dev/null and b/Recon_init_explanation.odt differ diff --git a/Recon_init_explanation.pdf b/Recon_init_explanation.pdf new file mode 100644 index 0000000..024f490 Binary files /dev/null and b/Recon_init_explanation.pdf differ diff --git a/Running_Instructions_ReconAnalog.odt b/Running_Instructions_ReconAnalog.odt new file mode 100644 index 0000000..5e2444c Binary files /dev/null and b/Running_Instructions_ReconAnalog.odt differ diff --git a/Running_Instructions_ReconAnalog.pdf b/Running_Instructions_ReconAnalog.pdf new file mode 100644 index 0000000..5d241f6 Binary files /dev/null and b/Running_Instructions_ReconAnalog.pdf differ diff --git a/SeasClim.R b/SeasClim.R new file mode 100755 index 0000000..503d1bb --- /dev/null +++ b/SeasClim.R @@ -0,0 +1,115 @@ +SeasClim<-function(X,begmo,endmo,kopt) { + # Seasonalize monthly climate data in a 3-column (year-month-value) input format + # D Meko + # Last revised 2022 MaY 02 + # + # Seasonalize monthly climate data in a 3-column (year-month-value) input format + # + #--- INPUT + # + # X [matrix]: monthly data in 3 columns: year-month-value + # begmo [numeric]: start month of season (1=Jan, 12=Dec) + # endmo [numeric]: end month of season (1=Jan, 12=Dec). + # kopt [numeric]: indicator of how data should be seasonalized + # =1: sum over months + # =2: average over months + # + #---OUTPUT + # + # Output: list with fields + # F [matrix, 2-col] year and seasonalized climate variable + # eflag: error flag + # = 0 no problem + # = 1 input data not consistent in having 12 months per year, with year incrementing by 1 + # + #---NOTES + # + # Seasons may cross year boundary, but may not exceed 12 months in length + + #--- NUMBER OF MONTHS IN SEASON + + if (endmo>=begmo){ + nmos <- endmo-begmo+1 + } else { + nmos <- endmo + (12-begmo)+1 + } + + + #--- GET INDEX TO ROWS OF ALL END MONTH, START MONTH + L <- X[,2]==endmo + i2 <-which(L) + L <- X[,2]==begmo + i1 <-which(L) + + #---ADJUST LAST INDICES SO THAT START MONTH PRECEDES END MONTH + if (i1[length(i1)]>i2[length(i2)]){ + i1 <- i1[-length(i1)] + } + + #---ADJUST FIRST INDICES SO THAT START MONTH PRECEDES END MONTH + if (i1[1]>i2[1]){ + i2 <- i2[-1] + } + + #--- CHECK INDICES + # + # Nummber of start months must equal number of end months; intervals must all be equal to expected number + # of months in season; year of end month must increment by 1 + L1 <- length(i1)==length(i2) + n1 <- i2-i1+1 + L2 <- all(n1==nmos) + yr <- X[i2,1] # years of end month + d <-diff(yr) + L3<-FALSE + if (all(d==1)){ + L3<-TRUE + } + L <- L1 && L2 && L3 + if (!L){ + eFlag<-1 + Output <- list('tsm'=NA,'eFlag'=eFlag,'begmo'=begmo,'endmo'=endmo) + return(Output) + } + rm(L1,L2,L3,L,n1,d) + + + #---BUILD INDEX MATRIX TO PULL SUBSET OF MONTHLY DATA + # + # Index to rows of input matrix X. Goal is to use index matrix to make subset matrix of values in X and + # then sum or average over the submatrix to get the seasonalized data + + I2 <- t(t(rep(1, nmos))) %*% t(i2) # row-dupe end-month indices into matrix with nmos rows + + # Build increment matrix + a = (nmos-1):0 + a=-1.0*a + A <- t(t(rep(1, length(i2)))) %*% t(a) + A <- t(A) + + I3 <-I2+A # Combine into final extraction index matris + nrow <- dim(I3)[1] + ncol <-dim(I3)[2] + + + #---PULL SUBMATRX MONTHLY DATA, SUM OR AVERAGE OVER ROWS, BIND WITH YEAR + + x <- X[,3] # vector of data values + Y <- x[I3] # vector of subsets of monthly data + dim(Y)=c(nrow,ncol) # mxn m is # months in season and n years + + # Treat as P or T + if (kopt==1){ + y <- colSums(Y) + }else{ + y <-colMeans(Y) + } + y <- colMeans(Y) # vector of seasonalized data + + F <-cbind(yr,y) # 2-col matrix, year and value + eFlag<-0 + + #--- ORGANIZE OUTPUT + + Output <- list('tsm'=F,'eFlag'=eFlag,'begmo'=begmo,'endmo'=endmo) + return(Output) +} \ No newline at end of file diff --git a/SignalDrop1.R b/SignalDrop1.R new file mode 100755 index 0000000..65d7271 --- /dev/null +++ b/SignalDrop1.R @@ -0,0 +1,35 @@ +SignalDrop1 <- function(N,r){ + # Drop in maximum climate signal in recent years as chronologies drop out + # D. Meko; last revised 2022-09-20 + # + # Have set of single-site reconstructions, each with a statistic (e.g., R-squared) and + # and ending year that may differ. Want to know how that signal strength drops year by + # year over the interval the chronologies end. + # + #--- IN + # N: vector of ending years + # r: vector of the statistics + # + #---OUT + # + # Output: named list: + # yrx1, x1: vectors of years and number of available series (from N) + # yrx2, x1: vectors of years and maximum statistic for those years + + yr1 <- min(N); yr2 <- max(N); yrx <- yr1:yr2 # yrx is vector of years covering ending years in N + yrx1 <- yrx; yrx2 <- yrx # year vectors for the output + mx <- length(yrx) # length of output vectors yrx1, yrx2, x1, x2 + + A <- t(replicate(mx,N)) # replicate N into matrix with identical rows like N + B <- replicate(length(N),yrx) # replicate year vector covering x1, x2 to identical columns + + L <- A >= B # logical matrix true of ending year in A at least as high as corresp. year in B + x1 <- rowSums(L) # vector of the total number of series in each year + + R <- t(replicate(mx,r)) # row-replicate the vector of statistics to mx rows + R[!L] <- NA # convert to NA the elements representing series not present + x2 <- apply(R,1,max,na.rm=TRUE) # maximum statistic in each year (represents maximum for the + # available series) + Output <- list(yrx1=yrx1,x1=x1,yrx2=yrx2,x2=x2) + return(Output) +} \ No newline at end of file diff --git a/TabSepTsm1.R b/TabSepTsm1.R new file mode 100755 index 0000000..19b17fa --- /dev/null +++ b/TabSepTsm1.R @@ -0,0 +1,86 @@ +TabSepTsm1 <- function(D) { + # Write tab-separated file of reconstruction with CI, plus observed predictand + # D. Meko + # Last revised 2022-06-27 + # + # Called from a script or function. For example, was called by function RecLR1 + # + # D is list with members: + # outDir: string tells where to write file (e.g., "/home/dave/AAAtrish2/test_out/") + # filename: name of output file (without txt; for example, ObservedAndReconstructedTimeSeries) + # header: vector of 5 strings to be headers for columns. For example, + # "Year","Obs RO (mm)","Reconstruction","Lower 50% CI","Upper 50% CI" + # observed: matrix with two columns (year and observed predictand) + # recon: 5-col matrix with year, recon, lower 50% CI and upper 50% CI + # fmtsH: vector of string formats for the column headers (e.g., c[1]="Year") + # fmtsD: vector of string formats for a row of the data matrix + # + # + # Notes + # + # In general, observed could have data extending closer to present then recon. + # Not a problem! + + + #=== UNLOAD + textH <- D$header + Y <- D$observed + V <- D$recon + fnm <- D$filename + fmtsD <- D$fmtsD; fmtsH<-D$fmtsH + outDir <- D$outDir + + #---Trim to complete cases + L <- complete.cases(Y) + Y <- Y[L,] + L <- complete.cases(V) + V <- V[L,] + rm(D) + + #--- Allocate storage + + yrgo <- min(V[1,1],Y[1,1]) + yrmax1 <- max(V[,1]) ; yrmax2 <- max(Y[,1]) + yrsp <- max(yrmax1,yrmax2) + + yrX <- yrgo:yrsp + mX <- length(yrX) + X = matrix(NA,nrow=mX,ncol=5) + + + #--- Fill X + + X[,1]=yrX + + # obs + yr <- Y[,1]; y <- Y[,2] + irow = yr - yrgo + 1 + X[irow,2] <- y + + # recon + yr <- V[,1]; V <- V[,-1] + irow = yr - yrgo + 1 + X[irow,3:5] <- V + + + #--- OUTPUT FILE + + pf = paste(outDir,fnm,'.txt',sep="") + + #--- Title + fprintf('%s\n\n',fnm,file=pf,append="FALSE") + + # Header line + for (n in 1:length(textH)){ + xthis <- textH[n] + fmt <- fmtsH[n] + fprintf(fmt,xthis,file=pf,append="TRUE") + } + + # Data lines + X1 = t(X) + fprintf(fmtsD,X1,file=pf,append=TRUE) + + Output <- NA + return(Output) +} \ No newline at end of file diff --git a/TabSepTsm2.R b/TabSepTsm2.R new file mode 100755 index 0000000..bec335c --- /dev/null +++ b/TabSepTsm2.R @@ -0,0 +1,56 @@ +TabSepTsm2 <- function(D) { + # Write tab-separated file of a time series matrix, with heading line + # D. Meko + # Last revised 2022-08-25 + # + # Called from a script or function. For example, was called by function RecLR1 + # + # D is list with members: + # outDir: string tells where to write file (e.g., "/home/dave/AAAtrish2/test_out/") + # filename: name of output file (without txt; for example, ObservedAndReconstructedTimeSeries) + # header: vector of strings to be headers for columns. For example, + # "Year","RO (mm)","meanSSD" + # observed: matrix with two columns (year and observed predictand) + # recon: 5-col matrix with year, recon, lower 50% CI and upper 50% CI + # fmtsH: vector of string formats for the column headers (e.g., c[1]="Year") + # fmtsD: vector of string formats for a row of the data matrix + # + # + # Notes + # + # In general, observed could have data extending closer to present then recon. + # Not a problem! + + #=== UNLOAD + textH <- D$textH + Y <- D$dataB # year, predictand, predictor + fnm <- D$filename + fmtsB <- D$fmtsB; fmtsH<-D$fmtsH + outDir <- D$outDir + textT <-D$textT # Tail + + rm(D) + + #--- Output file + pf = paste(outDir,fnm,'.txt',sep="") + + #--- Title and header line + fprintf('%s\n\n',fnm,file=pf,append="FALSE") + for (n in 1:length(textH)){ + xthis <- textH[n] + fmt <- fmtsH[n] + fprintf(fmt,xthis,file=pf,append="TRUE") + } + fprintf('%s\n','',file=pf,append="TRUE") + + #--- BODY + X1 = t(Y) + fprintf(fmtsB,X1,file=pf,append=TRUE) + + #--- TAIL + fprintf('%s\n','',file=pf,append=TRUE) + fprintf('%s\n',textT,file=pf,append=TRUE) + + Output <- NA + return(Output) +} \ No newline at end of file diff --git a/TabSepTsm3.R b/TabSepTsm3.R new file mode 100755 index 0000000..b09ed54 --- /dev/null +++ b/TabSepTsm3.R @@ -0,0 +1,52 @@ +TabSepTsm3 <- function(D) { + # Write general tab-separated file of a time series matrix, with heading line + # D. Meko + # Last revised 2022-09-09 + # + # Called from a script or function. For example, was called by function RecMLR1, first + # write PC scores to tab-sep file + # + # D is list with members: + # outDir: string tells where to write file (e.g., "/home/dave/AAAtrish2/test_out/") + # filename: name of output file (without txt; for example, PCscoresTimeSeries) + # textH: vector of strings to be headers for columns. For example, + # "Year","PC1","PC2", etc + # dataB: matrix of data (all numeric) for the body. Time (year) in column 1 and other variables in remaining columns + # textT: text to be written below the time series listing. The "T" stands for "tail." This text + # can be prepared using "paste," with \n to change lines + # fmtsH: vector of string formats for the column headers (e.g., c[1]='%5d') + # fmtsB: vector of string formats for a row of the data matrix + # + # + #=== NOTES + + #=== UNLOAD + textH <- D$textH + Y <- D$dataB # year, predictand, predictor + fnm <- D$filename + fmtsB <- D$fmtsB; fmtsH<-D$fmtsH + outDir <- D$outDir + textT <-D$textT # Tail + rm(D) + + #--- Output file + pf = paste(outDir,fnm,'.txt',sep="") + + #--- Title and header line + fprintf('%s\n\n',fnm,file=pf,append="FALSE") + for (n in 1:length(textH)){ + xthis <- textH[n] + fmt <- fmtsH[n] + fprintf(fmt,xthis,file=pf,append="TRUE") + } + fprintf('%s\n','',file=pf,append="TRUE") + + #--- BODY + fprintf(fmtsB,t(Y),file=pf,append=TRUE) + + #--- TAIL + fprintf('%s\n','',file=pf,append=TRUE) + fprintf('%s\n',textT,file=pf,append=TRUE) + Output <- NA + return(Output) +} \ No newline at end of file diff --git a/Table1Column.R b/Table1Column.R new file mode 100755 index 0000000..5197601 --- /dev/null +++ b/Table1Column.R @@ -0,0 +1,105 @@ +Table1Column <- function(D) { + # Write table with just 1 column of data after column of variable names + # D. Meko + # Last revised 2022-06-26 + # + # Called from a script or function. For example, was called by function RecLR1 to gene + # tables of statistics for calibration, validation and analysis of residuals of + # reconstruction model. Table has (H)ead, (B)ody, and (T)ail. + # + # D is list with members: + # outputDir: string tells where to write file (e.g., "/home/dave/AAAtrish2/test_out/") + # textH: header text; vector of strings whose elements are lines of text to go above the + # the table. textH[1] is special, will be the first line, and is also (without ".txt"), the + # file name of the output table. For example, "Table3-MSR-LR1-Calibration". textH[2] is + # text that, after " - ", will be printed after the filename at the top of the table. + # Remaining textH[?] are the column headings. + # textB: variable names; vector of strings to be printed in first column + # TfmtB: string with the format for column 1 (e.g., '%10s\t). Be sure that + # 1) the number before "s" is at least as long as any string in textB + # 2) you use "\t" to make tab separation of cols 1 and 2 + # dataB: corresponding variables as named in calling program; a vector of data variables + # DfmtsB: data formats for body; vector of strings that are fprint formats. For example, + # "c('%-8g','%-6.2f). Keep in mind: + # 1) formats in DfmtsB go 1-1 with data in dataB; consider formats accordingly + # 2) the "-" in the format strings left justify column 1 + # textT: tail text; vector of strings, each of which is a line in the tail under the table + # If do not want a tail, make textT and empty vector (textT <-c()) in calling function + # + # Notes + # Title line is followed by a blank line. Vector textH might have only one element. If more, those + # lines of head text are followed by another blank line. + # Table body has a line of "===================" above and below + # Body is followed by optional "tail," which, if it exists, is separated by a blank line from + # the "=================" below the body. + + + #=== UNLOAD + + textH <- D$textH + textB <- D$textB + TfmtB <- D$TfmtB + dataB <- D$dataB + DfmtsB <- D$DfmtsB; + textT <- D$textT + outDir <-D$outDir + rm (D) + + #--- BUILD OUTPUT FILENAME + + # Build path/filename for output file + TableTitle <- textH[1] # will be (with suffix txt) the outfile name, such as + fnm <- paste(TableTitle,'.txt',sep="") + pf1 <- paste(outDir,fnm,sep="") + + if (file.exists(pf1)){file.remove(pf1)} # must remove old version of file + + # Line to go above and below table + baseLine <- "=========================================" + + #=== HEADER + + for (n in 1:length(textH)){ + if (n==1 | n==length(textH)){ + fmtthis <- '%s\n\n' + } else { + fmtthis <- '%s\n' + } + vThis = textH[n] + if (n==1){ + vThis <- paste(vThis,' - ',textH[2]) + fprintf(fmtthis,vThis,file=pf1,append=FALSE) + } else if (n==2){ + # nothing + } else { + fprintf(fmtthis,vThis,file=pf1,append=TRUE) + } + } + fprintf('%s\n',baseLine,file=pf1,append=TRUE) + rm(vThis, fmtthis, textH, n) + + + #=== BODY + + nT <- length(dataB) + for (n in 1:length(dataB)){ + DfmtB <- DfmtsB[n] + Tdata <- dataB[n] + vName <- textB[n] + fprintf(TfmtB,vName,file=pf1,append=TRUE) + fprintf(DfmtB,Tdata,file=pf1,append=TRUE) + } + + #=== TAIL + + fprintf('%s\n\n',baseLine,file=pf1,append=TRUE) + nTail <- length(textT) + fmtT <- {'%s\n'} # for lines of tail + for (n in 1:nTail){ + vthis <- textT[n] + fprintf(fmtT,vthis,file=pf1,append=TRUE) + } + + Output <- NA + return(Output) +} \ No newline at end of file diff --git a/TablePCA1.R b/TablePCA1.R new file mode 100755 index 0000000..c88d8b0 --- /dev/null +++ b/TablePCA1.R @@ -0,0 +1,116 @@ +TablePCA1 <- function(D) { + # Write PCA summary table, including list of loadings + # D. Meko + # Last revised 2022-09-07 + # + # Called from a script or function. For example, was called by function RecLR1 + # + # D is list with members: + # outDir: string tells where to write file (e.g., "/home/dave/AAAtrish2/test_out/") + # filename: name of output file (without txt; for example, Table3-PCA1.txt + # header: vector of strings to be headers for columns. For example, + # "N","Site#","SiteID","PC1", "PC2", etc + # P: list with loadings and other data needed + # fmtsH: vector of string formats for the column headers (e.g., c[1]="Year") + # fmtsB: vector of string formats for a row of the body of table + # 1 applies to cols 1 and 2) "N" and "Site#" + # 2 applies to col 3 (site ID) + # 3 applies (after replicating) to remaing columns (e.g., '%-12.8g\t) + # + # + # Notes + # + # Column header and numeric format widths should be compatible; moreover, + # Col 1 should have width no smaller than 4 (to accomdate "Cum%') + # Col 2 should have width no smaller than 5 (to accomodate "Site#") + # Col 3 should be sized as large as length of longest site ID + + #=== UNLOAD + textH <- D$textH$Heading + DfmtsB <- D$DfmtB + DfmtsH <- D$DfmtH + fnm <- D$textH$Title + tit1 <- D$textH$SubTitle + fmtsB <- D$fmtB; fmtsH<-D$fmtH + TfmtB <-D$TfmtB + outDir <- D$outDir + textT <-D$textT # Tail + Y <- D$dataB$ResPCA$Loadings + EV <- D$dataB$ResPCA$EigValues + PctVar <- D$dataB$ResPCA$PctVar + CumPctVar <- D$dataB$ResPCA$CumPctVar + jScreened <- D$dataB$jScreened + SiteID <- D$dataB$SiteID + textT <- D$textT + BunnyTrack=D$BunnyTrack + rm(D) + + + nPC <- dim(Y)[2] # how many PCs + nSites <- nPC; # same number of variables + jPC <- 1:nSites + + #--- Output file + pf = paste(outDir,fnm,'.txt',sep="") + + #--- Title and header line + fprintf('%s\n\n',paste(fnm,' - ',tit1,sep=""),file=pf,append="FALSE") + fprintf('%s\n',BunnyTrack,file=pf,append="TRUE") + + # first three col headers + for (n in 1:3){ + xthis <- textH[n] + fmt <- TfmtB$Left[n] + fprintf(fmt,xthis,file=pf,append="TRUE") + } + # headers for PCs + for (n in 4:length(textH)){ + xthis <- textH[n] + fmt <- TfmtB$Right[[n-3]] + fprintf(fmt,xthis,file=pf,append="TRUE") + } + +#--- BODY, PART 1: LOADNGS + +for (n in 1:nSites){ + # First 3 columns + xthis <-c(jPC[n],jScreened[n]) + # The sequential number and the database site numer + for (m in 1:2) { + fmt <- DfmtsB$Left[m] + fprintf(fmt,xthis[m],file=pf,append="TRUE") + } + # Site id + fmt <-DfmtsB$Left[3] + fprintf(fmt,SiteID[n],file=pf,append="TRUE") + # Loadings on this site + xthis <- Y[n,] + fmt <- DfmtsB$Right + fprintf(fmt,xthis,file=pf,append="TRUE") +} + +fprintf('%s\n','',file=pf,append="TRUE") # blank line + +# Eigenvalue line +fprintf('%s\t\t','Eigenvalue ',file=pf,append="TRUE") +fmt <- DfmtsB$Right +fprintf(fmt,EV,file=pf,append="TRUE") + +# Lines for % Var. and Cum % Var.Eigenvalue line +fmt <- DfmtsB$Pctg +fprintf('%s\t\t','Pctg Variance ',file=pf,append="TRUE") +fprintf(fmt,PctVar,file=pf,append="TRUE") + +fprintf('%s\t\t','Cum. Pctg Variance',file=pf,append="TRUE") +fmt <- DfmtsB$Pctg +fprintf(fmt,CumPctVar,file=pf,append="TRUE") + +fprintf('%s\n',BunnyTrack,file=pf,append="TRUE") + + #--- TAIL + + fprintf('%s\n','',file=pf,append=TRUE) + fprintf('%s\n',textT,file=pf,append=TRUE) + Output <- NA + return(Output) +} \ No newline at end of file diff --git a/TableWrite1.R b/TableWrite1.R new file mode 100755 index 0000000..371d32e --- /dev/null +++ b/TableWrite1.R @@ -0,0 +1,67 @@ +TableWrite1 <- function(D) { + # Write table with any number of columns and rows + # D. Meko + # Last revised 2022-09-08 + # + # Called from a script or function. For example, was called by function RecMLR1 + # to write table of correlations of PC scores with some variable y. + # Table has (H)ead, (B)ody, and (T)ail. + # + # D is list with members: + # outputDir: string tells where to write file (e.g., "/home/dave/AAAtrish2/test_out/") + # textH: header text; vector of strings whose elements are lines of text to go above the + # the table. + # textH[1] is special, will be the first line, and is also (without ".txt"), the + # file name of the output table. For example, "Table4-PCA2" + # textH[2] is a short descriptive caption, for example ("Correlation of PCs with RO") + # textH[3-?] are column headings + # dataB: named list with the table data. Columns must be compatible with textH[3]. Number + # of rows in table is computed from contents of DataB. + # fmtHB: named list with formats for header row (Head) and table row (Body) + # textT: text to go below table (T="tail"). Multi-row easily written by using + # "paste" in combination with \n. + # + + #=== UNLOAD + + outputDir <- D$outputDir + textT <- D$textT + textH <- D$textH + dataB<- D$dataB + fmtH <- D$fmtHB[1]; fmtB <- D$fmtHB[2] + BunnyTrack <- D$BunnyTrack + + ncol <- length(textH)-2 # number of columns in table (first two elements title a) + H <- textH[3:length(textH)] + + + #=== BUILD FILE NAME AND WRITE TITLE AND HEADER + + fnm <- textH[1] + pf = paste(outputDir,fnm,'.txt',sep="") + xthis <- paste(fnm,': ', textH[2],sep='') + fprintf('%s\n\n',xthis,file=pf,append="FALSE") + fprintf('%s\n',BunnyTrack,file=pf,append="TRUE") + fprintf(fmtH$Head,H,file=pf,append="TRUE") + fprintf('%s\n',' ',file=pf,append="TRUE") + + #=== BUILD BODY + + fmtBody <- fmtB$Body + var1<-dataB[[1]] + for (n in 1:length(dataB[[1]])){ + # PC number + fmt <- fmtBody[1] + xthis <- var1[n] + fprintf(fmt,xthis,file=pf,append="TRUE") + # data vector + fmt <- fmtBody[2:length(fmtBody)] + xthis <- c(dataB$r[n],dataB$Thresh1[n],dataB$Thresh2[n],dataB$r1PC[n]) + fprintf(fmt,xthis,file=pf,append="TRUE") + } + fprintf('%s\n\n',BunnyTrack,file=pf,append="TRUE") + fprintf('%s\n',textT,file=pf,append="TRUE") + + Output <- NA + return(Output) +} \ No newline at end of file diff --git a/TranFlow.R b/TranFlow.R new file mode 100755 index 0000000..4b7597a --- /dev/null +++ b/TranFlow.R @@ -0,0 +1,82 @@ +TranFlow<- function(x,ktran){ + # Transformation of flows or some other single time series. + # D. Meko; last revised 2021-12-26 + # + # x, [matrix]r the time series (e.g., flows); assumed single column + # ktran [scalar]i type of transform requested + # =1: no tranform requested + # =2: square root (valid iff x non-negative) + # =3: log10 (valid iff x all-positive) + # + # Returns Output, a named list, with parts: + # x [matrix] the (possibly) transformed verstion of input x. If not possible + # to apply the requested transform, returns original x + # flag [scalar]i flag indicating if transform applied, and why not if not + # =0 No problem; transform applied + # =1 Square root transform rejected because some x non-negative + # =2 Log10 transform rejected becase x not all-positive + # Transformed [logical]1x1 whether flow transformed or not (T=yes,F=No) + # + # Why? For flow reconstruction, a transformation sometimes gives a stronger reconstruction + # as measured by calibration statistics, or avoids the problem of highly skewed residuals, or + # residuals whose variance strongly depends on the size of the predicted value (non-constant variance). + # + # Bombs if input x is all-NA or is not a 1-col matrix. Checks whether desired + # transform mathematically sensible (e.g., log10(0) is minus infinity) and if not, + # returns original x, and flag indicating why could not transform. + # + # Missing values: input x may conatin some NAs. If so, corresponding elements of + # transformed x are NA. + # + # Only two types of transformatons are supported: square root and log10 transform + + # Check input series + L1 <- is.matrix(x) + if (!L1){ + stop('x not a matrix') + } + nx<- dim(x)[2] + if (!nx==1){ + stop('x is a matrix, but not 1-column') + } + + if (ktran==1){ + sTran<-'' + } else if (ktran==2) { + sTran<- "(sqrt-transformed)" + } else if (ktran==3) { + sTran <- '(log10-transformed)' + } else { + sTran<- '(Invalid ktran choice)' + } + + + #--- TRANSFORM + v<-x + Transformed<-FALSE + flagTr<-0 + if (ktran==1){ + v<-v + } else if (ktran==2) { + if (!any(v<0)){ + v<-sqrt(v) + Transformed<-TRUE + } else { + flagTr<-1 + sTran<-'' + } + } else { + if(!any(v<=0)){ + v=log10(v) + Transformed<-TRUE + } else { + # Write error file + flagTr<-2 + sTran<-'' + } + } + + Output<-list(x=v,flag=flagTr,Transformed=Transformed,sTran=sTran) + return(Output) +} + diff --git a/TrimTsm1.R b/TrimTsm1.R new file mode 100755 index 0000000..fd1d6c7 --- /dev/null +++ b/TrimTsm1.R @@ -0,0 +1,95 @@ +TrimTsm1<- function(X,yrgo,yrsp,nNeg,nPos){ + # Trim a time series matrix with constraints for single-site reconstruction (SSR) + # D. Meko; last revised 2021-12-28 + # + # X [matrix]r time series matrix, year as col 1 + # yrgo [1x1]r nNeg + desired start year of output matrix. For example if yrgo=1750 and + # nNeg=2, desired start year is 1748. Output tsm includes only those columns with data in + # year yrgo-mlead. If yrgo=NA, output tsm is trimmed to begin with first year with data for + # all series in input X (first year of common period) + # yrsp [1x1]r desired end year - nPos of output tsm. For example, if yrsp=1990 and nPos=2, + # desired end year is 1992. Output tsm is truncated to end in yrsp+nPos or in the most recent + # year with data for any of the series in input X. If yrsp=NA, output X ends in the year of + # most recent data in X after column-screening for yrgo. + # + # Returns list Output, with fields: + # X: [matrix] trimmed time series matrix of input X; numbers of rows and columns generally + # reduced from input, X, but otherwise the same form. + # ix: [matrix] one-column matrix indicating which columns of the input X are columns of + # the output X (disregarding the year column) + # + # Input matrix X assumed to have year in column 1, values for time series (e.g., tree-ring indices) in + # remaining columns. + + nX <- dim(U)[2]-1 # number of time series in U + mX <- dim(U)[1] # number of years in U + + yrX = as.matrix(U[,1]) + X<-as.matrix(U[,2:(nX+1)]) + + L <- is.na(X) + n1<-rowSums(L) # numberic vector, number of NA in each row of X + ifull<-which(n1==0) # rows of X with no NA at any site + iFirstFull=min(ifull) # first row in X with no data missing + + iany <- which(n1EigThresh + EigCut <- max(which(L)) + + Output <- list('Scores'=F,'yrScores'=yrF,'Loadings'=P$rotation,'EigValues'=EV, + 'PctVar'=Pct1,'CumPctVar'=CumPct1,'Eig1Cutoff'=EigCut) + return(Output) +} \ No newline at end of file diff --git a/c13toc3.R b/c13toc3.R new file mode 100755 index 0000000..a7a4d14 --- /dev/null +++ b/c13toc3.R @@ -0,0 +1,40 @@ +c13toc3 <- function(V) { + # 13-column monthly climate matrix to three-column matrix (year, month value) + # D. Meko + # Last revised 2021-05-30 + # + #--- IN + # + # V [matrix] 13 columns, year and Jan-Dec data + # + #--- OUT + # + # X [matrix] 3 columns, year, month day + + mV <- nrow(V) # number of rows (years) in the 13-col matrix + + yrV<-V[,1] + V<-V[,-1] + + # Reshaped data + v <- as.vector(t(V)) + x<-as.matrix(v) # data as 1-col matrix + + # Build year 1-col matrix + yr<-yrV[1]:yrV[mV] + yr <- t(replicate(12,yr)) + yr <- as.vector(yr) + yr <- as.matrix(yr) # year as 1col matrix + + # Build month matrix + u <- 1:12 + U <- replicate(mV,u) + u <- as.vector(U) + month <- as.matrix(u) + #u <- as.matrix(u) # 1 col matrix + #u <- replicate(u,mV) + + X <-cbind(yr,month,x) + + return(X) +} diff --git a/emssgUNH.R b/emssgUNH.R new file mode 100755 index 0000000..973e864 --- /dev/null +++ b/emssgUNH.R @@ -0,0 +1,14 @@ +emssgUNH<- function(emssg,outDir){ +# Write an error message to a specified output directory +# D. Meko; last revised 2021-12-27 +# +# emmsg (xx?)s message, written to file "error.txt" +# outDir (1x?)s output directory to which message file is written +# +# Returns emssg, which is just a string of the input message, regurgitated +# Write error file +fileErr<-file(paste(outDir,"error.txt",sep="")) +writeLines(c(emssg), fileErr) +close(fileErr) +return(emssg) +} \ No newline at end of file diff --git a/hydroData_Katun.txt b/hydroData_Katun.txt new file mode 100644 index 0000000..b9115fb --- /dev/null +++ b/hydroData_Katun.txt @@ -0,0 +1,56 @@ +Year Value +1938 6.7813 +1939 4.8670 +1940 3.9139 +1941 4.9717 +1942 4.3328 +1943 3.0415 +1944 2.8320 +1945 1.9107 +1946 5.4235 +1947 5.6505 +1948 3.8399 +1949 3.1530 +1950 5.0362 +1951 2.9349 +1952 4.3734 +1953 3.6932 +1954 6.3032 +1955 3.7041 +1956 4.5448 +1957 4.2174 +1958 7.5932 +1959 4.2881 +1960 5.5209 +1961 6.5746 +1962 2.8528 +1963 2.8722 +1964 3.4105 +1965 3.4717 +1966 7.5052 +1967 4.0874 +1968 2.8858 +1969 7.2908 +1970 4.8931 +1971 4.3062 +1972 3.3492 +1973 5.1289 +1974 2.3607 +1975 4.3467 +1976 3.1762 +1977 4.1717 +1978 3.3827 +1979 3.5185 +1980 3.5541 +1981 3.8394 +1982 2.7001 +1983 4.4319 +1984 6.1600 +1985 3.4409 +1986 2.8081 +1987 4.6616 +1988 5.2907 +1989 2.8905 +1990 3.2971 +1991 2.6240 +1992 3.8642 diff --git a/mannken1.R b/mannken1.R new file mode 100755 index 0000000..518e619 --- /dev/null +++ b/mannken1.R @@ -0,0 +1,447 @@ +mannken1 <- function(Din){ + # X,kopt,outputDir,kplot,NextFigNumber + # Mann-Kendall trend test for a time series + # D. Meko + # Last revised 2023-11-24 + # + #---IN + # + # Input is a list with following fields: + # + # X [matrix]: year as col 1, time series as col 2 (see Notes) + # kopt [vector]1x2; options + # [1] Plot of time series, trend line, and detrended series + # 1 skip plotting + # 2 plot + # [2] Adjust signficance of Mann-Kendall statistic for lag-1 autocorrelations + # 1 Yes + # 2 No + # kplot [scalar] which version of plots to produce + # 1 Plot time series with fitted trend line & horiz line at mean; figure file + # named "mannken1_F1.png" + # 2 Likewise plot time series with fitted trend line;n but this is TRISH-specific, + # intended for looking at trend in regression residuals in context of other + # calls; horiz line at 0, and file named like "Figure??-AnalysisResduals2.png", with name + # part ?? controlled by input arg NextFigNumber + # 3 The GEOS485A version: 2x1 plot of trend-fit to time series (top) and detrended series (bottom) + # outputDir [char] folder to which any plots go (e.g., '/home/dave/test_out/') + # If "Null", this plotting of pngs to an output folder is ignored + # textPlot [vector, char]3 title, xlabel, ylabel for time series plot + # NextFigNumber [integer]: if called for TRISH plot (kplot=2), the figure file + # will be named Figure0?.png, where ? is NextFigNumber. Ignored otherwise. + # + #---OUT + # + # Output is list with elements: + # What: list with three elements telling (1) which function created Output, + # (1) user to refer to comment section of that function to get details on the list items, and + # (2) the date on which the Output list was created. + # statistic: Mann-Kendal statistic (see Notes and References) + # AnalysisPeriod: string first and last times of analysis period (e.g., '1950-2020') + # Lacf(L) request possible adjustment of signficance for positive significant lag-1 autocorrelation + # (only enacted if the residuals to a least-squares straight line fit to the series have + # significant positive lag-1 autocorrelation (0.05, one-tailed test) + # Ladjusted (L): whether autcorrelation adjustment ended up being applied + # vif [scalar] variance inflation factor (set to 1 if have not requested autcorrelation adjustment + # or if that adjustment not warranted by the data); see references on Mann Kendall test + # pvalue: p-value for significance of MK test; two-tailed null hypothesis of no trend + # ngrp: number of groups of ties + # nties: total number of ties + # Lflag (1x2)L flag + # (1) inadequate sample size (need 10 or more obs) + # T: sample size too small (fewer than 10 obs) + # F: sample size not too small + # (2) identically 0 slope (summation needed for test statistic dentically 0; this would + # result in an infinite test statistic; See Haan,2002) + # T: identically 0 slope, returns original as detrended without going through non-parametric fit + # F: slope either positive or negative (not necessarily significant); non-parametric fit proceeds + # b (1x1)r slope (nonparametric estimate) + # a (1x1)r intercept ... + # equation: equation for trend line (nonparametric fit) + # X (mx x 2)r: time series matrix (time as col 1) of original series for specified analysis period + # xhat (mx x 1)r trend line + # xdetrended (mx x 1)r detrended x (by non-parametric trend line) + # ErrorMessage [vector]c : error message associated with Lflag + # + #--=NOTES + # + # X: assumed 2-col matrix, year as col 1, data as col2. Assumed that x has not missing values + # and that yrx increments by 1 + # Lflag[1]: If time series has fewer than 10 observations, Lflag(1)=T, and Lflag and ErrorMessage are the only + # output list element returned; here Lflag[2] is set to FALSE + # Lflag[2]: set to T if essentially no slope in trend line. If so, the test statistic cannot + # be computed because a denominator in the equation for the test statistic is zero. In this case + # Lflag and ErrorMessage are the only list elements returned. + # pvalue: this is for a two-tailed test. H0 is no trend. A small p-value indicates reject H0. + # For example, if p-value==0.09, we reject H0 at alpha=0.10 level. If p-value==0.0499, we + # reject H0 at alpha=0.05. + # nties, ngrp: handling of ties follows Salas(1993) + # b, a, equation: Nonparametric trend line fit following equations in Haan (2002). The detrended series + # Result.xdetrended is shifted such that has same median as input series x. + # Autocorrelation adjustmentment. If requested, applied only if residuals rom an least squared fit + # straight line fit to the original time series have significant (0.05 alpha) lag-1 positive + # autocorrelation by a 1-tailed test. + # vif, or variance inflation factor: annotation of variance inflation factor (vif) at upper left + # of time series with fitted line. If kopt[2]==2 (you do not enable autocorrelation djustment), vif + # is not annotated. Otherwise, vif is annotated, but will be "vif=1.0" if the autocorrelation is + # not justified (no significant lag-1 autocorrelation in residuals from least-squares-fit line) + # Horizontal gray dashed gray line on plots: This is at the median of x if kplot= 1 or 3, and at 0 if kplot=2. + # The rationale for 0 is that with kplot=2 we are chacking for trend in regression residuals, which should + # should have a mean of zero for the calibraton period of the regression model. The median residual can differ + # from zero. + # + # Test data from Haan (2002) used to originally check results + # x<- c(25.56, 33.28, 34.03, 35.72, 39.33, 32.21, 30.76, 44.45, , 42.69) + # t <- 1978:1987; + # Cbind t and x into X and call mannken1.R; compare results to those in Haan(2002) + # + #---REFERENCES + # Haan, C. T. (2002). Statistical methods in hydrology (Second ed.). Iowa State University Press. (496 pp) + # Helsel, D. R., & Hirsch, R. M. (1992). Statistical methods in water research. Amsterdan, The Netherlands: Elsevier. + # Salas, J. D. (1992). Analysis and modeling of hydrologic time series. In D. R. Maidment (Ed.), Handbook of hydrology (p. 1-72). New York: McGraw-Hill, Inc. + # Wilks, D. S. (2019). Statistical methods in the atmospheric sciences (Fourth ed.). Cambridge, MA: Elsevier. (818 pp) + # + # Algorithms for Mann-Kendall statistic and adjustment of its signficance for autocorrelation from + # Wilks (2019). Handling of ties in time series as recommended by Salas (1992). Test data from Haan (2002). Detreding + # is done following Haan (2002, p. 345), who gives equations for non-parametric estimation of slope and intercept of a linear + # trend line. Haan (2002) got the equations for the estimation from Helse and Hirsch (1992). + # + # revised 2023-11-24. minor correction to labeling of plots + + source(paste(code_dir,"ties1.R",sep="")) # optional transformation of flows + + + #--- UNLOAD + + X <- Din$X; kopt <- Din$kopt; kplot <- Din$kplot + outputDir <- Din$outputDir; NextFigNumber <- Din$NextFigNumber + textPlot <- Din$textPlot + + # Hard code, needed if kplot==2 (special case of TRISH plot) + jFigAdd <- 0 # increment this for any plot after first + ErrorMessage <- "No problems" + Lflag <- c(FALSE,FALSE) # initialize error flags + + # Check input + L1 <- is.matrix(X) + L2 <- dim(X)[2]==2 + x <- X[,2]; yrx<- X[,1] # vectgrs + L3 <- !any(is.na(x)) && all(diff(yrx)==1) + L = L1 & L2 & L3 + if (!L){ + stop('Something amiss with in put X; should be 2-col matrux with year as col 1; no missing values') + } + + # Need at least 10 observations + mx <-length(x) + if (mx<10){ + Lflag[1]<-TRUE + Lflag[2]<-FALSE + ErrorMessage <- 'Few than 10 observations in series; cannot run function mannken1' + Output <- list(Lflag=Lflag,ErrorMessage=ErrorMessage) + return(Output) + } + + + # Build string label of time coverage (e.g., '1890-1989') + strFL <- paste(as.character(yrx[1]),'-',as.character(yrx[length(yrx)]),sep='') + + #---Optional check for lag-1 autocorrelation of residuals from least-squares straight-line trend fit to x + Ladjusted <-FALSE + Lacf <- FALSE + vif <-1 # initialize to effectively make no autocorrelaton adjustment to variance of the statistic + + + if (kopt[2]==1){ + + # adjustment to be explored + Lacf<-TRUE + M <- lm(x~yrx) # regress x on yrx + e <- M$residuals # residuals from straight line fit to x vs yrx (trend line) + r <- acf(e,plot=FALSE) # autocorrelation function of those residuals; acf object + r1 <- r$acf[2] # lag-1 autocorrelation + #rm(M,e,r,acf) + + # threhsold for statistically significant positive lag-1 autocorrelation (alpha=0.05) + r95 <- (-1+1.645*sqrt(mx-2))/(mx-1) + if (r1>r95){ + Ladjusted=TRUE + f <- (1+r1)/(1-r1) + Nprime <- floor(mx/f) # effective sample size + }else{ + f <-1 + Nprime <- mx + } + vif <-f; rm(f) + } else { + # do not consider adjustment + } + + #---BUILD SUMS FOR COMPUTATION OF STATISTIC + + # Col-dupe, then col-dupe x + A <- matrix(x,nrow=mx,ncol=mx,byrow=FALSE) + B <- matrix(x,ncol=mx,nrow=mx,byrow=TRUE) + + # Difference matrix, C + C <- A-B + # Consider elements below the diagonal of C: + # col 1 is difference of all succeeding values and x(1) + # col 2 is difference of all succeeding values and x(2) + #... col (mx-1) is difference of x(mx ) and x(mx-1) + + # Because interested only in elements below the diagonal, convert + # elements above diagonal to 0; then lop off first row and last col + L<-upper.tri(C,diag=FALSE) + C[L]=0; + D <- C[-1,]; D <- D[,-mx] + + # Logicals for positive and negative differences + Lp <- D>0; + Ln <- D<0; + Lz <- D==0; + + # Quantities for the test statistic + E <- D + E[Lp] <- (-1) + E[Ln] <- 1 + E[Lz] <- 0 + + # Test statistic is based on difference of number of positive and negative differences + s1 <- sum(E) + s <- sum(s1) + + + # There is and adjustent for ties in values of x; deal with that + T <- ties1(x) + if (length(T$ngroups)==0){ + vties <- 0 + nties <-0 + ngrp <-0 + } else { + ngrp <- T$ngroups + nties <- sum(T$nties) # total number of x involved in ties + w<-0 + for (k in 1:ngrp){ + e <- T$nties[k] + h = e*(e-1)*(2*e+5) + w <- w+h + } + vties <-w + } + + #======== COMPUTE TEST STATISTIC, u + + N <- mx + if (s>0){ + m <- (-1) + } else if (s<0){ + m <- 1 + } else { + # special case of exactly as many positive as negative differences. This indicates no trend, and + # also causes problem n computation of u because s occurs in a denominator + m <-0 + Lflag <- c(FALSE,TRUE) + ErrorMessage <- 'In mannken1, sums of neg and pos s are equal. For sure no trend' + Output <- list(Lflag=Lflag,ErrorMessage=ErrorMessage) + return(Output) + } + + if (m==0){ + # For case of no slope, do not try to compute Mann-Kendall statistic + } else { + v <- ((N*(N-1)*(2*N+5))-vties)/18 # "variance of the sampling distribution of S" Wilks, 2019, p 173 + if (kopt[2]==1){ + v <- vif*v # adjust variance with variance inflation factor, if enabled and warranted + } else { + } + u <- (s+m)/sqrt(v); # test statistic for Mann Kendall trend test + Tstatistic=u; # eq 14.10 in Haan (2002) + + w <- pnorm(abs(u), mean = 0, sd = 1, lower.tail = TRUE, log.p = FALSE) + pvalue <- 2*(1-w) + pstring <- as.character(round(pvalue,digits=6)) + strP <- paste('p = ',pstring,', Mann-Kendall test (H0: no trend)',sep='') + + #================== NON-PARAMETRIC TREND LINE + #Haan 2002, p. 345 + + # matrix with (mx-1) rows, each of which is duped vector (mx-1):1 + N1 <- N-1 + k <- N1:1 + K <- matrix(k,ncol=N1,nrow=N1,byrow=TRUE) + rm(k) + + # matrix with (mx-1) cols, each of which is duped vector (mx-2):0 + N2 <- N-2 + j <- N2:0 + J <- matrix(j,ncol=N1,nrow=N1,byrow=FALSE) + rm(j) + + # More matrices + H <- K-J + L<-upper.tri(H,diag=TRUE) + Q1 <- D/(lower.tri(H,diag=TRUE)*H) + + b <- median(Q1,na.rm=TRUE) # slope + tmed <-median(yrx) + + a <- median(x)-b*tmed + + # Build a string for trend line + if (b<0){ + bb <- ' - ' + } else { + bb <- ' + ' + } + eqn1 = paste('y = ', sprintf('%g',a), bb, sprintf('%g',b), 't, ','trend line\n',sep='') + + # Generate the prediction of x from the non-parametric trend model + xhat <- a + b*yrx # prediction by trend model + + # Generate a detrended version of x; shift that to have the same median as x + xdetrended <- x-xhat # before shift + xmed1 <- median(xdetrended) + xmed2 <- median(x) + d1 <- xmed1-xmed2 + xdetrended <- xdetrended-d1 + + #============= OPTIONAL PLOT, TO BE RETURNED AS A PNG + # see these inputs: + # kopt ....whether want plot + # kplot... which plots + + if (kopt[1]==2){ + # You want plots + + # Next setting apply to plot with trend line in it, regardless of kplot setting + Tit1 <- textPlot[1]; xlab <- textPlot[2]; ylab <- textPlot[3] + Tit1 <- paste(Tit1,strFL) + Tit2 <- textPlot[4] + yhi <- max(c(max(x),max(xhat),max(xdetrended))); ylo = min(c(min(x),min(xhat),min(xdetrended))) + yexpand = 0.10*(yhi-ylo) + ylims <- c(ylo,yhi+yexpand) + + yrgo1 <- yrx[1]; yrsp1 <- yrx[length(yrx)] + if (kplot==3){ + # 1x2 with seris and trend line at top, detrended and original series at bottom + + #--- Build figure png filename + fileOut <- paste(outputDir,'mannken1_F1a','.png',sep="") + zm <- c(xmed2,xmed2) # horizontal line will be at median x, which should also be the + # median of xdetrended + + + # Figure size and margins + png(filename=fileOut, width = 960, height = 480) + layout.matrix <- matrix(c(1,2), nrow = 2, ncol = 1) + layout(layout.matrix,heights=1,widths=1) + + # Top plot + par(mar=c(4.0,8,2,8),cex.axis=1.1, cex.lab=1.5, cex.main=1.3) + plot(yrx,x,type="b",pch=1,col="blue",xlim=c(yrgo1,yrsp1),xlab=xlab, + ylab=ylab, main=Tit1,ylim=ylims) + lines(yrx,xhat,type="l",col="red") # non-parametic-fit trend line + abline(h=zm,lty=2,col='#808080') # dash gray + + # annote test info + f1 <- 1.1 + ySep <- yexpand # y-separate from above line of text + text(yrx[1],ylims[2],eqn1,adj=c(0,1),cex=1.0) # line eqn + text(yrx[1],ylims[2]-f1*ySep,strP,adj=c(0,1),cex=1.0) # pvalue for MK test + # conditional annotated text on variance inflation factor + if (Lacf){ + # You asked to look at the acf of residuals of a least-squares-fit straight line fit to + # the time series. If the residuals from this line have positive lag-1 autocorrelation signficant + # at p<0.05 by a one-tailed test, vif will be computed and vif>1.0. If no significant + # lag-1 autocorrelation, vif is set to 1.0. + strVIF <- paste('VIF=',sprintf('%g',vif)) + text(yrx[1],ylims[2]-2*f1*ySep,strVIF,adj=c(0,1),cex=1.0) # variance inflation factor + } + + # Bottom plot + par(mar=c(4.0,8,2,8),cex.axis=1.1, cex.lab=1.5, cex.main=1.3) + plot(yrx,xdetrended,type="b",pch=1,col="blue",xlim=c(yrgo1,yrsp1),xlab=xlab, + ylab=ylab, main=Tit2,ylim=ylims) + abline(h=zm,lty=2,col='#808080') # dash gray + dev.off() + } else if ((kplot==2) |(kplot==1)){ + # 1x1 with the series and fitted trend line, with special naming of figure file for TRISH + + #--- Build figure png filename + if (kplot==2){ + # TRISH-special + zm <- c(0,0) + FigNumber <- NextFigNumber+jFigAdd # for naming this png + if (FigNumber<10){ + fileOut <- paste(outputDir,'Figure0', as.character(FigNumber),'-AnalysisResiduals2.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure', as.character(FigNumber),'-AnalysisResiduals2.png',sep="") + } + } else { + zm <- c(xmed2,xmed2) + # Most general + if (outputDir=="Null"){ + } else { + fileOut <- paste(outputDir,'mannken1_F1a','.png',sep="") + } + } + #--- Build time plot of time series with trend line and annotation + if (outputDir=="Null"){ + } else { + #fileOut <- paste(outputDir,'mannken1_F1a','.png',sep="") + png(filename=fileOut, width = 960, height = 480) + par(mar=c(5,6,2,2),cex.axis=1.5, cex.lab=1.5, cex.main=1.5) + } + plot(yrx,x,type="b",pch=1,col="blue",xlim=c(yrgo1,yrsp1),xlab=xlab, + ylab=ylab, main=Tit1,ylim=ylims) + lines(yrx,xhat,type="l",col="red") # non-parametic-fit trend line + abline(h=zm,lty=2,col='#808080') # dash gray + + # annote test info + ySep <- yexpand/2 # y-separate from above line of text + + # Simplify annotation if outputDir="Null" + if (outputDir=="Null"){ + } else { + text(yrx[1],ylims[2],eqn1,adj=c(0,1),cex=1.2) # line eqn + text(yrx[1],ylims[2]-ySep,strP,adj=c(0,1),cex=1.2) # pvalue for MK test + } + # conditional annotated text on variance inflation factor + if (Lacf){ + # You asked to look at the acf of residuals of a least-squares-fit straight line fit to + # the time series. If the residuals from this line have positive lag-1 autocorrelation signficant + # at p<0.05 by a one-tailed test, vif will be computed and vif>1.0. If no significant + # lag-1 autocorrelation, vif is set to 1.0. + strVIF <- paste('VIF=',sprintf('%g',vif)) + + if (outputDir=="Null"){ + nullTxt <- paste(strP,'VIF=',sprintf('%g',vif)) + text(yrx[1],ylims[2],nullTxt,adj=c(0,1),cex=1.0) + } else { + text(yrx[1],ylims[2]-2*ySep,strVIF,adj=c(0,1),cex=1.2) # variance inflation factor + } + } + if (outputDir=="Null"){ + } else { + dev.off() + } + } else { + stop ('kplot must be 1 or 2') + } + } + } + + #--- BUILD OUTPUT LEST + + creation <- 'List created by function mannkenn' + definitions <- 'See opening comment section of the creation function' + dateCreated <- Sys.Date() + What <- list("creation"=creation,"definitions"=definitions,"dateCreated"=dateCreated) + + Output <- list("What"=What,"statistic"=Tstatistic,"AnalysisPeriod"=strFL,"Lacf"=Lacf,"Ladjusted"=Ladjusted, + "vif"=vif,"pvalue"=pvalue,"ngrp"=ngrp,"nties"=nties,"Lflag"=Lflag,"b"=b,"a"=a, + "equation"=eqn1,"X"=X,"xhat"=xhat,"xdetrended"=xdetrended) + return(Output) +} + diff --git a/readme.odt b/readme.odt new file mode 100644 index 0000000..66b94ca Binary files /dev/null and b/readme.odt differ diff --git a/readme.pdf b/readme.pdf new file mode 100644 index 0000000..469c811 Binary files /dev/null and b/readme.pdf differ diff --git a/reconsw4.R b/reconsw4.R new file mode 100755 index 0000000..252e1b0 --- /dev/null +++ b/reconsw4.R @@ -0,0 +1,658 @@ +reconsw4<- function(X,Y,nNeg,nPos,yrsCalWindow,c1,Lcausal,LallowLags,MinCalibLength,RequireStable){ + # reconsw4(): single-site reconstruction (SSR) by stepwise forward distributed-lag regression + # D. Meko; last revised 2024-04-17 + # + # When LallowLags=True, for predictand y and chronology x, when LallowLags=True, code + # assumes a potential-predictor pool of x(t-2) to x(t+2) for predicting y(t). If all + # predictors were to enter, the final model would have 5 predictors: x(t-2), x(t-1), x(t), + # x(t+1) and x(t+2). Predictors enter forward stepwise until the adjusted R-squared + # fails to increase by c1 (see below) from the previous step. The predictor most highly + # correlated with y(t) enters first. Additional predictors enter in order of decreasing + # correlation with regression residuals from the previous step. At each step the model + # is cross-validated by leave-9-out cross-validation, and tested for stability by + # split-sample validation. The reduction-of-error statistic is computed as the skill + # statistic in these validation exercises. + # + # The maximum adjusted R-squared model is then simplified, or "cut back" to the step + # of maximum validation skill, as judged by the maximum computed reduction-of-error + # statistic. The model is then accepted or rejected based on several criteria. + # Rejection results from ANY of the following being true: + # 1 REcv<=0: no skill of validation by leave-9-out cross-validation + # 2 REa <=0 or REb <=0: no skill in either of the split-sample validation tests + # 3 pF >=0.05: no significant calibration skill, as judged by p-value of overall F + # 4 Illogical lagged model: final model implies that y(t) can be predicted from + # just the past values of x(t). Logic, by example, is that this years runoff logically + # should not be predictable from a model with only past years' tree rings as predictors. + # + # Model input parameters Lcauasal and LallowStable allow overriding of the rejection by + # criteria 4 and 2 above (see comments on those input parameters) + # + # When LallowLags=false, the predictor pool for y(t) includes just x(t), and the above + # stepwise description can be ignored. In this case, the model is simple linear regression, + # and of course "Lcausal" has no effect. But the screening is still guided by skill + # requirements for cross-validation and split-sample validation. + # + # The broadest possible lagging of t-2 to t+2 is critical in this function because code builds + # variables such as a 5-character pointer output coding which lags are in the final model. So, + # the function will bomb if inputs nNeg and nPos inputs are not both set to 2. + # + #=== INPUT + # + # X [matrix]r tree-ring index as col 2, year as col 1; may have leading and trailing NA + # Y [matrix]r flow (or some other predicand) time series in col 2, year in col 1 + # Time series in Y and X will need to overlap by at least 30 years + # nNeg [1x1]i maximum number of negative lags allowed. The only acceptable setting + # is nNeg=2, which means consider lags t-2 and t-1 relative to flow as possible predictors. + # nPos [1x1]i maximum number of positive lags allowed. The only acceptable setting + # is nPos=2, which means consider lags t+2 and t+1 relative to flow as possible predictors. + # Note that you can over-ride the input settings for nNeg and nPos with the input + # argument LallowLags, such that effectively no lags are allowed in the model. + # yrsCalWindow (1x2)i calibration will make use of flow data only within this period + # designated by first and last year + # c1 (1x1)r critical necessary increment of adjusted R-square and cross-validation reduction of error (REcv) + # required to include an anddition step in stepwise regression. Models are first fit up to the step + # at which R2adj has increased by at least c1 from prveious step. After leave-9-out cross-validation, + # model is possibly further simplified such that last step must yield an increase of at least + # c1 (e.g., 0.01) in REcv. This threshold is in interest of parsimony, to avoid a more complicated model + # if practical gain in accuracy and skill is negligible. + # Lcausal (1x1)L TRUE if reject any model that has negative lags only on the tree-ring series. Makes most + # sense to do this if using standard chronologies, but not for residual chronologies, as a negative lag might + # be compensating for over-whitening or under-whitening. + # LallowLags (1x1)L TRUE if allow lagged model; FALSE if force model to be lag-0 only + # MinCalibLength (1x1)i minimum allowable length of calibration period; if overlap of X and Y is too short + # for this, the function bombs with an error message. The error message is also written to the output + # directory "/outputDir/", which must be in the global space (e.g., from calling script) + # RequireStable (1x1)L TRUE if model tagged for "rejection" when the the RE statistic is negative for + # either half of the split-sample validation. FALSE if the the split-sample RE is to be ignored in + # the decision to reject + # MinCalibLength (1x1)i minimum allowable length of calibration period; if overlap of X and Y is too short + # for this, the function bombs with an error message. The error message is also written to the output + # directory "/outputDir/", which must be in the global space (e.g., from calling script) + # + # + #=== OUTPUT + # + # Returns named list Output with following elements: + # Model [vector]i columns of [t-2 t-1 t t+1 t+2] lagged tree-ring matrix in final model, L-to-R + # in order as the variables entered stepwise. For example [5 2] means model has t+2 and t-1 + # as predictors, and that t+2 (element 5) entered first. + # ModedCoded [string] 1x5 string showing which of the five potential predictors are in the + # final model, and order that they entered. This could be used in a supplemental table. For + # example, "02001" indicates lags t-1 and t+2 are in the model, and that t+2 entered before + # t-1 + # ModelSign [string] 1x5 string with "0" if lag not in model, and "P" or "N" indicating lag + # in model with coefficient of positive or negative sign + # yearsCal(1x2)i first and last year of calibration + # yearsRec(1x2)i first and last year of reconstruction + # MaxLagNegPos (1x2)i maximum negative and positive lags considered in modeling + # LeftOutCV (1x1)i number of observations left out in cross-validation + # IncrementR2adj (1x1)r critical threshold for meaningful "increase" in adjusted R square + # RegCoefs (vector)r regression coefficients, constant term first + # Rsquared (1x1)r R-squared of calibration + # RsquaredAdj (1x1)r adjusted .... + # F (1x1)r overall F of regression + # pF (1x1)r p-value of overall F + # Lsig (1x1)L final model overall-F significant AT 0.05 + # REcv (1x1)r reduction of error statistic for leave-9-out cross-validati0on + # REa (1x1)r RE for model calibrated on first half, validated on second + # REb (1x1)r RE for model calibrated on second half, validated on first + # RMSE (1x2)r root mean square error of calibration (1) and cross-validation (2) + # LREcut (1x1)L final model was truncated, or cut off, at a lower lag than indicated + # by maximum adjusted R-squared because cross-validation RE was higher at a lower lag. + # Lrefit (1x1)L final model was re-fit to a longer calibration period + # because the calibration/validation procedure resulted in a model + # with fewer than two positive lags. + # LNegOnly(1x1)L TRUE is negative lags only in final model; FALSE otherwise + # Lreject (1x1)L if true, tree-ring chronology rejected because at least one + # screening criterion not satisfies. If false, chronology not rejected. Screening + # criteria always include a significant calibration signal (p-value of overall F) + # a positive skill of cross-validation. Additional criteria apply if Lcausal=true + # or RequireStable=true (see above) + # Yh [matrix] reconstruction; 2-col matrix, with year in first column + # + # revised 20221213: adding option LallowLags + # revised 20230325: added input arg MinCalibLength and code that gives error message if calibration + # interval for model (in terms of y years) is fewer than MinCalibLength observations + # revised 2023-04-09: to allow the requirement for temporal stability of models to be optional. + # See RequireStable + # revised 2023-05-26: call to new function, LagModel2Sign, to get new list item, + # revised 2024-03-04: (1) fixed error in call to LagModel2Sign for coding the lags in model to + # sign of regression coefficients, (2) added commented-out debug code that can be uncommented + # for future debugging lagged regression [search "#edebug"], (3) fixed error in getting + # lagged tree-ring matrix ready for regression refit (see Z<- Xorig[,ColsInModel,drop=FALSE] ) + # revised 2024-04-17: comments clarified and corrected for typos + + source(paste(code_dir,"LagYear.R",sep="")) # build lagged matrix of chrons + source(paste(code_dir,"LagReOrder.R",sep="")) # build lagged matrix of chrons + source(paste(code_dir,"CrossValid1.R",sep="")) # leave-m-out cross-validation of stepwise models + source(paste(code_dir,"CrossValid2.R",sep="")) # leave-m-out cross-validation of stepwise models + source(paste(code_dir,"PeriodCommon.R",sep="")) # common period of overlap of chrons and predictand + source(paste(code_dir,"ForwStep2.R",sep="")) # forward stepwise regression + source(paste(code_dir,"ssValid.R",sep="")) # split-sample cross-validation + source(paste(code_dir,"LagModel2Char.R",sep="")) # Build string representation of lagged model estimate forward stepwise + source(paste(code_dir,"LagModel2Sign.R",sep="")) # Build string representation of signs of coefs in model + source(paste(code_dir,"emssgUNH.R",sep="")) # write error file to system, specified output folder + + + #--- CHECK INPUT + + # X and Y must be matrix and 2-column + L<-is.matrix(X) && is.matrix(Y) + if (!L) {stop('X or Y not matrix')} + L<- dim(X)[2]==2 && dim(Y)[2]==2 + if (!L) {stop('X or Y must be 2-column')} + + # Maximum lag of 2: both nNeg and nPos must be 2 + # Be aware that LallowLags can override these settings and allow no-lag + # models, but nNeg and nPos must still be input as 2. + L <- (nNeg==2 && nPos==2) + if (!L){ + emssg <- 'reconsw4 requires that input nNeg=2 and nPos=2}' + ResTemp<-emssgUNH(emssg,outputDir) + stop(emssg) + } + + + # yrsCalWindow should be length 2 vector + if (!length(yrsCalWindow)==2) {stop('yrsCalWindow should be length 2 vector')} + + # c1 should be greater than or equal to zero but no greater than 0.05 + L <- (c1>=0) && (c1<=0.05) + if (!L) {stop('c1 should be non-negative and not greater than 0.05')} + + + ############################################################################## + # + # BUILD MATRIX OF LAGGED TREE-RING INDEX, AFTER TRIMMING TO COMPLETED CASES5 + + a5<-c(1,2,3,4,5) # vector needed later; refers to cols 1-5 of lagged tree-ring matrix + + # LagYear() requires X as single-column matrix + mX <- dim(X)[1] + tGo <- X[1,1] + tSp <- X[mX,1] + yrX <- tGo:tSp + + ktrim <-2 # do not trim lagged matrix to exclude any leading or trailing years containing one or more NA; + # But all-NA rows are trimmed off + x <- matrix(X[,2]) + L <- complete.cases(x) + x <- as.matrix(x[L]) # trim x to non-NA + mlength <- dim(x)[1] + yrX <- yrX[L] + tGo <- yrX[1] + tSp <- yrX[mlength] + yrX <- tGo:tSp + + ResLag<-LagYear(x,tGo,tSp,nNeg,nPos,ktrim) # to build lagged matrix + + X <- ResLag$X # lagged tree-ring matrix: col order is first unlagged, then + # increasing negative lags, then increasing positive lags. So, if nNeg=2 and nPos=2, + # cols would be: t t-1 t-2 t+1 t+2 + tGo <- ResLag$tGo + tSp <- ResLag$tSp; # start and end year of returned lagged matrix X + yrX <- tGo:tSp + + + #--- Call function to re-order columns of lagged matrix. LagYear returned matrix columns + # ordered no-lag, followed by negative lags and then positive lags with increasing lag + # left to right. For consistency with other functions, want cols of X arranged L to R + # from highest negative to highest positive lag. This to be consistent with what is expected + # in functions yet to be called. + # After call to LagReOrder, if nNeg and NPos are 2, for example, X has cols ordered + # t-2 t-1 0 t+1 t+2 + X <- LagReOrder(X) + + + ############################################################################## + # + # STORE VERSIONS OF LAGGED TREE-RING MATRIX: ORIGINAL, AND INCLUDING ONLY + # THOSE ROWS WITHOUT ANY NAN + # + # Because will use the latter in first pass of stepwise regression, where need + # data for all five potential predictors, and depending on the final selected lags + # may be able to use additional rows of X for final calibration. + nX <- dim(X)[2] # cols in lagged matrix + Xorig <- X # full lagged matrix + yrXorig <- as.matrix(tGo:tSp) # year col-vector for Xorig + + L <- complete.cases(Xorig) + X <- Xorig[L,] # Lagged tree-ring matrix, any row with a NA deleted + yrX <- as.matrix(yrXorig[L]) + + +################################################################################ +# +# PREPARE MATRICES OF FLOWS AND LAGGED TREE-RINGS FOR STEPWISE + +#--- PeriodCommon() to trim lagged tree-ring matrix and flow time series to same +# time coverage. Flow data are already in matrix of desired form in V. +U<- cbind(yrX,X) # matrix of lagged chronology, with year as col 1 +namesU<-c('XN2','XN1','X0','XP1','XP2') +ResPC <- PeriodCommon(U,V) +U1<-ResPC$X +V1<-ResPC$Y + +#--- Optional truncation of calibration years; user not allowed to specify a start +# year of calibration earlier than first year of overlap of lagged predictor matrix with y +# +if (is.na(yrsCalWindow[1])){ + tGo <- ResPC$tgo + } else if (yrsCalWindow[1]ResPC$tsp){ + tSp <- ResPC$tsp +} else { + tSp <- yrsCalWindow[2] +} + +#--- Truncation of flows and tree-ring matrix for calibration +yrU1<-as.matrix(U1[,1]) +U1<-as.matrix(U1[,-1]) +yrV1<-as.matrix(V1[,1]) +V1<-as.matrix(V1[,-1]) + +# V1 and U1 Ok as-is if the desired calibration period matches the overlap of y and lagged X +# Otherwise, must truncate. +L<- tGo==ResPC$tgo && tSp==ResPC$tsp +if (!L){ + tGo<-max(tGo,ResPC$tgo) + tSp<-min(tSp,ResPC$tsp) + L1<-yrV1>=tGo & yrV1<=tSp + U1 <- as.matrix(U1[L1,]) ; yrU1<-as.matrix(yrU1[L1]) + V1 <- as.matrix(V1[L1,]) ; yrV1<-as.matrix(yrV1[L1]) +}else{ + # no need for action +} + +# Minimum allowable length of calibration period is MinCalibLength. Return error message +# and bomb out if this minimum length of calibration period violated +nCalib <- tSp-tGo+1 +Lbad <- nCalib < MinCalibLength +if (Lbad){ + emssg <- paste('Function reconsw4 requires calibration period of at least ', as.character(MinCalibLength),' years.', + '\nOverlap for at least one tree-ring chronology allows only ', as.character(nCalib),' years.', sep='') + ResTemp<-emssgUNH(emssg,outputDir) + stop(emssg) +} +rm(Lbad) + + +################################################################################ +# +# PRELIMINARY REGRESSION TO SET ORDER OF ENTRY OF VARIABLES OR MODEL FOR WHICH +# ADJUSTED R-SQUARE IS APPROXIMATELY MAXIMUM; DEPENDING ON INPUT LallowLags, MAY SIMPLIFY +# BECAUSE ONLY LAG-0 IS POSSIBLE. +# +# Status. Flow and lagged tree-ring matrix of calibration length are in matrices U1,V1, with +# 1-col year matrices yrU1 and yrV1. tGo and tSp are the corresponting start and end years +# for calibration. To go back to longer data, have available longer calib data in ResPC fields. +# Have full--length lagged tree-ring matrix in Xorig, yrXorig for later use in reconstruction. + +#--- Forward stepwise of flow on lagged tree rings + +namesU<-c('XN2','XN1','X0','XP1','XP2') # matrices have been organized L to R from lag-2 to lag+2 + +# #debug on +# write.csv(U1,file='U1.csv') +# write.csv(V1,file='V1.csv') +# # In MATLAB, can troubleshoot with simple script (see text_reconsw4.m), such as +# # y = csvread('V1.csv',1,1) +# # X = csvread('U1.csv',1,1) +# # stepwise(X,y) +# #debug off + + +if (LallowLags){ + ResFS1<- ForwStep2(U1,namesU,V1,c1) +} else { + ResFS1<- ForwMoot(U1,namesU,V1) +} + +# $StepMaxR2adj -- the indicated final step +# $ColsInOrderEntry -- where {1 2 3 4 5} are lags t-2 t-2 t t+1 t+2 +i1<-ResFS1$ColsInOrderEntry # Cols entered into max-R2a model, in order as entered +ni1<-length(i1) + +# Store a few statistics, which could change later in response to re-fit with one or two more years on +# recent end if data allow (fewer than 2 positive lags in SSE model and y not limiting) +ModelPicked<-i1 +ColsInModel <- ResFS1$ColsInModel # cols in model in order of RegCoefs (after constant term) +RegCoefs<-ResFS1$Coefficients +R2<-ResFS1$Rsquared +R2a<-ResFS1$RsquaredAdj +Foverall<-ResFS1$Foverall +Fp<-ResFS1$Fpvalue +yearsCal1<-c(yrV1[1],yrV1[length(yrV1)]) +if (Fp<=0.05){ + Lsig<-TRUE +} else { + Lsig<-FALSE +} +H<-summary(ResFS1$Model) +rmseCal<-H$sigma + +################################################################################ +# +# LEAVE-9-OUT CROSS-VALIDATION OF MODELS AT EACH STEP UP TO THE LAST STEP OF THE +# APPROXIMATE MAX-ADJR2 MODEL. +# At each step compute REcv (reduction of error from cross-validation). +# Select as last step in model the step with maximum REcv. Argument i1 +# indicates cols of the lagged tree-ring index (1=lag-2, 3=no lag, 5=lag+2), in order +# of entry in the preliminary stepwise regression. +# +ResCV1<-CrossValid1(U1, V1, nNeg, nPos, i1) +if (ResCV1$REmaxStep=yrgo2 & yrY2<=yrsp2 +Y2<-Y2[L,,drop=FALSE] +yrY2<-yrY2[L,,drop=FALSE] + +# Get tree-ring matrix with complete cases for columns i1 + +# revised 2024-03-04 +Z<- Xorig[,ColsInModel,drop=FALSE] # changed from Z<- Xorig[,i1,drop=FALSE] +L <- complete.cases(Z) + +Z <- Z[L,,drop=FALSE] +yrZ <- yrXorig[L,1,drop=FALSE] + +#--- Find common period of Y1 and Z, which will define the "revised" calibration period +Zm <- as.matrix(cbind(yrZ,Z)) +Y2m <- as.matrix(cbind(yrY2,Y2)) +ResPC2 <- PeriodCommon(Zm,Y2m) +yearsCal2<-c(ResPC2$tgo, ResPC2$tsp) # revised calibration period + +#--- Model will be refit if LREcut or if yearsCal2[2]>yrsCal[2]. One condition is that +# cross-validation resulted in a simpler model that was initially fit (results stored in +# ResFS1$). The other condition is that fewer than two positive lags in the model may allow +# a later year for the calibration period than used in generating ResFS1$ + +if (LREcut || (yearsCal2[2]>yearsCal1[2])){ + Lrefit<-TRUE +} else { + Lrefit<-FALSE +} + + +################################################################################ +# +# IF INDICATED, RE-FIT AND RE-VALIDATE REGRESSION MODEL + +if (!Lrefit){ + yearsCal<-yearsCal1 # if no refitting of model, final calib period is same as + # for preliminary stepwise regression +} else { + # Store the predictor(s) and predictand for revised model + U1<-ResPC2$X + yrU1<-U1[,1,drop=FALSE] + U1 <- U1[,-1,drop=FALSE] # drop year column + colnames(U1)<-namesU[ColsInModel]; # U1, like X, organized L to R as lag-2 to Lag+2, as 1-5 + V1<-ResPC2$Y + yrV1<-V1[,1,drop=FALSE] + V1 <- V1[,-1,drop=FALSE] + + # Regression and storage of revised calibration statistics + G <- lm(V1 ~ U1) + H<-summary(G) + R2<-H$r.squared + R2a<-H$adj.r.squared + Foverall<-H$fstatistic[1] + Fp<-Fpvalue(G) + if (Fp<=0.05){ + Lsig<-TRUE + } else { + Lsig<-FALSE + } + yearsCal<-yearsCal2 + RegCoefs<-G$coefficients + rmseCal<-H$sigma + + # #debug on: These csv files for Matlab stepwise check on entry and coefficients after refit + # # Commment out this block after debug check + # write.csv(U1,file='U1r.csv') + # write.csv(V1,file='V1r.csv') + # #debug off + + #--- Cross-validation of the re-fit model + ResCVrefit<- CrossValid2(U1,V1,nNeg,nPos) + REcv<-ResCVrefit$REcv + rmseCV<-ResCVrefit$RMSEcv + LeftOutCV<-ResCVrefit$LeftOut + + #--- Split-sample validation of the re-fit model + InModel<- 1:length(ModelPicked) # because for this refit the predictor matrix has + # already been culled; all columns are in the model + + # Need pointer to rows of V1, first and second "halves" + iAstop <- ceiling(dim(V1)[1]/2) # end row index in V1 of first half of data, assumed + # longer of the two halves if row-size of V1 odd + iBgo <- iAstop+1 # start row of second half + iA <- 1:iAstop # row indices of first half of full calib period + iB <- iBgo:(dim(V1)[1]) # ... of second half + + #--- Calibrate on early, validate on late, then reverse + ical<-iA; ival<-iB + ResSS2=ssValid(V1,U1,ical,ival,InModel); + REa2<-ResSS2$RE # RE for calib on early, valid on late + ical<-iB; ival<-iA + ResSS2=ssValid(V1,U1,ical,ival,InModel); + REb2<-ResSS2$RE # RE for calib on late, valid on early +} + +# Set the correct REa and REb +if (Lrefit){ + REa<-REa2 + REb<-REb2 +} else { + REa<-REa1 + REb<-REb1 +} + + +################################################################################ +# +# DECIDE IF CHRONOLOGY SHOULD BE REJECTED FOR RECONSTRUCTION +# +# Reject if any one of these is true: 1) overall F of regression not significant +# at p<0.05, 2) Cross-validation reduction of error (REcv) not greater than zero, +# 3) reduction of error computed from split-sample validation on either half +# (REa,REb) not greater than zero. Depending on input Lcausal, could also reject +# if only lags in model are negative on tree rings. Depending on RequireStable, +# could dispense with requirement for temporal stability, such that OK if REa<0 +# or REb<0 or if both are <0. +Lreject<-FALSE +if (RequireStable){ + L<- !Lsig || REcv <=0 || REa <= 0 || REb<=0 +} else { + L<- !Lsig || REcv <=0 +} +if (L) {Lreject=TRUE} + +# Optional rejection of model with negative lags only on tree rings +LNegOnly=FALSE +if (!any(i1>=3)){ + LNegOnly <-TRUE +} +if (Lcausal && LNegOnly) Lreject<-TRUE + + +################################################################################ +# +# APPLY FITTED REGRESSION MODEL TO RECONSTRUCT. + +# Get sub-matrix of full-length lagged chronologies with complete cases for the +# lags in model +# Xr <- as.matrix(Xorig[,ModelPicked]) # code error corrected by next line on 2 Mar 2024 +Xr <- as.matrix(Xorig[,ColsInModel]) +L<-complete.cases(Xr) +Xr <- as.matrix(Xr[L,]) +yrXr<-matrix(yrXorig[L,1]) +mXr <- dim(Xr)[1] + +# Add ones column and reconstruct +Xones<-matrix(1,nrow=mXr,ncol=1) +Xr <- cbind(Xones,Xr) +yh <- Xr %*% RegCoefs # reconstruction as 1-col matrix +yh <- cbind(yrXr,yh) +yearsRec<-c(yh[1,1],yh[mXr,1]) + + +###### BUILD 5-CHARACTER CODE OF SIGN OF REGRESSION COEFFICIENT ON LAGS -2 TO +2 +# +# Code like [00P0P], meaning positive coefficients on lags 0 and t+1, and other lags not in model +#ModelSign <- LagModel2Sign(i1,5,RegCoefs) ---- +ModelSign <- LagModel2Sign(ColsInModel,5,RegCoefs) # revised 2024-03-04 + + +################################################################################ +# +# MAKE NAMED LIST FOR RETURN + +Output<-list("ColsInModel"=ColsInModel,"Model"=ModelPicked,"ModelCoded"=ModelCoded, + "ModelSign"=ModelSign,"yearsCal"=yearsCal,"yearsRec"=yearsRec,"MaxLagNegPos"=c(nNeg,nPos), + "LeftOutCV"=LeftOutCV,"IncrementR2adj"=c1,"RegCoefs"=RegCoefs,"Rsquared"=R2, + "RsquaredAdj"=R2a,"F"=Foverall,"Fp"=Fp, "Lsig"=Lsig,"REcv"=REcv,"REa"=REa,"REb"=REb, + "RMSE"=c(rmseCal,rmseCV),"LREcut"=LREcut,"Lrefit"=Lrefit,"LNegOnly"=LNegOnly, + "Lreject"=Lreject,"yhat"=yh) +return(Output) +} + +ForwMoot <- function(X,namesX,y) { + # Moot-point forward stepwise regression for special case of one potential predictor. + # D. Meko + # Last revised 2022-12-13 + # + # Tailored for reconsw4, such that works with middle column (lag 0) of a matrix + # of predictors assumed to be lagged t-1:t+2 from predictand + # + # INPUT ARGUMENTS + # y [matrix] 1-col of predictand + # X [matrix] one-col matrix of the single potential predictor + # namesX [character] vector of id of potential predictor + # + # OUTPUT + # H: named list, + # names(H)<-c('Model','StepMaxR2adj','ColsInModel','Coefficients', + # 'ColsInOrderEntry','Rsquared','RsquaredAdj','Step', + # 'RsquaredAllSteps','RsquaredAdjAllSteps','Foverall', + # 'Fpvalue') + # Model [lm object] is a special type of R object, and holds many of the + # regression statistics and data, such as the residuals and predicted data. + # R has functions that operate on lm objects. For example, + # summary(H#Model) shows a summary table of the regression + # The Coefficients, combined with ColsInModel would allow a reconstruction to + # be generated from the long time series of potenial predictors X. + # ColsInModel gives the columns of that matrix that the coefficients apply + # to. By plotting RsquaredAllSteps or RsquaredAdjAllSteps agains step, you + # can disply how R-square and adjusted R-square changes with step in the + # stepwise modelin. + # Most of the other list items are obvious from their names. StepMaxR2adj is + # the step at which adjusted R-square reaches a maximum. + + source(paste(code_dir,"Fpvalue.R",sep="")) # p-value of overall-F from lm() [not written by Meko] + + # Regression + G <- lm(y ~ X[,3]) # regression on col 3 of X, which is no-lag from y + kstep <- 1 # only one possible step in simple linear regression + + Foverall<-summary(G)$fstatistic[1] + p<-Fpvalue(G) + + H <- list('Model'=G,'StepMaxR2adj'=kstep,'ColsInModel'=3,'Coefficients'=G$coefficients, + 'ColsInOrderEntry'=3,'Rsquared'=summary(G)$r.squared,'RsquaredAdj'=summary(G)$adj.r.squared, + 'Step'=kstep,'RsquaredAllSteps'=summary(G)$r.squared, + 'RsquaredAdjAllSteps'=summary(G)$adj.r.squared,'Foverall'=Foverall,'Fpvalue'=p) + + return(H) + +} + diff --git a/siteData_Katun.txt b/siteData_Katun.txt new file mode 100644 index 0000000..14603b9 --- /dev/null +++ b/siteData_Katun.txt @@ -0,0 +1,229 @@ +Year russ135 russ137 russ133 russ232 russ233 russ255 russ127 russ129 russ234 russ259 russ222 russ140 russ136 russ228 russ130 russ254 russ230 russ229 russ235 russ226 mong018 mong017 russ252 mong029 mong007 mong009 mong024 mong016 mong025 mong020 russ247 russ251 russ257 russ250 russ246 russ227 russ248 russ231 +1786 1.2025 1.0994 1.0881 1.394 1.4459 1.3051 1.2306 1.1679 1.0305 1.3058 1.1319 0.9893 0.7743 1.0676 1.0391 1.1255 1.6345 1.1964 1.4398 1.4222 0.8869 1.0656 1.0436 1.1102 1.0304 1.2093 0.9762 1.0619 1.0286 1.0413 1.2013 1.2434 1.3941 1.3746 1.2143 1.2301 1.2443 1.1716 +1787 1.1641 0.6202 0.9215 1.1561 0.8305 1.1549 1.3006 1.3233 0.7702 0.9178 0.9843 1.3825 1.2804 1.0939 1.0801 0.9111 0.671 0.9157 1.182 1.1689 0.9854 0.925 0.9765 1.187 0.8948 1.0395 0.8532 1.0345 0.8623 0.9974 1.0069 0.9874 1.2121 1.1436 1.0234 1.1051 1.0718 1.2904 +1788 0.5927 0.473 0.5195 0.4642 1.2558 0.5658 0.7932 0.5881 0.5723 0.7186 0.712 0.8935 0.7718 0.7348 0.7525 0.6146 1.1972 0.6058 0.9758 0.5431 0.9254 0.7952 0.7461 0.7892 0.901 0.6105 0.5228 0.7167 0.6843 0.7041 0.616 0.6537 0.6726 0.5677 0.7046 0.6493 0.4819 0.8707 +1789 1.0575 1.0194 1.0083 0.7651 1.0167 1.0921 1.2563 1.0394 0.9553 0.62 1.059 1.0174 1.0743 1.0029 0.9943 0.8796 1.3212 0.8696 1.2068 0.8645 0.9236 1.2806 0.9039 1.3942 1.409 1.0343 1.1983 1.225 1.4879 1.2792 0.9935 0.9688 1.0803 1.0275 0.9902 1.1387 0.8661 1.5064 +1790 1.1284 0.9122 0.9608 0.9594 1.0703 1.0966 1.0905 1.1924 0.9505 0.9406 0.8803 1.109 1.0403 1.158 1.1542 0.9659 1.0641 0.9764 0.9007 1.0063 1.0197 1.0883 1.0576 1.1759 1.2414 1.0885 1.1111 1.0561 1.0558 1.1836 1.0837 0.9726 1.0925 1.0526 1.0325 1.1345 0.9542 0.9791 +1791 0.8953 1.0592 1.1145 1.0406 1.0232 1.1372 1.1197 1.1689 1.1261 1.0613 0.8994 0.9673 0.8764 0.9242 0.9379 1.0286 1.0606 0.9924 0.7262 1.011 0.871 0.8028 0.9472 0.8793 0.7925 1.0641 1.2068 1.1017 1.1006 1.1523 1.1333 1.23 1.0848 1.0629 1.0905 0.9955 1.0799 1.022 +1792 1.0655 1.0348 1.0513 0.9588 0.8836 0.9739 0.9181 1.0631 1.0482 0.967 0.9444 1.0078 0.9139 1.0004 1.0212 0.7838 0.7149 0.9487 0.7552 0.9599 1.2022 0.6859 0.8672 0.5925 0.5747 0.7525 1.118 0.985 0.9871 1.121 0.8588 0.9168 0.6122 0.7917 0.8431 0.8117 0.9465 0.8529 +1793 0.9945 1.0469 1.0211 1.0172 0.878 0.9295 0.7807 1.0726 1.0096 0.991 0.9723 0.8993 0.9056 1.022 1.0274 1.0781 0.8298 1.1205 0.8685 0.9908 0.9092 0.9911 1.0661 0.937 0.707 1.0247 0.9492 0.873 0.8208 0.8593 1.1554 1.2441 1.0574 0.9916 1.094 1.1109 1.0434 0.9613 +1794 0.9356 0.996 1.0684 0.9502 0.9723 0.9854 1.1956 0.9555 0.9502 0.9372 0.9738 0.581 0.609 0.6261 0.6 1.0482 1.0786 0.9276 0.6518 0.9766 1.0736 1.0513 1.1061 0.9186 0.9706 1.0509 0.9032 0.9211 0.8203 0.9561 1.0013 0.9102 1.1098 1.0309 1.0237 1.0483 0.9047 0.742 +1795 0.9783 0.7619 0.9574 0.8112 0.9766 0.8709 0.9345 0.6829 0.8819 0.8551 0.9899 0.8217 0.7582 0.6472 0.6314 0.9681 1.1665 1.1033 0.774 0.8288 0.9852 0.9655 0.9674 1.0656 1.0984 0.9372 0.9205 0.9388 1.1463 1.1649 1.0378 1.0522 0.942 0.9339 1.0028 1.0208 0.9414 0.8227 +1796 0.9303 0.8346 0.7189 0.917 1.182 1.0135 0.5109 0.9386 0.8864 0.8778 0.9081 0.9092 1.0429 0.9332 0.9131 1.0127 1.1275 1.0391 1.2432 1.0168 0.989 1.0012 1.0766 1.0096 1.0967 1.0364 0.8053 0.8581 0.9313 0.9741 0.7931 0.7958 0.7889 0.9196 0.8979 0.7979 0.7582 0.8604 +1797 0.8615 0.7439 0.4929 0.92 1.0089 0.9263 1.0816 0.9919 0.7432 0.8186 0.9247 0.9405 0.9183 1.0034 1.0281 0.7761 0.9938 0.7884 0.77 0.9647 1.1123 0.9956 0.848 0.9726 0.8558 0.7467 1.0067 1.0112 1.138 1.0482 0.8161 0.777 0.8618 0.9423 0.8689 0.8461 0.7143 0.8942 +1798 1.0619 1.1193 0.951 1.0762 1.2831 1.1127 1.0989 1.1291 1.1239 0.9506 1.1087 1.1687 1.1842 1.1394 1.1564 1.2509 1.2666 1.1232 0.9215 1.1377 1.0752 1.2116 1.1164 1.1873 1.1611 1.2001 0.7887 0.9175 0.6849 0.841 1.1788 1.023 1.1815 1.0888 1.1283 1.2507 0.976 1.0296 +1799 0.9118 0.9608 0.8122 0.8542 1.1773 0.9419 0.8368 0.8844 0.9271 0.9157 0.9342 0.9611 0.8864 0.9413 0.8903 0.9222 1.1374 0.9514 1.1818 0.845 1.0617 0.9785 0.946 1.0562 1.0588 1.0309 0.6683 0.795 0.5678 0.6793 0.8724 0.901 0.916 0.899 0.9265 0.925 0.9042 0.9047 +1800 0.9735 0.9014 1.0309 0.9617 1.4224 1.0695 1.0628 1.1622 0.9493 0.8921 0.938 1.0056 0.9138 1.0117 1.0188 0.9223 1.5546 0.9516 1.3373 0.9853 0.9879 1.0397 0.9648 0.9206 0.9909 1.0296 1.2337 1.0447 1.4249 1.0911 0.9348 0.945 0.8293 0.9585 0.9453 0.8798 0.982 1.2122 +1801 1.0955 1.2082 1.0004 1.0205 1.2265 0.9846 0.9573 0.836 1.1631 0.9533 1.0143 0.8282 0.9497 0.7285 0.7735 1.0327 1.2559 1.0348 1.6318 1.0912 0.9295 0.9924 1.029 1.0622 1.2196 0.934 0.9622 1.0345 1.226 1.3027 1.0145 0.7391 1.0019 0.9864 0.9563 1.002 0.8755 1.3151 +1802 0.9956 1.1021 1.0197 1.0831 1.3038 1.149 1.0723 0.9306 1.0866 1.0691 0.8555 0.619 0.6269 0.8495 0.7902 1.0682 1.259 1.1488 0.9402 1.094 0.9757 1.2456 1.1195 1.1107 1.15 1.0064 1.1963 1.1083 1.339 1.0468 0.9714 1.0368 1.1317 1.0634 1.0499 1.0778 1.0596 1.1615 +1803 1.197 1.3227 1.0968 1.1752 0.8914 1.1434 1.2278 1.1688 1.2824 1.0853 1.0158 1.0707 1.1733 1.1352 1.1672 1.1365 0.909 1.1469 1.2688 1.0977 0.9626 1.3776 1.2073 1.306 1.417 1.298 1.2767 1.1825 1.1831 1.2937 1.3733 1.3096 1.2715 1.3049 1.2045 1.2014 1.2702 1.2394 +1804 0.8982 1.0615 0.9625 1.0628 1.1073 1.0887 1.0805 1.0412 1.0091 1.0744 0.9462 0.7965 0.9045 0.8961 0.8596 0.9736 1.0101 1.006 0.8046 1.0072 1.0821 1.1134 1.0467 1.0087 0.9298 1.0205 0.8814 0.9348 0.8841 1.0916 1.0188 1.1122 1.0329 1.0042 1.0102 1.0423 1.0138 0.8215 +1805 1.209 1.1166 1.2978 1.0027 0.9666 1.0847 1.0633 1.0421 1.1268 1.0237 0.9606 1.1194 1.2043 1.1251 1.1371 1.0311 0.6992 1.0519 1.0007 0.9864 1.2468 0.6644 0.9454 0.7038 0.7274 0.9733 1.0966 1.0795 1.0497 0.9961 1.018 0.9261 0.961 1.0926 1.0227 1.0411 0.9293 1.2489 +1806 1.3806 1.1826 1.2949 1.1338 1.1334 1.1382 1.0455 1.1355 1.1883 1.1628 0.9707 1.1524 1.1682 1.0867 1.0997 1.0026 1.1521 1.1567 1.3666 1.0785 0.6637 0.8025 0.8686 0.999 1.2385 1.0647 0.8949 1.0573 1.2005 0.8839 1.0837 0.9099 1.0156 0.9955 1.0065 1.1585 0.9838 1.0535 +1807 0.9888 0.9198 0.9549 1.0311 0.9515 1.0325 1.1093 1.0826 0.8851 1.051 0.8747 1.0892 1.1737 1.0336 1.0147 0.8814 1.2161 1.0509 1.6227 1.022 0.8448 1.1886 0.959 1.2388 1.1516 1.1134 1.0959 1.115 1.2687 1.0251 1.018 1.086 0.9947 0.8528 0.9752 0.988 1.121 1.0214 +1808 1.1212 0.9476 0.97 0.9731 1.3012 0.9008 0.8255 1.034 1.0262 0.8481 0.9158 1.0932 1.1229 1.0063 1.0157 1.075 1.2884 1.1645 1.0476 1.002 0.9211 0.9943 1.0893 1.2509 0.9668 1.1358 1.1945 0.9114 1.0878 1.1497 0.6837 0.8208 0.7679 1.0384 0.9264 0.8679 0.7967 0.9002 +1809 0.9968 0.9882 1.0798 0.9926 0.9425 0.906 1.131 1.1499 0.9785 1.07 1.0032 1.1054 1.1684 1.095 1.0699 0.9333 0.7877 1.0684 0.9274 1.081 0.8101 0.8692 0.8757 1.2479 0.8034 1.2154 1.0117 1.0357 1.0027 1.1157 1.0453 0.9688 0.9675 0.9214 0.9824 1.0402 0.8918 1.0624 +1810 1.2806 1.1606 1.1061 1.2824 0.9727 1.0343 1.2049 0.9787 1.1887 1.2243 1.1027 1.0848 1.0155 1.1884 1.1537 1.156 0.9279 1.1065 1.2732 1.2226 0.7815 1.1289 0.9766 1.02 1.2287 1.0388 1.0329 1.0581 1.1738 1.0159 1.275 1.1032 1.2471 1.2455 1.1438 1.2416 1.175 1.0475 +1811 1.2804 1.2231 1.1801 1.2652 1.026 1.147 1.1145 1.0766 1.1652 1.3158 1.1616 1.1754 1.0716 1.0994 1.1042 1.1628 1.0864 1.2561 1.049 1.1556 0.8114 1.0455 1.1615 1.0844 0.7494 1.0418 1.058 1.0835 0.9101 1.2155 1.3688 1.2938 1.3134 1.2179 1.193 1.1678 1.2721 0.9928 +1812 0.9019 0.9911 0.878 0.7992 0.7676 0.9332 0.9705 0.8185 0.969 0.9192 0.9432 0.8969 0.7372 0.9415 0.9937 0.631 0.8807 0.8176 0.7045 0.8112 0.8438 0.5642 0.7857 0.516 0.66 0.7134 1.0416 0.8988 0.9469 0.7931 1.0163 1.061 0.8839 0.7129 0.8826 0.8412 1.0708 1.0086 +1813 0.6931 0.4885 0.6843 0.3167 0.7846 0.5811 0.9284 0.9818 0.5382 0.3857 0.6476 0.9868 0.8489 0.9278 0.9151 0.6377 1.0075 0.4448 1.2307 0.5259 0.8353 0.8297 0.9408 0.6377 1.0849 0.6191 0.8952 0.9073 0.8921 0.804 0.5394 0.6274 0.522 0.5273 0.6652 0.5884 0.6909 1.0862 +1814 0.8059 0.7429 0.8381 0.7975 1.0007 0.769 0.8676 0.7869 0.7368 0.778 0.7312 0.9712 1.0716 1.0496 1.1013 0.8908 1.1754 0.7349 1.0709 0.8753 0.786 1.0084 0.9791 0.98 1.0786 0.9123 0.7433 0.922 0.6074 0.7642 0.6096 0.53 0.6996 0.7687 0.7918 0.7549 0.6056 0.9423 +1815 1.1763 1.2329 1.1963 1.0769 1.1136 1.0953 1.2077 0.9494 1.2116 1.1451 1.3013 1.3325 1.205 1.3549 1.4062 1.0981 1.4002 0.9513 1.3524 1.0745 0.9094 1.0942 1.0437 1.0246 1.0934 1.0468 1.1191 0.9407 0.979 0.9948 1.0557 1.1323 1.1656 1.0654 1.0856 1.0641 1.2061 0.9549 +1816 1.0122 0.8917 0.8973 1.027 1.1191 1.0201 0.9826 0.9911 0.9114 1.0712 0.9844 0.993 0.9229 0.8477 0.8329 1.0504 1.2455 0.9293 0.8643 1.0501 0.8305 0.9434 0.856 0.807 0.8266 0.9598 1.1497 1.0788 0.8069 1.0686 1.1846 1.1103 1.0429 0.9586 1.0425 1.0352 1.1229 1.0824 +1817 1.0113 1.0177 0.9185 1.0372 1.0121 1.0575 0.9246 1.0329 0.9912 0.9724 0.9713 0.9262 0.93 0.9828 0.9748 1.0423 1.4878 0.877 1.3689 1.0685 0.8376 0.7499 0.9197 0.6486 0.6652 0.8931 0.8512 1.0481 0.8326 0.7731 1.0868 1.0384 0.9401 0.9712 1.0104 0.9017 1.0792 1.0864 +1818 1.0676 1.0345 1.0947 0.9342 1.0079 0.9604 1.1217 0.9466 1.0551 1.0324 0.9429 1.0973 1.0931 0.9729 1.0004 0.9238 0.9727 0.9208 0.9245 0.9791 0.8777 0.6977 0.9285 1.0389 1.0584 1.0013 0.8542 0.9748 0.7792 0.8286 0.9182 1.0494 0.8749 0.9736 0.9662 0.8902 1.0842 0.9955 +1819 0.8105 0.8387 0.8566 0.6536 0.6707 0.6861 0.7796 0.8498 0.8038 0.7146 1.0055 0.6338 1.1006 0.9513 0.9602 0.7999 0.6688 0.7083 0.7024 0.7958 0.7754 0.7573 0.9139 0.901 0.9809 0.892 1.0143 0.9802 0.9767 0.938 0.7986 0.8302 0.767 0.8351 0.8498 0.7422 0.7532 0.9341 +1820 1.0201 0.8312 1.0006 0.8843 0.9989 0.9227 0.8283 0.8648 0.8802 0.9413 0.8512 0.8367 0.9303 0.9576 0.9369 0.9222 0.991 0.9133 0.7151 0.9204 0.9282 1.0208 0.9904 1.0822 1.045 1.0029 1.011 0.9878 0.9757 0.9648 0.8124 0.7767 0.8194 0.9218 0.9001 0.8827 0.8722 1.0123 +1821 1.2283 1.0357 1.0978 1.1127 0.9054 1.045 1.0774 1.0342 1.1037 1.0811 0.9863 1.0303 1.1258 1.0988 1.1428 1.0993 1.0841 1.0159 1.0284 1.1018 1.0311 1.0252 1.0763 1.119 0.5596 0.9818 0.9905 1.1738 1.0316 1.0899 1.1725 1.0891 1.1247 1.0607 1.0866 1.0293 1.1401 1.2741 +1822 0.9737 0.8875 1.0048 0.7938 1.0302 0.9777 1.1685 1.0388 0.904 0.918 1.0384 0.9794 0.9622 0.9841 0.9532 0.8813 0.9794 0.9002 1.0822 0.7551 0.8225 0.8146 0.9884 0.811 0.9313 0.8421 0.8241 0.7901 0.8239 0.7334 0.9284 1.0772 0.9769 0.8383 0.9486 0.9533 1.131 0.8106 +1823 0.9641 1.0207 0.9418 1.034 0.972 1.0439 0.8762 0.9038 1.0706 1.0861 1.1033 0.693 0.6765 0.6959 0.7184 1.2021 0.9194 1.0238 1.0239 0.9861 1.1131 1.1002 1.1425 1.1491 1.0839 1.1563 1.0162 1.0359 0.9685 1.0278 1.0804 1.0143 0.952 0.9845 1.0439 0.8999 1.0324 0.9082 +1824 1.0936 1.2301 1.0204 1.1143 0.9786 1.0354 1.0133 0.9576 1.1657 0.9978 1.1932 1.1278 0.8989 1.078 1.1179 0.9982 0.8928 1.017 0.6675 1.071 0.8381 0.7342 0.7768 0.8673 0.5617 0.827 1.0754 1.0612 0.9404 1.1837 1.1154 1.0908 0.9074 0.9251 1.0107 1.0627 1.0859 0.9194 +1825 1.0191 0.8875 1.0597 0.9008 0.7475 0.9651 0.8737 1.1586 0.9249 0.9234 0.8567 1.0903 1.1824 1.1778 1.1406 0.891 0.7988 0.8755 0.8755 0.8725 0.8315 0.8437 0.835 0.8674 1.0177 0.8795 0.6315 0.8159 0.7802 0.9357 0.9771 0.9999 0.8562 0.9206 0.9402 0.8619 0.9243 0.8069 +1826 1.0149 0.8039 0.7634 0.698 0.7733 0.779 0.7883 0.7932 0.8093 0.7755 0.8292 0.8208 1.1961 0.7879 0.7914 0.9267 0.676 0.8086 0.6324 0.8396 0.9833 1.1006 0.9465 1.0751 0.91 0.8563 0.8899 0.8455 1.0824 1.0265 0.9168 0.7461 0.851 0.9007 0.9106 0.7579 0.7838 0.7428 +1827 1.0681 1.0147 0.9804 1.0847 0.9272 1.1238 0.9387 0.8936 1.061 1.0504 1.0537 0.805 0.9574 0.8382 0.8214 1.0544 1.0842 1.0016 1.1543 1.0743 1.0524 1.0577 1.0684 1.1067 0.9455 1.0976 1.1705 0.9529 0.9284 1.0865 1.0024 0.9368 0.9244 1.0554 1.0007 1.0689 0.9458 1.1649 +1828 1.0694 1.0834 0.9948 1.0884 0.9969 1.1339 1.1633 0.9147 1.0997 1.085 1.0791 1.0523 0.8973 0.9405 0.9796 1.2512 1.0697 1.1426 0.9345 0.9894 1.2526 1.1897 1.1503 1.1297 1.0773 1.1027 1.108 1.0732 1.2053 1.1803 1.1079 1.137 1.0644 1.1377 1.1313 1.0978 1.1182 1.0207 +1829 1.1476 1.1029 1.0933 0.9789 0.9041 1.0076 1.0189 1.1307 1.0488 1.1554 1.1859 1.0214 1.0282 1.0818 1.1064 1.1073 0.6813 1.1129 0.8418 0.9442 0.9779 1.0865 1.1959 1.0762 0.9361 1.1114 1.1106 1.0345 1.2163 1.2097 1.0094 1.1332 1.0201 1.0219 1.0459 1.0739 1.2117 1.0227 +1830 1.3243 1.3093 1.3947 1.0245 1.0668 1.0871 1.2176 1.3117 1.2394 1.0915 1.0616 1.0464 1.0078 0.8823 0.8947 1.1492 1.1389 1.3324 0.9867 0.9932 1.1052 1.0244 1.1191 0.9774 0.7971 1.0802 1.1574 1.0833 1.3171 1.2615 1.2997 1.3033 1.2971 1.1755 1.1925 1.1656 1.2912 1.3152 +1831 0.8643 0.9403 0.9434 0.9351 1.1165 0.9892 1.2715 1.1458 0.9345 0.9653 1.2038 1.1939 0.8818 0.8115 0.792 1.0739 0.9173 0.9829 1.1996 0.9245 1.0268 1.1901 0.9576 1.0218 1.1074 0.9582 0.8795 0.9434 0.9616 1.0403 0.9 0.9727 1.0278 0.9884 0.9995 0.9483 0.8594 1.1015 +1832 0.9384 0.9677 0.9601 1.0119 1.035 0.9602 1.0329 1.0601 0.9562 1.0937 1.2349 1.0086 0.9514 0.891 0.9007 1.1783 1.0372 1.1337 0.9097 1.049 1.026 1.0029 1.1815 0.8297 0.8535 0.8826 1.1042 0.9605 0.9971 0.9739 1.1146 1.1314 1.0466 1.0737 1.0951 1.0752 1.0786 1.0276 +1833 0.6481 0.6973 0.8034 0.8557 0.7887 0.7852 1.0789 0.9907 0.8027 0.8366 0.9724 1.0266 1.063 0.9538 0.9395 0.9225 0.9722 0.8802 0.6564 0.9054 0.7014 0.9629 0.9296 0.7972 0.9494 0.8334 1.0002 0.9282 0.979 0.9212 0.8304 0.7143 0.7862 0.9703 0.8825 0.9572 0.9543 1.0526 +1834 1.0512 0.8228 0.9801 1.0072 0.9492 1.0043 0.9312 0.979 0.7558 0.8824 0.8915 0.959 0.8676 1.0039 0.9843 1.0317 1.0026 0.9957 1.116 1.0335 0.8137 0.9657 0.8799 1.0668 1.2674 0.8556 1.1937 1.0817 1.1892 0.7996 0.9351 0.9147 0.9657 0.9797 0.973 0.937 0.876 0.8527 +1835 0.9206 0.7737 0.9017 0.8367 1.068 0.8645 0.8739 0.5921 0.7984 0.9306 1.1737 0.7428 0.9114 0.8468 0.8633 0.6669 0.8491 0.8216 0.9704 0.787 0.7357 0.9201 0.7571 1.0253 1.044 0.8652 0.8689 0.9405 0.6412 0.7175 0.6039 0.7086 0.6741 0.6966 0.7474 0.6118 0.7662 0.7412 +1836 1.0329 1.0816 1.1053 1.0991 0.9342 1.0162 0.8078 0.9876 1.0076 1.1177 1.1896 0.8329 0.6575 0.7167 0.7251 1.078 0.8876 1.0389 0.6726 1.1411 0.9287 0.9709 1.067 1.0716 1.0053 0.9593 0.9797 0.9004 0.9138 0.8443 0.9385 1.0877 0.7274 0.9512 0.9874 0.7351 0.9381 1.0974 +1837 1.0859 1.1031 0.9712 1.1312 0.8836 1.0926 1.2198 1.0014 0.9934 1.1643 1.1582 1.0582 0.6567 0.8464 0.8093 1.1992 0.851 1.061 0.7449 1.1356 1.1359 1.1001 1.1512 0.9854 0.8809 1.0009 1.0077 0.9807 0.9081 1.1141 1.087 1.1448 0.9964 1.0278 1.0863 1.0977 1.1576 0.9699 +1838 1.0374 1.1425 1.1123 1.1011 1.1323 1.0009 1.0746 1.1596 1.0028 1.1234 0.7087 1.0951 1.0952 1.2201 1.1889 1.0702 0.9207 1.166 1.104 1.0156 1.0071 1.0169 1.0515 1.184 1.2219 1.0087 0.7702 0.9514 0.6571 0.9124 0.9634 0.9664 1.0531 1.0035 1.0254 1.0266 0.9721 0.7798 +1839 0.9912 1.1082 1.0744 0.9075 1.009 0.9952 1.0735 0.8728 1.0687 1.0621 1.0166 1.0212 0.905 1.0136 1.0046 1.1904 1.0984 1.3283 0.9374 0.9765 1.0533 1.0994 1.0291 0.872 0.9069 1.0073 0.9296 0.9473 0.963 0.893 1.0994 1.0948 1.0341 1.1088 1.0851 1.0077 1.0775 0.9605 +1840 0.7634 0.674 0.6658 0.5458 1.077 0.7613 0.8656 0.9081 0.6846 0.6824 0.6897 0.9841 0.987 0.9513 0.9538 0.695 1.0078 0.6293 1.0569 0.6379 0.7625 0.8132 0.8741 0.7297 0.8771 0.8414 0.9877 0.988 1.0116 0.9206 0.6486 0.4958 0.6594 0.7822 0.7403 0.6478 0.5808 1.1154 +1841 1.0728 1.2413 0.9871 1.1164 1.3048 1.1048 1.0951 1.1529 1.1262 1.2056 1.2562 0.8336 1.1434 1.0158 1.0145 1.3588 1.2434 1.1877 1.2178 1.1712 0.9903 1.0657 1.1818 1.2479 1.1292 1.0475 0.9059 1.0074 1.1503 1.0782 1.1565 1.2114 1.023 1.2594 1.1617 1.0671 1.0755 1.1888 +1842 0.7991 0.6431 0.7786 0.6911 0.9072 0.8522 0.8164 0.7844 0.7745 0.8063 0.9755 0.6937 0.6528 0.7672 0.8029 0.6602 0.9672 0.8091 0.7417 0.7433 0.6871 0.7386 0.7355 0.6789 0.8741 0.7854 0.6557 0.7545 0.6661 0.7973 0.7205 0.8044 0.6977 0.7732 0.7836 0.6856 0.8052 0.804 +1843 1.072 1.0101 1.0305 0.8967 0.9274 0.8441 0.6255 0.8492 0.9448 0.8764 0.8597 0.876 0.7806 0.8615 0.9026 0.879 0.8583 0.8927 0.8613 1.0378 0.8266 0.8949 0.7265 0.725 0.9396 0.9129 1.0614 0.9163 0.743 0.9466 1.0341 0.7142 0.9197 1.0183 0.9322 0.8914 0.9458 1.159 +1844 1.1083 1.1493 1.1531 1.1144 1.1881 1.3001 1.1451 0.8685 1.0526 1.2253 1.082 0.8786 0.7855 0.9009 0.9027 1.1504 1.3206 1.1184 0.9581 1.0831 1.0355 0.8957 1.147 0.9961 1.3358 1.0651 1.1224 0.9829 1.0033 0.9705 1.2125 1.1268 1.0641 1.1154 1.1045 1.0848 1.161 0.7355 +1845 1.0888 1.0915 0.9255 1.0068 0.983 1.0837 1.2072 0.9226 1.0548 1.0802 0.8554 0.7486 0.7463 0.8433 0.8593 1.2179 1.1262 1.0311 1.1765 0.9882 0.9605 1.0642 1.0178 1.0015 1.1938 1.0685 1.02 1.0344 1.2223 0.9983 1.0059 0.9375 0.965 1.0723 1.0451 0.9074 0.935 1.0323 +1846 1.1691 1.2927 1.172 1.1664 1.3237 1.1417 1.2459 1.3468 1.2282 1.1869 1.1069 1.2162 1.2581 1.396 1.3834 1.1889 1.3275 1.2077 1.2075 1.0711 1.2171 1.4139 1.2417 1.3687 1.2818 1.2291 1.3315 1.0996 1.3569 1.3441 1.1534 1.0379 1.1601 1.212 1.1335 1.1819 1.0844 1.251 +1847 0.7741 0.7592 0.6958 0.6552 0.5567 0.7363 0.8981 0.9549 0.8027 0.7262 0.8996 0.8887 1.0131 0.9963 1.0553 0.4744 0.747 0.7177 0.8481 0.7734 0.8607 0.9205 0.9735 0.7038 0.6668 0.8706 0.5811 0.7583 0.8071 0.7797 0.569 0.5778 0.5878 0.6078 0.6534 0.6469 0.613 0.6615 +1848 1.1624 1.3827 1.0323 1.0648 1.1165 0.9815 1.1471 1.1431 1.2846 1.0736 1.4467 0.9828 1.1163 1.1194 1.0611 1.0855 1.0543 1.1589 1.2248 1.0239 1.1713 1.1492 1.1865 0.8534 0.9583 0.9295 1.0837 0.9413 1.1972 1.0733 1.0365 1.1284 1.0392 1.1578 1.0751 1.0528 1.0633 1.2225 +1849 0.8823 1.0109 0.7628 0.9723 0.9216 1.0565 0.8083 0.6792 0.981 1.041 0.7687 0.7265 0.7538 0.7638 0.7947 1.1011 0.9046 1.1349 0.8032 0.9577 1.0496 1.2356 1.0258 1.0697 1.1705 1.0205 1.2738 1.0563 1.144 1.1191 0.986 0.9815 1.0454 0.8152 1.004 1.0813 1.058 0.6688 +1850 0.6194 0.43 0.7054 0.7649 1.1741 0.9411 0.6052 0.5586 0.5543 0.7952 0.6021 0.581 0.7806 0.5743 0.6099 0.8078 1.0173 0.7819 1.1251 0.8703 0.8043 0.9272 0.8879 0.9694 1.048 0.9576 0.9594 0.9446 0.9086 0.8591 0.479 0.6736 0.6954 0.8168 0.7744 0.6613 0.6454 0.7293 +1851 1.0927 1.1589 1.0765 1.0743 1.3026 1.0407 1.1493 1.1213 1.1152 1.1457 1.1517 0.9224 1.2016 1.058 1.0325 1.0126 1.2341 1.1979 1.2445 1.0155 1.0805 1.2371 1.0939 1.1105 1.0009 1.2049 1.2857 1.0746 1.1642 1.2381 0.8232 0.9896 0.8746 1.0562 0.9765 1.0497 0.7787 1.2214 +1852 0.9584 0.8877 1.0116 0.9056 0.9043 0.9735 0.8745 0.8036 0.8868 0.889 0.7761 0.7744 0.9968 0.9316 0.907 0.9032 0.9523 0.9308 0.9452 0.9612 0.886 0.9679 0.9495 0.9395 0.9619 0.9228 0.9622 0.9812 0.9148 0.7785 0.7882 0.7663 0.7932 0.9913 0.8943 0.8306 0.817 0.9018 +1853 1.1407 1.1002 1.1592 1.0741 1.2669 1.0561 1.0455 1.1766 1.0559 0.9261 1.124 0.9884 1.1822 1.0678 1.0542 1.0969 1.0822 1.1009 0.9396 1.0166 1.038 1.1817 1.0292 1.1842 1.2669 1.0435 1.0848 1.262 1.088 1.1442 1.0276 1.1021 1.0542 1.0503 1.0587 1.1278 1.0606 0.9948 +1854 0.704 0.5633 0.5889 0.5343 0.6745 0.654 0.6024 0.5705 0.5861 0.6372 1.0093 0.6939 0.4962 0.5928 0.6655 0.7625 0.6517 0.6062 0.9637 0.6251 0.7647 0.5227 0.7471 0.5672 0.615 0.6575 0.4766 0.9726 0.7157 0.8667 0.748 0.7345 0.7793 0.7741 0.8152 0.6647 0.7031 0.7791 +1855 1.1503 1.1491 1.2539 1.0607 0.9385 1.1079 1.1925 0.8788 1.1687 1.1262 1.0334 1.0891 1.2008 1.2878 1.2885 0.9449 0.9014 1.095 1.209 1.0291 0.9269 1.0594 0.9395 1.0859 1.1176 1.0665 0.9 0.8723 0.5567 0.7463 1.0248 1.0813 1.0692 0.9215 1.0032 1.04 1.0204 0.7856 +1856 1.1777 1.0521 1.0456 0.9635 1.2007 1.0825 1.0553 1.2191 0.9787 1.0257 1.1904 1.1473 1.2597 1.2102 1.147 1.0779 1.171 1.123 1.155 1.0448 1.025 1.0591 1.0845 0.8791 0.9012 0.9826 0.9033 0.8577 0.9646 0.829 0.9903 0.9985 1.0061 1.0225 1.0185 1.0193 0.9518 0.7849 +1857 1.3181 1.2521 1.2632 1.1588 1.1721 1.219 1.0837 1.0921 1.195 1.2145 1.0944 1.338 1.3079 1.2724 1.2295 1.1431 1.0695 1.1381 0.928 1.1484 0.9386 0.98 1.0774 0.9851 0.6993 1.0104 1.1498 1.1193 1.1803 1.1618 0.9392 0.9593 1.1791 1.1038 1.069 1.2235 1.0004 1.3578 +1858 0.8785 0.6831 0.6572 0.9898 0.5275 1.0409 0.8735 0.8398 0.7998 1.078 0.8988 0.655 0.9098 0.9729 1.0069 0.9746 0.6227 0.8708 0.8984 1.0334 0.8394 0.7894 1.0068 0.8945 0.8547 0.9408 1.3798 1.1863 1.0909 1.3098 1.0443 0.9445 1.0223 0.9822 0.994 0.9919 1.0544 0.9364 +1859 0.9865 0.8226 0.9135 0.8743 0.9546 0.8397 0.6809 0.9914 0.8407 0.8972 1.0014 0.7233 1.2657 1.0657 1.1156 0.8234 0.9511 0.9058 0.9221 0.9641 0.8024 0.7217 0.9211 0.8491 0.8943 0.8439 1.1208 1.0075 0.9694 0.7622 0.975 0.9229 0.8121 0.8621 0.8953 0.7661 0.8915 0.8926 +1860 1.0953 1.1443 1.1493 1.2155 1.1388 1.1182 1.153 1.0865 1.1773 1.3114 1.113 1.1673 1.2028 1.2023 1.1447 1.1693 0.9462 1.3495 0.8404 1.119 1.3119 1.3073 1.1495 1.1858 1.2476 1.2979 1.155 1.2124 1.2409 1.1325 1.2317 1.1658 1.2701 1.1926 1.1702 1.2125 1.1907 1.0957 +1861 0.9119 0.9753 0.9194 0.9251 1.1259 1.1674 1.1252 1.0435 0.9727 0.9331 0.8783 0.961 1.111 1.1338 1.1108 1.0321 1.0352 0.9618 0.9383 1.0409 1.1443 1.0067 1.056 0.8346 0.604 0.9064 1.0689 1.1051 1.0461 1.2448 0.9292 0.9531 1.2306 0.9713 1.0176 1.0105 0.9452 1.0675 +1862 1.0747 1.0582 1.0201 0.9151 1.1626 1.1011 0.8969 1.2372 1.0319 1.0136 1.1457 0.9891 1.2062 1.2089 1.1327 1.0841 1.1544 1.0163 1.1702 0.9601 1.0168 1.0475 1.0188 0.9128 0.9084 1.0099 1.09 1.0992 0.8761 1.1652 0.9131 1.0099 1.164 0.9919 1.032 1.1679 1.0253 1.1977 +1863 0.9968 1.0378 0.9712 0.9503 0.8936 0.9448 0.7271 1.0028 1.0207 0.9961 0.8978 0.8444 0.8663 0.9379 0.9686 0.864 0.8143 0.8191 0.407 0.9398 0.7898 0.7074 1.0358 0.7664 0.6888 0.8819 0.801 0.9324 0.4403 0.9308 0.8942 0.88 0.8588 0.9015 0.9026 0.9309 0.969 0.7427 +1864 1.1295 1.2449 1.0074 1.1395 0.9327 1.1002 0.9932 0.8837 1.1858 1.1094 1.144 0.9932 0.7351 0.7023 0.7108 1.2057 0.9915 1.069 0.9196 1.1607 1.0939 1.126 0.9949 1.2024 1.2063 1.1281 0.827 0.8501 0.9272 0.8308 1.1098 1.1535 1.2401 1.1731 1.1452 1.1272 1.1255 0.9397 +1865 0.9241 0.9375 0.9871 1.0065 0.8145 1.0072 0.9932 0.8249 0.9351 0.8956 1.0478 0.8227 0.6639 0.637 0.6386 1.055 0.8414 0.9759 0.8263 0.9712 1.0652 1.0676 1.1116 0.9593 0.969 0.967 1.23 1.0166 1.1706 1.113 0.9982 1.0702 1.0171 1.055 1.0283 0.9831 1.0083 0.8187 +1866 0.9337 1.0423 1.0807 0.932 1.1022 0.9586 1.0347 0.9152 0.9385 1.0126 0.9887 1.3471 1.217 1.196 1.1612 1.0351 1.0466 0.9858 1.0603 0.9254 0.9184 0.8162 0.986 0.9265 1.1463 1.0314 0.9623 1.134 1.1364 1.1037 0.9599 0.9691 0.881 0.9425 0.9692 0.8414 0.9498 0.8438 +1867 0.9531 0.8216 1.0608 0.9084 0.9224 1.0863 0.9239 1.0973 0.9213 0.7991 0.8097 1.0652 1.0247 0.8895 0.9002 0.9854 0.9957 1.1558 0.8228 0.9997 0.8965 0.8687 0.9623 0.9313 0.8715 0.8998 0.6775 1.2389 1.0237 1.0747 1.0271 1.1678 1.0539 1.2075 1.0753 0.965 1.1064 1.0721 +1868 1.1374 1.0442 1.1942 0.9795 0.9864 1.079 1.0805 1.0114 1.0245 0.9644 0.9213 1.1325 1.0186 0.973 0.9853 0.9061 0.8769 1.006 0.5848 1.0008 0.8516 1.177 1.0435 1.1494 1.223 1.0326 1.0656 1.0369 1.1357 1.2235 0.9309 0.9857 1.0434 1.0006 0.9641 1.1025 1.1071 1.0074 +1869 0.7602 0.8445 0.5281 0.8661 1.1152 0.8449 0.9097 0.7888 0.8922 0.8411 0.8786 0.8159 0.621 0.6927 0.7428 0.9705 1.0208 1.0081 1.1803 0.9363 0.9042 1.0861 0.9749 1.0193 1.0827 0.9378 0.9687 1.0125 1.0231 1.0333 0.8059 0.8164 0.8607 1.0031 0.9289 0.8982 0.766 0.7971 +1870 0.9943 1.1412 1.2394 1.0247 1.2692 1.1713 1.0554 0.8943 1.0924 0.8998 0.9372 1.1836 1.1195 1.1564 1.1421 0.8101 1.3725 1.0144 0.9381 1.0612 0.7517 1.1027 0.8499 1.0928 1.1927 0.9567 1.2572 1.1468 1.2207 0.9741 0.9523 1.1401 0.9902 0.9453 0.9673 0.9675 0.9844 1.2555 +1871 0.6789 0.7517 0.6682 0.7204 1.1358 0.8171 0.7437 0.7953 0.8539 0.8128 0.8167 0.8067 0.7588 0.8132 0.8358 0.956 1.2638 0.8681 1.6727 0.7272 0.9979 1.1313 0.9817 1.0623 1.0573 1.0843 0.9585 0.8709 0.7629 0.8914 0.5868 0.754 0.8229 0.9172 0.8792 0.7059 0.7931 0.8772 +1872 0.8429 0.8177 1.0401 0.8467 0.9419 0.8704 0.9913 0.9842 0.8841 0.9449 1.205 1.2775 1.1274 1.1882 1.1691 0.7324 0.8182 1.02 1.1287 0.8114 0.741 0.679 0.7619 0.5789 0.6404 0.6223 1.1615 1.0758 1.0261 0.8723 0.9092 1.0994 0.9277 1.0096 0.9409 0.8233 1.0409 0.8565 +1873 0.9602 1.0445 1.1145 1.094 0.7335 0.8991 0.7003 0.7777 1.0038 0.9934 0.9956 1.028 0.8024 0.9641 0.9821 0.8911 0.6725 0.9245 0.5131 1.07 0.8846 0.7471 0.9715 0.9982 0.9868 0.9205 1.0796 1.0095 1.0754 1.1065 1.0648 0.9773 1.0043 1.0484 1.003 1.0237 1.0052 0.933 +1874 0.6799 0.8069 0.974 0.6576 0.8944 1.0315 1.0085 0.8461 0.7697 0.7907 1.1373 0.7399 0.8221 0.8943 0.866 1.0288 1.0771 0.8458 0.7649 0.7106 0.96 1.1143 1.088 1.1924 1.1983 1.0844 0.7266 0.9784 0.7929 1.1812 1.1376 1.1917 1.1652 0.7362 1.0325 1.2303 1.0822 0.8285 +1875 0.6609 0.553 0.8112 0.7978 0.8079 1.1713 0.8649 0.9078 0.5071 0.9625 1.001 0.7885 0.8292 0.7151 0.7708 1.0939 0.9799 1.2101 0.7251 0.7927 1.0341 0.9901 1.0725 1.0459 0.9806 1.0816 0.6739 0.6893 0.7385 0.6581 1.0117 1.0834 0.9169 0.7179 0.981 0.8139 1.0843 0.2869 +1876 0.9641 0.9498 1.3474 1.0081 1.2369 0.9917 0.9749 1.1171 0.9132 1.0416 1.1787 1.0174 1.0299 1.207 1.1578 1.1826 1.1193 1.2177 1.1128 1.0101 1.05 1.2065 1.0648 1.1701 1.2516 1.0228 1.349 1.1344 1.2768 0.8471 1.0145 0.9958 1.0372 1.0756 1.0618 1.0023 1.0152 1.0976 +1877 1.0993 1.1239 1.3307 1.2503 1.2173 1.2002 1.1656 0.9633 1.1094 1.2602 1.0693 0.9656 0.8839 0.9847 0.9726 1.3193 1.0743 1.306 1.275 1.1344 1.2358 1.4219 1.4177 1.3831 1.2238 1.3045 1.6236 1.2887 1.3407 1.4229 1.3135 1.2654 1.3678 1.1336 1.2158 1.2216 1.2871 0.9988 +1878 0.9153 1.0026 0.8307 0.9302 0.5642 0.9577 0.6579 1.038 0.9643 0.9667 1.1005 1.019 1.0303 1.0482 1.0882 0.9121 0.5686 0.8568 0.7076 0.9181 1.0999 0.7749 1.1919 0.9342 1.0397 0.8787 0.9014 0.9029 0.867 1.1392 0.9669 0.997 1.0637 0.8243 0.9459 1.0347 1.1458 0.6205 +1879 1.0717 1.252 1.1555 1.2318 1.1034 1.1658 1.0303 1.0233 1.1978 1.0245 1.1028 1.2428 1.193 1.1856 1.1866 1.2463 1.1597 1.2574 1.068 1.1408 0.9649 0.6835 1.1689 0.9747 0.638 0.9966 0.898 0.8979 0.6205 1.0259 1.1188 1.1789 1.1524 1.0412 1.109 1.1706 1.0733 0.8907 +1880 1.0921 1.0395 1.198 1.079 1.0094 0.986 1.1441 1.0352 0.9493 1.1152 1.3246 1.317 0.9796 1.1399 1.1241 1.0509 0.7979 1.0319 1.2063 1.0508 0.8943 1.0448 0.554 1.1672 1.088 1.1522 0.8492 0.8824 0.9304 0.9114 1.0003 0.9427 1.0781 1.0913 1.0405 1.069 0.9226 0.93 +1881 1.0738 1.1896 1.2235 1.0302 0.9105 0.9277 0.7357 0.8163 1.1002 0.8955 0.9138 0.9905 0.8498 1.0308 1.0189 1.0795 0.887 0.8521 1.0787 1.1167 1.0694 1.1069 0.9749 0.804 1.0654 0.9494 0.804 0.8562 0.9385 0.7874 0.946 0.9002 1.0008 0.935 0.9973 0.8922 0.9533 0.7874 +1882 1.044 0.9874 0.9793 0.7144 0.8179 0.7313 1.1114 1.0756 0.9726 0.7127 1.1137 1.1567 1.099 1.2431 1.24 0.5666 0.8 0.7768 0.7398 0.8416 1.0672 0.9833 0.8488 0.9649 0.8083 0.8438 1.0888 1.0336 1.1505 0.9989 0.8799 0.9527 1.0073 0.9002 0.8584 0.9963 0.8282 1.0669 +1883 1.0482 1.0514 1.0006 0.7051 1.0352 0.9962 0.9978 1.017 1.0003 0.7195 0.9413 0.9117 1.1176 1.1477 1.1565 0.7041 0.9537 0.844 1.104 0.8359 0.7655 1.0014 0.9038 0.9923 0.8161 0.967 0.8868 0.9518 0.7843 1.1384 0.8885 0.9215 0.9742 0.9016 0.8847 0.9302 0.8246 1.0118 +1884 0.7958 0.5633 0.6854 0.7879 0.8664 0.8739 0.8632 0.8781 0.6862 0.7489 0.8882 0.583 0.8678 0.6952 0.7719 0.6335 0.8116 0.7276 1.0556 0.7844 0.6977 0.7592 0.7383 0.7818 0.8832 0.8487 0.7043 0.875 0.6681 0.8834 0.4509 0.6557 0.5917 0.648 0.691 0.5838 0.7938 0.9013 +1885 1.1634 1.092 1.1566 1.294 0.877 1.1028 1.1566 1.0497 1.1316 0.9936 1.2285 1.2699 0.9823 0.8208 0.8422 1.0705 0.9261 1.0841 0.5226 1.3897 1.1061 1.3221 1.0881 1.0209 1.0134 1.1602 0.8718 0.8559 0.9606 0.8255 1.1586 1.3418 1.1596 0.9875 1.1039 1.1203 1.238 0.6741 +1886 1.0603 0.7687 0.975 1.0431 0.9002 0.9613 1.0087 1.2081 0.8818 0.9093 0.9288 1.3005 1.3998 1.394 1.3686 0.8523 0.8902 0.9417 1.1653 1.0811 1.0021 0.7817 0.9907 0.6789 0.6638 0.9086 0.6846 0.6752 0.6299 0.7167 0.8604 1.0281 0.969 0.9339 0.9417 0.9254 0.9347 0.9605 +1887 0.8442 0.8477 0.7871 0.8247 0.9054 0.899 0.9594 0.9808 0.8414 0.838 0.8165 0.8653 0.8979 0.9142 0.9462 0.8707 0.8661 0.9098 1.0297 0.8696 0.6936 0.8024 0.8964 0.8571 0.8857 0.7891 0.7772 0.8832 0.872 0.7659 0.9385 0.9196 0.826 0.9994 0.9294 0.7582 0.9549 0.9826 +1888 1.1606 1.1098 1.1558 1.2012 1.4495 1.1984 0.9609 1.0953 1.1153 1.0356 1.0211 1.0991 0.9948 0.9362 0.9185 0.8481 1.3763 1.2356 0.9045 1.1396 0.7918 1.2244 0.815 0.9998 1.0568 0.8455 1.1487 0.9669 1.352 0.9238 1.0741 0.9693 0.9142 1.1522 0.992 1.0638 1.0392 1.2288 +1889 1.2941 1.2847 1.1638 1.1693 1.3385 1.0856 0.8677 1.0191 1.2091 1.0758 1.0932 0.8356 0.5113 0.8865 0.8731 1.1307 1.3311 1.1235 1.4984 1.0718 1.1831 1.4491 1.0977 1.2683 1.2281 1.2717 1.2463 1.1265 1.2476 1.1146 1.1118 1.1096 1.1694 1.0967 1.1013 1.1397 1.1946 1.1681 +1890 0.8483 0.8387 0.7219 0.8781 0.8897 0.8395 0.8428 0.7786 0.8817 0.9032 1.1342 0.5006 0.7807 0.6566 0.6745 1.0555 1.1174 0.9392 1.2577 0.8951 1.0529 0.994 1.0516 1.0007 1.0747 0.9496 0.9821 1.0137 0.9825 0.8962 0.8616 1.023 0.9739 1.008 1.0048 0.9418 0.9243 0.8867 +1891 1.0426 1.0739 1.0326 1.1408 1.1687 1.0304 1.0616 0.895 1.099 1.035 1.0715 0.9199 0.9226 0.9676 0.9561 1.084 1.29 1.1493 0.8539 1.0698 1.0516 1.1323 1.0986 1.2341 0.9095 1.0759 1.4481 1.1563 1.1947 1.1008 0.8999 1.0717 1.1548 1.1834 1.0751 1.1882 1.0532 1.0049 +1892 0.9562 1.1378 1.1409 1.0201 0.7691 0.918 1.0796 0.9883 1.1222 1.0335 1.1949 0.9191 0.8565 0.9378 0.91 0.8403 0.7253 0.7906 0.9513 1.042 0.6997 0.9277 0.9708 0.9851 0.9004 0.9692 1.0034 0.9584 0.8786 0.9964 0.9511 1.0331 0.9806 0.8361 0.9384 0.9775 0.9783 1.0286 +1893 0.9635 0.8784 1.0662 1.0403 0.7512 0.9557 0.8035 1.0261 0.9607 0.961 0.8377 0.7921 0.8357 0.8578 0.8726 0.8935 0.7964 0.8254 1.1391 1.0713 1.0465 1.0064 0.9284 0.8851 0.7287 0.9119 1.1038 1.041 0.843 0.8505 1.1429 1.0193 1.0776 1.023 1.0095 0.9175 1.0216 0.9592 +1894 0.9909 1.1398 1.153 1.0987 1.0677 0.941 0.9636 1.0015 1.0945 1.0913 1.0065 1.0461 1.1308 1.146 1.0782 0.9306 1 0.9344 0.9886 1.0425 0.972 0.887 0.9349 1.1319 1.0392 1.0548 0.9734 1.0005 1.0048 0.7738 0.9941 0.9712 0.8956 0.9795 0.9674 1.037 1.0282 1.0017 +1895 1.027 1.0339 1.0234 1.0073 0.7347 0.9523 1.0363 0.9798 1.0142 0.9035 0.9299 0.9166 1.0014 1.0901 1.0816 0.9049 0.8722 0.8737 1.3406 0.9063 0.9118 0.7981 0.9482 0.8657 0.8072 0.941 0.7935 0.9152 0.6946 0.9376 0.8968 0.8809 0.8488 0.944 0.9342 0.891 0.9045 0.9126 +1896 0.9585 1.0822 1.1537 1.2497 0.8028 1.1026 1.068 1.1187 1.1114 1.1561 0.9606 1.0526 1.1927 1.2757 1.2303 1.1297 0.8686 0.9409 0.6718 1.1572 1.0958 1.0863 1.2621 0.9346 0.925 1.0422 1.1941 1.1337 1.165 0.8993 1.1327 1.2104 1.153 1.0352 1.1171 1.1188 1.0835 0.8924 +1897 1.1006 1.1617 1.3634 1.1527 1.0608 1.15 1.1215 1.1 1.1524 1.1732 1.0118 1.1383 1.1477 1.1165 1.0943 1.0462 0.9716 1.0236 1.0288 1.1077 1.2848 1.3243 1.0468 1.2766 1.2571 1.158 0.8864 0.8612 0.8642 1.0072 1.0091 1.0671 1.009 1.0785 1.0459 1.0595 1.0861 0.8684 +1898 1.1148 0.9905 0.9157 0.9454 1.1185 1.2543 1.123 0.8045 0.9925 0.9772 1.0732 0.8749 0.5911 0.7758 0.8296 1.0428 1.0365 0.9504 1.0923 1.0332 0.9555 1.095 1.0847 0.8877 0.9636 1.0239 0.9081 0.8694 0.8966 0.968 1.014 1.0952 1.0304 1.0651 1.0411 1.0688 1.0805 1.1484 +1899 0.8202 0.8703 0.5949 0.967 0.7894 1.0182 1.109 1.1301 0.8919 0.8515 0.8962 0.9336 0.8824 0.8666 0.8647 0.9467 0.9838 0.9723 1.1242 0.8709 0.8671 0.852 0.7802 0.639 0.7761 0.6415 0.9961 1.0173 1.0247 0.9992 0.9358 0.9027 0.9911 1.038 0.9662 1.0033 1.0164 1.1605 +1900 0.9495 1.0097 0.8926 1.2828 0.6406 0.9616 1.2214 0.9974 1.1205 1.2405 0.9554 0.932 0.9069 0.9557 0.9621 1.0379 0.5794 1.0446 0.5032 1.1336 0.9937 0.655 0.8155 1.052 0.8735 0.8586 0.5765 0.9003 1.0525 0.7003 1.2426 1.2459 1.269 0.8138 1.0726 1.2517 1.2427 0.6868 +1901 0.9019 1.0378 1.0418 1.0868 0.7118 1.1178 1.2481 1.212 1.0578 1.1057 0.8042 1.2632 1.2665 1.3477 1.3437 1.157 0.7517 1.0919 0.5237 1.0003 1.2187 1.1611 1.2344 0.9557 0.8069 1.0667 0.6631 0.8073 0.7168 0.6202 1.2447 1.0753 1.2023 0.7542 1.0737 1.013 1.2776 1.0764 +1902 0.8095 1.0332 0.9421 1.0509 1.115 1.0556 1.0555 1.043 1.0262 1.1519 1.1239 1.2409 1.2297 1.1495 1.1906 1.1141 1.1619 1.0003 1.0862 1.0852 1.147 1.0268 1.1443 0.8207 0.9044 1.0375 1.2008 0.9752 1.0695 0.9205 0.9305 0.8807 1.0469 0.9809 1.0043 1.0703 0.915 1.1424 +1903 0.9073 0.8613 0.968 0.8664 1.0032 1.0038 0.8043 0.9199 0.8846 0.8616 0.9731 0.8999 0.9008 0.951 0.9756 0.8919 0.8976 0.9645 0.7525 0.9625 0.6712 1.0085 0.9505 1.0087 0.9326 0.8535 1.0357 1.0023 1.1895 1.1268 0.7349 0.8231 0.9438 0.9175 0.8979 0.8972 0.7158 1.164 +1904 1.1147 1.3166 1.0611 1.5311 0.9296 1.138 1.1293 0.9817 1.3042 1.2159 0.8736 1.0263 0.9932 0.9587 0.9532 1.2508 0.9087 1.2843 0.7475 1.4117 1.1829 1.1531 1.1598 1.1036 1.0332 1.1147 1.298 1.2173 1.1872 1.3275 1.4273 1.2898 1.2676 1.3249 1.2446 1.3061 1.2877 0.9204 +1905 0.9374 1.1354 0.8502 1.1037 0.7801 1.0285 0.8135 1.2752 1.1079 1.1041 1.1969 1.1871 1.3682 1.3647 1.3053 0.9661 0.799 1.0448 0.7174 1.0428 1.035 1.1167 1.0756 1.079 1.0447 0.9958 1.0078 0.9436 0.7786 1.1268 1.2585 1.2042 1.1458 0.9094 1.0568 1.1119 1.2397 0.8588 +1906 0.9217 0.7248 0.8804 0.834 1.0472 0.935 0.9048 0.9807 0.8074 0.883 0.9185 1.2278 1.1118 1.1267 1.1252 0.7893 1.0623 0.904 1.0333 0.8205 0.8747 1.0293 0.9564 0.9713 0.9055 0.9509 0.9551 0.9628 0.896 0.9686 0.7667 0.7755 0.9334 0.7667 0.8412 0.8387 0.7559 1.0207 +1907 0.9311 0.754 0.8771 0.8563 0.9008 1.0398 0.7293 1.0643 0.7363 0.936 0.9295 1.1272 1.2924 1.2309 1.2362 0.8867 1.0893 0.8565 0.9473 1.0068 1.0958 1.2631 1.0712 1.1772 1.2448 1.112 1.0724 1.0668 1.1251 1.1765 0.8511 0.8558 0.9304 0.954 0.9186 0.9545 0.761 1.1639 +1908 1.3182 1.3474 1.1223 1.3607 1.0649 1.1346 1.0193 1.452 1.3194 1.3777 1.1164 1.1046 1.4527 1.3095 1.2624 1.3119 1.1647 1.279 1.1334 1.45 1.3375 1.1851 1.3054 1.1238 1.0318 1.0979 0.9596 1.2208 1.1097 1.1011 1.183 1.1782 1.27 1.2529 1.1925 1.3418 1.1877 1.229 +1909 1.1346 1.3909 0.9872 1.4436 0.9275 1.1497 0.9712 1.2322 1.3828 1.3733 0.9798 0.6782 1.104 1.3513 1.2942 1.3076 1.0344 1.2342 1.1824 1.3965 1.5042 1.0058 1.0047 1.1038 1.0694 1.183 0.8225 0.9646 0.9514 0.886 1.254 1.4014 1.3071 1.2026 1.2279 1.3683 1.2406 0.6816 +1910 0.7634 0.896 0.7948 0.9124 0.8554 0.8174 0.9132 0.8015 0.8575 0.6244 1.0771 0.8212 0.8095 0.6351 0.6392 0.5032 0.8163 0.6292 0.584 0.9449 0.5152 0.6101 0.6403 0.6506 0.4717 0.6809 0.4763 0.7812 0.6955 0.5368 0.9434 0.6924 0.8027 0.7543 0.7821 0.724 0.9495 0.5424 +1911 0.5178 0.412 0.6711 0.5727 0.8399 0.6736 1.0117 0.9631 0.4822 0.5555 1.0406 0.9195 0.8606 0.8244 0.7979 0.6167 0.9135 0.5881 0.8431 0.6467 0.5119 0.5587 0.5937 0.6121 0.8841 0.7003 0.9458 0.7896 0.9617 0.7587 0.7031 0.7452 0.7665 0.6838 0.7501 0.6462 0.6812 0.9123 +1912 1.0726 0.867 0.9748 0.9061 1.1361 0.9998 1.0655 1.0612 0.8958 1.0312 0.9821 0.8571 0.7442 1.0877 1.0489 0.8964 1.2756 0.9536 0.8707 0.9287 0.9815 1.2833 0.967 1.3513 1.3344 1.0425 1.0966 1.0567 1.3364 1.1379 0.9248 0.8624 0.9608 0.8675 0.9121 0.9843 0.931 1.1858 +1913 1.1182 0.9007 1.0256 0.9756 1.1509 1.0765 0.9246 1.0276 0.9274 0.7688 1.0351 0.8017 0.9695 0.8629 0.8832 0.9303 0.9566 0.9259 1.1629 1.0099 0.9305 1.1877 0.906 0.9759 1.0599 0.9459 1.0334 1.0452 1.1667 1.1658 0.9566 0.8232 1.0272 0.9952 0.9577 1.0619 0.9097 1.0363 +1914 0.8439 0.7853 1.0192 0.9045 1.1555 1.122 1.075 1.0441 0.8317 0.9086 0.8205 0.9244 0.8808 0.9504 0.9282 0.9086 1.2444 0.9041 1.3876 0.9852 0.9711 1.0364 0.8632 1.1065 1.1366 1.0592 1.027 1.0741 1.1645 0.9947 0.814 0.8257 1.0798 1.0264 0.9576 1.0105 1.0577 1.0919 +1915 1.2032 1.1231 1.2261 1.1565 0.9634 1.1896 1.0707 0.9613 1.2087 1.1102 1.0459 0.8884 0.9395 1.0144 1.0193 1.0784 0.94 1.1342 1.0724 1.1142 1.0341 1.1038 0.9666 1.2156 1.3585 1.1562 1.4822 1.1821 1.1333 1.3883 0.9 0.8184 1.1517 1.0257 1.0131 1.2033 1.0761 0.897 +1916 1.1388 1.0037 0.9985 1.2908 1.31 1.2659 1.0932 1.1624 1.0845 1.1369 0.941 0.9307 0.6951 0.7996 0.8348 1.0676 1.0959 1.0822 1.2927 1.1769 1.246 1.2324 1.0429 1.3245 1.1265 1.1781 1.1942 1.0234 1.2098 1.3064 1.0318 0.9579 1.0955 1.105 1.0548 1.0354 1.1434 1.2063 +1917 0.7703 0.7952 0.8494 0.6871 0.5807 0.8856 0.8361 0.7222 0.8252 0.8615 0.9851 0.6976 0.6735 0.5022 0.4805 0.7624 1.0445 0.8115 0.9331 0.7405 0.8072 1.0643 0.9291 0.9288 1.197 0.8478 0.8147 0.9101 0.7834 0.7244 0.6765 0.6728 0.6233 0.8556 0.7876 0.634 0.7132 1.3053 +1918 1.1267 1.0769 1.0832 1.048 0.7918 0.9306 0.9955 1.0857 1.0674 0.9418 1.0803 1.0961 0.8501 0.8708 0.975 0.9589 0.7708 0.954 1.1649 1.0028 1.0594 0.8703 1.0454 1.1656 1.2154 0.931 0.667 1.0469 1.0474 0.8786 1.0614 0.9739 1.0797 1.0225 1.0139 1.1346 0.8719 1.0604 +1919 0.8021 0.9739 0.9642 0.9768 1.2478 0.9398 0.8569 0.9778 0.9877 0.9374 1.0042 1.0363 0.8022 0.9353 0.8914 1.0541 1.1278 1.033 1.22 0.9328 1.0398 1.0052 1.011 0.9376 1.11 0.9295 0.9427 0.8585 0.8474 0.9692 0.9005 0.7881 0.8754 1.0201 0.9602 0.8985 0.8959 0.8793 +1920 1.148 1.2918 1.1086 1.2817 1.033 1.1206 0.9843 1.0505 1.3042 1.3024 1.0367 1.1347 0.8752 0.923 0.9154 1.2919 1.1277 1.2186 1.1476 1.2004 1.2357 1.1714 1.1576 1.0971 1.2783 1.1733 0.9587 0.9606 0.9243 1.0561 1.2619 1.1193 1.3041 1.3518 1.2279 1.3186 1.2212 0.9097 +1921 0.998 1.0702 1.2308 0.8436 1.2006 1.1057 1.0802 1.2036 1.101 0.9708 1.0989 1.3073 1.0494 1.1115 1.0754 1.0251 1.2909 1.016 1.2721 0.904 1.079 1.1417 1.1089 1.3088 1.3093 1.0626 0.7263 0.9288 1.1832 0.8141 0.8186 0.9775 0.9958 1.0206 0.9837 1.0278 0.9342 1.0988 +1922 0.6887 0.8637 0.7274 1.0166 0.9797 0.9514 1.0711 1.1475 0.8871 1.0596 1.0827 1.0627 0.9665 1.0027 1.0008 1.0939 0.9893 1.0367 1.0358 0.9425 1.0719 1.1721 1.1372 1.2166 1.272 1.1251 1.3101 1.0928 1.1619 1.2795 1.0892 1.0067 0.7987 1.1216 1.0186 0.9283 1.0187 1.0474 +1923 0.8467 0.9372 1.001 1.0286 1.0561 1.1039 1.0504 1.2146 0.9562 1.024 1.0909 1.041 0.8643 0.9947 0.9944 0.9449 1.0564 1.0217 0.6149 0.9477 0.828 0.8185 0.8964 0.8193 0.6355 0.8008 0.9377 0.9652 1.0688 1.1171 1.1533 1.094 1.0419 1.0675 1.0317 0.9652 1.1859 1.0512 +1924 1.0476 1.2869 1.2564 1.1826 0.9528 1.0438 1.0036 1.1737 1.2954 1.1042 1.3684 0.9742 1.022 0.9908 0.9745 1.2982 1.062 1.0225 1.1943 1.0831 1.1911 1.1981 1.047 1.0013 1.0548 1.0116 1.158 1.014 1.1245 1.286 1.2146 1.0967 1.0969 1.178 1.1502 1.2003 1.0961 0.9679 +1925 0.9736 1.0057 1.1817 0.8727 1.11 0.943 1.0211 1.1026 0.975 0.9404 0.936 0.9912 0.8539 0.8247 0.8405 0.7708 0.8744 0.9652 0.7794 0.9291 0.9907 0.914 0.8271 1.0252 0.9361 0.959 1.0191 0.8844 0.881 0.8424 0.9019 0.8289 0.9934 0.9469 0.9096 0.9907 0.9414 1.1471 +1926 1.0873 1.2298 1.1737 1.1165 1.1199 0.9932 0.97 0.8725 1.2827 1.0674 0.9257 0.9413 0.8328 0.9249 0.9152 1.0623 0.9644 1.1961 0.9848 1.0365 1.1099 1.1325 1.1401 1.2079 1.3022 1.0827 1.2193 1.0617 1.0443 1.0612 1.098 0.9622 1.1146 1.0888 1.0603 1.1853 1.0584 1.0232 +1927 0.7743 0.5289 0.8236 0.5519 0.9758 0.5985 0.6002 0.9877 0.5692 0.6332 0.843 1.0226 0.9771 0.9048 0.9381 0.813 0.9818 0.6063 1.0088 0.6293 0.7181 0.9339 0.8161 0.9287 0.9702 0.8601 0.6973 0.9756 0.6736 1.0392 0.6388 0.6135 0.7289 0.7831 0.782 0.6927 0.6138 1.0438 +1928 1.463 1.5106 1.5528 1.4197 1.3926 1.2099 1.1087 1.2904 1.4671 1.2022 1.2704 1.4279 1.1983 1.347 1.2697 1.1558 1.485 1.1068 1.4558 1.365 1.2007 1.1156 1.0569 1.325 1.2549 1.1811 1.1377 0.9954 1.2453 1.0286 1.0302 1.0552 1.3412 1.3347 1.1494 1.3326 1.0594 1.3491 +1929 1.1111 1.2035 1.2054 1.059 1.1347 1.1063 0.9999 1.0409 1.2166 1.0548 1.0768 1.0114 1.0643 1.0019 1.0034 1.2299 1.1282 1.1278 1.5102 1.0642 1.0859 1.1441 1.1085 1.0149 1.1725 1.0221 1.0894 1.0036 1.1681 0.8959 1.0547 1.1159 0.9281 1.0905 1.0795 1.1431 1.1339 0.9538 +1930 1.085 1.2386 1.0629 1.3569 0.6513 1.2011 1.0996 0.8728 1.2224 1.4105 1.0356 1.0821 1.2108 1.1709 1.1806 1.2814 0.826 1.2436 0.529 1.2957 1.4445 1.242 1.1033 0.7412 0.3324 1.0665 1.2627 1.1894 1.1957 1.4255 1.1924 1.1029 1.2513 1.1906 1.169 1.3495 1.2038 0.9995 +1931 1.0409 0.9335 0.8321 1.0311 0.7686 1.0405 0.9418 0.8481 0.8773 1.0433 0.9963 1.1004 0.9785 0.9996 1.0082 1.0939 0.9844 1.1626 0.9215 1.075 0.9008 0.7587 0.909 0.8267 0.9635 0.8831 0.9238 0.927 0.9809 1.0978 1.2919 1.1202 1.2162 1.1884 1.1548 1.1571 1.0903 0.7105 +1932 1.1504 0.8566 0.9776 0.8467 1.262 0.9967 0.7659 1.1633 0.9037 0.9898 1.0264 1.0715 1.1362 1.1519 1.1488 0.8296 1.093 0.9809 0.9715 0.8264 0.5552 0.9065 0.8435 0.8737 0.9398 0.8099 0.8445 0.9238 1.044 1.0241 0.9171 0.8802 1.0016 0.7958 0.9068 0.9544 0.9329 0.7519 +1933 1.1044 1.0495 1.0886 0.9319 1.0298 0.8431 0.7227 1.022 1.0961 0.912 0.9927 0.9058 0.9598 1.0825 1.0713 0.8558 0.8778 1.0345 0.7708 0.9638 0.7168 1.0255 1.1068 1.1468 1.1905 1.0327 0.8826 0.8833 0.8615 0.8065 0.8433 0.8408 0.8397 0.8314 0.8815 0.9763 0.9516 1.2263 +1934 0.9997 0.8384 0.8549 1.2713 1.0662 1.1913 1.1353 0.8884 0.8726 1.1869 1.0234 1.3277 1.1367 1.0676 1.0872 1.155 0.9704 1.1817 0.8989 1.2819 1.1555 0.9008 1.1665 1.0288 0.9574 1.127 1.187 1.0914 1.3701 1.1123 1.2868 1.2545 1.2861 1.2369 1.1809 1.3347 1.24 0.9597 +1935 1.1587 0.9803 1.0923 1.0749 1.0372 1.1197 1.0611 1.0202 0.9606 1.1881 1.1102 1.0746 1.1633 1.0196 0.993 1.237 1.1466 1.0736 0.9206 1.0871 1.3654 1.1382 1.1572 1.1506 1.2136 1.0289 0.9655 0.991 1.0502 1.116 1.1355 1.0851 1.1518 1.1547 1.1277 1.036 1.1373 0.9636 +1936 0.9996 0.9471 0.9059 0.9803 1.0283 0.8884 0.8917 1.1447 0.8917 1.1017 1.0402 1.0231 1.0763 1.0747 1.0933 0.9904 1.0072 1.0819 0.9196 1.0339 1.1013 1.0344 1.134 1.1261 1.1584 1.0425 1.2312 0.9935 0.9873 1.2254 0.9521 1.0535 0.9331 0.9678 0.9865 0.8439 0.8888 0.9435 +1937 1.0448 0.8135 1.0525 0.8972 1.1773 0.9485 1.0338 1.126 0.8373 0.8816 0.689 1.154 0.9057 1.0114 1.0419 0.8962 1.3066 1.0259 1.0671 0.8781 0.7998 0.9523 1.0445 1.1535 1.1203 1.028 1.1563 1.0172 1.0636 0.9725 0.8682 0.8014 0.8113 1.0141 0.9078 0.9521 0.7838 1.2286 +1938 0.8268 0.8081 0.8247 0.7331 1.2156 0.8561 0.8987 0.8431 0.8276 0.8256 0.7139 0.6365 0.7663 0.8052 0.8548 0.8359 1.058 0.8458 1.2181 0.7897 0.8259 0.7595 0.8146 0.9448 0.9209 0.9041 1.0531 1.0494 0.9876 1.0258 0.7447 0.7411 0.7218 0.8771 0.8361 0.8178 0.7696 1.2295 +1939 1.0543 1.1954 1.2162 1.324 1.2272 1.0827 1.0892 1.1695 1.1998 1.2051 1.1795 1.0107 1.1355 1.1039 1.0958 1.0358 1.5489 1.1216 1.3827 1.276 1.1456 1.0607 1.0102 0.8083 0.9166 1.1006 1.2516 1.1718 1.2114 1.3396 1.1609 1.0862 1.2048 1.1879 1.0967 1.2424 1.0311 1.352 +1940 0.9102 1.0895 0.9623 1.026 1.004 1.1015 1.0291 0.7378 1.0465 1.1186 1.2288 1.0453 1.0848 1.0083 1.0001 0.8559 1.0828 1.1262 1.0913 0.9686 0.9246 0.896 0.7988 0.617 1.0053 1.0351 1.0312 1.165 0.9891 0.9483 1.1089 1.1131 1.1742 1.1012 1.0454 1.1432 1.1551 1.0241 +1941 1.1852 1.1928 1.1759 1.0308 0.661 0.9579 1.0735 1.149 1.0935 1.0303 0.9345 1.1716 1.1562 1.122 1.1252 0.7371 0.585 1.0754 1.0321 1.005 1.0217 1.2212 1.0728 1.1309 1.0317 1.1454 0.823 1.0925 0.8635 1.0527 1.1469 1.0224 1.184 0.9741 0.9958 0.9729 1.0801 1.1508 +1942 1.019 1.1142 1.2028 0.6492 0.9064 1.0074 1.0784 1.1026 1.0875 0.8547 1.0271 1.0927 0.8467 0.8819 0.9124 1.0727 0.8192 0.7847 1.2835 0.642 1.2616 0.9453 1.1082 0.8387 1.087 1.0193 0.8343 0.8386 1.2788 1.1968 1.1611 1.0678 0.9589 0.5511 0.9633 0.9005 1.0735 0.8424 +1943 0.8704 0.9464 1.2317 0.9725 1.1119 1.0565 0.9143 0.6705 0.9735 1.039 1.022 0.5543 0.4294 0.3151 0.32 1.0903 0.9853 1.05 1.6014 1.1 1.119 0.7921 0.8701 0.768 0.867 0.9254 0.9442 0.6902 1.1938 0.782 1.0231 1.0539 0.7189 0.9344 0.9825 0.9533 0.8751 1.0424 +1944 1.0721 1.2507 1.1644 1.2661 1.0875 1.1744 1.1714 1.169 1.2518 1.2353 1.1656 1.1913 1.1037 1.1067 1.0709 1.1481 1.0293 1.312 1.0305 1.1866 1.3919 1.1921 1.0685 1.1331 1.1577 1.2401 1.3548 1.3647 1.1936 1.1442 1.1961 1.2519 1.1277 1.1382 1.1386 1.1287 1.0958 1.0572 +1945 1.247 1.2449 1.1473 1.2049 0.8245 1.0147 1.3187 0.9667 1.2436 1.1449 1.124 1.1223 1.0856 1.001 1.0019 1.1458 0.9449 1.3044 0.8892 1.1583 1.4474 1.0315 1.1641 1.2181 0.7504 1.2308 1.3158 1.3099 1.0171 1.2093 1.3232 1.2836 1.3636 1.1502 1.2008 1.1809 1.2828 0.9545 +1946 1.1488 1.3381 1.1682 1.1781 0.9103 0.928 1.0592 1.0565 1.2621 1.3304 0.9818 1.096 1.225 1.0822 1.0385 1.2013 0.7482 0.9314 1.0269 1.0043 1.6502 1.0931 1.32 1.0217 0.9651 1.1704 0.8385 0.8747 0.9301 1.2294 0.9086 0.983 0.8869 0.9079 1.0136 0.8356 1.0643 0.8075 +1947 0.9313 0.73 0.9937 0.7552 1.0823 0.8143 0.7226 0.8191 0.7439 0.7718 0.5332 0.6537 1.0812 1.033 1.0069 0.8451 0.9397 0.7965 1.4525 0.8331 0.6342 0.8057 0.7935 0.8785 0.9515 0.8956 1.0951 0.917 0.796 0.788 0.6407 0.5834 0.6505 0.8999 0.7932 0.6508 0.6228 1.0049 +1948 1.0855 1.427 1.3214 1.3725 0.9663 1.0854 1.0447 1.2112 1.3593 1.2392 1.1559 1.0399 1.2432 1.1415 1.1073 1.1281 0.934 1.2266 1.3267 1.3382 1.2874 1.1085 1.1117 1.2164 1.1033 1.236 1.4372 1.1018 1.1508 1.1839 1.3809 1.2258 1.2365 1.2013 1.1825 1.2275 1.2553 1.085 +1949 1.0166 1.0056 0.9377 0.8722 0.8397 0.9173 1.0922 0.9816 1.0315 1.0303 1.0895 1.0983 0.8966 0.9542 0.9886 0.8481 0.8434 0.9134 0.6258 0.8849 0.8897 0.8319 1.0054 0.8435 0.7286 0.9223 0.7807 0.7262 0.6107 0.9441 0.8266 0.9227 0.8817 0.9038 0.8995 0.7827 1.0198 0.7668 +1950 1.2593 1.3504 1.4313 1.2203 1.1733 1.1512 1.1866 1.0727 1.3838 1.0862 1.0767 0.8558 0.8247 0.8048 0.7934 0.9577 1.1114 1.0781 0.7856 1.1507 0.9222 0.7222 1.1271 0.7294 0.6582 0.9438 1.2874 0.9774 1.0517 1.0082 1.0928 1.136 1.1309 1.0924 1.0655 1.0861 1.1377 1.2353 +1951 1.0926 1.0803 1.1501 1.2279 0.8925 1.1361 1.1444 0.9866 0.9737 1.2382 1.0959 0.8105 0.8753 0.9761 0.9475 1.1345 1.0131 1.2505 0.8395 1.1554 1.1281 1.0754 0.9986 0.7865 0.8328 1.0277 0.6806 0.9302 0.997 0.896 1.2164 1.1076 1.2767 1.3105 1.1632 1.1617 1.099 0.9375 +1952 0.5383 0.6998 0.7035 0.7299 0.7733 0.9501 1.0398 1.2252 0.7602 0.7935 0.9132 1.0404 0.9318 0.9614 0.9141 0.9663 0.9569 0.856 1.1307 0.7782 0.8065 1.0063 0.838 1.0836 1.1223 0.7639 0.8864 1.0043 1.1917 0.9975 0.8538 0.8723 0.9545 0.8553 0.927 0.8357 0.8483 1.0835 +1953 1.2661 1.0786 0.9483 0.8811 0.8458 0.8847 1.0918 1.1714 1.0668 0.8351 0.8983 0.9529 1.07 0.8206 0.848 1.3436 0.9666 0.9919 1.2768 0.8682 1.1575 1.1762 1.1901 1.3167 1.3141 1.1777 1.031 1.1106 0.968 1.0295 1.2166 1.0997 1.0166 1.1122 1.1503 1.0457 1.1697 1.0736 +1954 0.9884 0.9802 0.948 0.9707 1.0583 0.9953 1.1493 1.1838 1.052 1.0596 0.9596 1.1504 1.2259 1.0187 1.0128 0.825 1.0361 0.9173 0.8053 0.9826 0.9272 1.0314 0.9366 0.9012 0.9101 1.0084 1.0704 0.9637 0.9561 0.7992 0.983 1.0542 0.9092 0.8534 0.9253 0.9323 0.9683 1.1449 +1955 1.2624 1.1319 1.0822 1.3618 0.8591 1.2082 1.0781 0.9825 1.1754 1.2392 0.9341 1.1689 1.34 1.2231 1.1349 1.2603 0.9195 1.2165 0.8988 1.2569 0.9279 1.0693 0.9888 1.22 1.1522 1.0985 1.1737 1.1133 1.2429 1.1761 1.2789 1.2672 1.184 1.2043 1.1895 1.1887 1.1827 1.2977 +1956 0.8968 0.8377 0.851 0.7104 0.9861 0.8674 0.9072 0.8822 0.8003 0.842 1.0667 1.3103 1.1735 1.096 1.1085 0.872 0.7979 0.7249 1.105 0.7427 0.9082 0.9293 0.8453 1.0331 1.0955 0.8458 0.7255 0.9161 0.8189 1.0747 0.8582 0.8886 0.9854 0.8279 0.9168 0.9591 0.9956 1.0713 +1957 1.457 1.2297 1.1452 1.0787 0.8809 1.094 0.952 1.1492 1.2232 1.0948 1.0945 1.2564 1.1722 1.2093 1.211 1.0589 1.1409 1.2133 1.1565 1.0575 0.8998 0.8981 1.0757 0.925 0.6267 1.1482 1.327 1.1713 1.2641 1.2544 1.2656 1.197 1.2568 1.1437 1.1441 1.3313 1.1742 1.4853 +1958 0.563 0.4 0.4293 0.4823 1.0574 0.5707 0.7245 0.7545 0.4046 0.6115 0.7962 0.6102 0.4926 0.6551 0.701 0.6158 1.1935 0.6159 1.0717 0.5597 0.6929 0.734 0.8023 0.8454 0.7878 0.6536 0.657 0.9135 0.9931 0.6615 0.5036 0.6865 0.5096 0.6186 0.6773 0.5873 0.5088 1.122 +1959 1.1407 1.2402 1.2278 1.1767 1.0907 1.2243 1.2682 1.0204 1.2502 1.1498 1.0166 1.2023 1.1889 1.3422 1.2702 1.3387 0.9406 1.1577 1.2691 1.1722 1.0954 1.2759 1.0993 1.2637 1.2977 1.2235 1.4394 1.5181 1.4944 1.2902 1.1731 1.1622 1.2717 1.3518 1.2167 1.3574 1.0755 1.2621 +1960 0.7464 0.856 0.8471 0.8678 1.1009 0.9825 0.9519 0.9711 0.9196 0.9695 1.0128 0.8242 1.1597 0.9254 0.9448 0.9446 0.6812 0.8894 1.0239 0.8727 1.0559 1.0323 1.0158 1.0323 1.0859 1.0508 0.8533 0.903 0.7273 1.1007 0.8781 0.9908 0.977 0.9952 0.9758 0.8936 0.8821 0.6693 +1961 0.4901 0.4685 0.6273 0.6547 1.3287 0.6561 0.8563 0.8146 0.5364 0.6585 0.8098 0.7665 0.8582 0.8714 0.9002 0.6961 1.271 0.6831 1.0933 0.7708 0.6382 0.723 0.7592 0.8183 1.035 0.8192 0.6148 0.9017 0.706 0.8237 0.4964 0.6798 0.5042 0.7419 0.7141 0.56 0.6654 0.9814 +1962 1.0742 1.2518 1.1989 1.1909 1.033 1.1154 1.3325 1.2343 1.1927 1.0495 1.2011 1.2166 1.3084 1.3975 1.3512 1.0643 1.2805 1.1358 0.9493 1.1936 1.0159 1.1065 0.867 1.2985 1.3718 1.0886 1.465 1.4043 1.0508 1.2696 1.2644 1.3704 1.2486 1.2252 1.1811 1.2139 1.1107 1.1695 +1963 1.0834 1.2887 1.1907 1.2547 1.0549 1.0708 1.0839 1.2216 1.2981 1.1263 0.9323 1.1383 1.3266 1.2679 1.2297 1.1688 0.9644 1.1318 0.3076 1.1837 1.2563 1.3435 1.1557 1.2812 1.2777 1.3123 0.689 0.7534 0.787 0.9138 1.3085 1.3211 1.0448 1.0489 1.1479 1.091 1.203 0.7032 +1964 1.0141 1.082 1.0515 0.9916 1.0701 0.8958 0.8184 1.079 1.0183 0.9387 1.0117 1.1036 1.3788 1.2808 1.3089 0.9881 0.6593 0.8801 0.8574 1.0343 1.1382 0.9447 1.1956 0.9044 0.6107 1.0764 0.9975 0.926 0.8149 0.6375 0.84 0.9775 0.9108 0.9451 0.96 0.9738 0.9223 0.8162 +1965 1.0896 0.9741 1.0687 1.1422 1.0116 0.9256 1.0143 1.0361 0.9592 1.0994 1.0463 0.9742 0.958 1.0598 1.0863 0.9835 0.9428 0.9933 0.9079 1.1266 1.2463 1.0577 0.9465 1.0157 1.1021 1.3715 1.0171 0.7622 0.8217 0.8151 0.9845 1.0367 1.0776 1.1235 1.0414 1.0279 0.8579 0.9273 +1966 1.1066 1.1474 0.9618 1.084 1.1821 1.1015 1.1042 0.9681 1.0584 1.0885 0.9442 0.9532 0.8368 1.0777 1.0445 1.1029 1.1707 1.086 1.2562 1.0252 0.9746 1.0645 1.0035 0.9167 1.1055 1.0429 0.9358 1.0086 0.9534 0.967 1.1095 1.0546 1.2068 1.1525 1.1025 1.0876 1.0117 1.0125 +1967 0.9484 0.7533 0.9348 0.8893 1.0399 0.837 0.9686 0.9383 0.8631 0.8027 0.9814 0.8921 0.8266 0.7189 0.7303 0.6809 1.0382 0.7393 0.9329 0.8658 0.7337 1.0093 0.8287 0.9567 1.231 0.8659 1.2121 1.0656 1.0123 1.1686 0.9277 0.9663 0.8023 0.8183 0.8522 0.8699 0.977 1.0141 +1968 1.2202 1.1839 1.0429 1.2391 1.6484 1.2008 1.1193 0.8304 1.2253 1.1213 1.109 1.1388 1.0054 1.001 1.0045 1.2348 1.562 1.1977 1.6071 1.2827 1.2728 1.2393 1.132 1.261 1.2845 1.0693 1.0425 1.0021 1.1479 1.2444 1.1713 1.1819 1.2445 1.2457 1.1742 1.2713 1.184 1.4541 +1969 1.0424 1.0694 0.8692 0.963 0.7625 0.9549 0.9683 1.0143 1.0034 1.098 1.0541 1.0309 1.0381 1.0247 1.0137 1.1734 0.6591 1.043 0.6535 1.0547 1.1089 0.8491 1.1163 1.0523 0.8495 1.1092 0.9349 0.9861 0.8799 0.8071 1.0409 1.1086 1.1516 1.1116 1.1019 0.8443 1.0311 0.8196 +1970 0.811 0.6807 0.7704 0.8911 0.8993 0.9865 0.9075 0.9982 0.7856 0.8569 0.7764 0.8891 1.0568 0.9036 0.9108 0.947 0.9127 0.8473 0.9368 0.7823 0.9774 1.0004 0.981 0.9394 0.9217 0.9035 1.3778 1.0832 1.1599 1.0644 0.7666 0.6225 0.7815 0.9686 0.8652 0.6935 0.7515 0.9901 +1971 0.7251 0.8866 0.7917 0.9749 0.6702 0.9132 0.9574 1.0105 0.864 0.9448 0.9153 0.8849 0.8233 0.8856 0.9132 0.9498 0.5569 0.9671 1.1551 0.9282 0.9386 0.7723 0.9129 0.8964 0.8832 0.8815 0.9716 1.0324 1.0158 1.1505 1.0016 0.91 0.8958 1.1732 0.9965 0.8491 1.1338 1.0332 +1972 0.9308 0.9418 0.9799 0.9333 0.8804 0.9128 0.8842 0.9086 0.9593 0.9525 0.8627 0.9614 1.0176 1.0069 0.9932 0.9233 1.031 0.8077 1.0389 0.9673 0.9426 1.0166 0.969 0.9613 0.9712 0.9184 0.9155 1.0284 1.0031 1.0287 0.8483 0.9137 0.9605 0.8988 0.9348 0.9358 0.9778 1.21 +1973 1.0141 0.9535 1.1344 0.9604 1.347 1.1274 0.9309 0.7985 0.9686 1.0327 0.8719 0.983 0.9519 1.0384 1.0194 0.9984 1.1559 0.9595 1.4034 1.0227 1.1036 0.9473 1.0227 0.8619 0.9218 1.0515 1.1587 1.0235 1.0036 0.7279 0.8456 0.9274 0.9607 0.8244 0.9336 1.007 1.0736 1.2159 +1974 1.24 1.2357 1.1363 1.3025 0.8176 1.1185 1.1421 1.0434 1.1928 1.1482 0.9407 1.262 1.3892 1.323 1.3172 1.1944 1.0601 1.0861 1.4989 1.2848 1.1784 1.1009 1.1299 1.1589 1.0536 1.1505 0.8828 0.9436 0.8308 0.9726 1.1243 1.1749 1.1385 0.9271 1.0896 1.0663 1.3028 0.8781 +1975 0.9169 0.967 0.9686 0.8147 0.8555 0.9255 1.0367 0.9888 0.92 1.0736 0.9035 0.9821 1.0017 0.7908 0.8511 0.8561 0.8126 0.8573 0.519 0.9441 1.1284 0.7018 0.9983 1.0051 0.8637 1.0506 0.9033 1.0783 0.8842 0.9584 1.0348 1.1135 1.009 0.9034 0.9765 1.0439 1.2371 0.8858 +1976 1.1233 0.8929 0.9612 0.9504 0.9629 0.9743 1.2062 1.268 0.904 1.0432 0.9508 1.4705 1.3481 1.2402 1.2453 0.9574 1.1353 1.0256 1.3677 0.9921 0.8174 0.8523 0.8568 1.0507 1.027 0.9569 0.832 0.9824 1.0384 0.8811 0.8837 0.9306 0.9399 1.0139 0.9705 1.0089 1.0457 1.0311 +1977 1.1835 1.1335 1.0413 1.1627 0.9999 1.0206 1.1006 1.0045 1.0894 1.0371 0.888 1.1008 1.0428 0.9674 0.9846 1.1134 1.2129 1.0491 1.0337 1.1871 0.9809 0.8574 1.0459 0.8921 0.894 1.0337 0.775 0.8868 1.0237 1.0164 1.0487 1.0367 1.1057 1.1514 1.0806 0.9862 1.1542 0.7436 +1978 0.9642 1.0554 0.913 1.0139 1.168 1.052 1.0586 1.0633 0.9779 1.029 1.0004 1.0996 0.787 0.846 0.9041 1.0487 0.9406 0.9982 1.0354 0.935 0.8533 0.7725 1.1889 0.8513 0.6718 0.8984 0.928 0.886 0.6689 0.8281 0.9856 1.0944 0.5635 0.9794 0.9544 0.8059 0.9671 0.8774 +1979 1.1892 1.1444 1.0226 1.0758 1.2294 1.0973 1.3194 1.0441 1.0741 1.0513 0.9085 1.5985 1.384 1.3981 1.3981 1.1776 1.241 1.0634 0.9934 1.0775 0.9185 0.8682 1.13 0.9941 1.0889 1.1302 1.1973 1.0947 1.2581 0.9729 1.2056 1.1334 1.0453 1.003 1.0858 1.1898 1.3103 1.3097 +1980 1.1223 0.8674 0.9723 0.8766 1.2073 0.9595 1.0033 0.9703 0.8895 0.9653 0.9184 0.5728 0.8332 1.0615 1.0804 1.0462 1.0815 1.0109 1.4309 0.8835 1.063 1.0545 1.1753 0.8581 1.1527 1.0773 1.0726 1.0351 1.0134 1.1385 0.9776 0.902 0.8976 0.8647 0.951 0.9511 0.9717 1.0604 +1981 1.1624 1.1513 1.0169 1.1527 0.697 1.0772 1.1527 0.8123 1.133 1.1637 1.1731 0.8243 0.9971 1.073 1.0471 1.0892 0.9792 1.0394 1.0062 1.0054 1.2118 1.0116 1.1079 0.9135 0.9401 0.9993 0.7566 1.0018 0.9855 0.8665 1.154 1.2166 1.2047 1.1193 1.1295 1.2454 1.2007 1.0212 +1982 0.982 0.9716 1.0409 0.9834 0.8025 1.01 0.8676 0.8988 1.0098 0.9932 1.2106 1.2546 1.2012 1.0773 1.0803 1.0876 1.2024 0.8831 0.8809 0.9367 1.1721 1.0279 1.058 1.0226 0.8305 0.8313 0.7805 0.7055 0.8132 0.5147 1.0689 1.0594 1.0987 1.0259 1.0548 0.9288 1.1301 0.6917 +1983 0.8125 0.6667 0.8781 0.853 0.932 0.8002 1.0727 0.9996 0.7838 0.7985 1.0833 1.1264 1.0972 1.1959 1.1858 0.7995 0.9542 0.9601 0.7976 0.8722 0.8036 0.9142 0.9261 1.0071 1.0612 0.8445 0.7363 0.8391 0.9135 0.5984 0.7506 0.8313 0.7976 0.8107 0.8489 0.8333 0.9713 1.0231 +1984 1.0242 1.0063 0.9209 0.9836 1.156 1.1159 0.9629 0.9156 1.0274 1.0866 0.8582 0.9192 0.9094 1.0932 1.0744 0.9694 1.1614 1.0094 0.9479 1.0026 1.0588 1.1085 1.1821 1.0659 1.2064 1.1137 1.2096 1.1162 1.1891 1.1178 1.0433 0.9594 0.9001 1.0389 0.9858 0.9367 1.03 1.1633 +1985 0.5991 0.586 0.7775 0.7104 1.0428 0.8806 0.8116 0.534 0.6435 0.7393 0.8599 0.7231 0.6128 0.6193 0.6017 0.9277 1.0971 0.7299 1.0172 0.7946 0.8493 1.0449 0.852 1.0289 0.9803 0.8606 0.8229 1.02 0.9046 1.0589 0.7767 0.7672 0.6771 0.9532 0.8711 0.6332 0.7467 0.7222 +1986 0.8316 0.8257 0.8431 1.1491 0.9733 1.0028 1.0047 0.809 0.8338 1.0158 0.9475 0.8396 0.9601 0.8882 0.9354 1.0937 1.0704 1.0203 0.9836 1.1133 1.1713 1.0666 1.0232 1.2573 1.146 0.9372 0.9664 0.95 1.2256 1.0205 0.9293 1.0282 0.937 1.0893 1.0211 0.9489 0.8725 1.0043 +1987 0.996 0.8573 0.8028 0.938 1.2729 1.0179 1.2237 1.0389 0.889 0.9317 1.1311 1.0995 1.0934 1.1402 1.1332 0.958 1.2475 1.0413 1.197 0.9566 1.0178 1.0323 0.9033 0.8382 1.2483 0.9793 1.242 1.0567 1.2633 0.9716 1.0245 1.0726 0.9763 1.0735 1.0077 0.9932 0.921 1.2576 +1988 0.8854 0.9062 0.9882 0.9691 1.0387 0.9927 1.085 0.8353 0.8729 0.9037 0.7161 0.9311 0.9795 0.9425 0.9694 0.637 0.9027 1.0091 0.6895 0.9019 0.7913 0.9216 0.8253 0.4912 1.1489 0.9087 1.0432 1.1154 1.0149 0.9862 0.9704 0.8593 0.9761 0.8674 0.8662 1.0237 0.987 0.9381 +1989 1.0133 1.037 1.0765 1.0917 1.2826 0.9949 1.2065 1.212 1.0491 0.998 1.1062 0.9849 1.1238 1.2336 1.1872 0.8568 1.1904 1.0648 1.2247 0.9785 0.7296 1.1015 0.7578 1.2199 1.1908 1.147 0.8174 0.9872 1.1072 1.1551 0.9246 0.943 0.9815 1.0482 0.9648 1.1274 1.0109 0.9279 +1990 0.9533 1.0948 1.0566 0.9549 0.917 0.9768 0.9126 1.012 1.0701 0.9162 1.0745 0.9331 0.9467 0.8031 0.8383 1.131 0.9154 1.0683 0.8489 0.8767 1.1097 0.9925 1.1086 1.142 0.6113 1.1153 1.105 0.9066 0.7874 1.0327 1.1085 1.1065 0.988 0.9154 1.0407 0.8747 1.1233 0.6917 +1991 1.0925 1.2092 1.1274 1.2967 1.0837 1.1194 0.9665 0.9814 1.1666 1.1515 1.0758 1.2064 1.1549 1.0057 0.9874 1.2099 0.6022 1.1734 1.1365 1.1902 1.3122 1.2105 1.1238 1.4608 1.2911 1.2471 1.1429 1.0879 1.2739 1.0338 1.0564 1.1577 0.9754 0.9523 1.0658 0.9922 0.9523 1.0084 +1992 1.0103 1.1826 0.9489 1.0088 0.8188 1.0483 1.2064 0.7552 1.122 0.9801 1.0895 1.3374 1.1014 1.2597 1.1769 0.9577 0.9484 1.0418 0.6966 0.9572 1.0127 0.8834 0.8839 0.8122 0.9642 0.939 0.7689 0.9632 0.8798 1.0061 1.0875 1.0728 1.0927 1.0682 1.043 1.1984 1.1254 0.9438 +1993 0.7853 0.7441 0.9465 0.6896 1.0716 0.844 0.8483 0.669 0.7604 0.7956 0.701 0.6587 0.6674 0.7824 0.7601 0.7614 0.8479 0.7736 1.2009 0.8429 0.7248 1.0053 0.8157 1.1342 1.1104 0.9357 0.932 1.0022 1.1026 0.8225 0.8569 0.8695 0.8794 0.9213 0.8828 0.8124 0.8942 1.017 +1994 1.0785 1.4044 1.0572 1.3769 1.1351 1.2252 1.0777 0.9712 1.342 1.081 1.1057 1.0115 1.1486 0.9729 0.9715 1.1482 0.9244 1.1575 1.4059 1.2626 1.0798 1.3149 1.1696 1.2329 1.462 1.0796 1.4931 1.2582 1.4738 1.3781 1.2726 1.2735 1.3085 1.2632 1.1875 1.1233 1.1572 1.235 +1995 NaN NaN NaN 0.6787 0.978 0.8971 NaN NaN 0.8391 0.8265 1.0331 NaN NaN 1.0833 NaN 0.9441 0.9482 1.0586 0.7587 0.7051 0.9206 0.6473 0.6937 0.6734 NaN 1.0206 0.7956 0.7885 0.6715 0.84 0.895 0.7734 0.8933 0.8623 0.9056 0.8929 0.831 0.9918 +1996 NaN NaN NaN 1.2108 1.0977 1.1651 NaN NaN NaN 1.0977 1.1416 NaN NaN NaN NaN 1.0688 1.1149 1.2799 0.9013 1.111 1.3204 1.34 0.986 1.2209 NaN 1.1601 1.058 1.1657 0.7218 1.1085 1.2592 1.1371 1.2672 1.0186 1.1179 1.2979 1.202 1.2038 +1997 NaN NaN NaN 0.6974 0.9611 0.7599 NaN NaN NaN 0.7665 1.1445 NaN NaN NaN NaN 0.764 0.7925 0.8361 0.725 0.7521 0.8427 1.0247 0.897 0.6848 NaN 0.8916 1.1792 0.9597 1.3266 0.9893 0.8749 0.8661 0.7247 0.8937 0.859 0.6891 0.9197 1.0017 +1998 NaN NaN NaN 1.2906 0.8672 1.3067 NaN NaN NaN 1.076 1.1567 NaN NaN NaN NaN 1.2856 0.944 0.8429 0.6395 1.2184 1.3014 1.2443 1.0135 1.0494 NaN 1.2629 1.0135 0.8758 1.3652 1.0455 1.2548 1.3404 1.3024 1.2106 1.2098 1.2961 1.3352 1.26 +1999 NaN NaN NaN 0.8572 0.9455 0.7792 NaN NaN NaN 0.8264 0.973 NaN NaN NaN NaN 0.948 0.9295 0.7802 1.1441 NaN 0.5365 0.409 0.7727 NaN NaN NaN 0.938 0.9315 0.6057 0.906 0.9121 0.9076 0.8174 0.7456 0.8923 0.8475 1.0346 0.9302 +2000 NaN NaN NaN NaN 1.1264 1.0726 NaN NaN NaN 1.0038 0.9242 NaN NaN NaN NaN 1.0565 1.0227 1.1102 1.3415 NaN 0.9656 1.0704 1.0306 NaN NaN NaN 0.9549 0.981 1.1078 0.8763 1.0477 0.85 1.0315 0.9627 0.9935 1.0682 0.9836 1.1477 +2001 NaN NaN NaN NaN NaN 1.1449 NaN NaN NaN 1.0582 0.8428 NaN NaN NaN NaN 1.1014 NaN NaN NaN NaN 1.3772 1.0092 1.2048 NaN NaN NaN 1.0399 1.1795 1.4489 1.1793 1.1607 1.1081 0.9335 1.1656 1.0954 NaN 1.1719 NaN +2002 NaN NaN NaN NaN NaN 1.0409 NaN NaN NaN 0.9579 1.0725 NaN NaN NaN NaN 0.8191 NaN NaN NaN NaN 1.0133 1.1388 0.8574 NaN NaN NaN 0.9676 1.0166 0.7989 0.9244 1.0337 0.9831 1.1008 0.9046 0.9728 NaN 1.0216 NaN +2003 NaN NaN NaN NaN NaN 1.0857 NaN NaN NaN 1.0797 1.1856 NaN NaN NaN NaN 1.1116 NaN NaN NaN NaN 1.2099 0.9041 0.8878 NaN NaN NaN 1.2491 1.1126 0.9569 1.0001 1.2045 1.2211 0.9655 0.8671 1.0619 NaN 1.0537 NaN +2004 NaN NaN NaN NaN NaN 1.0805 NaN NaN NaN 1.0507 0.8939 NaN NaN NaN NaN 1.2629 NaN NaN NaN NaN 1.0921 1.2578 1.1902 NaN NaN NaN 0.959 0.925 1.1518 1.2883 1.1537 1.1634 0.95 1.1039 1.1106 NaN 1.0243 NaN +2005 NaN NaN NaN NaN NaN 1.0228 NaN NaN NaN 1.0665 1.2534 NaN NaN NaN NaN 1.2823 NaN NaN NaN NaN 1.1611 1.2619 1.0825 NaN NaN NaN NaN NaN NaN 1.0879 1.1738 1.0709 1.037 1.1411 1.1184 NaN 1 NaN +2006 NaN NaN NaN NaN NaN 1.0467 NaN NaN NaN 1.0619 1.0866 NaN NaN NaN NaN 0.9232 NaN NaN NaN NaN NaN NaN 1.094 NaN NaN NaN NaN NaN NaN NaN 1.1148 1.1549 1.1146 1.0439 1.0496 NaN 1.0999 NaN +2007 NaN NaN NaN NaN NaN 0.6384 NaN NaN NaN 0.9325 1.2221 NaN NaN NaN NaN 0.7875 NaN NaN NaN NaN NaN NaN 0.8041 NaN NaN NaN NaN NaN NaN NaN 0.8582 0.9104 0.6936 0.9342 0.8601 NaN 0.8735 NaN +2008 NaN NaN NaN NaN NaN 1.1539 NaN NaN NaN 0.9654 1.15 NaN NaN NaN NaN 1.0452 NaN NaN NaN NaN NaN NaN 1.0337 NaN NaN NaN NaN NaN NaN NaN 1.2407 1.1835 1.1986 1.1479 1.1504 NaN 1.224 NaN +2009 NaN NaN NaN NaN NaN 0.8553 NaN NaN NaN 0.8656 0.6773 NaN NaN NaN NaN 0.8423 NaN NaN NaN NaN NaN NaN 0.6616 NaN NaN NaN NaN NaN NaN NaN 0.5968 0.533 0.6148 0.5862 0.6643 NaN 0.8409 NaN +2010 NaN NaN NaN NaN NaN 1.3728 NaN NaN NaN 1.2721 1.0814 NaN NaN NaN NaN 1.3459 NaN NaN NaN NaN NaN NaN 1.3318 NaN NaN NaN NaN NaN NaN NaN 1.1343 1.2943 1.289 1.3976 1.2089 NaN 0.8706 NaN +2011 NaN NaN NaN NaN NaN 1.0832 NaN NaN NaN 1.0659 0.7184 NaN NaN NaN NaN 1.0472 NaN NaN NaN NaN NaN NaN 0.9099 NaN NaN NaN NaN NaN NaN NaN 1.2098 1.2097 0.9744 1.1333 1.1262 NaN NaN NaN +2012 NaN NaN NaN NaN NaN 1.0115 NaN NaN NaN 1.3312 NaN NaN NaN NaN NaN 0.8771 NaN NaN NaN NaN NaN NaN 1.2727 NaN NaN NaN NaN NaN NaN NaN 1.2402 NaN NaN NaN NaN NaN NaN NaN +2013 NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN diff --git a/siteMeta_Katun.txt b/siteMeta_Katun.txt new file mode 100644 index 0000000..051dede --- /dev/null +++ b/siteMeta_Katun.txt @@ -0,0 +1,39 @@ +N1 N2 Id Long Lat ElevM Species T FirstYear LastYear +1 94 russ135 87.58 50.42 2000 LASI R 1700 1994 +2 96 russ137 87.65 50.48 2150 LASI R 1786 1994 +3 93 russ133 87.68 50.5 1950 LASI R 1713 1994 +4 47 russ232 87.83 50.17 1644 LASI R 1700 1999 +5 48 russ233 87.92 50.12 1731 LASI R 1700 2000 +6 64 russ255 88.17 50.07 2100 LASI R 1700 2012 +7 89 russ127 85.37 50.15 1750 LASI R 1700 1994 +8 90 russ129 85.63 51 1450 LASI R 1700 1994 +9 49 russ234 87.48 50.48 1887 LASI R 1700 1995 +10 68 russ259 87.54 50.04 2250 LASI R 1700 2012 +11 40 russ222 84.62 50.42 1898 PISI R 1777 2011 +12 97 russ140 84.98 50.65 1500 LASI R 1744 1994 +13 95 russ136 85.23 50.87 1400 LASI R 1764 1994 +14 43 russ228 85.23 50.87 1560 LASI R 1700 1995 +15 91 russ130 85.23 50.87 1450 LASI R 1700 1994 +16 63 russ254 89.59 50.24 2280 LASI R 1700 2012 +17 45 russ230 87.83 50.27 1703 LASI R 1700 2000 +18 44 russ229 87.83 50.3 2235 LASI R 1700 2000 +19 50 russ235 87.97 50.68 1449 LASI R 1753 2000 +20 41 russ226 87.93 50.8 1943 LASI R 1700 1998 +21 13 mong018 90.98 49.48 1925 LASI R 1700 2005 +22 12 mong017 91 49.97 2124 LASI R 1700 2005 +23 61 russ252 91.28 50.36 2170 LASI R 1722 2012 +24 23 mong029 91.43 49.87 1939 LASI R 1700 1998 +25 69 mong007 91.55 49.7 2000 LAGM R 1733 1994 +26 6 mong009 91.57 49.92 2500 LASI R 1700 1998 +27 18 mong024 88.5 48.5 2172 LASI R 1700 2004 +28 11 mong016 88.37 48.6 2096 LASI R 1700 2004 +29 19 mong025 88.8 48.7 2046 LASI R 1738 2004 +30 14 mong020 88.87 48.27 2238 LASI R 1700 2005 +31 56 russ247 87.23 49.23 2200 LASI R 1700 2012 +32 60 russ251 86.57 49.36 2200 LASI R 1700 2011 +33 66 russ257 88.14 49.39 2250 LASI R 1700 2011 +34 59 russ250 87.5 49.51 2250 LASI R 1700 2011 +35 55 russ246 87.9208 49.611 2200 LASI R 1700 2011 +36 42 russ227 88.1 49.62 2076 LASI R 1700 2000 +37 57 russ248 87.02 49.2 2250 LASI R 1700 2010 +38 46 russ231 87.28 49.17 2410 LASI R 1700 2000 diff --git a/ssValid.R b/ssValid.R new file mode 100755 index 0000000..3303e67 --- /dev/null +++ b/ssValid.R @@ -0,0 +1,104 @@ +ssValid<- function(y,X,ical,ival,i1) { + # Split-sample calibration-validation of regression model + # D Meko + # last revised 2024-03-08 + # + # Does one half of the split sample validation/calibration. Generally would be called + # twice, first time with ical and ival pointing to first and second halves of data, and then + # to second and first halves of data. Written because needed by function resonsw4. + # + # y [matrix] single-col matrix of predictand + # X [matrix] predictors, not all of which may be in model model + # ical [vector]i vector of rows for calibration part of y,X + # ival [vector]i vector of rows of validation... + # i1 [vector]i columns of X that are to be used as predictors in regression + # + # Returns named list Output with fields: + # RE reduction of error statistic + # PearsonRcalib: correlation of predicted values with observed for cal period + # PearsonRvalid: correlation of predicted values with observed for val period + # MeanObsCalibPd: mean obs predictand for calib period + # MeanObsValidPd: mean obs predictand for validation period + # MeanRecCalibPd: mean recon predctand for calibration period + # MeanRecValidPd: mean recon predctand for validation period + # RsquaredCalib: Calibration R squared of regression + # RsquaredValid: Prediction R squared; as computed here this is equivalent to + # the reduction of error statistic + # MeanAbsErrorCalibPd: mean absolute error of reconstruction for calib period + # MeanAbsErrorValidPd: mean absolute error of reconstruction for validation period + # SampleSizeCalib:number of observations in calib period + # SampleSizeValid:number of observations in validation period + # SummaryStatisticsMatrix (includes all of the above, with value for calib + # period in first col and for validation period in second col + # ssPred: vector of predictions for validation period + # + # Output.A adds nothing new to the other fields of Outlook, but may be useful for a quick look + # at statistics of calibration and validation (cols 1 and 2 of A). + # + # revised 2024-03-08: cosmetic. Correction of typos in comments + + #--- ALLOCATE + + A<-matrix(NA,nrow=6,ncol=2) # to hold for calib (col1) and validation (col2): + # Pearson r observed with predicted + # Observed mean + # Reconstructed mean + # R squared + # Mean absolute error + # Nunber of observaions + + #--- CALIBRATION + + y <- as.matrix(y) # in case y happened to be passes as vector + yc<-as.matrix((y[ical,1])) + X<-as.matrix(X) + Xc<-as.matrix(X[ical,i1]); + + G<-lm(yc~Xc) + + A[1,1]<-cor(G$fitted.values,as.vector(y[ical])) # Pearson r obs with recon + A[2,1]<-mean(y[ical]) # mean observed y + A[3,1]<-mean(G$fitted.values) # mean recon y + A[4,1]<-summary(G)$r.squared # R squared of calibration + A[5,1]<-mean(abs(G$residuals)) # mean absolute error + A[6,1]<-length(ical) + + PredNull<-rep(A[2,1],length(ival))# The "null" prediction, defined as the observed + # calib-period mean, expanded to a vector the length of the calibration period + + #--- VALIDATION + + mValid<-length(ival)# number of obs in validation period + eNull <- y[ival]-PredNull # null-prediction errors, computed as observed y minus + # prediction (vector) + + # Use calib-pd model to generate prediction for validation period. + X1 <- cbind((matrix(1,nrow=mValid,ncol=1)),X[ival,i1]) # predictor matrix, with leading col of ones + b<-as.matrix(G$coefficients) # matrix, 1 col + yhat<-X1 %*% b # predictions for validation period (1-col matrix) + ev <- y[ival]-yhat # reconstruction errors, computed as observed y minus predicted + + # Store some results + A[1,2]<- cor(as.matrix(y[ival]),yhat) # Pearson r calibration-period prediction with observed + A[2,2]<- mean(y[ival]) # mean observed + A[3,2]<- mean(yhat) # mean reconstructed + + # Compute RE and the prediction R squared, which as I am computing them are identical + SSEv<-sum(ev*ev) # sum of squares of validation errors + SSEnull <- sum(eNull*eNull) # sum of squares of null-prediction residuals + RE<-1-(SSEv/SSEnull) # reduction of error statistic + A[4,2]<- RE # prediction R squared + A[5,2]<-mean(abs(ev)) + A[6,2]<-length(ival) + + + #--- RETURN OUTPUT AS LIST + + Output <- list("RE"=RE,"PearsonRcalib"=A[1,1],"PearsonRvalid"=A[1,2],"MeanObsCalibPd"=A[2,1], + "MeanObsValidPd"=A[2,2],"MeanRecCalibPd"=A[3,1],"MeanRecValidPd"=A[3,2], + "RsquaredCalib"=A[4,1],"RsquaredValid"=A[4,2],"MeanAbsErrorCalibPd"=A[5,1], + "MeanAbsErrorValidPd"=A[5,2],"SampleSizeCalib"=A[6,1],"SampleSizeValid"=A[6,2], + "SummaryStatisticsMatrix"=A,"ssPreds"=yhat) + + return(Output) +} \ No newline at end of file diff --git a/stem1.R b/stem1.R new file mode 100755 index 0000000..99a5f5f --- /dev/null +++ b/stem1.R @@ -0,0 +1,81 @@ +stem1 <- function(Din){ +# Stem plot for ACF, ala Matlab +# D. Meko +# Revised 2022-05-17 +# +# Stem plot, useful for plotting ACF with CI +# +#---IN +# +# Din: list with elemets as follows: +# x [vector] lags for plot (assume start at lag 0, where r(0)==1) +# nsize [integer] numbe observations in time series on which acf was computed +# y [vector] acf at those lags, x +# kAlpha [integer] alpha level for CI (two-sided test of H0 that acf(k)=0) +# =1 0.05 level (95% CI) +# =2 0.01 level (99% CI) +# nextFigNumber [integer]; png with name graph-??.png will be written to outputDir, +# where ?? (e.g., 1) is the number of the figure +# outputDir [char] output directory (e.g., ) +# linecol1, 2, 3: line colors for stems, zero line, and CI +# textPlot [list] text for xlabel, ylabel, title, and upper left annotation +# +#---NOTES +# +# I got the idea for this plot function from this page: +# https://www.r-bloggers.com/2009/11/matlab-style-stem-plot-with-r/ + + + +#---UNLOAD INPUT + +x <- Din$x; y <- Din$y; Kalpha <- Din$kAlpha; nextFigNumber <- Din$NextFigNumber +outputDir <- Din$outputDr; nsize <- Din$nsize +linecol1 <- Din$linecol1; linecol2 <- Din$linecol2; linecol3 <- Din$linecol3 + +xlab1 <- Din$xtextPlot[1] +ylab1 <- Din$xtextPlot[2] +Tit1 <- Din$xtextPlot[3] +txtAnn <- Din$textPLot[4] + +#---COMPUTE CRITICAL R FOR CONFIDENCE INTERVAL + +if (kAlpha==1){ + rcrit <- 1.96/sqrt(nsize) +} else if (kAlpha==2){ + rcrit <- 2.5758/sqrt(nsize) +} else { + stop('stem1 accepts kAlpha of either 1 or 2') +} + + +#---SET UP FIGURE + +#--- Build graphics png filename +FigNumber <- NextFigNumber # for naming this png +if (FigNumber<10){ + fileOut <- paste(outputDir,'graph-0', as.character(FigNumber),'.png',sep="") +} else { + fileOut <- paste(outputDir,'graph-', as.character(FigNumber),'.png',sep="") +} + +# Figure size and margins +png(filename=fileOut, width = 960, height = 480) +par(mar = c(5.1, 4.5, 5.1, 2.1),cex.axis=1.1, cex.lab=1.5, cex.main=1.3) + + +#---MAKE PLOT + +ylims <- c(-1.05,1.05) + +plot(x,y,pch=16,type='p',col=linecol1,xlab=xlab1,ylab=ylab1, + main=Tit1) +for (i in 1:length(x)){ + lines(c(x[i],x[i]), c(0,y[i]),col=linecol) +} +abline(h=0,lty=1,col=linecol2) +abline(h=rcrit,lty=1,col=linecol3) +abline(h=-rcrit,lty=1,col=linecol3) + +dev.off() +} \ No newline at end of file diff --git a/stemACF.R b/stemACF.R new file mode 100755 index 0000000..675fcc3 --- /dev/null +++ b/stemACF.R @@ -0,0 +1,110 @@ +stemACF <- function(Din){ + # Stem plot for ACF, ala Matlab + # D. Meko + # Revised 2022-05-17 + # + # Stem plot for ACF, ala Matlab. + # + #---IN + # + # Din: list with elemets as follows: + # x [vector] lags for plot (assume start at lag 0, where r(0)==1) + # nsize [integer] numbe observations in time series on which acf was computed + # y [vector] acf at those lags, x + # kAlpha [integer] alpha level for CI (two-sided test of H0 that acf(k)=0) + # =1 0.05 level (95% CI) + # =2 0.01 level (99% CI) + # FigNumber [integer]; png with name Figure??.png will be written to outputDir, + # where ?? (e.g., 1) is the number of the figure. + # outputDir [char] output directory (e.g., ) + # linecol1, 2, 3: line colors for stems, zero line, and CI + # textPlot [list] text for xlabel, ylabel, title, and optional upper left annotation + # If textPlot[4]=='null', nothing is annotated; also, textPlot[5] is either 'null' or some + # string, such as '-AnalysisResiduals3', which is to be built into the filename. Thus, might + # have output "Figure12-AnalysisResiduals3.png" + # + # + #---OUT + # + #---NOTES + # + # Little checking of inputs for proper class, etc. + # Motivation:I got the idea for this plot function from this page: + # https://www.r-bloggers.com/2009/11/matlab-style-stem-plot-with-r/ + # textPlot: typically something like c('Lag k (yr)', 'r(k))','ACF of ...',xxx) + # where xxx might be some string giving additional information, such as DW statistic + # txtPlot[5]: set this to 'Null' for general use (outside of TRISH) + + #---HARD CODE + + ylims <- c(-1.05,1.05) # acf can range from -1 to +1 + + #---UNLOAD INPUT + + x <- Din$x; y <- Din$y; kAlpha <- Din$kAlpha; FigNumber <- Din$FigNumber + outputDir <- Din$outputDir; nsize <- Din$nsize + linecol1 <- Din$linecol1; linecol2 <- Din$linecol2; linecol3 <- Din$linecol3 + + xlab1 <- Din$textPlot[2] + ylab1 <- Din$textPlot[3] + Tit1 <- Din$textPlot[1] + txtAnn <- Din$textPlot[4] + txtFnm <- Din$textPlot[5] + + + #---COMPUTE CRITICAL R FOR CONFIDENCE INTERVAL + + if (kAlpha==1){ + rcrit <- 1.96/sqrt(nsize) + } else if (kAlpha==2){ + rcrit <- 2.5758/sqrt(nsize) + } else { + stop('stem1 accepts kAlpha of either 1 or 2') + } + + + #---SET UP FIGURE + + #--- Build figure png filename + if (FigNumber<10){ + if (txtFnm=='Null'){ + fileOut <- paste(outputDir,'Figure0', as.character(FigNumber),'.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure0', as.character(FigNumber),txtFnm,'.png',sep="") + } + } else { + if (txtFnm=='Null'){ + fileOut <- paste(outputDir,'Figure', as.character(FigNumber),'.png',sep="") + } else { + fileOut <- paste(outputDir,'Figure', as.character(FigNumber),txtFnm,'.png',sep="") + } + } + + # Figure size and margins + png(filename=fileOut, width = 960, height = 480) + par(mar = c(5.1, 4.5, 5.1, 2.1),cex.axis=1.1, cex.lab=1.5, cex.main=1.3,cex=1.2) + + + #---MAKE PLOT + + plot(x,y,pch=16,type='p',col=linecol1,xlab=xlab1,ylab=ylab1, + main=Tit1,ylim=ylims) + for (i in 1:length(x)){ + lines(c(x[i],x[i]), c(0,y[i]),col=linecol1) + } + # horiz lines at 0 and upper and lower CI + abline(h=0,lty=1,col=linecol2) + abline(h=rcrit,lty=5,col=linecol3) + abline(h=-rcrit,lty=5,col=linecol3) + + # optional annotation + if (txtAnn=='null'){ + # no action needed + } else { + text(1.1,ylims[2],txtAnn,adj=c(0,1),cex=1.2) + } + dev.off() + + Output <-NA + return(Output) +} \ No newline at end of file diff --git a/ties1.R b/ties1.R new file mode 100755 index 0000000..3395a14 --- /dev/null +++ b/ties1.R @@ -0,0 +1,70 @@ +ties1 <- function(x){ +# Identify ties in a time series +# D Meko +# Last revised 2022-05-10 +# +#--- Input +# x [numeric] time series +#--- Output is a list N with fields +# ngroups = number of groups of ties +# nties number of members each group +#--- Notes +# Modeled after my matlab ties1.m function +# Needed in context of Mann-Kendall trend analysis (mannken1.R) +# Make sure that input x is a vector, and has no NAs +# $nties: if a signle tie in a series, would make the nties(j)=2, since two +# data values are involved in a single tie + +#--- Check input +L1 <- is.vector(x) +L2 <- !any(is.na(x)) +L <- L1 & L2 +if (!L){ + stop('Input x must be a vector with no NAs') +} + + +mx <- length(x) + +j1<-1:mx # numbering vector same length as x + +#--- Check that not all values in x are unique; if all are unique, no need for further +# work, and can return empty elements in list Output +c <- unique(x) # unique value in x; a 1-col matrix, even if x a vector +if (length(c)==mx) { + Output <- list(ngroups=vector(),nties=vector()) + return(Output) +} + +#--- find the dupicates +L <- duplicated(x) +d <- x[L] # the duplicates, a vector +ndupe=length(d) + +#--- find the unique duplicates, which will represent "groups" of ties +g <- unique(d) +ngrp <- length(g) # number of groups + +#--- Number of members for each group. Will dupe vectors to matrics. + +# Convert vector of unique non-uniques in x into a row vector and row-dupe it to row +# size equal to the number of duplicates, ndupe rows +V <- matrix(g, nrow=ndupe, ncol=length(g), byrow=TRUE) + +# col-dupe the vector of values, d, involved in any ties +F <- matrix(d, nrow=length(d), ncol=ngrp, byrow=FALSE) + +# associate each tie-value with a group; number of trues in each col are number +# of tie-values in each group; +L <- V==F + +# sum over rows and add 1 to get number of obs in x associated with ties in the ngrp groups +nties <- colSums(L)+1 # a vector + +#---- BUILD LIST +Output <-list(ngroups=ngrp,nties=nties) +} + + + + diff --git a/trimRowNA.R b/trimRowNA.R new file mode 100755 index 0000000..b221fca --- /dev/null +++ b/trimRowNA.R @@ -0,0 +1,34 @@ +trimRowNA<- function(X){ + # Row index for trimming trailing and leading all-NA rows from a matrix + # D. Meko; last revised 2022-01-07 + # + # X, [matrix]r the time series; assumed nX columns, no "time" column + # Returns vector:indices of X marking the row rows remaining + # after any trimming off leading and trailing NAs. But if any of the + # columns after trimming has and internal NA, returns a string with + # message instead of the vector of row indices. + # + # Why? Utility function for manipulating time series matrices of tree-ring + # prdictors for a reconstruction model + + # Return an error string if X is not matrix + if (!is.matrix(X)){return("X is not a matrix in trimRowNA()")} + nX<- dim(X)[2] # number of colunns in X + + # Identify first and last rows that are not all-NA + i1<- which(apply(X, 1, function(x) !all(is.na(x)))) # identify rows all-NA + igo1 <- i1[1]; isp1 <- i1[length(i1)] + + # Check that no internal NA in any columns after trimming X + X1<-X[igo1:isp1,,drop=FALSE] + for (n in 1:nX){ + x<- X[,n,drop=FALSE] + i2 <- which(complete.cases(x)) + L<-all(diff(i2)==1) + if (!L){return("Internal NA in one or more cols of X n call to trimRowNA()")} + } + + Output<-igo1:isp1 + return(Output) +} + diff --git a/trimnan.R b/trimnan.R new file mode 100755 index 0000000..7f2b46e --- /dev/null +++ b/trimnan.R @@ -0,0 +1,35 @@ +trimnan<- function(X){ + # Get row indices of 1-col matrix after trimming of leading and trailing NA + # D. Meko; last revised 2021-12-24 + # + # X, [matrix]r the time series; assumed single column + # + # Returns vector: + # Output: a vector of row indices of X marking the row after any trimming + # off of leading and trailing NAs. Internal NAs still allowed. + # + # Why? Utility function for eliminating leading and trailing missing values + # of a time series + # + # Checks that X is a 1-col matrix and not all NA. Internal NAs may still exist in + # the values of X pointed to by Output. This function does not deal with the + # actual time variable (e.g., year). That is handled at an upper level. + + L1 <- is.matrix(X) + if (!L1){ + stop('X not a matrix') + } + nx<- dim(X)[2] + if (!nx==1){ + stop('X is a matrix, but not 1-column') + } + L3<- complete.cases(X) + if (!any(L3)){ + stop('X cannot be all-NA') + } + i3<-which(L3) + igo<-min(i3) + isp<-max(i3) + Output<-igo:isp +} + diff --git a/tsmExtend.R b/tsmExtend.R new file mode 100755 index 0000000..bc3a3f6 --- /dev/null +++ b/tsmExtend.R @@ -0,0 +1,204 @@ +tsmExtend<- function(X,yrX,yrsp,N1,N2){ + # Extend time series matrix on recent end by quantile method + # D. Meko; last revised 2022-01-26 + # + # X, [matrix]r the time series; assumed nX columns, no "time" column + # yrX [matrix]i 1-col year matrix for X + # yrsp: desired stop year of extended time series matrix (tsm) + # If yrsp=NA, extend X so that all series have data up to year of most recent series in X + # If yrsp=nnnn, where nnnn is any year, extend all series to be full through year nnnn, as long as + # nnn is not later than yrX(length(yrX)). If n>yrX(length(yrX)), treat as if yrsp=NA + # If yrsp=-1, truncate X to end with the last year with data at all series in X. + # N1: common period to all series in X should be at least this many years (e.g., 50) + # N2: each series in X must overlap somewhere with each other series by at least N2 years (e.g., 100) + # + # Returns list Output, with fields: + # Y: the extended version of input X + # yrY: the extended version of input yrX + # khow: how the extension was made + # =1 no NA in any column of X; no action needed; return Y as X + # =2 successful extension, but note that input yrsp later than last year with + # data for any series + # =3 successful extension as requested + # =4 aborted because common period of all X =N2 years + # =6 aborted because yrX not continuous + # =7 aborted because first year of X has a NA in some column + # + # N1: the common period of N>=N1 years is used for the spearman correlation (r) matrix to set + # order of series examined for a quantile prediction + # N2: a period N>=N2 of overlap of series A and B is examined to find the quantile from that + # period of N years from which to pull an extension value + # Method. Overall common period is used to get spearman r matrix. That matrix allows + # for each column of X and ordering of the other series from most-correlated to least-correlated. + # For given year i of series A needing "filling" all other series are examined to find which of + # the other series has data in year i. Then, in order of decreasing r, the two-series overlap + # of N>=N2 years is used to pull the overlap. The most highly correlated series that also has data + # in year i provides the estimate. The value of B in year i is compared with the values of + # B in the N>=N2 overlap to get a quantile, or non-exceedance probability. The "prediction" is linearly + # interpolated from the sorted values of A in the N>=N2 overlap such that the estimate has the same + # non-exceedance probability in the overlap. + + # Debugging stressors + #X <- X[216:316,,drop=FALSE]; yrX <- yrX[216:316,,drop=FALSE] + # X <- X[-250,,drop=FALSE]; yrX <- yrX[-250,,drop=FALSE] + # X [1,4]<- NA + + mX <- dim(X)[1] # number of rows in X + nX <- dim(X)[2] # number of cols in X + Ifill<-matrix(0,mX,nX) # to hold either 0 or the column of X used as predictor + + # Input X should be a tsm that increments by 1 + L1 <- !all(diff(yrX)==1) + if (L1) { + khow=6; + Output <- list("Y"=NA,"yrY"=NA,"khow"=khow) + return(Output) # abort year vector, yrX, not continuous + } + + #--- All columns of input tsm X should have valid data in first years + xtemp<-X[1,] + if (any(is.na(xtemp))){ + khow<-7 + warning('First row of input tsm X must not have any NA') + Output <- list("Y"=NA,"yrY"=NA,"khow"=khow) + return(Output) # abort; a NA in first year of X, some column + } + + + + # Check that matrix already not without NA and that yrsp not later than last + # tree-ring data in any series. + khow<-3 # initialize as successful extension, no unusual circumstances + if (!any(is.na(X))){ + khow<-1 + Y<-X; yrY<-yrX + } else if (yrsp> yrX[length(yrX),1]) { + yrsp<-NA + khow=2 + } + yrab <- yrX + if (khow==1){ + # no action needed; Y, yrY, khow already set + } else { + + #--- FIND COMMON PERIOD OF X AND COMPUTE SPEARMAN r MATRIX + L <- complete.cases(X) + U <- X[L,,drop="FALSE"] + yrU <- yrX[L,,drop="FALSE"] + mU <- dim(U)[1]; nU <- dim(U)[2] + L1 <- dim(U)[1]= max(bsort)){ + apred <- max(asort) + + } else if (xhave<=min(bsort)){ + apred<-min(asort) + + } else { + # interpolate by non-exceedance probability + #phave<- interp1(bsort,p,xhave,method="linear") + #apred <- interp1(bsort,asort,xhave,method="linear") + + apredList <- approx(bsort,asort,xhave,method="linear",ties="ordered") + apred <- apredList$y + } # end if (xhave >= max(bsort)) + + Y[j,n] <- apred # filled in value + + Ifill[j,n] <- ifind # corresponding column of predictor + j<-j-1 # will check next year back + # if (j==305){ + # print(j) + # browser() + # } + + if (is.na(X[j,n])){ + # proceed with the estimation + } else { + kwh <- FALSE # will exit the while loop + } + } # end while + } # if (!is.nan(uthis[length(uthis)])) + + } # for (n in 1:nX) + } # if khow==1 + Output <- list("Y"=Y,"yrY"=yrY,"khow"=khow) + + +} \ No newline at end of file diff --git a/xyCI.R b/xyCI.R new file mode 100755 index 0000000..874baac --- /dev/null +++ b/xyCI.R @@ -0,0 +1,52 @@ +xyCI <- function(X){ + # Upper and lower CI into x,y for CI polygon + # D. Meko + # Revised 2022-09-23 + # + # Upper and lower CI into x,y for CI polygon. Utility function to get x,y polygon + # coordinates for, say, plotting a shaded confidence interval + # + #---IN + # + # X: [matrix] 3-column time series matrix with year, lower CI and upper CI + # + #---OUT + # + # Output: a list with elements: + # x [vector] x coordinates for CI polygon + # y [vector] y coordinates for CI polygon + + #---CHECK THAT INPPUT X IS 3-COL MATRIX WITH VALUES IN COL 1 INCREMENTING BY 1 + L1 <- is.matrix(X) + L2 <- dim(X)[2]==3 + + if (!L1 && L2){ + stop('X must be 3-col matrix as input to xyCR') + } + + + #---UNLOAD INPUT + + x1 <- X[,1] # time vector + # check that time increments by 1 + d <- diff(x1) + if (!all(d==1)){ + stop('Time column in input X to xyCI must increment by 1') + } + u1 <- X[,2] # lower CI (e.g., lower 50% CI) + u2 <- X[,3] # upper CI (e.g., upper 50% CI) + + #--- MAKE POLYGON COORDINATES + + # reorganize the data values for the lower and upper Ci into a vector whose end value equals the first value + yP <- cbind(u1,rev(u2)) # matrix with lower CI as col 1, reversed upper CI as col 2 + yP <- c(yP) # convert matrix to vector: col 2 appended to end of col 1 + yP <- append(yP,yP[1]) # append first year's value of lower CI as the last value in the vector + + # Similarly reorganize the time (e.g., year) vector + xP <- cbind(x1,rev(x1)) + xP <- c(xP) + xP <- append(xP,xP[1]) + Output <- list('x'=xP,'y'=yP) + return(Output) +} \ No newline at end of file