#' @include covls.R
#'
#' @author Christelle Gonindard-Melodelima
#' @author Eric Coissac
NULL

#' Generate permutation matrix according to a schema.
#'
#' @param perm xxx
#' @param n zzz
#' @param strata eeee
#'
#'
#' The permutation schema is defined using the `how` function.
#' The implementation of this function is inspired
#' from the VEGAN package and reproduced here to avoid an extra
#' dependency on an hidden vegan function.
#'
getPermuteMatrix = function(perm, n, strata = NULL)
{
  if (length(perm) == 1) {
    perm <- permute::how(nperm = perm)
  }
  if (!missing(strata) && !is.null(strata)) {
    if (inherits(perm, "how") && is.null(permute::getBlocks(perm)))
      permute::setBlocks(perm) <- strata
  }
  if (inherits(perm, "how"))
    perm <- permute::shuffleSet(n, control = perm)
  else {
    if (!is.integer(perm) && !all(perm == round(perm)))
      stop("permutation matrix must be strictly integers: use round()")
  }
  if (is.null(attr(perm, "control")))
    attr(perm, "control") <- structure(list(within = list(type = "supplied matrix"),
                                            nperm = nrow(perm)), class = "how")
  perm
}



#' Compute the person correlation matrix of K coordinate matrices
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
corls.test <- function(...,
                       permutations = permute::how(nperm = 999),
                       p.adjust.method="holm") {
  eps <- sqrt(sqrt(.Machine$double.eps))
  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)


  cov <- varls(xs, nperm = 0)
  lcov <- cov - eps
  ngreater <- array(0,dim = dim(cov))

  n <- nrow(xs)
  nx <- length(xs)
  pmatrix <- getPermuteMatrix(permutations, n)

  if (ncol(pmatrix) != n) {
    stop(gettextf(
      "'permutations' have %d columns, but data have %d observations",
      ncol(pmatrix), n
    ))
  }

  npermutation <- nrow(pmatrix)
  for (i in seq_len(npermutation)) {
    ps <- sample(1:npermutation,
      size = nx,
      replace = FALSE
    )

    rcov = varls(as.procmod.frame(
        lapply(
          1:nx,
          function(j) xs[[j]][pmatrix[ps[j], ], ]
        )
      ),
      nperm = 0
      )
    ngreater <- ngreater + (
       rcov >= lcov)
  }

  p_values <- ngreater / npermutation
  diag(p_values) <- 0

  c_p_values <- p.adjust(p_values[upper.tri(p_values,diag = FALSE)],
           method = p.adjust.method,
           n = (nx - 1) * nx / 2)

  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

  p_values

}
