.packageName <- "verification"
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/1/7 11:29:42 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
 attribute<- function(x, ...){
UseMethod("attribute")
 }
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/1/7 11:29:42 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
 attribute.default<- function(x, obar.i,  prob.y=NULL, obar = NULL, titl = NULL, ...){
## attribute plot as displayed in Wilks, p 264.
## If the first object is a prob.bin class, information derived from that.

   old.par <- par(no.readonly = TRUE) # all par settings which
                                      # could be changed.
   on.exit(par(old.par))


plot(x, obar.i,  col = 2, lwd = 2, type = "n",
     xlim = c(0,1), ylim = c(0,1),
     xlab =  expression( paste("Forecast probability, ", y[i] ) ),
     ylab = expression( paste("Observed relative frequency, ", bar(o)[1] ))
     )


###################  need to put down shading before anything else.

if(!is.null(obar)){
a <- (1-obar)/2 + obar
b <- obar / 2
x.p<- c(obar, obar, 1, 1, 0, 0)
y.p<- c(0, 1, 1, a, b, 0)

polygon(x.p, y.p, col = "gray")

text(0.6, obar + (a-b)*(0.6 - obar), "No skill", pos = 1,
     srt = atan( a - b )/(2*pi)*360 )

}


###########

points(x, obar.i, type = "b", col = 2, lwd = 2)


## plot relative frequency of each forecast
ind<- x< 0.5
text(x[ind], obar.i[ind], formatC(prob.y[ind], format = "f", digits = 3),
          pos = 3, offset = 2, srt = 90)
text(x[!ind], obar.i[!ind], formatC(prob.y[!ind], format = "f", digits = 3),
          pos = 1, offset = 2, srt = 90)
if(is.null(titl)){title("Attribute Diagram")}else
{title(titl)}

abline(0,1)

## resolution line
if(!is.null(obar)){
abline(h = obar, lty = 2)
abline(v = obar, lty = 2)
text( 0.6, obar, "No resolution", pos = 3)
}

invisible()
}
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/1/7 11:29:42 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
attribute.prob.bin<- function(x, ...){
# retreives data from a verify object.

assign("obar.i", x$obar.i)
assign("prob.y", x$prob.y)
assign("obar", x$obar) 
assign("x", x$y.i)
do.call("attribute.default", list(x, obar.i, prob.y, obar,...) )

}
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/1/7 11:29:42 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
brier<- function(obs, pred, baseline = NULL, thresholds  = seq(0,1,0.1), ... ){
## internal function used in verify
## used with a probablistic forecast with a binary outcome.
  
  
if(max(pred)>1 | min(pred)<0) {

cat("Predictions outside [0,1] range.  \n Are you certain this is a probability forecast? \n")}

bs<- mean( (pred - obs)^2)

## baseline ave if not provided.

if(is.null(baseline)){obar <- mean(obs); baseline.tf <- FALSE}else
{obar<- baseline; baseline.tf <- TRUE}

bs.baseline <- mean( (obar - obs)^2)

N0    <- sum(pred == 0)
N1    <- sum(pred == 1)
bins  <- thresholds  ### this will only work if an internal function.

pred.bins<- cut(pred, breaks = bins, labels = FALSE, include.lowest = TRUE )

N<-  aggregate(pred.bins, by = list(pred.bins), length)$x # number of preds in each bin
obar.1<- aggregate(obs, by = list(pred.bins), sum)$x # number of preds in each bin

obar.i<- obar.1/N

y.i <- bins[-length(bins)] + diff(bins)/2 # mid point of each bin
  
n<- length(obs)

ss <- 1 - bs/bs.baseline


bs.rel <- (sum(N*(y.i -obar.i)^2)) /n   ## reliability
bs.res <- (sum(N*(obar.i -obar)^2)) /n  ## resolution
bs.uncert<- obar*(1- obar)
check <- bs.rel - bs.res + bs.uncert 

prob.y <- N/n

bs.discrete <-  mean( ( obs - y.i[pred.bins])^2 )## for comparison, a bs score based on binned categories.

return(list(baseline.tf = baseline.tf, bs = bs, bs.baseline = bs.baseline, ss = ss,
            bs.reliability = bs.rel, bs.resol = bs.res, bs.uncert = bs.uncert,
            y.i = y.i, obar.i = obar.i, prob.y = prob.y, obar = obar) )
  
}
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
        # ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA
