.packageName <- "ensembleBMA"
CRPS <- function(a,b,sigma,w,X,Y)
{
  #a couple of helper functions
  erf <- function(x) 2 * pnorm(x * sqrt(2)) - 1

  absExp <- function(mu, sig)
  {
	sigma <- sig
	mean <- mu
	out <- (1/sqrt(pi))*sig*sqrt(2)*exp((-.5*mean^2)/(sig^2)) + mean*erf(.5*mean*sqrt(2)/sig)
	out
  }




  # Get the count of how many obs we have

  nmod <- ncol(X)

  # set up variance and sd vectors

  if(length(sigma)==1)
  {
    vars=rep(sigma^2, nmod)
  }
  else
  {
    vars=sigma^2
  }
  sds <- sqrt(vars)	

  # Create a matrix for the ensemble prediction

  means <- matrix(0,length(Y),nmod)
  maxFirst <- 0
  maxSecond <- 0
  i = 1
  while( i <= nmod )
  {
    means[,i] <- a[i] + b[i]*X[,i]
    i = i + 1
  }

  # Expression of the CRPS formula and the E|x| if x ~ N(mu,sigma^2)

  # CRPS = .5 sum( sum( w(i)w(j) a( u(i) - u(j), sigma(i)^2 + sigma(j)^2) ) ) - sum( w(i) a( mu(i) - obs, sigma(i)^2 )
  # here, a(u, sigma^2) is from E|X| with X ~ N(u, sigma^2)
  # Using Maple, I get Expected value of abs( X ) with X ~ N > >
  # (sigma*sqrt(2)*exp(-1/2/sigma^2*mu^2)+mu*erf(1/2/sigma*mu*2^(1/2))*sqrt(Pi)) > / Pi^(1/2) > > 
  # where erf is the error function.


  # Begin computing the first term in the CRPS formula.  This is a double sum since it is over w(i)*w(j) for all i and j.

  crps <- rep(0,length(Y))
  firSec <- matrix(0,length(Y),2)
  k = 1
  while( k <= nrow(means) )
  {
    firstSum <- 0
    secondSum <- 0
	
    # First get the first sum (the double sum of the CRPS)
	
    i = 1
    while( i <= nmod )
    {
      j = 1
      while( j <= nmod )
      {
        tvar <- vars[i] + vars[j]  # total variance
        tsd <- sqrt(tvar)          # total standard deviation
        tmean <- means[k,i] - means[k,j]
		
        firstSum <- firstSum + w[i]*w[j]*absExp(tmean,tsd)
        j = j + 1
      }
	
      i = i + 1
    }
	
    # Now get the second sum.  This one is only over all w(i) for all i.
	
    i = 1
    while( i <= nmod )
    {
      tvar <- vars[i]              # total variance
      tsd <- sqrt(tvar)            # total standard deviation
      tmean <- means[k,i] - Y[k]
      secondSum <- secondSum + w[i]*absExp(tmean,tsd)
      i = i + 1
    }
	
    # Using Szekely's expression for the CRPS, the first sum and second are put together
    # to compute the CRPS.

    crps[k]  <- -.5*firstSum + secondSum
    firSec[k,] <- c(.5*firstSum, secondSum)
		
    k = k + 1
  }

  out <- abs(mean(crps))
  out
}

"EM.for.date" = function(date, date.list, X, Y, eps = 1e-005, maxiter=1000, start.w=NULL, start.sigma=NULL, const.var = TRUE, num.training.days = 25, lead=2, reg.adjust = TRUE, min.CRPS = TRUE)
#EM.for.date fits a model to forecast a given date based on a 25-day training sample
#with a 1-day gap (so the forecast is 48 hours - if we give it day index of 27, it trains on days 1 through 25)
#X is the matrix of forecasts, Y is the vector of observations, date is the date you want to forecast for,
#and date.list is the list of the dates corresponding to each observation
#the specific format for the dates in date and date.list does not matter, so long as they are numeric, and
#a difference of 1 indicates a difference of 1 day
#this function discards from the training set any observations for which we are missing one or more of the member forecasts
{
  foo=(1:length(Y))
  baz=rep(0, length(Y))
  for(i in 1:(dim(X)[2]))
  {
    baz=baz+is.na(X[,i])
  }
  bar=foo[((date-(lead + num.training.days))<date.list) & (date.list<(date-lead+1)) & (baz==0)]
  output=EM.normals(X[bar,1:(dim(X)[2])], Y[bar], eps, maxiter,
                    start.w, start.sigma, const.var, reg.adjust, min.CRPS)
  output
}

