#'Chunks Long Simulations For Comparison With Hindcasts
#'
#'This function reorganizes a long run (historical typically) with only one 
#'start date into chunks corresponding to a set of start dates. The expected 
#'input structure is the one output from \code{Load()} with 4 to 7 dimensions.
#'
#'@param varin Array of model or observational data with dimensions:\cr
#'  c(nmod/nexp/nobs, nmemb/nparam, nsdates, nltimes) up to\cr
#'  c(nmod/nexp/nobs, nmemb/nparam, nsdates, nltimes, nlevel, nlat, nlon)
#'@param sdatesin Start date of the input matrix 'YYYYMMDD'.
#'@param sdatesout List of start dates of the output matrix 
#'  c('YYYYMMDD', 'YYYYMMDD', ...).
#'@param nleadtimesout Number of leadtimes in the output matrix.
#'
#'@return An array with the same number of dimensions as varin, the same 
#' dimensions 1 and 2 and potentially the same dimensions 5 to 7. Dimensions 
#' 3 and 4 are set by the arguments sdatesout and nleadtimesout.
#'
#'@keywords datagen
#'@author History:\cr
#'0.1  -  2012-11  (V. Guemas, \email{vguemas@ic3.cat})  -  Original code\cr
#'1.0  -  2013-09  (N. Manubens, \email{nicolau.manubens@ic3.cat})  -  Formatting to CRAN
#'@examples
#'# See examples on Load() to understand the first lines in this example
#'  \dontrun{
#'data_path <- system.file('sample_data', package = 's2dverification')
#'exp <- list(
#'         name = 'experiment',
#'         path = file.path(data_path, 'model/$EXP_NAME$/monthly_mean',
#'                          '$VAR_NAME$_3hourly/$VAR_NAME$_$START_DATES$.nc')
#'       )
#'obs <- list(
#'         name = 'observation',
#'         path = file.path(data_path, 'observation/$OBS_NAME$/monthly_mean',
#'                          '$VAR_NAME$/$VAR_NAME$_$YEAR$$MONTH$.nc')
#'       )
#'# Now we are ready to use Load().
#'startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101')
#'sampleData <- Load('tos', list(exp), list(obs), startDates,
#'                   leadtimemin = 1, leadtimemax = 4, output = 'lonlat',
#'                   latmin = 27, latmax = 48, lonmin = -12, lonmax = 40)
#'  }
#'  \dontshow{
#'startDates <- c('19901101')
#'sampleData <- s2dverification:::.LoadSampleData('tos', c('experiment'),
#'                                                c('observation'), startDates,
#'                                                leadtimemin = 1,
#'                                                leadtimemax = 4,
#'                                                output = 'areave',
#'                                                latmin = 27, latmax = 48,
#'                                                lonmin = -12, lonmax = 40)
#'  }
#'
#'
#'start_dates_out <- c('19901101', '19911101', '19921101', '19931101', '19941101')
#'leadtimes_per_startdate <- 12
#'experimental_data <- Histo2Hindcast(sampleData$mod, startDates[1], 
#'                                    start_dates_out, leadtimes_per_startdate)
#'observational_data <- Histo2Hindcast(sampleData$obs, startDates[1], 
#'                                     start_dates_out, leadtimes_per_startdate)
#'PlotAno(experimental_data, observational_data, start_dates_out, 
#'        toptitle = paste('anomalies reorganized into shorter chunks'), 
#'        ytitle = 'K', fileout='tos_histo2hindcast.eps')
#'
#'@export
#Histo2Hindcast <- function(varin, sdatesin, sdatesout, nleadtimesout) {

