#'Compute the regression of an array on another along one dimension.
#'
#'Compute the regression of the array 'datay' on the array 'datax' along the
#''reg_dim' dimension by least square fitting (default) or self-defined model. 
#'The function provides the slope of the regression, the intercept, and the
#'associated p-value and confidence interval. The filtered datay from the 
#'regression onto datax is also provided.\cr
#'The p-value relies on the F distribution, and the confidence interval relies 
#'on the student-T distribution.
#'
#'@param datay An numeric array as predictand including the dimension along
#'  which the regression is computed.
#'@param datax An numeric array as predictor. The dimension should be identical
#'  as parameter 'datay'.
#'@param reg_dim A character string indicating the dimension along which to 
#'  compute the regression. The default value is 'sdate'.
#'@param formula An object of class "formula" (see function \code{link[stats]{lm}}).
#'@param pval A logical value indicating whether to retrieve the p-value 
#'  or not. The default value is TRUE.
#'@param conf A logical value indicating whether to retrieve the confidence 
#'  intervals or not. The default value is TRUE.
#'@param conf.lev A numeric indicating the confidence level for the 
#'  regression computation. The default value is 0.95.
#'@param na.action A function or an integer. A function (e.g., na.omit, 
#'  na.exclude, na.fail, na.pass) indicates what should happen when the data 
#'  contain NAs. A numeric indicates the maximum number of NA position (it
#'  counts as long as one of datay and datax is NA) allowed for compute 
#'  regression. The default value is na.omit-
#'@param ncores An integer indicating the number of cores to use for parallel 
#'  computation. Default value is NULL.
#'
#'@import multiApply
#'@importFrom stats pf
#'@return 
#'A list containing:
#'\item{$regression}{
#'  A numeric array with same dimensions as parameter 'datay' and 'datax' except 
#'  the 'reg_dim' dimension, which is replaced by a 'stats' dimension containing 
#'  the regression coefficients from the lowest order (i.e., intercept) to 
#'  the highest degree. The length of the 'stats' dimension should be 
#'  \code{polydeg + 1}.  
#'}
#'\item{$conf.lower}{
#'  A numeric array with same dimensions as parameter 'daty' and 'datax' except
#'  the 'reg_dim' dimension, which is replaced by a 'stats' dimension containing 
#'  the lower value of the \code{siglev}\% confidence interval for all
#'  the regression coefficients with the same order as $regression. The length 
#'  of 'stats' dimension should be \code{polydeg + 1}. Only present if 
#'  \code{conf = TRUE}.
#'}
#'\item{$conf.upper}{
#'  A numeric array with same dimensions as parameter 'daty' and 'datax' except
#'  the 'reg_dim' dimension, which is replaced by a 'stats' dimension containing 
#'  the upper value of the \code{siglev}\% confidence interval for all
#'  the regression coefficients with the same order as $regression. The length 
#'  of 'stats' dimension should be \code{polydeg + 1}. Only present if 
#'  \code{conf = TRUE}.
#'}
#'\item{$p.val}{
#'  A numeric array with same dimensions as parameter 'daty' and 'datax' except
#'  the 'reg_dim' dimension, The array contains the p-value.
#'}
#'\item{$filtered}{
#'  A numeric array with the same dimension as paramter 'datay' and 'datax', 
#'  the filtered datay from the regression onto datax along the 'reg_dim' 
#'  dimension.
#'}
#'
#'@examples
#'# Load sample data as in Load() example:
#'example(Load)
#'datay <- sampleData$mod[, 1, , ]
#'names(dim(datay)) <- c('sdate', 'ftime')
#'datax <- sampleData$obs[, 1, , ]
#'names(dim(datax)) <- c('sdate', 'ftime')
#'res1 <- Regression(datay, datax, formula = y~poly(x, 2, raw = TRUE))
#'res2 <- Regression(datay, datax, conf.lev = 0.9)
#'
#'@importFrom stats lm na.omit confint
#'@import multiApply
#'@export
Regression <- function(datay, datax, reg_dim = 'sdate', formula = y ~ x, 
                       pval = TRUE, conf = TRUE, conf.lev = 0.95,
                       na.action = na.omit, ncores = NULL) {

  # Check inputs 
  ## datay and datax
  if (is.null(datay) | is.null(datax)) {
    stop("Parameter 'datay' and 'datax' cannot be NULL.")
  }
  if (!is.numeric(datay) | !is.numeric(datax)) {
    stop("Parameter 'datay' and 'datax' must be a numeric array.")
  }
#  if (is.null(dim(datay)) | is.null(dim(datax))) {
#    stop("Parameter 'datay' and 'datax' must be at least one dimension 'reg_dim'.")
#  }
  if (is.null(dim(datay))) {  #is vector
    dim(datay) <- c(length(datay))
    names(dim(datay)) <- reg_dim
  }
  if (is.null(dim(datax))) {  #is vector
    dim(datax) <- c(length(datax))
    names(dim(datax)) <- reg_dim
  }
  if(any(is.null(names(dim(datay))))| any(nchar(names(dim(datay))) == 0) |
     any(is.null(names(dim(datax))))| any(nchar(names(dim(datax))) == 0)) {
    stop("Parameter 'datay' and 'datax' must have dimension names.")
  }
  if(!all(names(dim(datay)) %in% names(dim(datax))) | 
     !all(names(dim(datax)) %in% names(dim(datay)))) {
    stop("Parameter 'datay' and 'datax' must have same dimension name")
  }
  name_datay <- sort(names(dim(datay)))
  name_datax <- sort(names(dim(datax)))
  if(!all(dim(datay)[name_datay] == dim(datax)[name_datax])) {
    stop("Parameter 'datay' and 'datax' must have same length of all dimensions.")
  }
  ## reg_dim
  if (!is.character(reg_dim) | length(reg_dim) > 1) {
    stop("Parameter 'reg_dim' must be a character string.")
  }
  if (!reg_dim %in% names(dim(datay)) | !reg_dim %in% names(dim(datax))) {
    stop("Parameter 'reg_dim' is not found in 'datay' or 'datax' dimension.")
  }
  ## formula
  if (class(formula) != 'formula') {
    stop("Parameter 'formula' must the an object of class 'formula'.")
  }
  ## pval
  if (!is.logical(pval) | length(pval) > 1) {
    stop("Parameter 'pval' must be one logical value.")
  }
  ## conf
  if (!is.logical(conf) | length(conf) > 1) {
    stop("Parameter 'conf' must be one logical value.")
  }
  ##conf.lev
  if (!is.numeric(conf.lev) | conf.lev < 0 | conf.lev > 1 | length(conf.lev) > 1) {
    stop("Parameter 'conf.lev' must be a numeric number between 0 and 1.")
  }
  ## na.action
  if (!is.function(na.action) & !is.numeric(na.action)) {
      stop(paste0("Parameter 'na.action' must be a function for NA values or ",
                  "a numeric indicating the number of NA values allowed ",
                  "before returning NA."))
  }
  if (is.numeric(na.action)) {
    if (any(na.action %% 1 != 0) | any(na.action < 0) | length(na.action) > 1) {
      stop(paste0("Parameter 'na.action' must be a function for NA values or ",
                  "a numeric indicating the number of NA values allowed ",
                  "before returning NA."))
    }
  }
  ## ncores
  if (!is.null(ncores)) {
    if (!is.numeric(ncores) | ncores %% 1 != 0 | ncores < 0 |
      length(ncores) > 1) {
      stop("Parameter 'ncores' must be a positive integer.")
    }
  } 

  ###############################
  # Sort dimension
  name_datay <- names(dim(datay))
  name_datax <- names(dim(datax))
  order_datax <- match(name_datay, name_datax)
  datax <- Reorder(datax, order_datax)


  ###############################
  # Calculate Regression
    if (conf & pval) {
    output_dims <- list(regression = 'stats', conf.lower = 'stats',
                        conf.upper = 'stats', p.val = NULL, filtered = reg_dim)
  } else if (conf & !pval) {
    output_dims <- list(regression = 'stats', conf.lower = 'stats',
                        conf.upper = 'stats', filtered = reg_dim)
  } else if (!conf & pval) {
    output_dims <- list(regression = 'stats',
                        p.val = NULL, filtered = reg_dim)
  } else if (!conf & !pval) {
    output_dims <- list(regression = 'stats', filtered = reg_dim)
  }
  
  res <- Apply(list(datay, datax), 
               target_dims = reg_dim, 
               output_dims = output_dims,
               fun = .Regression, 
               formula = formula, pval = pval, conf = conf,
               conf.lev = conf.lev, na.action = na.action, 
               ncores = ncores)

  return(invisible(res))
}