"EM.normals"= function(X, Y, eps = 1e-005, maxiter=1000, start.w=NULL, start.sigma=NULL, const.var = TRUE, reg.adjust = TRUE, min.CRPS = TRUE)
# function for EM algorithm for mixture of ensemble-member-centered normals
# Modification of Adrian's modification of Fadoua's EM code for SLP - Adrian 9/11/03, 10/21/03
# McLean 12/01/03 - modifying to use for 8-member wind speed (should be generalizeable to any mixture of normals)
# McLean 05/30/04 - incorporating Veronica's changes to have a single variance parameter for all models
# McLean 06/18/04 - fixed matrix transpose errors in calculating z

# Inputs:
#  X           matrix of ensemble members. This is an n by K matrix, where there are
#              n observations to be used in the fitting, and K ensemble members
#  Y           n-vector of observations
#  eps         stopping criterion
#  maxiter     maximum number of EM iterations allowed
#  start.w     initial values for the weights (optional)
#  start.sigma initial value for the sd

{
  n=length(Y)
  k=dim(X)[2]
  lik = 0
  z=matrix(ncol=k, nrow=n)
  w.new=rep(0, k)
  v.new=rep(0, k)

  start.v=(start.sigma)^2

  # set initial value for v, either as total variance or given starting value
  if(is.null(start.sigma))
  {
     v=var(Y)
  }
  else
  {
    v=start.v
  }

  # set intial weights, either as equal weights or given starting values
  if(is.null(start.w))
  {
    w=rep(1/k, k)
  }
  else
  {
    w=start.w
  }

  error=rep(1, 3)
  niter=0

  if(reg.adjust == TRUE)
  {
    #bias-correction terms (linear regression)
    B=rep(0, k)
    A=rep(0, k)
    for(i in 1:k)
    {
      B[i]=var(X[,i], Y, na.rm=TRUE)/var(X[,i], na.rm=TRUE)
      A[i]=mean(Y)-B[i]*mean(X[,i])
    }
  }
  else {
    B=rep(1, k)
    A=rep(0, k)
  }

  if(const.var == TRUE) {
  #main EM algorithm
  while((max(abs(error)) > eps) && (niter < maxiter))
  {
    sumz=0
    z.old=z
    #weighted sum of distribution functions for each member (sumz is a vector, one value for each observation)
    for(i in 1:k)
    {
      sumz=sumz+w[i]*dnorm(Y, mean=A[i]+B[i]*X[,i], sd=sqrt(v))
    }
    #matrix of probabilities for each observation coming from each member (latent variables)
    z=t(w*t(dnorm(Y, mean=t(A+B*t(X)), sd=sqrt(v))))/sumz    

    #calculate new weights and variance based on latent variables
    for(i in 1:k)
    {
      w.new[i]=sum(z[,i])/n
    }
    v.new=sum(z*((Y-t(A+B*t(X)))^2))/sum(z)
    
    # Compute log-likelihood (corrected by Adrian on 10/21/03)
    lik.old=lik
    lik=sum(log(sumz))

    #calculate change from last iteration to this one
    error[1]=max(abs(w.new-w))
    error[2]=max(abs(log(v.new/v)))
    if(niter==0)
    {
      error[3]=1
    }
    else
    {
      error[3]=max(abs(z-z.old))
    }
    v=v.new
    w=w.new
    niter <- niter + 1
    
  }
  }
 else {

  v = rep(var(Y),k)

  while((max(abs(error)) > eps) && (niter < maxiter))
  {
    sumz=0
    #weighted sum of distribution functions for each member (sumz is a vector, one value for each observation)

    #matrix of probabilities for each observation coming from each member (latent variables)
      z.old=z
	for(i in 1:k)
	{
		value <- dnorm(Y, mean=A[i]+B[i]*X[,i], sd=sqrt(v[i]))* w[i]
		sumz <- sumz + value
		z[,i] <- value
	}

		for( i in 1:k)
		{
			z[,i] <- z[,i]/sumz
	}


    #calculate new weights and variance based on latent variables
    for(i in 1:k)
    {
      w.new[i]=sum(z[,i])/n
	v.new[i]=sum(z[,i]*(Y-A[i]-B[i]*X[,i])^2)/sum(z[,i])
    }
    
    # Compute log-likelihood (corrected by Adrian on 10/21/03)
    lik.old=lik
    lik=sum(log(sumz))

    #calculate change from last iteration to this one
    error[1]=max(abs(w.new-w))
    error[2]=max(abs(log(v.new/v)))
    if(niter==0)
    {
      error[3]=1
      error[4]=1
    }
    else
    {
      error[3]=max(abs(z-z.old))
      error[4]=max(abs(lik-lik.old))
    }

    v=v.new
    w=w.new
    niter <- niter + 1

  }
  }

  if(min.CRPS==TRUE)
  {
    if(const.var==TRUE)
    {
      sigma.CRPS=sqrt(v[1])
      CRPS.optim=function(sigma)
      {
        CRPS(A,B,rep(sigma,k),w,X,Y)
      }
      v=rep((optimize(CRPS.optim,interval=c(0, 2*sigma.CRPS))$minimum)^2,k)
    }
    else
    {
      sigma.CRPS=sqrt(v)
      CRPS.optim=function(sigma)
      {
        CRPS(A,B,sigma,w,X,Y)
      }
      v=(optim(sigma.CRPS, CRPS.optim)$par)^2
    }
  }

  list(loglik=lik, a=A, b=B, w=w, sigma=sqrt(v), z=z, niter=niter)
}


