#'@rdname CST_MultiEOF
#'@title EOF analysis of multiple variables
#'
#'@author Jost von Hardenberg - ISAC-CNR, \email{j.vonhardenberg@isac.cnr.it}
#'@author Paolo Davini - ISAC-CNR, \email{p.davini@isac.cnr.it}
#'
#'@description This function performs EOF analysis over multiple variables,
#'accepting in input a list of CSTools objects. Based on Singular Value 
#'Decomposition. For each field the EOFs are computed and the corresponding PCs 
#'are standardized (unit variance, zero mean); the minimum number of principal 
#'components needed to reach the user-defined variance is retained. The function 
#'weights the input data for the latitude cosine square root.
#'
#'@param datalist A list of objects of the class 's2dv_cube', containing the 
#'  variables to be analysed. Each data object in the list is expected to have 
#'  an element named \code{$data} with at least two spatial dimensions named 
#'  "lon" and "lat", a dimension "ftime" and a dimension "sdate". Latitudinal 
#'  dimension accepted names: 'lat', 'lats', 'latitude', 'y', 'j', 'nav_lat'. 
#'  Longitudinal dimension accepted names: 'lon', 'lons','longitude', 'x', 'i', 
#'  'nav_lon'.
#'@param neof_composed Number of composed eofs to return in output.
#'@param minvar Minimum variance fraction to be explained in first decomposition.
#'@param neof_max Maximum number of single eofs considered in the first 
#'  decomposition.
#'@param lon_lim Vector with longitudinal range limits for the EOF calculation 
#'  for all input variables.
#'@param lat_lim Vector with latitudinal range limits for the EOF calculation 
#'  for all input variables.
#'@return A list with elements \code{$coeff} (an array of time-varying principal 
#'component coefficients), \code{$variance} (a matrix of explained variances),
#'\code{eof_pattern} (a matrix of EOF patterns obtained by regression for each 
#'variable).
#'@import abind
#'@examples
#'seq <- 1 : (2 * 3 * 4 * 5 * 6 * 8)
#'mod1 <- sin( 0.7 + seq )^2 + cos( seq ^ 2 * 1.22  )
#'dim(mod1) <- c(dataset = 2, member = 3, sdate = 4, ftime = 5, lat = 6, 
#'               lon = 8)
#'mod2 <- sin( seq * 2 ) ^ 3 + cos( seq ^ 2 )
#'dim(mod2) <- c(dataset = 2, member = 3, sdate = 4, ftime = 5, lat = 6, 
#'               lon = 8)
#'lon <- seq(0, 35, 5)
#'lat <- seq(0, 25, 5)
#'exp1 <- list(data = mod1, coords = list(lat = lat, lon = lon))
#'exp2 <- list(data = mod2, coords = list(lat = lat, lon = lon))
#'attr(exp1, 'class') <- 's2dv_cube'
#'attr(exp2, 'class') <- 's2dv_cube'
#'d = as.POSIXct(c("2017/01/01", "2017/01/02", "2017/01/03", "2017/01/04", 
#'                 "2017/01/05", "2018/01/01", "2018/01/02", "2018/01/03",
#'                 "2018/01/04", "2018/01/05", "2019/01/01", "2019/01/02", 
#'                 "2019/01/03", "2019/01/04", "2019/01/05", "2020/01/01", 
#'                 "2020/01/02", "2020/01/03", "2020/01/04", "2020/01/05"))
#'exp1$attrs$Dates = d
#'exp2$attrs$Dates = d
#'
#'cal <- CST_MultiEOF(datalist = list(exp1, exp2), neof_composed = 2)
#'@export
CST_MultiEOF <- function(datalist, neof_max = 40, neof_composed = 5, 
                         minvar = 0.6, lon_lim = NULL, lat_lim = NULL) {
  # Check s2dv_cube
  if (!(all(sapply(datalist, inherits, 's2dv_cube')))) {
     stop("Elements of the list in parameter 'datalist' must be of the class ",
          "'s2dv_cube', as output by CSTools::CST_Load.")
  }

  # Check if all dims equal
  adims = lapply(lapply(datalist, function(x) x$data), dim)
  if(!all(apply(apply(abind(adims, along = 0), 2, duplicated), 2, sum) ==
         (length(adims)-1))) {
    stop("Input data fields must all have the same dimensions.")
  }

  exp <- abind(lapply(datalist, '[[', 'data'), along = 0)
  dim(exp) <- c(var = length(datalist), dim(datalist[[1]]$data))

  if (any(is.na(exp)))  {
    stop("Input data contain NA values.")
  }

  # Check coordinates
  if (!all(c('data', 'coords', 'attrs') %in% names(datalist[[1]]))) {
    stop("Parameter 'datalist' must have 'data', 'coords' and 'attrs' elements ",
         "within the 's2dv_cube' structure.")
  }
  if (!any(names(datalist[[1]]$coords) %in% .KnownLonNames()) | 
      !any(names(datalist[[1]]$coords) %in% .KnownLatNames())) {
    stop("Spatial coordinate names do not match any of the names accepted by the ",
         "package. Latitudes accepted names: 'lat', 'lats', 'latitude', 'y', 'j', ", 
         "'nav_lat'. Longitudes accepted names: 'lon', 'lons', 'longitude', 'x',", 
         " 'i', 'nav_lon'.")
  }
  # Check dimensions
  if (!any(names(dim(datalist[[1]]$data)) %in% .KnownLonNames()) | 
      !any(names(dim(datalist[[1]]$data)) %in% .KnownLatNames())) {
    stop("Spatial dimension names do not match any of the names accepted by ",
         "the package.")
  }

  lon <- names(datalist[[1]]$coords)[[which(names(datalist[[1]]$coords) %in% .KnownLonNames())]]
  lat <- names(datalist[[1]]$coords)[[which(names(datalist[[1]]$coords) %in% .KnownLatNames())]]

  lon_name <- names(dim(datalist[[1]]$data))[[which(names(dim(datalist[[1]]$data)) %in% .KnownLonNames())]]
  lat_name <- names(dim(datalist[[1]]$data))[[which(names(dim(datalist[[1]]$data)) %in% .KnownLatNames())]]

  result <- MultiEOF(exp, 
                     lon = as.vector(datalist[[1]]$coords[[lon]]), 
                     lat = as.vector(datalist[[1]]$coords[[lat]]),
                     lon_dim = lon_name, lat_dim = lat_name, 
                     time = datalist[[1]]$attrs$Dates, minvar = minvar,
                     neof_max = neof_max, neof_composed = neof_composed,
                     lon_lim = lon_lim, lat_lim = lat_lim)

  return(result)
}
#'@rdname MultiEOF
#'@title EOF analysis of multiple variables starting from an array (reduced 
#'version)
#'
#'@author Jost von Hardenberg - ISAC-CNR, \email{j.vonhardenberg@isac.cnr.it}
#'@author Paolo Davini - ISAC-CNR, \email{p.davini@isac.cnr.it}
#'
#'@description This function performs EOF analysis over multiple variables, 
#'accepting in input an array with a dimension \code{"var"} for each variable to 
#'analyse. Based on Singular Value Decomposition. For each field the EOFs are 
#'computed and the corresponding PCs are standardized (unit variance, zero mean); 
#'the minimum number of principal components needed to reach the user-defined 
#'variance is retained. The function weights the input data for the latitude 
#'cosine square root.
#'
#'@param data A multidimensional array with dimension \code{"var"}, containing 
#'  the variables to be analysed. The other diemnsions follow the same structure
#'  as the \code{"exp"} element of a 's2dv_cube' object. Latitudinal 
#'  dimension accepted names: 'lat', 'lats', 'latitude', 'y', 'j', 'nav_lat'. 
#'  Longitudinal dimension accepted names: 'lon', 'lons','longitude', 'x', 'i', 
#'  'nav_lon'.
#'@param lon Vector of longitudes.
#'@param lat Vector of latitudes.
#'@param time Vector or matrix of dates in POSIXct format.
#'@param lon_dim String with dimension name of longitudinal coordinate.
#'@param lat_dim String with dimension name of latitudinal coordinate.
#'@param neof_composed Number of composed eofs to return in output.
#'@param minvar Minimum variance fraction to be explained in first decomposition.
#'@param neof_max Maximum number of single eofs considered in the first 
#'  decomposition.
#'@param lon_lim Vector with longitudinal range limits for the calculation for 
#'  all input variables.
#'@param lat_lim Vector with latitudinal range limits for the calculation for 
#'  all input variables.
#'@return A list with elements \code{$coeff} (an array of time-varying principal
#'component coefficients), \code{$variance} (a matrix of explained variances), 
#'\code{eof_pattern} (a matrix of EOF patterns obtained by regression for each 
#'variable).
#'@examples
#'exp <- array(runif(1280)*280, dim = c(dataset = 2, member = 2, sdate = 3, 
#'                                      ftime = 3, lat = 4, lon = 4, var = 1))
#'lon <- seq(0, 3)
#'lat <- seq(47, 44)
#'dates <- c("2000-11-01", "2000-12-01", "2001-01-01", "2001-11-01", 
#'           "2001-12-01", "2002-01-01", "2002-11-01", "2002-12-01", "2003-01-01")
#'Dates <- as.POSIXct(dates, format = "%Y-%m-%d")
#'dim(Dates) <- c(ftime = 3, sdate = 3)
#'cal <- MultiEOF(data = exp, lon = lon, lat = lat, time = Dates)
#'@import multiApply
#'@export
MultiEOF <- function(data, lon, lat, time,
                     lon_dim = "lon", lat_dim = "lat",
                     neof_max = 40, neof_composed = 5, minvar = 0.6,
                     lon_lim = NULL, lat_lim = NULL) {

  # Know spatial coordinates names
  if (!any(lon_dim %in% .KnownLonNames()) | 
      !any(lat_dim %in% .KnownLatNames())) {
    stop("Spatial coordinate names do not match any of the names accepted by ",
         "the package.")
  }

  # Reorder and group ftime and sdate together at the end in that order
  cdim0 <- dim(data)
  imaskt <- names(cdim0) %in% "ftime"
  imasks <- names(cdim0) %in% "sdate"
  data <- .aperm2(data, c(which(!(imasks | imaskt)),
                          which(imaskt), which(imasks)))
  cdim <- dim(data)
  ind <- 1:length(which(!(imaskt | imasks)))
  # compact (multiply) time_dim dimensions
  dim(data) <- c(cdim[ind], samples = prod(cdim[-ind]))

  # Repeatedly apply .multi.eofs
  result <- Apply(data, c("var", lon_dim, lat_dim, "samples"),
                  .multi.eofs, lon, lat, time, neof_max = neof_max,
                  neof_composed = neof_composed, minvar = minvar,
                  xlim = lon_lim, ylim = lat_lim, 
                  lon_dim = lon_dim, lat_dim = lat_dim)
  
  # Expand back samples to compacted dims
  dim(result$coeff) <- c(cdim[-ind], dim(result$coeff)[-1])
  # Recover first lon and first lat list
  dd = dim(result[[lon_dim]])[1]; m = matrix(1, nrow = dd, ncol = length(dim(result[[lon_dim]])));
  m[1:dd] = 1:dd; result[[lon_dim]] = result[[lon_dim]][m]
  dd = dim(result[[lat_dim]])[1]; m = matrix(1, nrow = dd, ncol = length(dim(result[[lat_dim]])));
  m[1:dd] = 1:dd; result[[lat_dim]] = result[[lat_dim]][m]

  return(result)
}