.Regression <- function(y, x, formula = y~x, pval = TRUE, conf = TRUE, 
                        conf.lev = 0.95, na.action = na.omit) {

  NApos <- 1:length(x)
  NApos[which(is.na(x) | is.na(y))] <- NA
  filtered <- rep(NA, length(x))
  check_na <- FALSE

  if (is.numeric(na.action)) {
    na_threshold <- na.action
    na.action <- na.omit
    check_na <- TRUE
  }

  # remove NAs for potential poly()
  x2 <- x[!is.na(NApos)]
  y2 <- y[!is.na(NApos)]
  lm.out <- lm(formula, data = data.frame(x = x2, y = y2), na.action = na.action)
  coeff <- lm.out$coefficients
  if (conf) {
    conf.lower <- confint(lm.out, level = conf.lev)[, 1]
    conf.upper <- confint(lm.out, level = conf.lev)[, 2]
  }
  if (pval) {
    f <- summary(lm.out)$fstatistic
    p.val <- pf(f[1], f[2], f[3],lower.tail = F)
  }
  filtered[!is.na(NApos)] <- y[!is.na(NApos)] - lm.out$fitted.values

  # Check if NA is too many
  if (check_na) {
    if (sum(is.na(NApos)) > na_threshold) {  #turn everything into NA
      coeff[which(!is.na(coeff))] <- NA
      if (conf) {
        conf.lower[which(!is.na(conf.lower))] <- NA
        conf.upper[which(!is.na(conf.upper))] <- NA
      }
      if (pval) {
        p.val[which(!is.na(p.val))] <- NA
      }
      filtered[which(!is.na(filtered))] <- NA
    }
  }

  if (conf & pval) {
    return(list(regression = coeff, conf.lower = conf.lower, conf.upper = conf.upper, 
                p.val = p.val, filtered = filtered))
  } else if (conf & !pval) {
    return(list(regression = coeff, conf.lower = conf.lower, conf.upper = conf.upper,
                filtered = filtered))
  } else if (!conf & pval) {
    return(list(regression = coeff,
                p.val = p.val, filtered = filtered))
  } else if (!conf & !pval) {
    return(list(regression = coeff, filtered = filtered))
  }

}

