https://github.com/cran/ensembleBMA
Raw File
Tip revision: 65bc4d8d72e5060987d37deb8279042bbcd033ff authored by Chris Fraley on 08 May 2008, 00:00:00 UTC
version 3.0-2
Tip revision: 65bc4d8
trainingData.R
`trainingData` <-
function(ensembleData, date = NULL, trainingRule = list(length=NA, lag=NA), 
         exchangeable = NULL)
{
 if (!inherits(ensembleData,"ensembleData")) stop("not an ensembleData object")
 call <- match.call()

 trainingRule <- as.list(trainingRule)

 if (is.null(trainingRule$length) || is.na(trainingRule$length) ||
     is.null(trainingRule$lag) || is.na(trainingRule$lag))
   stop("length and lag must be specified in training rule")

 if (trainingRule$length < 0 || trainingRule$lag < 0) 
   stop("improperly specified training rule")

 ensMemNames <- ensembleMemberLabels(ensembleData)
 nForecasts <- length(ensMemNames)

 exchangeable <- getExchangeable( exchangeable, ensembleGroups(ensembleData),
                                  nForecasts)

# remove instances missing all forecasts, obs or dates

 M <- apply(ensembleForecasts(ensembleData), 1, function(z) all(is.na(z)))
 M <- M | is.na(ensembleVerifObs(ensembleData))
 M <- M | is.na(ensembleDates(ensembleData))
 ensembleData <- ensembleData[!M,]
 
 nObs <- ensembleNobs(ensembleData)
 if (!nObs) stop("no observations")

 ensDates <- ensembleDates(ensembleData)
 if (is.null(ensDates)) stop("dates unavailable")

 Dates <- as.character(ensDates)
 DATES <- sort(unique(Dates))

 if (trainingRule$length+trainingRule$lag > length(DATES)) 
   stop("insufficient training data")

 julianDATES <- ymdhTOjul(DATES)
 origin <- attr( julianDATES, "origin")
 incr <- min(1,min(diff(julianDATES))) ## incr may be fractional for hours

## dates that can be modeled by the training data (ignoring gaps)

 Jdates <- seq(from = julianDATES[trainingRule$length]+trainingRule$lag*incr,
               to = max(julianDATES)+trainingRule$lag*incr, by = incr)

## determine the modeling dates

 dl <- nchar(DATES[1])

 if (nullDates <- is.null(dates)) stop("date must be specified")

 dates <- date


   dates <- sort(unique(as.character(dates)))

   if (!all(dateCheck(dates))) 
     stop("improperly specified date(s) in dates argument")

   if (nchar(dates[1]) != dl)
     stop("format of dates argument does not match date format in data")

   if (any(dates < julTOymdh(min(Jdates),origin=origin,dropHour=(dl == 8)))) {
     stop("some dates precede the first training period")
   }

   if (any(dates > julTOymdh(max(Jdates),origin=origin,dropHour=(dl == 8)))) {
     warning("there are dates beyond the last training period")
   }

 juliandates <- ymdhTOjul( dates, origin = origin)

 nDates <- length(dates)

 L <- length(juliandates)
 twin <- 1:trainingRule$length

 cat("\n")

 l <- 0
 for(i in seq(along = juliandates)) {

    I <- (juliandates[i]-trainingRule$lag*incr) >= julianDATES
    if (!any(I)) stop("insufficient training data")

    j <- which(I)[sum(I)]

    if (j != l) {

      twin <- (j+1) - (1:trainingRule$length)
      D <- as.logical(match(Dates, DATES[twin], nomatch=0))
      if (!any(D)) stop("this should not happen")
  
     DATA <- ensembleData[D,]

    }
 }

 attr( DATA, "exchangeable") <- exchangeable
 DATA
}

back to top