#'AdamontAnalog finds analogous data in the reference dataset to experiment data based on
#'weather types
#'
#'@description This function searches for analogs in a reference dataset for experiment data, based on corresponding weather types. The experiment data is typically a hindcast, observations are typically provided by reanalysis data.
#'@author Paola Marson, \email{paola.marson@meteo.fr} for PROSNOW version
#'@author Lauriane Batté, \email{lauriane.batte@meteo.fr} for CSTools adaptation
#'
#'@param exp experiment data an object of class \code{s2dv_cube}, can be output from quantile correction
#'@param wt corresponding weather types (same dimensions as \code{exp} but lat/lon), also of class \code{s2dv_cube}
#'@param obs reference data, also of class \code{s2dv_cube}. Note that lat/lon dimensions need to be the same as \code{exp}
#'@param wt_obs corresponding weather types (same dimensions as \code{obs} but lat/lon)
#'@param nanalogs integer defining the number of analog values to return (default: 5)
#'@param method a character string indicating the method used for analog definition
#'       Coded are 'pattcorr': pattern correlation
#'	           'rain1' (for precip patterns): rain occurrence consistency
#'	           'rain01' (for precip patterns): rain occurrence/non occurrence consistency
#'@param thres real number indicating the threshold to define rain occurrence/non occurrence in rain(0)1
#'@param search_obsdims list of dimensions in \code{obs} along which analogs are searched for
#'@param londim name of longitude dimension
#'@param latdim name of latitude dimension
#'@return analog_vals an object of class \code{s2dv_cube} containing nanalogs analog values for each value of \code{exp} input data
#'@import CSTools, multiApply, ClimProjDiags

CST_AdamontAnalog <- function(exp, obs, wt_exp, wt_obs, nanalogs, method = 'pattcorr', thres = NULL, search_obsdims = c('member', 'sdate', 'ftime'), londim = 'lon', latdim = 'lat') {

  if (!inherits(exp, 's2dv_cube') || !inherits(obs, 's2dv_cube')) {
     stop("Inputs 'exp' and 'obs' must be of class 's2dv_cube', ",
	  "as output by CSTools::CST_Load.")
  }
  if (!(method %in% c('pattcorr','rain1','rain01'))) {
     stop("Input parameter 'method' must be 'pattcorr', 'rain1', or 'rain01'")
  }
  if (!is.null(nanalogs)){
     nanalogs <- 5
  }
  dimnames <- names(dim(obs$data))
  if (!is.null(which(dimnames == latdim)) || !is.null(which(dimnames == londim))) {
     stop("'londim' or 'latdim' inputs should correspond to 'obs' dimension names")
  }
  # More sanity checks needed? Same dimensions in obs and exp; wt_obs and wt_exp
  analog_vals <- AdamontAnalog(exp = exp$data, obs = obs$data, wt_exp = wt_exp, 
			       nanalogs = nanalogs, method = method, thres = thres,
			       search_obsdims = search_obsdims, londim = londim,
			       latdim = latdim )

  return(analog_vals)
}

AdamontAnalog <-  function(exp, obs, wt_exp, wt_obs, nanalogs=5, method = 'pattcorr', thres = NULL,search_obsdims = c('member', 'sdate', 'ftime'), londim = 'lon', latdim = 'lat') { 
  # exp: lat, lon, sdate, ftime, member
  # obs: lat, lon, dims for searching 'sdate' 'ftime'...
  # wt_exp: sdate, ftime, member 
  # wt_obs: the dims for searching
  if (method %in% c('rain1','rain01') & is.null(thres)){
     stop("Threshold 'thres' must be defined with methods 'rain1' and 'rain01'")
  }
  if (method == 'pattcorr' & !is.null(thres)){
     warning("Parameter 'thres' is not used with method 'pattcorr'.")
  }
  # Position of lat/lon dimensions in exp data
  poslatexp <- which(names(dim(exp)) == latdim)
  poslonexp <- which(names(dim(exp)) == londim)
  # Reshaping obs:
  ## The dimensions where to search in a single dim
  if (length(search_obsdims) > 1) {
    for (i in 1:(length(search_obsdims) - 1)) {
      obs <- MergeDims(obs, search_obsdims[i:(i + 1)], rename = search_obsdims[i + 1])
      wt_obs <- MergeDims(wt_obs, search_obsdims[i:(i + 1)], rename = search_obsdims[i + 1])
    }
  }
  names(dim(obs))[which(names(dim(obs)) == search_obsdims[length(search_obsdims)])] <- 'time'  
  names(dim(wt_obs))[which(names(dim(wt_obs)) == search_obsdims[length(search_obsdims)])] <- 'time' 
  # Split 'time' dim in weather types
  obs <- SplitDim(obs, split_dim = 'time', indices = as.vector(wt_obs), new_dim_name='type')

  analog_vals <- Apply(list(exp, obs, wt_exp), target_dims = list(c(londim, latdim),
                                                          c(londim, latdim, 'time', 'type'), NULL),
               .analogs, method = method, thres = thres)$output1
  
  # Reshaping output:
  analog_vals <- Subset(analog_vals,along='type',indices=1,drop='selected')
  poslat <- which(names(dim(analog_vals)) == latdim)
  poslon <- which(names(dim(analog_vals)) == londim)
  postime <- which(names(dim(analog_vals)) == 'time') # Dimension with N analogs
  pos <- 1:length(dim(analog_vals))
  if (poslatexp > poslonexp){
      analog_vals <- aperm(analog_vals,c(pos[-c(poslon,poslat,postime)],postime,poslon,poslat))
  } else {
      analog_vals <- aperm(analog_vals,c(pos[-c(poslon,poslat,postime)],postime,poslat,poslon))
  }
  # Renaming 'time' dim to 'analog'
  names(dim(analog_vals))[which(names(dim(analog_vals)) == 'time')] <- 'analog' 
  return(analog_vals)
}


.analogs <- function(exp, obs, wt_exp, nanalogs = 5, method = 'pattcorr', thres = NULL, 
                     londimexp = 'lon', latdimexp = 'lat', londimobs = 'lon', latdimobs = 'lat') {
  # exp: lon, lat
  # obs: lon, lat, time, wt
  # wt_exp: wt single scalar
  	
  search_analog <- switch(method, 'rain1' = .rain1, 'rain01' = .rain01, 
                          'pattcorr' = .pattcor, 
                          stop(paste0("Adamont Analog function supports methods ",
                                      "'rain1', 'rain01', 'pattcorr' only")))

  obs <- Subset(obs, along = 'type', indices = wt_exp)
  accuracy <- Apply(list(exp, obs), target_dims = list(c(londimexp, latdimexp),
                                                       c(londimobs, latdimobs)),
                    search_analog, thres = thres)$output1
  obs <- Subset(obs, along = 'time', indices = order(accuracy, decreasing = TRUE)[1:nanalogs])
  return(obs)
}

.rain1 <- function(exp_day, obs_day, thres) {
  accuracy <- sum((obs_day >= thres) * (exp_day >= thres))
  return(accuracy)
}
.rain01 <- function(exp_day, obs_day, thres) {
  accuracy <- sum(diag(table((obs_day >= thres),(exp_day >= thres))))
  return(accuracy)
}
.pattcor <- function(exp_day, obs_day, thres = NULL) {
  accuracy <- cor(as.vector(obs_day),as.vector(exp_day))
  return(accuracy)
}