h2h <- function(var, sdate, sdatesout, n_ftimes, 
                ftime_dim = NULL, sdate_dim = NULL, 
                freq = 'month', calendar_in = 'leap', 
                calendar_out = calendar_in, 
                leap_fill_method = 'put_NA') {
  # Check var
  if (!is.array(var) || !is.numeric(var)) {
    stop("Parameter 'var' must be a numeric array.")
  }

  # Check sdate
  if (!('POSIXct' %in% class(sdate))) {
    stop("Parameter 'sdate' must be a POSIXct date.")
  }
  sdate <- sdate[1]

  # Check sdatesout
  if (!('POSIXct' %in% class(sdatesout))) {
    stop("Parameter 'sdatesout' must be a POSIXct date.")
  }

  # Check n_ftimes
  if (!is.numeric(n_ftimes)) {
    stop("Parameter 'n_ftimes' must be numeric.")
  }
  n_ftimes <- round(n_ftimes[1])

  # Check ftime_dim
  dims <- dim(var)
  if (is.null(ftime_dim)) {
    if (!is.null(names(dims))) {
      if ('ftime' %in% names(dims)) {
        ftime_dim <- which(names(dims) == 'ftime')
      } else {
        stop("Parameter 'var' must have a dimension named 'ftime' if 'ftime_dim = NULL'.")
      }
    } else {
      stop("Parameter 'var' must have dimension names if 'ftime_dim = NULL'.")
    }
  }
  if (is.character(ftime_dim)) {
    ftime_dim <- which(names(dims) == ftime_dim)
    if (length(ftime_dim) == 0) {
      stop("Could not find the specified 'ftime_dim' in 'var' dimension names.")
    }
  } else if (!is.numeric(ftime_dim)) {
    stop("Parameter 'ftime_dim' must be numeric.")
  }
  ftime_dim <- round(ftime_dim[1])
  # Check sdate_dim
  # A 0 will be assigned when the sdate_dim is not present and needs to be added later
  if (is.null(sdate_dim)) {
    if (!is.null(names(dims))) {
      if ('sdate' %in% names(dims)) {
        sdate_dim <- which(names(dims) == 'sdate')
      } else {
        sdate_dim <- 0
      }
    } else {
      sdate_dim <- 0
    }
  }
  if (is.character(sdate_dim)) {
    sdate_dim <- which(names(dims) == sdate_dim)
    if (length(sdate_dim) == 0) {
      stop("Could not find the specified 'sdate_dim' in 'var' dimension names.")
    }
  } else if (!is.numeric(sdate_dim)) {
    stop("Parameter 'sdate_dim' must be numeric.")
  }
  sdate_dim <- round(sdate_dim[1])

  # Check freq
  if (!('difftime' %in% class(freq))) {
    if (freq == 'min') {
      freq <- as.difftime(1, units = 'mins')
    } else if (freq == 'day') {
      freq <- as.difftime(1, units = 'days')
    } else if (freq %in% c('month', 'year')) {
    } else {
      stop("Parameter 'freq' must be either of the class 'difftime' or one ",
           " of 'month' or 'year'.")
    }
  }

  # Check calendar_in
  if (!is.character(calendar_in)) {
    stop("Parameter 'calendar_in' must be a character string.")
  }
  if (!(calendar_in %in% c('leap', 'noleap'))) {
    stop("Parameter 'calendar_in' must be one of 'leap' or 'noleap'.")
  }

  # Check calendar_out
  if (!is.character(calendar_out)) {
    stop("Parameter 'calendar_out' must be a character string.")
  }
  if (!(calendar_out %in% c('leap', 'noleap'))) {
    stop("Parameter 'calendar_out' must be one of 'leap' or 'noleap'.")
  }

  # Check leap_fill_method
  if (!is.character(leap_fill_method)) {
    stop("Parameter 'leap_fill_method' must be a character string.")
  }
  if (!(leap_fill_method %in% c('put_NA', 'copy_28th_feb', 'copy_1st_mar'))) {
    stop("Parameter 'leap_fill_method' must be one of 'put_NA', ",
         "'copy_28th_feb' or 'copy_1st_mar'.")
  }

  # Create the list_of_dates, containing a list of vectors each
  # with the dates of the values of each sdate
  # Create the dates_in, a vector of the dates of the input data
  # Create tolerance according to freq
  dates_seq <- function(from, by, n, calendar = 'leap') {
    r <- seq(from, by = by, length.out = n)
    if ((calendar == 'noleap') && (by == as.difftime(1, units = 'days'))) {
      keep_doing <- TRUE
      feb29_indices <- which(format(r, '%m%d') == '0229')
      new_feb29_indices <- feb29_indices
      while (keep_doing) {
        if (length(new_feb29_indices) > 0) {
          new_r <- seq(r[length(r)], by = freq, 
                       length.out = 1 + length(new_feb29_indices))[-1]
          new_feb29_indices <- which(format(new_r, '%m%d') == '0229') + length(r)
          r <- c(r, new_r)
          feb29_indices <- c(feb29_indices, new_feb29_indices)
        } else {
          keep_doing <- FALSE
        }
      }
      if (length(feb29_indices) > 0) {
        r <- r[-feb29_indices]
      }
    }
    if (any(is.na(r))) print("HEEEY")
    r
  }
  dates_in <- NULL
  if ('difftime' %in% class(freq)) {
    list_of_dates <- lapply(sdatesout, 
                            function(x) {
                              dates_seq(x, freq, n_ftimes, calendar_out)
                            })

    dates_in <- dates_seq(sdate, freq, dims[ftime_dim], calendar_in)
    tolerance <- 0.5 * freq
  } else if (freq == 'month') {
    # Monthly series
    # x has to be 'YYYYMMDD'
    # n_ftimes number of dates to generate
    generate_dates <- function(x, n_ftimes) {
      syear <- as.integer(substr(as.character(x), 1, 4))
      smonth <- as.integer(substr(as.character(x), 6, 7))
      sday <- as.integer(substr(as.character(x), 9, 10))
      months_seq <- (((1:12 + smonth - 1) - 1) %% 12) + 1
      month_inds <- ((1:n_ftimes - 1) %% length(months_seq)) + 1
      months_seq <- months_seq[month_inds]
      year_changes <- which(months_seq == 12)
      as.POSIXct(
        sapply(1:n_ftimes, 
               function(y) {
                 offset_years <- sum(year_changes < y)
                 paste0(syear + offset_years, '-', months_seq[y], '-', sday)
               })
      )
    }
    list_of_dates <- lapply(sdatesout, generate_dates, n_ftimes)
    dates_in <- generate_dates(sdate, dims[ftime_dim])
    tolerance <- as.difftime(15, units = 'days')
  } else if (freq == 'year') {
    stop("Feature 'freq = \"year\"' still to be implemented.")
  }

  # Work out the dimensions of the output array
  new_dims <- dims
  new_dims[ftime_dim] <- n_ftimes
  sdate_dim_out <- 0
  if (sdate_dim > 0) {
    new_dims[sdate_dim] <- length(sdatesout)
  } else {
    new_dims_2 <- NULL
    if (ftime_dim > 1) {
      new_dims_2 <- new_dims[1:(ftime_dim - 1)]
    }
    sdate_dim_out <- length(new_dims_2) + 1
    new_dims_2 <- c(new_dims_2, sdate = length(sdatesout), 
                    new_dims[ftime_dim:length(new_dims)])
    new_dims <- new_dims_2
  }

  # Create output array
  var_out <- array(dim = new_dims)

  # Populate output array with corresponding values
  for (i in 1:length(sdatesout)) {
    # First select the values to take for each start date
    indices <- as.list(rep(TRUE, length(dims)))
    indices[[ftime_dim]] <- sapply(1:n_ftimes, 
      function(x) {
        diffs <- abs(dates_in - list_of_dates[[i]][x])
        match <- which.min(diffs)
        if (diffs[match] <= tolerance) {
          match[1]
        } else {
          NA
        }
      })
    if (all(is.na(indices[[ftime_dim]]))) {
      value <- rep(NA, n_ftimes)
    } else {
      value <- do.call('[', c(list(x = var), indices, list(drop = FALSE)))
    }
    # Fill in 29th februaries if calendar_in == 'noleap' and calendar_out == 'leap'
    if (calendar_in == 'noleap' && calendar_out == 'leap') {
      feb29_indices <- which(format(list_of_dates[[i]], '%m%d') == '0229')
      if (length(feb29_indices) > 0) {
        if (leap_fill_method == 'put_NA') {
          indices_hindcast <- indices
          indices_hindcast[[ftime_dim]] <- feb29_indices
          value <- do.call('[<-', c(list(x = value), indices_hindcast, 
                           list(value = rep(NA, prod(dims[-ftime_dim]) * 
                                        length(feb29_indices)))))
        } else if (leap_fill_method == 'copy_28th_feb') {
          indices_hindcast <- indices
          #if (indices[[ftime_dim]][feb29_indices[1] + 1] - 2 < 1) {
          #  feb29_indices <- feb29_indices[-1]
          #  warning("WARNING: 29th february at the beginning of the ",
          #          "historical series and 'copy_28th_feb' fill method ",
          #          "requested. Filling in with NA instead.")
          #}
          if (length(feb29_indices) > 0) {
            indices[[ftime_dim]] <- indices[[ftime_dim]][feb29_indices - 1]
            feb29_values <- do.call('[', c(list(x = var), indices, list(drop = FALSE)))
            indices_hindcast[[ftime_dim]] <- feb29_indices
            value <- do.call('[<-', c(list(x = value), indices_hindcast, 
                             list(value = feb29_values)))
          }
        } else if (leap_fill_method == 'copy_1st_mar') {
          indices_hindcast <- indices
          #if (indices[[ftime_dim]][feb29_indices[length(feb29_indices)] - 1] + 2 > 
          #    dims[ftime_dim]) {
          #  feb29_indices <- feb29_indices[-length(feb29_indices)]
          #  warning("WARNING: 29th february at the end of the ",
          #          "historical series and 'copy_1st_mar' fill method ",
          #          "requested. Filling in with NA instead.")
          #}
          if (length(feb29_indices) > 0) {
            indices[[ftime_dim]] <- indices[[ftime_dim]][feb29_indices + 1]
            feb29_values <- do.call('[', c(list(x = var), indices, list(drop = FALSE)))
            indices_hindcast[[ftime_dim]] <- feb29_indices
            value <- do.call('[<-', c(list(x = value), indices_hindcast, 
                             list(value = feb29_values)))
          }
        }
      }
    }

    # Then put into output array
    indices <- as.list(rep(TRUE, length(new_dims)))
    indices[[sdate_dim_out]] <- i
    var_out <- do.call('[<-', c(list(x = var_out), indices, list(value = value)))
  }

  if (calendar_in == 'leap' && calendar_out == 'noleap') {
    warning("WARNING: 29th februaries from input have been removed.")
  }

  var_out
}