# ** 2004/1/7 11:29:42 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
conditional.quantile<- function(pred, obs, bins = NULL, thrs = c(10, 20), main = "Conditional Quantile Plot", ...){
## creates conditional probability plots as described in Murphy et al.
#set.seed(1)

#frcst <- round(runif(100, 20, 70))
#obs<- rnorm( 100, frcst, 10)
#bins <- seq(0,100,10)
#thrs<- c( 10, 20) # number of obs needed for a statistic to be printed #1,4 quartitle, 2,3 quartiles

  old.par <- par(no.readonly = TRUE) # all par settings which                                    # could be changed.
   on.exit(par(old.par))
  
# check bin sizes; issue warning
if(!is.null(bins)){
if( min(bins)> min (obs) | max(bins)< max(obs) ){warning("Observations outside of bin range. \n")}
if( min(bins)> min (pred) | max(bins)< max(pred) ){warning("Forecasts outside of bin range. \n")}
} else {
dat <- c(obs,pred); min.d <- min(dat); max.d <- max(dat)
  bins<- seq(floor(min.d), ceiling(max.d), length = 11)

}

  ## close bin check
  
## plot ranges

#lo<- min(pred, obs); hi<- max(pred, obs)
  lo<- min(bins); hi<- max(bins)
  
## if selected, the quasi-continuous data is subsetted into larger
## bins so that quantile statistics might be calculated.

  b<- bins[- length(bins)]
labs<- b + 0.5*diff(bins)

obs.cut<- cut(obs, breaks = bins, include.lowest = TRUE, labels = labs)
obs.cut[is.na(obs.cut)]<- labs[1] # place anything below the limit into first bin. 
obs.cut<- as.numeric(as.character(obs.cut))

frcst.cut<- cut(pred, breaks = bins, include.lowest = TRUE, labels = labs)
frcst.cut[is.na(frcst.cut)]<- labs[1]
frcst.cut<- as.numeric(as.character(frcst.cut))

## calculate stats ext

n<- length(labs)

lng<- aggregate(obs.cut, by = list(frcst.cut),length)
med<- aggregate(obs.cut, by = list(frcst.cut),median)

q1 <- aggregate(obs.cut, by = list(frcst.cut),quantile, 0.25)

q2<- aggregate(obs.cut, by = list(frcst.cut),quantile, 0.75)

q1$x[lng$x <= thrs[1]] <- NA
q2$x[lng$x <= thrs[1]] <- NA

q3 <- aggregate(obs.cut, by = list(frcst.cut),quantile, 0.1)
q4<- aggregate(obs.cut, by = list(frcst.cut),quantile, 0.9)

q3$x[lng$x <= thrs[2]] <- NA
q4$x[lng$x <= thrs[2]] <- NA

par( mar = c(5,5,5,5) )

plot(frcst.cut, obs.cut, xlim = c(lo,hi), ylim = c(lo, hi), main = main,
     type = 'n', ylab = "Observed Value", xlab = "Forecast Value", ... )
mtext("Sample Size", side = 4, adj = -1)

#### legend
legend.txt<- c("Median", "25th/75th Quantiles", "10th/90th Quantiles")

legend(min(pred) + 0.55*diff(range(pred)),
       min(obs) + 0.25*diff(range(obs)), legend.txt, col = c(2,3,4),
       lty = c(1,2,3), lwd = 3, cex = 0.7 )

abline(0,1)

lines(labs[labs%in%med$Group.1], med$x, col = 2, lwd = 3)
lines(labs[labs%in%q1$Group.1], q1$x,
      col = 3, lty = 2, lwd = 3)
lines(labs[labs%in%q2$Group.1], q2$x,
      col = 3, lty = 2, lwd = 3)
lines(labs[labs%in%q3$Group.1], q3$x,
      col = 4, lty = 3, lwd = 3)
lines(labs[labs%in%q4$Group.1], q4$x,
      col = 4, lty = 3, lwd = 3)


pp<- par("plt")

par("plt" = c(pp[1], pp[2], pp[3], 0.2))

par(new = TRUE)

hist(frcst.cut, breaks = bins, col = "blue",
     main = "", axes = FALSE, xlim = c(lo, hi),
     xlab = " " , ylab = " ")
axis(4, line = 0)
# mtext("Sample Size", side = 4, line = 1)


}
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/9/1 14:13:55 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
crps <- function(obs, pred, ...)
  ## Tilmann Gneiting's crps code, assumes pred is either a vector of length
  ## 2 (mu, sig) or a matrix of mu and sig if each forcast is different
  {
  if(is.null( dim(pred)) & length(pred)==2){mu <- pred[1];
                                            sigma <- pred[2]} else {
    mu<- as.numeric( pred[,1] ); sigma <- as.numeric( pred[,2]) }
    
  z <- (obs-mu)/sigma ## center and scale
  
  crps<- sigma * (z*(2*pnorm(z,0,1)-1) + 2*dnorm(z,0,1) - 1/sqrt(pi))
  ign <-  0.5*log(2*pi*sigma^2) + (obs - mu)^2/(2*sigma^2)
  pit <- pnorm(obs, mu,sigma )

return(crps = crps, CRPS = mean(crps), ign = ign, IGN = mean(ign), pit = pit )

}

# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/1/7 11:29:42 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
"discrimination.plot" <- function(obs, pred, breaks = 11, main = "Comparison of Distributions",  xlim = c(0,1), median = TRUE, ... ){
 old.par <- par(no.readonly = TRUE) # all par settings which
                                      # could be changed.
 #  on.exit(par(old.par))


  y<- pred[obs==1]
n<- pred[obs==0]


Y<- hist(y, plot = FALSE,
         xlim = xlim, breaks = breaks)

N<- hist(n, plot = FALSE,
         xlim = xlim, breaks = breaks)


plot(Y$mids, Y$counts/sum(Y$counts), type = "b", col = "red", pch = 16,
     xlab = "Forecast", ylab = "Density", xlim = c(0,1), ylim = c(0, 1), main = main, ...)

#axis(4, at= c(0, length(y))   )

#plot(Y$mids, Y$counts, type = "b", col = "red", pch = 16,
#     xlab = "Forecast", ylab = "Density", xlim = c(0,1), ylim = c(0,1) )


points(N$mids, N$counts/sum(N$counts), type = "b", col = "blue", pch = 17)


abline(h = 0); abline(v=0)

leg.txt <- c("Event", "No Event")
  legend(list(x=.8,y=.8), legend = leg.txt, col= c("red", "blue"), pch = c(16, 17),
         lty=1, merge=TRUE, cex = 0.6)
if(median){
abline(v = median(y), col =2)
abline(v = median(n), col ="blue")
}

}
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/9/1 14:13:55 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
int.scale.verify <- function(frcs, obs, thres = quantile(frcs, p= seq(0,0.9,0.1) ),  ... )
{
# controls on inputs and error messages
# check that dimensions are equal and factor of the power of two
if(dim(frcs)[1]!=dim(obs)[1]){
stop("Input matrices must have the same dimensions")}
if(dim(frcs)[2]!=dim(obs)[2]){
stop("Input matrices must have the same dimensions")}
if(dim(frcs)[1]!=dim(frcs)[2]){
stop("Input matrices must be squared")}
if(log2(dim(frcs)[1])-floor(log2(dim(frcs)[1]))!=0){
stop("Input matrices must have dimensions equal to a power of 2")}

## check dimensions
if(	(dim(frcs)[1]==dim(obs)[1]) & 
	(dim(frcs)[2]==dim(obs)[2]) &
	(dim(frcs)[1]==dim(frcs)[2]) & 
	(log2(dim(frcs)[1])-floor(log2(dim(frcs)[1]))==0) ) {
  
	SSul = c()  ## stores ??
        N<- log2( dim(frcs)[1]) ## 2^N dimensions for forecast and obs.
        MSE.out <- matrix(NA, ncol = length(thres), nrow = (N+1) )
        ind <- 1 ## MSE.out index  
        
for(t in thres){  ## check each threshold and create loop.
	
		E <-  matrix(0,  nrow = dim(frcs)[1], ncol = dim(frcs)[2] )
		E[(frcs>t)&(obs<=t)]<-  1  # false positives
		E[(frcs<=t)&(obs>t)]<- -1  # false negatives
                # discrete haar wavelet decomposition from package waveslim
		E.dwt <-  dwt.2d(E,wf="haar",J=log2(dim(frcs)[1]))
		
		# evaluation of MSE of each wavelet component
		#
MSE<- numeric()
 for(i in 1:N){ 
       MSE[i] <- mean( (E.dwt[[ 1 + 3*(i - 1)]]/2^i)^ 2 )+
                 mean( (E.dwt[[ 2 + 3*(i - 1)]]/2^i)^ 2 )+
                 mean( (E.dwt[[ 3 + 3*(i - 1)]]/2^i)^ 2 ) 
               }  ## close 1:N loop
		MSE <-  c(MSE, mean(E)^2)
                MSE.out[,ind]<- MSE 
ind <- ind + 1
                                        #
		# evaluation of skill score
		#
		br <-  length(obs[obs>t])/length(obs) ## br = base rate 
		B <-  length(frcs[frcs>t])/length(obs[obs>t])## bias              
		MSE.random <-  B*br*(1-br)+br*(1-B*br) ## MSE from a random forecast with bias and base rate
		SSul <-  c(SSul, 1- (MSE * (N+1) )/MSE.random) ## Skil score thres = u,  scale = l
		} ## close threshold loop
		SSul <-  matrix(SSul, nrow = N + 1)

        colnames(SSul) <- round(thres,2)
        rownames(SSul) <- c(seq(1,log2(dim(frcs)[1])),"bias")
        
        colnames(MSE.out) <- round(thres,2)
        rownames(MSE.out) <- c(seq(1,log2(dim(frcs)[1])),"bias")

           # image of the skill score as function of threshold and scale
	z<- list(SSul = SSul, MSE = MSE.out, l.frcs = dim(frcs)[1], thres = thres )	

class(z)<- "int.scale"
        return(z)
      } ## closes check function
} ### closes function



# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/1/7 11:29:42 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
leps<- function(x, ...){
UseMethod("leps")
}
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/1/7 11:29:42 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
leps.default <- function(x, pred,  plot = TRUE, ...){
## leps function
# x<- rnorm(100, mean = 1, sd = sqrt(50))
# pred<- rnorm(100, mean = 10, sd = sqrt(500)) 

old.par <- par(no.readonly = TRUE) # all par settings which
                                      # could be changed.
on.exit(par(old.par) )

emp.prob <- rank(x)/( length(x)+ 1)
# add points to emp.prob to make it a full ecdf 0, min(c(pred, x)  ) and
# 1, max( c(pred, x) )
obs.a<- c(obs, min(c(pred, x)) , max(c(pred, x) ) )
emp.prob.a<- c(emp.prob, 0, 1 )

ecdf.obs <- approxfun(obs.a, emp.prob.a) ## function returns ecdf of obs

leps.0 <- mean(abs( ecdf.obs(pred) - ecdf.obs(x) ) )

leps.1 <- 2 - 3*(leps.0 + mean(ecdf.obs(pred)*(1-ecdf.obs(pred) ) )
                        + mean(ecdf.obs(x)* (1-ecdf.obs(x)  ) ) )

if(plot){
#  if(is.null(titl)){titl<- "LEPS plot"} 
plot(x, ecdf.obs(x), ylim = c(0,1),
     ylab = expression(paste("Empirical CDF ", F[o](o)) ),
         xlab = "Observation", ... )
}

r <- list(leps.0 = leps.0, leps.1 = leps.1)

invisible(r)

} # end of function.


# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/9/1 14:13:55 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
measurement.error <- function( obs, frcs = NULL, theta = 0.5, t = 1, u = 0, h = NULL, ...){
### if frcs is null, its assumed that obs is a vector with
### assume data entered as c(n11, n10, n01, n00)
if(is.null(frcs) & length(obs) ==4 ){
## assume data entered as c(n11, n10, n01, n00)
n11<- obs[1]
n10<- obs[2]
n01<- obs[3]
n00<- obs[4]} else{

### check to see if frcs is [0,1] if not convert
if( prod(unique(obs) %in% c(0,1) ) == 1 ){ ## if obs is not binomial

  if(is.null(h)){ frcs <- as.numeric(frcs > theta)  } else {frcs <- as.numeric(frcs > h) }
}# close if not unique 

A<- table(data.frame(obs, frcs) )

n11 <- A[2,2]
n00 <- A[1,1]
n10 <- A[2,1]
n01 <- A[1,2]
}# close is.null else

## check p > theta else transform
n  <- n11 + n10 + n01 + n00
p  <- (n10 + n11) / n # prob obs = yes
## transform it p > theta

if(p > theta){
n00.old <- n00
n11.old <- n11
n10.old <- n10
n01.old <- n01
n11     <- n00.old
n10     <- n01.old
n01     <- n10.old
n00     <- n11.old
theta   <- 1-theta  
}## close if vector

 
n  <- n11 + n10 + n01 + n00
p<- (n10 + n11) / n # prob obs = yes
px1  <- (n11 + n01)/ n
px0  <- (n10 + n00)/ n
p11 <- (n11*(1-u) - n01*u) / ( (n11+n01)*(t-u) )
p00 <- ( n00*t - n10*(1-t)) / ( (n10+n00)*(t-u))
p10 <- (n10*(1-u)- n00*u ) /
  ( ( n10+ n00)*(t-u) )

# K <- px1*(p11 - theta)/(p*(1-theta))

K <- (n11*(1 - u - theta*(t-u)) - n01 * (u + theta*(t - u)) ) /
  ( (n11+ n10)*(1-theta) - n*(u *(1-theta)) )

L1 <- log(n11/( (n01 + n11 )  *(theta*(t - u)+ u  )) )
L2 <-   log(n01/( (n01 + n11)   * ( 1 -u - theta*(t-u) ) ) )

G  <- 2*n11* L1 + 
              2*n01* L2
  p.val <- (1-pchisq(G, 1)) / 2
q11<- n11/(n11+n01)

return(list(G = G, p = p.val, K = K))
}
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/9/1 14:13:55 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
observation.error <- function(obs, gold.standard = NULL, ...){

if(is.null(gold.standard) & length(obs) ==4 ){
## assume data entered as c(n11, n10, n01, n00)
n11<- obs[1]
n10<- obs[2]
n01<- obs[3]
n00<- obs[4]
  return( t = n11/(n11+n01), u = n10/(n10+n00) )
} else {
A   <- table(data.frame( obs, gold.standard) )
n11 <- A[2,2]
n00 <- A[1,1]
n10 <- A[2,1]
n01 <- A[1,2]

return( t = n11/(n11+n01), u = n10/(n10+n00) )
}

}
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/1/7 11:29:42 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
plot.cont.cont <- function(x, ...){
assign("frcst", x$pred )
assign("obs", x$obs )
do.call("conditional.quantile", list(pred, obs, ...) )

}
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/1/7 11:29:42 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
plot.int.scale <- function(x,y = NULL, plot.mse = FALSE, main = NULL,...){

  ## x is an object of int.scale class
  ## stupid manipulation to plot matrix

if(plot.mse != TRUE){DAT <- x$SSul
                   if(is.null(main)) {main <- "Intensity Scale Verification" } }
              else {DAT<- x$MSE

                   if(is.null(main)) {main <- "MSE Intensity Scale Verification" }             }

  P<- t(DAT)

m <- dim(P)[1]
n <- dim(P)[2]
o<- x$l.frcs
  
# image of the skill score as function of threshold and scale
	
par(mar = c(5,5,4,4))          
          image(x =seq(1,m ) , y = seq(1, n), P, axes = FALSE, zlim = range(P), 
			xlab="Threshold",ylab="spatial scale:  2^n", xaxs = "i", yaxs = "i",
                col = topo.colors(256), main = main, ...)

box()
		axis(1,at=seq(1, m),labels=round(x$thres,2))
		axis(2,at=seq(1,log2(o)+1),labels=c(seq(1,log2(o)),"bias"))

image.plot( zlim = range(P), legend.only=TRUE, offset = 0.02, legend.width = 0.03,
           horizontal=FALSE, add=TRUE)

}
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/1/7 11:29:42 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
plot.prob.bin <- function(x, ...){

  attribute(x, ...)

}
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/1/7 11:29:42 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
## ranked histogram plot.
ranked.hist <- function(frcst, nbins = 10, titl = NULL){

if( min(frcst) < 0 | max(frcst) > 1 ){warning("Observations outside of [0,1] interval. \n")}

brks<-  seq(0,1, length = nbins + 1)
hist(frcst, breaks = brks, main = "")
if(is.null(titl)){title("Ranked Histogram")}else
{title(titl)}
abline(h = length(frcst)/nbins, lty = 2)
invisible()

} # close function
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/1/7 11:29:42 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
reliability.plot<- function(x,...)
UseMethod("reliability.plot")
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/1/7 11:29:42 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
reliability.plot.default<- function(x, obar.i, prob.y, titl = NULL, legend.names = NULL, ...){
## this function is similar to a attribute plot but somewhat simplified.
## The differences are as follows.  These include
## if obar.i is a matrix, multiple lines will be ploted with single graph.
## if obar.i is a matrix with 2 columns or 2 verify objects are used as inputs, 2
## ranked histograms will be printed.

#  x<- c(0,0.05, seq(0.1, 1, 0.1))
#  obar.i <- c(0.006, 0.019, 0.059, 0.15, 0.277, 0.377, 0.511, 0.587, 0.723, 0.779, 0.934, 0.933)
#  obar.i<- data.frame(obar.i, runif(12) )
#  obar.i<- data.frame(obar.i, runif(12) )
#  prob.y<- c(0.4112, 0.0671, 0.1833, 0.0986, 0.0616, 0.0366, 0.0303,  0.0275, 0.0245, 0.022, 0.017, 0.0203) 
#  a<- runif(12)
#  prob.y<- data.frame(prob.y,a/sum(a))
#  prob.y<- data.frame(prob.y,a/sum(a))
  
# titl <- "Sample Reliability Plot"
# legend.names<- c("Test 1", "Test 2", "Test 3")
# methods(  
  old.par <- par(no.readonly = TRUE) # all par settings which
                                      # could be changed.
  on.exit(par(old.par))

  obar.i<- as.matrix(obar.i)
  if(is.null(legend.names)) legend.names<- paste("Model", seq(1,dim(obar.i)[2])) 

   prob.y<- as.matrix(prob.y)
  
  plot(x, obar.i[,1],  col = 2, lwd = 2, type = "n",
     xlim = c(0,1), ylim = c(0,1),
     xlab =  expression( paste("Forecast probability, ", y[i] ) ),
     ylab = expression( paste("Observed relative frequency, ", bar(o)[1] ))
     )
if(is.null(titl)){title("Reliability Plot")}else{
title(titl)
}

m<- dim(obar.i)[2]
  for(i in 1:m){
points(x, obar.i[,i], type = "b", col = 1+i, lty = i, lwd = 2)
}
abline(0,1)

if(m == 1){
leg.txt<- legend.names[1]
legend(0.8, 0.35, leg.txt, bty = 'n', col = 2, lwd = 2, pch = 1, lty = 1)  
}

if(m >= 2){
leg.txt<- legend.names[1:m]
legend(0.8, 0.4, leg.txt, bty = 'n', col = c(2:(1+m) ), lwd = 2, pch = 1, lty = c(1:m) )  
}  
## rank histogram plot in lower corner.
  
pp<- par("plt")

# par("plt" = c(0.7, pp[2], pp[3], 0.3))
if(m<=2){ # if one or two forecasts are used, plot lower box plot.
  
par("plt" = c(pp[2] - 0.2 , pp[2],  pp[3], pp[3]+ 0.2) )
par(new = TRUE)
barplot(prob.y[,1], axes = FALSE, axisnames = FALSE)
axis(4)
  box() }


if(m == 2){
par("plt" = c(pp[1], pp[1]+ 0.2,  pp[4] - 0.2, pp[4] ))

par(new = TRUE)

barplot(prob.y[,2], axes = FALSE, xlab = "", axisnames = FALSE)
axis(4)
  box()

}# close if m = 2
  
invisible()  
 }# close function

# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/1/7 11:29:42 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
reliability.plot.verify<- function(x, ...){
#if(sum(class(A) == "prob.bin") < 1){
#  warning("This function works only on probability forecast \n binary outcome objects. \n")}else{
assign("y.i", x$y.i)
assign("obar.i", x$obar.i)
assign("prob.y", x$prob.y)

do.call("reliability.plot.default", list(y.i, obar.i, prob.y, ...))


}
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/1/7 11:28:18 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
roc.area <- function(obs, pred){ 

  A<- data.frame(obs, pred)
  names(A)<- c("obs", "pred")


####

e<- sum(A$obs == 1)
e.p <- sum(A$obs == 0)
n<- length(A$obs)

####

  o2 <- order(A$pred, A$obs, decreasing = TRUE) # order for f
  DAT<- A[o2,]
  DAT$ind<- seq(1,n)
  ind.2<- DAT$ind[DAT$obs == 1]

f<- 0 # no ties. 

for(i in 1:e){
  d<-   sum(DAT[1:ind.2[i],]$obs == 0)
  f<-  f +  d
}

#f.tilda - ties include
  o1 <- order(A$pred, -A$obs, decreasing = TRUE) # order for f
  DAT<- A[o1,]
  DAT$ind<- seq(1,n)
  ind.2<- DAT$ind[DAT$obs == 1]
  f.tilda <- 0

for(i in 1:e){
  d<-   sum(DAT[1:ind.2[i],]$obs == 0)
  f.tilda <-  f.tilda  +  d
}


A.tilda<- 1 - 1/(e*e.p)*f - 1/(2*e*e.p)*(f.tilda - f)

U<- e*e.p*(1-A.tilda)


### normal approximation (no ties)

p<- pnorm(U, mean = e*e.p/2, sd = sqrt(e*e.p*(n+1)/12 ) )

### normal approximation (ties) adjusting for ties

tau <- aggregate(A$pred, by = list(A$pred), length)

V<- e*e.p*(n+1)/12 - e*e.p/(12*n*(n -1))*sum(tau$x*(tau$x - 1)*(tau$x +1))


p.adj<- pnorm(U, mean = e*e.p/2, sd = sqrt(V) )

return(list(A.tilda = A.tilda, n.total = n, n.events = e, n.noevents = e.p,  U = U, p = p, p.adj = p.adj) )
     }  # close function
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/1/7 11:29:42 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
"roc.plot" <- function(x, ...){
UseMethod("roc.plot")
## if a verify.prob.bin object is entered, create ROC plot or multiple ROC
}
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/1/7 11:29:42 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 