#'Atomic MultiEOF
#'@param field_arr_raw An array of dimension: (n_field, lon, lat, time).
#'  where n_field is the number of variables over which to calculate the 
#'  multi_eofs.
#'@param neof_composed Number of composed eofs to return in output.
#'@param minvar Minimum variance fraction to be explained in first decomposition.
#'@param neof_max Maximum number of single eofs considered in the first 
#'  decomposition.
#'@param xlim Vector with longitudinal range limits for the calculation.
#'@param ylim Vector with latitudinal range limits for the calculation.
#'@param lon_dim String with dimension name of longitudinal coordinate.
#'@param lat_dim String with dimension name of latitudinal coordinate.
#' 
#'@return A list with elements \code{$coeff} (an array of time-varying principal 
#'component coefficients), \code{$variance} (a matrix of explained variances),
#'\code{eof_pattern} (a matrix of EOF patterns obtained by regression for each 
#'variable).
#'@noRd

.multi.eofs <- function(field_arr_raw, lon, lat, time, neof_max = 40, 
                        neof_composed = 5, minvar = 0.6, xlim = NULL, 
                        ylim = NULL, lon_dim = "lon", lat_dim = "lat") {

  if (exists(".lm.fit")) {
    lin.fit <- .lm.fit
  } else {
    lin.fit <- lm.fit
  }

  n_field <- dim(field_arr_raw)[1]
  etime <- .power.date(time)

  field_arr <- array(dim = dim(field_arr_raw))
  for (k in seq(1, n_field, 1)) {
    field_arr[k, , , ] <- .daily.anom.mean(lon, lat, field_arr_raw[k, , , ], etime)
  }

  # area weighting, based on the root of cosine
  ww <- .area.weight(lon, lat, root = T)

  for (k in seq(1, n_field, 1)) {
    field_orig <- field_arr[k, , , ]
    # calculate the area weight
    field <- sweep(field_orig, c(1, 2), ww, "*")
    idx <- .selbox(lon, lat, xlim, ylim)
    slon <- lon[idx$ilon]
    slat <- lat[idx$ilat]
    field <- field[idx$ilon, idx$ilat, ]

    # transform 3D field in a matrix
    field <- array(field, dim = c(dim(field)[1] * dim(field)[2], dim(field)[3]))

    # calling SVD
    SVD <- svd(field, nu = neof_max, nv = neof_max)

    # extracting EOFs (loading pattern), expansions coefficient
    # and variance explained
    pattern <- array(SVD$u, dim = c(dim(field)[1], dim(field)[2], neof_max))
    coefficient <- SVD$v
    variance <- (SVD$d[1:neof_max]) ^ 2 / sum((SVD$d) ^ 2)
    reqPC <- which(cumsum(variance) > minvar)[1]
    variance <- variance[1:reqPC]
    coefficient <- coefficient[, 1:reqPC]
    if (reqPC == 1) {
      coefficient <- replicate(1, coefficient)
    }
    coefficient <- apply(coefficient, c(2), .standardize)
    regression <- array(NA, dim = c(length(lon), length(lat), neof_max))
    for (i in 1:reqPC) {
      regression[, , i] <- apply(field_orig, c(1, 2),
                                 function(x) lin.fit(as.matrix(coefficient[, i],
                                                     ncol = 1), x)$coefficients)
    }
    assign(paste0("pc", k), list(coeff = coefficient, variance = variance,
                                 wcoeff = sweep(coefficient, c(2), variance, "*"),
                                 regression = regression))
  }

  newpc <- NULL
  for (k in seq(1, n_field, 1)) {
    newpc <- cbind(newpc, get(paste0("pc", k))$wcoeff)
  }
  newpc <- t(newpc)

  SVD <- svd(newpc, nu = neof_composed, nv = neof_composed)
  # extracting EOFs, expansions coefficient and variance explained
  coefficient <- SVD$v
  variance <- (SVD$d[1:(neof_composed)]) ^ 2 / sum( (SVD$d) ^ 2)
  coefficient <- apply(coefficient, c(2), .standardize)

  # linear regressions on anomalies
  regression <- array(dim = c(n_field, length(lon),
                              length(lat), neof_composed))
  for (k in seq(1, n_field, 1)) {
    for (i in 1:neof_composed) {
      regression[k, , , i] <- apply(field_arr[k, , , ], c(1, 2),
                                    function(x) lin.fit(as.matrix(coefficient[, i],
                                                        ncol = 1), x)$coefficients)
    }
  }

  names(dim(coefficient)) <- c("time", "eof")
  variance <- array(variance)
  names(dim(variance)) <- "eof"
  names(dim(regression)) <- c("var", "lon", "lat", "eof")

  out <- list(coeff = coefficient, variance = variance, eof_pattern = regression)

  out[[lon_dim]] <- slon
  out[[lat_dim]] <- slat

  return(out)
}