"bmacdf" <- function (a,b,sigma,w,X,Y)
{
  # Sept 12, 2003 (Adrian)
  # McLean 06/28/04 - changed hard-coded 8 dimensions to arbitrary number of dimensions
  # Find the BMA cdf at x for the K-component BMA mixture 
  # Inputs:
  #  a          vector of K intercepts in the regression bias correction
  #  b          vector of K slopes in the regression bias correction
  #  sigma        vector of K standard deviations from the BMA fit
  #  w          vector of K weights from the BMA fit
  #  Y		value of temperature or SLP at which cdf is required
  #  X          vector of K forecasts

  # Output:
  #             Value of the BMA cdf evaluated at x

  if(length(sigma) == 1)
  {
    sigma = rep(sigma, length(a))
  }


  sum (w * pnorm (rep(Y,length(X)), a+b*X, sigma) )
}

"bmaquant" <- function (a,b,sigma,w,alpha,X,niter=14)
{
  # Sept 12, 2003 (Adrian). Modified June 1, 2004
  # McLean 06/18/04 - changed arguments to bmacdf() to be consistent with new version of bmacdf()
  # Find the alpha quantile of the K-component BMA mixture 
  #  using the bisection method.
  # Inputs:
  #  a          vector of K intercepts in the regression bias correction
  #  b          vector of K slopes in the regression bias correction
  #  sigma      vector of K standard deviations from the BMA fit
  #             (a,b,sig are all outputs of EM.normals)
  #  alpha	required quantile
  #  X		vector of K forecasts
  #  niter	number of iterations in the bisection method
  #             Default 14, which gives accuracy on the order of
  #             (length of plausible interval)/16000

  out = NULL
  if( length(alpha) > 1 )
  {
	k = length(alpha)
	out = rep(0,k-1)
	for(i in 1:(k-1))
	{
		out[i] = bmaquant(a,b,sigma,w,alpha[i],X,niter)
	}
	alpha = alpha[k]
  }

  # Initialize: Find lower and upper bounds
  lower <- min (a+b*X-3*sigma)
  upper <- max (a+b*X+3*sigma)
  Flower <- bmacdf (a,b,sigma,w,X,lower)
  Fupper <- bmacdf (a,b,sigma,w,X,upper)
  if (Flower>alpha || Fupper<alpha) return(NA)

  # Bisection method
  for (iter in 1:niter)
  {
    mid <- (lower+upper)/2
    Fmid <- bmacdf (a,b,sigma,w,X,mid)
    if (Fmid>alpha) upper <- mid
    if (Fmid<alpha) lower <- mid
  }
  out = c(out, mid)
  out
}

