#' @include procmod.R
#' @include procmod_frame.R
#' @include multivariate.R
#' @import doParallel
#' @import foreach
#'
#' @author Christelle Gonindard-Melodelima
#' @author Eric Coissac
NULL

library(doParallel)
registerDoParallel(1)

#' Compute the trace of a square matrix.
#'
#' The trace of a square matrix is defined as the sum
#' of its diagonal elements.
#'
#' @param X a square matrix
#' @return the trace of X
#'
#' @examples
#' m <- matrix(1:16, nrow = 4)
#' ProcMod:::.Trace(m)
#' @note Internal function do not use.
#'
#' @rdname internal.Trace
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#'
.Trace <- function(X) sum(diag(X))


.var2cor <- function(c) {
  v <- sqrt(diag(c))
  vv <- v %o% v
  c / vv
}

#' Compute the procrustean variance, covariance matrix of K matrices.
#'
#' Procrustean covariance between two matrices X and Y, is defined as the sum
#' of the singular values of the X'Y matrix
#' \insertCite{Gower:71:00,Lingoes:74:00}{Rdpack}. Both the matrices must have
#' the same number of rows.
#'
#' \code{varls} computes the variance covariance matrix of a set of matrices
#' following the above definition. The variances and covariances are corrected
#' to avoid over fitting \insertCite{Coissac-Eric:19:00}{Rdpack}. .
#'
#' Before computing the covariances, matrices are projected into an
#' orthogonal space using the \code{\link[ProcMod]{ortho}} function.
#'
#' @references{
#'  \insertRef{Gower:71:00}{ProcMod}
#'
#'  \insertRef{Lingoes:74:00}{ProcMod}
#'
#'  \insertRef{Coissac-Eric:19:00}{ProcMod}
#' }
#'
#' @param ...   the set of matrices or a \code{\link[ProcMod]{procmod.frame}}
#'              object.
#' @param nrand number of randomisation used to estimate the mean
#'              covariance observed between two random matrix.
#'              If rand is \code{NULL} or equal to \code{0}, no correction
#'              is estimated and the raw procrustean covariances are
#'              estimated.
#' @param p.adjust.method the multiple test correction method used
#'              to adjust p values. \code{\link[stats]{p.adjust.method}}
#'              belongsone of the folowing values: \code{"holm"},
#'              \code{"hochberg"}, \code{"hommel"}, \code{"bonferroni"},
#'              \code{"BH"}, \code{"BY"}, \code{"fdr"},  \code{"none"}.
#'              The default is,set to \code{"holm"}.
#'
#' @return a \code{procmod.varls} object which corresponds to a numeric
#'              matrix annotated by several attributes.
#'
#'              The following attribute is always added:
#'
#'              - \code{nrand} an integer value indicating the number of
#'                randomisations used to estimate the mean of the random
#'                covariance.
#'
#'              When \code{nrand} is greater than 0 a couple of attributes
#'              is added:
#'
#'              - \code{rcovls} a numeric matrix containing the estimation
#'                of the mean of the random covariance.
#'
#'              - \code{p.value} a numeric matrix containing the estimations
#'                of the p.values of tests checking that the observed
#'                covariance is larger than the mean of the random covariance.
#'                p.values are corrected for multiple tests according to the
#'                method specified by the \code{p.adjust.method} parameter.
#'
#' @examples
#' # Build Three matrices of 3 rows.
#' A <- matrix(1:9, nrow = 3)
#' B <- matrix(10:15, nrow = 3)
#' C <- matrix(20:31, nrow = 3)
#' # compute the variance covariance matrix
#' varls(A, B, C)
#' varls(A = A, B = B, C = C)
#' data = procmod.frame(A = A, B = B, C = C)
#' varls(data)
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
varls <- function(...,
                  nrand = 100,
                  p.adjust.method = "holm") {
  if (!is.null(nrand) && length(nrand) > 1) {
    stop("nrand must be a single numeric value or the NULL value")
  }

  if (nrand == 0) nrand <- NULL

  xs <- list(...)

  if (length(xs) == 1) {
    x <- xs[[1]]
    if (is.procmod.frame(x)) {
      xs <- x
    } else {
      xs <- procmod.frame(x)
    }
  }
  else {
    xs <- as.procmod.frame(xs)
  }

  x_names <- names(xs)

  xs <- ortho(xs)

  # xxs <- as.procmod.frame(mapply(tcrossprod,
  #   xs,
  #   SIMPLIFY = FALSE
  # ))

  nx <- length(xs)
  n <- nrow(xs)
  n1 <- n - 1

  cov_xxs <- Matrix::Matrix(0, nrow = nx, ncol = nx)

  # Computes the standard Covls covariance matrix
  for (i in seq_len(nx))
    for (j in i:nx)
      #cov_xxs[i, j] <- Re(.Trace(expm::sqrtm(xxs[[i]] %*% xxs[[j]])))
      cov_xxs[i, j] <- sum(svd(crossprod(xs[[i]],xs[[j]]))$d) / n1

  cov_xxs <- as.matrix(Matrix::forceSymmetric(cov_xxs, uplo = "U"))

  # Computes Covls under null hypothesis
  if (!is.null(nrand)) {
    n_r_greater <- array(0, dim = dim(cov_xxs))

    v_xs <- vector(mode = "list", nx)
    for (i in seq_len(nx))
      v_xs[[i]] <- var(xs[[i]])

    # s_cov_xxs <- array(0, dim = c(nx, nx, nrand))
    # for(k in seq_len(nrand)) {
    #   #s1_cov_xxs <- matrix(0, nrow = nx, ncol = nx)
    #   r_xs <- vector(mode = "list", nx)
    #   r_ys <- vector(mode = "list", nx)
    #   for (i in seq_len(nx)) {
    #     r_xs[[i]] <- MASS::mvrnorm(n,
    #                                rep(0,nrow(v_xs[[i]])),
    #                                Sigma = v_xs[[i]],
    #                                empirical = TRUE)
    #     r_ys[[i]] <- MASS::mvrnorm(n,
    #                                rep(0,nrow(v_xs[[i]])),
    #                                Sigma = v_xs[[i]],
    #                                empirical = TRUE)
    #   }
    #
    #   for (i in seq_len(nx))
    #     for (j in i:nx)
    #       s_cov_xxs[i, j, k] <- sum(svd(crossprod(r_xs[[i]],r_ys[[j]]))$d)
    # }

    s_cov_xxs <- foreach(k = seq_len(nrand),
                         .combine = cbind) %dopar% {
      s1_cov_xxs <- matrix(0, nrow = nx, ncol = nx)
      r_xs <- vector(mode = "list", nx)
      r_ys <- vector(mode = "list", nx)
      for (i in seq_len(nx)) {
        r_xs[[i]] <- MASS::mvrnorm(n,
                                   rep(0,nrow(v_xs[[i]])),
                                   Sigma = v_xs[[i]],
                                   empirical = TRUE)
        r_ys[[i]] <- MASS::mvrnorm(n,
                                   rep(0,nrow(v_xs[[i]])),
                                   Sigma = v_xs[[i]],
                                   empirical = TRUE)
      }

      for (i in seq_len(nx))
        for (j in i:nx)
          s1_cov_xxs[i, j] <- sum(svd(crossprod(r_xs[[i]],r_ys[[j]]))$d)

      s1_cov_xxs  / n1

                         }

    dim(s_cov_xxs) = c(nx, nx, nrand)

    s_cov_xxs <- s_cov_xxs

    r_cov_xxs <- apply(s_cov_xxs,
      MARGIN = c(1,2),
      FUN = mean
    )

    for (k in seq_len(nrand))
      n_r_greater <- n_r_greater + (s_cov_xxs[, , k] >= cov_xxs)

    r_cov_xxs <- as.matrix(Matrix::forceSymmetric(r_cov_xxs, uplo = "U"))
    cov_xxs <- pmax(cov_xxs - r_cov_xxs, 0)

    colnames(r_cov_xxs) <- x_names
    rownames(r_cov_xxs) <- x_names

    p_values <- n_r_greater / nrand

    c_p_values <- p.adjust(p_values[upper.tri(p_values, diag = FALSE)],
      method = p.adjust.method
    )

    p_values[upper.tri(p_values, diag = FALSE)] <- c_p_values
    p_values <- as.matrix(Matrix::forceSymmetric(p_values, uplo = "U"))

    colnames(p_values) <- x_names
    rownames(p_values) <- x_names

    #attr(cov_xxs, "scovls") <- s_cov_xxs
    attr(cov_xxs, "rcovls") <- as.matrix(r_cov_xxs)
    attr(cov_xxs, "p.value") <- p_values
    attr(cov_xxs, "nrand") <- nrand
  }

  colnames(cov_xxs) <- x_names
  rownames(cov_xxs) <- x_names

  make_subS3Class(cov_xxs, "procmod.varls")
}