# new function to create simple list with date values - Oct-18
# it needs a date or PCICt object, and returns also the season subdivision
.power.date <- function(datas, verbose = FALSE) {

  # create a "season" for continuous time, used by persistance tracking
  startpoints <- c(0, which(diff(datas) > 1))
  deltapoints <- diff(c(startpoints, length(datas)))
  seas <- inverse.rle(list(lengths = deltapoints,
                           values = seq(1, length(startpoints))))

  etime <- list(
    day = as.numeric(format(datas, "%d")),
    month = as.numeric(format(datas, "%m")),
    year = as.numeric(format(datas, "%Y")), data = datas, season = seas
  )

  .printv("Time Array Built", verbose)
  .printv(paste("Length:", length(seas)), verbose)
  .printv(paste("From", datas[1], "to", datas[length(seas)]), verbose)
  return(etime)
}

# function for daily anomalies, use array predeclaration and rowMeans (40 times faster!)
.daily.anom.mean <- function(ics, ipsilon, field, etime) {
  condition <- paste(etime$day, etime$month)
  daily <- array(NA, dim = c(length(ics), length(ipsilon),
                             length(unique(condition))))
  anom <- field * NA

  for (t in unique(condition)) {
    if (sum(t == condition) == 1) {
      print(paste0("Cannot compute a mean with only one value: ",
                   "using climatological mean"))
      anom[, , which(t == condition)] <- rowMeans(field, dims = 2)
    } else {
      daily[, , which(t == unique(condition))] <- rowMeans(field[, , t == condition], dims = 2)
      anom[, , which(t == condition)] <- sweep(field[, , which(t == condition)],
                                               c(1, 2),
                                               daily[, , which(t == unique(condition))], "-")
    }
  }
  return(anom)
}