"roc.plot.default" <- function(x, pred, thresholds = NULL, binormal = FALSE,  leg = NULL,  
          plot = "emp", plot.thres = seq(0.1, 0.9, 0.1),
               main = "ROC Curve",  xlab = "False Alarm Rate", ylab = "Hit Rate",  ...){
#

#  old.par <- par(no.readonly = TRUE) # all par settings which
#  on.exit(par(old.par) )
if(( plot=="binorm"| plot == "both")  & binormal == FALSE){
  stop("binormal must be TRUE in order to create a binormal plot")}
  
pred<- as.matrix(pred)
n.forc<- dim(pred)[2] ## number of forecasts

########### threshold vector

if(is.null(thresholds) ){ ## if thresholds are not provided, calculate thresholds so that the
  # are approximately the same number in each bin.
  thresholds <- sort(as.numeric( unique(pred) ) ) }
if(length(thresholds) == 1){
  n.thres.bins<- thresholds
t          <- seq(0, 1, 1/n.thres.bins)
  thresholds <-quantile(pred, t) # pred needs to be all preds
}

####################################################### internal roc function

roc <- function(x, pred, thres){ # internal function that returns plot points
pody     <- numeric()
podn     <- numeric()
n        <- length(x)
n.thres  <- length(thres)  # number of unique thresholds, thres =  
lng      <- length(x)            # 

a         <- x > 0 #
a.sum     <- sum(a)
a.not.sum <- sum(!a)

for(i in 1:(n.thres) ){
  
  b      <- pred >= thres[i]
  pody[i]<- sum(  b * a  )/ a.sum ## hit rate
  podn[i]<- sum(  (!b)  * (!a)  )/ a.not.sum  ## FAR
 
} ## close for loop 1:n.thres


thres[n.thres +1 ]<- 1 # plot 0,0 point
pody[n.thres  + 1] <- 0
podn[n.thres  + 1] <- 1 

    if(binormal){
       zH <- c(NA ,qnorm( pody[-c(1, n.thres + 1)] ),  NA )  # NA are for top and bottom value
       zF <- c(NA ,qnorm(1 - podn[-c(1, n.thres + 1) ]), NA )# NA are for top and bottom value
       } else {
         zH <- rep(NA, n.thres + 1)
         zF <- rep(NA, n.thres + 1)
       } ## close if binormal
    return(cbind(thres, pody, podn, zH, zF))
       }    # closs roc function

##############################################################

### roc.area function


DAT  <- array(NA, dim = c(length(thresholds) + 1, 5, n.forc))  ## adj to 5 cols to cal area under.
VOLS <- matrix(nrow = n.forc, ncol = 5)
binormal.pltpts<- list()

for(j in 1:n.forc){  ## n.forc = number of forecasts = number of columns
DAT[, , j] <- roc(x, pred[, j], thresholds)
#############################

if(binormal){
  dat  <- as.data.frame( DAT[,,j] )
  names(dat) <- c("thres", "proby", "probn", "zH", "zF")
  dat <- dat[is.finite(dat$zH) & is.finite(dat$zF), ] ## reduce dat, get rid of nans and inf   
  new <-  as.data.frame( matrix(qnorm(seq(0.005, 0.995, 0.005 ) ), ncol = 1) )
  names(new) <- "zF"
  A <- lm(zH ~ zF, data = dat)$fitted.values
  B <- predict(lm(zH ~ zF, data = dat), newdata = new)

binormal.pltpts[[j]]<- data.frame( t = new$zF, x = pnorm(new$zF), y = pnorm(B) )
binormal.area  <- sum(0.005*pnorm(B) , na.rm = TRUE) } else {binormal.area <- NA}

#############################
## vol calcs
v <- roc.area(x, pred[,j])
VOLS[j,1]<- v$A.tilda
VOLS[j,2]<- v$p.adj
VOLS[j,3]<- v$A
VOLS[j,4]<- v$p
VOLS[j,5]<- binormal.area
} ## close for j in 1:n.forc

VOLS<- data.frame(paste("Model ", seq(1, n.forc) ), VOLS )  
names(VOLS)<- c("Model", "Area.adj", "p.adj", "Area", "p-value", "binorm.area")
  
## stuff to return
r<- structure(list( plot.data = DAT, roc.vol = VOLS, binormal.ptlpts = binormal.pltpts), class = "roc.data")

####################################################  
###### plot if required  

if(!is.null(plot) ){  ## if plot is not false, then make frame.
 par(mar = c(4,4,4,1))

plot( 1 - DAT[,3 ,], DAT[,2,], type = 'n', xlim = c(0,1), ylim = c(0,1),
     main = main,  xlab = xlab, ylab = ylab, ... ) # points don't matter, plot is type 'n'

abline(h=seq(0,1,by=.1),v=seq(0,1,by=.1),lty=3, lwd = 0.5, col = "grey")
abline(0,1)
 
if(length(thresholds)< 16){L <- "b" }else{L<-"l"} # if less than 12 point show points
}
### if empirical or both

if(plot == "emp" | plot == "both" ){ 
 for(i in 1:n.forc){
    points(1  - DAT[,3,i], DAT[ ,2,i] , col = i, lty = i, type = "l", lwd = 2)

## plot threshold points on graph   
if(!is.null(plot.thres)){  ## does this need an else statement ?  ## by default, these match

    ind <- match(round(plot.thres,2),  round( DAT[,1,i], 2) )
    points(1 - DAT[ind,3, i], DAT[ind,  2, i], col = 1, pch = 19)
    text(1 - DAT[ind,3, i], DAT[ind,  2, i], plot.thres, pos = 4, offset = 1 )
} # close plot thres
 } ## close 1:n.thres
 
### general info

} ## close empirical

if(plot == "binorm" | plot == "both" ){

for(i in 1:n.forc){
  dat<- binormal.pltpts[[i]]
    points(dat$x, dat$y , col = 2, lty = i, type = "l", lwd = 2)

  }## close i:n.force loop
}## close binorm plot 

#### text
if(plot == "both"){
 text(0.6, 0.1, "Black lines are the empirical ROC")  
text(0.6, 0.07, "Red lines and symbols are the bi-normal ROC")
 text(0.6, 0.04, "The area under the binormal curve is in parathesis.")

}

if(plot == "emp"){
 text(0.6, 0.1, "Black lines are the empirical ROC")  
}

if(plot == "binorm"){
text(0.6, 0.1, "Red lines  are the bi-normal ROC")
}

########
## make legend text
if(is.null(leg)){
leg.txt<- paste ("Model ", LETTERS[seq(1, n.forc)]) } else {(leg.txt <- leg)}

if(plot == "emp"){
leg.txt<- paste (leg.txt, "  ",formatC(VOLS$Area.adj, digits = 3) ) }

if(plot =="binorm"){ 
leg.txt<- paste (leg.txt, "  ", formatC(VOLS$binorm.area, digits = 3)  )}

if(plot == "both"){
leg.txt<- paste (leg.txt, "  ",formatC(VOLS$Area.adj, digits = 3), " (",
formatC(VOLS$binorm.area, digits = 3) ,")" ) }

  
#if(leg != FALSE){  
legend(list(x=0.6, y=0.4), legend = leg.txt, bg = "white", cex = 0.6,
         lty = seq(1,n.forc), col = c("black", "red","blue"), merge=TRUE) #}
# invisible()
 invisible(r)
 # end function
}
                





# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/1/7 11:29:42 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
roc.plot.prob.bin<- function(x, ...){
# retreives data from a verify object.


assign("obs", x$obs)
assign("pred", x$pred)

do.call("roc.plot.default", list(obs, pred,...) )

}
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/1/7 11:29:42 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
summary.bin.bin <- function(object, ...){
  ## print function for binary forecast, binary outcome
  cat("\nThe forecasts are binary, the observations are binary.\n")
  cat("The contingency table for the forecast \n")
  print(object$tab)
  cat("\n")
 
  cat(paste("PODy = ", formatC(object$POD, digits = 4), "\n"))
  cat(paste("TS   = ", formatC(object$TS, digits = 4), "\n"))
  cat(paste("ETS  = ", formatC(object$ETS, digits = 4), "\n"))
  cat(paste("FAR  = ", formatC(object$FAR, digits = 4), "\n"))
  cat(paste("HSS  = ", formatC(object$HSS, digits = 4), "\n"))
  cat(paste("PC   = ", formatC(object$PC, digits = 4), "\n"))
  cat(paste("BIAS = ", formatC(object$BIAS, digits = 4), "\n"))
  }

# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/1/7 11:29:42 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
summary.cont.cont <- function(object, ...){

  cat("\nThe forecasts are continuous, the observations are continous.\n")
if(object$baseline.tf){cat("Baseline data provided. \n")} else{
  cat("Sample baseline calcluated from observations.\n")}

  cat(paste("MAE               = ", formatC(object$MAE, digits = 4), "\n"))
  cat(paste("ME                = ", formatC(object$ME, digits = 4), "\n"))
  cat(paste("MSE               = ", formatC(object$MSE, digits = 4), "\n"))
  cat(paste("MSE - baseline    = ", formatC(object$MSE.baseline, digits = 4), "\n"))
  cat(paste("MSE - persistence = ", formatC(object$MSE.pers, digits = 4), "\n"))
  cat(paste("SS  - baseline     = ", formatC(object$SS.baseline, digits = 4), "\n"))

}


# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/1/7 11:29:42 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
summary.norm.dist.cont <- function(object, ...){

  cat("\nThe forecasts are a normal probability distribution. \n")
  cat("The observations are continuous.\n\n")
  cat(paste("Average crps score      = ", formatC(object$CRPS, digits = 4), "\n"))
  cat(paste("Average ignorance score = ", formatC(object$IGN, digits = 4), "\n"))
}
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/1/7 11:29:42 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
summary.prob.bin <- function(object, ...){

  cat("\nThe forecasts are probablistic, the observations are binary.\n")
if(object$baseline.tf){cat("Baseline data provided. \n")} else{
  cat("Sample baseline calcluated from observations.\n")}
  cat(paste("Brier Score (BS)           = ", formatC(object$bs, digits = 4), "\n"))
  cat(paste("Brier Score - Baseline     = ", formatC(object$bs.baseline, digits = 4), "\n"))
  cat(paste("Skill Score                = ", formatC(object$ss, digits = 4), "\n"))
  cat(paste("Reliability                = ", formatC(object$bs.reliability, digits = 4), "\n"))
  cat(paste("Resolution                 = ", formatC(object$bs.resol, digits = 4), "\n"))
  cat(paste("Uncertaintity              = ", formatC(object$bs.uncert, digits = 4), "\n")) 
}
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/1/7 11:29:42 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
table.stats<- function(obs, pred){
## internal function used in verify
## used with a binary forecast and a binary outcome.
  
  tab.out <- table(obs, pred)

  a<-tab.out["0","0"]
  b<-tab.out["0","1"]
  c<-tab.out["1","0"]
  d<-tab.out["1","1"]

    
TS<- a/(a+b+c)
POD<- a/(a+c)
FAR <- b/(a+b)
HSS <- 2*(a*d - b*c)/ ((a+c)*(c+d) + (a+b)*(b+d))  
KSS <- (a*d - b*c)/((a+c)*(b + d))
PC <- (a+d)/(a+b+c+d)
BIAS <- (a+b)/(a+c)

HITSrandom <- (a+c)*(a+b)/(a+b+c+d)
ETS <- (a-HITSrandom)/(a+b+c-HITSrandom)

return(list(tab = tab.out, TS = TS,
            POD = POD, FAR = FAR , HSS = HSS,KSS = KSS,
            PC = PC, BIAS = BIAS, ETS = ETS))
}


# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/1/7 11:29:42 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
verify<- function(obs, pred, tseries = NULL,
                  baseline = NULL, # sample.baseline = FALSE, ? 
                  frcst.type = "prob", obs.type = "binary", 
                  thresholds = seq(0,1,0.1) ){
if(frcst.type == "binary" & obs.type == "binary"){
if(length(unique(obs))>2 | length(unique(pred))>2 ) {warning("Prediction or observation may not be binary \n")}
A <- table.stats(obs, pred)
class(A)<- c("verify", "bin.bin")

} else

if(frcst.type == "prob" & obs.type == "binary"){

cat("If baseline is not included, baseline values  will be calculated from the  sample obs. \n")

A<- brier(obs, pred, baseline, thresholds )
class(A)<- c("verify", "prob.bin")
} else

if(frcst.type == "norm.dist" & obs.type == "cont"){
A<- crps(obs,pred)
class(A)<- class(A)<- c("verify", "norm.dist.cont")
  
}else

if(frcst.type == "cont" & obs.type == "cont"){

A<- c()
if(is.null(baseline)){baseline <- mean(obs); A$baseline.tf <- FALSE} else {A$baseline.tf <- TRUE}
A$MAE       <- mean(abs(pred - obs))
A$MSE       <- mean( (pred - obs)^2 )
A$ME        <- mean( (pred - obs) )
A$MSE.baseline <- mean( (mean(baseline) - obs)^2)
# mse persistance only valid if data is presented in chronological order.
A$MSE.pers  <- mean( (obs[-length(obs)]- obs[-1])^2)
A$SS.baseline  <- 1 - (A$MSE - A$MSE.baseline)

class(A)<- c("verify", "cont.cont")

} else { cat("This combination of predictions \n and observations is not \n currently supported. \n") }

## attach original data to be used in plot functions.

A$obs   <- obs
A$pred <- pred
A$baseline <- baseline


return(A)

} # close function
  

# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
# ** Copyright UCAR (c) 1992 - 2004 
# ** University Corporation for Atmospheric Research(UCAR) 
# ** National Center for Atmospheric Research(NCAR) 
# ** Research Applications Program(RAP) 
# ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA 
# ** 2004/9/1 14:13:55 
# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* 
.First.lib <- function(lib, pkg) {
require(waveslim)
require(fields)
cat("\n",
"Package verify:", "\n")
cat( "Please send comments or suggestions to pocernic@(Remove this)ucar.edu", "\n")
} # end of '.First.lib' fcn