#' Compute the person correlation matrix of K coordinate matrices
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
corls <- function(..., nrand = 100,
                  p.adjust.method = "holm") {
  cov <- varls(...,
    nrand = nrand,
    p.adjust.method = p.adjust.method
  )
  s <- sqrt(diag(cov))
  vv <- s %o% s
  rls <- cov / vv


  if (!is.null(attr(cov, "rcovls"))) {
    attr(rls, "nrand") <- attr(cov, "nrand")
    attr(rls, "rcorls") <- attr(cov, "rcovls") / vv
  }

  make_subS3Class(rls, "procmod.corls")
}

#' Compute the person partial correlation matrix of K coordinate matrices
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
corls.partial <- function(..., nrand = 100) {
  rls <- corls(..., nrand = nrand)
  C <- solve(rls)
  S <- sqrt(diag(C))
  D <- S %o% S
  rp <- C / D

  attr(rp, "nrand") <- attr(rls, "nrand")
  attr(rp, "rcovls") <- attr(rls, "rcovls")

  make_subS3Class(rp, "procmod.corls")
}

#' Compute the person partial correlation matrix of K coordinate matrices
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
print.procmod.varls <- function(x, ...) {
  class(x) <- "matrix"
  attr(x, "nrand") <- NULL
  attr(x, "rcovls") <- NULL
  attr(x, "p.value") <- NULL
  print(x)
}

#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
`$.procmod.varls` <- function(x, name) {
  attr(x,name)
}

#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
names.procmod.varls <- function(x) {
  names(attributes(x))
}



#' Compute the person partial correlation matrix of K coordinate matrices
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
print.procmod.corls <- function(x, ...) {
  class(x) <- "matrix"
  attr(x, "nrand") <- NULL
  attr(x, "rcovls") <- NULL
  attr(x, "rcorls") <- NULL
  attr(x, "p.value") <- NULL
  print(x)
}

#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
`$.procmod.corls` <- function(x, name) {
  attr(x,name)
}

