#' @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.
#'
#' @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". 
#' @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
#' @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
#' @export
#' @examples
#' \donttest{
#' exp <- 1 : (2 * 3 * 4 * 8 * 8)
#' }

CST_MultiEOFs <- function(datalist,
                          neof_max = 40, neof_composed = 5, minvar = 0.6,
                          xlim = c(-180, 180), ylim = c(20, 85)) {
  print("Pasting data...")
  exp <- abind(lapply(datalist, '[[', 'exp'), along = 0) 
  dim(exp) <- c(var = length(datalist), dim(datalist[[1]]$exp))
  print("...done")
  result <- MultiEOFs(exp, datalist[[1]]$lon, datalist[[1]]$lat,
                      datalist[[1]]$Dates$start,
                      time_dim = c("ftime", "sdate"),
                      neof = neof, neof_composed = neof_composed,
                      xlim = xlim, ylim = ylim)

  return(result)
}

#' @rdname MultiEOFs
#' @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 arry with a dimension \code{"var"} for each variable to analyse.
#' Based on Singular Value Decomposition.
#'
#' @param datalist 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.
#' @param lon Vector of longitudes.
#' @param lat Vector of latitudes.
#' @param time Vector or matrix of dates in POSIXct format.
#' @param time_dim Character vector of dimension names to be considered as times 
#' @param lon_dim String with dimension name of longitudinal coordinate (default: "lon")
#' @param lat_dim String with dimension name of latitudinal coordinate (default: "lat")
#' @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
#' @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 multiApply
#' @export
#' @examples
#' # Example for the 'reduced' MultiEOFs function
#'
#' \donttest{
#' }

MultiEOFs <- function(data, lon, lat, time, time_dim = NULL,
                       lon_dim = "lon", lat_dim = "lat",
                       neof_max = 40, neof_composed = 5, minvar = 0.6,
                       xlim = c(-180, 180), ylim = c(20, 85)) {
  # Check/detect time_dim
  if (is.null(time_dim)) {
    time_dim_names <- c("ftime", "sdate", "time")
    time_dim_num <- which(time_dim_names %in% names(dim(data)))
    if (length(time_dim_num) > 0) {
    # Find time dimension with length > 1
      ilong <- which(dim(data)[time_dim_names[time_dim_num]] > 1)
      if (length(ilong) > 0) {
        time_dim <- time_dim_names[time_dim_num[ilong[1]]]
      } else {
        stop("No time dimension longer than one found.")
      }
    } else {
      stop("Could not automatically detect a target time dimension ",
           "in the provided data in 'data'.")
    }
    print(paste("Selected time dim: ", time_dim))
  }

  # reorder and group time_dim together at the end
  cdim0 <- dim(data)
  imask <- names(cdim0) %in% time_dim
  data <- .aperm2(data, c(which(!imask), which(imask)))
  cdim <- dim(data)
  ind <- 1:length(which(!imask))
  # 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 = xlim, ylim = ylim)

  return(result)
}


#' Atomic MultiEOFs
#' @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 (default: c(-180 180))
#' @param ylim Vector with latitudinal range limits for the calculation (default: c(20 85))
#' @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 = c(-180, 180), ylim = c(20, 85)) {

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

  n_field <- dim(field_arr_raw)[1]

  etime <- power.date.new(time)
  print("Calculating anomalies...")
  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
  print("Area Weighting...")
  ww <- area.weight(lon, lat, root = T)

  for (k in seq(1, n_field, 1)) {
    field <- field_arr[k, , , ]
    # calculate the area weight
    wwfield <- sweep(field, c(1, 2), ww, "*")

    # selection of the box
    box <- wwfield[whicher(lon, xlim[1]):whicher(lon, xlim[2]),
                   whicher(lat, ylim[1]):whicher(lat, ylim[2]), ]
    slon <- lon[whicher(lon, xlim[1]):whicher(lon, xlim[2])]
    slat <- lat[whicher(lat, ylim[1]):whicher(lat, ylim[2])]

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

    # calling SVD
    print("Calling SVD...")
    SVD <- svd(new_box, nu = neof_max, nv = neof_max)

    # extracting EOFs (loading pattern), expansions coefficient
    # and variance explained
    pattern <- array(SVD$u, dim = c(dim(box)[1], dim(box)[2], neof_max))
    coefficient <- SVD$v
    variance <- (SVD$d[1:neof_max]) ^ 2 / sum((SVD$d) ^ 2)
    print("Accumulated variance:")
    print(cumsum(variance))
    reqPC <- which(cumsum(variance) > minvar)[1]
    print("Number of EOFs needed for var:")
    print(reqPC)
    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(get(paste0("field", k)), 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)

  print("Calculating composed EOFs")
  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)) {
    print("Linear Regressions (it can take a while)... ")
    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
                              )
    }
  }

  print("Finalize...")

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

  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.new <- 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)
}


# produce a 2d matrix of area weights
area.weight <- function(ics, ipsilon, root = T) {
  field <- array(NA, dim = c(length(ics), length(ipsilon)))
  if (root == T) {
    for (j in 1:length(ipsilon)) {
      field[, j] <- sqrt(cos(pi / 180 * ipsilon[j]))
    }
  }

  if (root == F) {
    for (j in 1:length(ipsilon)) {
      field[, j] <- cos(pi / 180 * ipsilon[j])
    }
  }

  return(field)
}

# verbose-only printing function
printv <- function(value, verbosity = TRUE) {
  if (verbosity) {
    print(value)
  }
}


# detect ics ipsilon lat-lon
whicher <- function(axis, number) {
  out <- which.min(abs(axis - number))
  return(out)
}


# normalize a time series
standardize <- function(timeseries) {
  out <- (timeseries - mean(timeseries, na.rm = T)) / sd(timeseries, na.rm = T)
  return(out)
}
