#' @include internals.R
#' @include omit_action.R
#' @include covls.R
#' @include procmod_model.R
#'
NULL

#' Fitter Function for Procrustean Linear Models
#'
#' These is the basic computing engines called by \code{\link[ProcMod]{pm}}
#' used to fit Procrustean linear models.
#'
#' @param covmat the covariance matrix of the model_procmod
#' @param y a numeric value or a logical vector indicating
#'        which column and row of \code{covmat} corresponds to
#'        the response variable.
#' @param xs a numeric or logical vector indicating which colulns and
#'        rows of \code{covmat} correspond to the explanatory variables
#' @param singular_ok logical. If FALSE, a singular model is an error.
#' @param tol tolerance for the \code{\link[base]{qr}} decomposition.
#'        Default is 1e-7.
#'
#' @return
#' \describe{
#'    \item{coeficients}{a least-square solution of the fitting problem.
#'              The names of coefficients are taken from the column names
#'              of x, or given names "x1" to "xN". If column count is higher
#'              than the rank of x, missing values are placed in the
#'              inestimable coefficients.}
#'    \item{rank}{ the number of linearly independant matrix in the procruste model.}
#'    \item{qr}{the QR decomposition}
#'  }
#'
#' @note Internal function do not use.
#'
#' @author Eric Coissac <eric.coissac@metabarcoding.org>
#' @author Christelle Gonindard-Melodelima <christelle.gonindard@metabarcoding.org>
#' @rdname internal.pm_fit
.pm_fit <- function(covmat, y, xs,
                    singular_ok = TRUE,
                    tol = 1e-07) {

  xy_cov <- covmat[xs, y, drop = FALSE]
  xx_cov <- covmat[xs, xs, drop = FALSE]

  xx_qr <- qr(xx_cov, tol = tol)

  if (!singular_ok && xx_qr$rank < ncol(xx_cov)) {
    stop("singular fit encountered")
  }

  # coef = as.numeric(solve(xx_cov, to) %*% xy_cov)
  # names(coef)=rownames(xx_cov)
  coef    <- qr.coef(xx_qr, xy_cov)
  # effects <- qr.qty(xx_qr, xy_cov)


  list(coefficients = coef,
       rank = xx_qr$rank + 1,
       qr = xx_qr
      )
}

#' Tests that the object is as `pm` instance.
#'
#' @param obj the object to test for its belonging to
#'            the \code{\link[ProcMod]{pm}} class.
#'
#' @return \code{TRUE} if \code{obj} is a \code{\link[ProcMod]{pm}}
#'         instance, \code{FALSE} otherwise.
#'
#' @examples
#' # Builds a list containing two random matrices
#' m1 <- simulate_matrix(10,20)
#' m2 <- simulate_matrix(10,30)
#' d <- procmod_frame(m1 = m1, m2 = m2)
#' p <- pm(m1 ~ m2, data=d)
#'
#' is_pm(3.0) # Must returns FALSE
#' is_pm(p)   # Must returns TRUE
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
is_pm <- function(obj) {
  inherits(obj, "pm")
}

#' Performs a procruste model on a set of coordinate matrices
#'
#' @param formula an object of class \code{\link[stats]{formula}} (or one that
#'   can be coerced to that class): a symbolic description of the model to be
#'   fitted. The details of model specification are given under ‘Details’.
#'
#' @param data an optional procmod frame, list or environment (or object
#'   coercible by \code{\link[ProcMod]{as_procmod_frame}} to a procmod frame)
#'   containing the variables in the model. If not found in data, the variables
#'   are taken from environment(formula), typically the environment from which
#'   \code{pm} is called.
#'
#' @param subset subset	an optional vector specifying a subset of observations
#'   to be used in the fitting process.
#'
#' @param weights	an optional vector of weights to be used in the fitting
#'   process. Should be NULL or a numeric vector. If non-NULL, weighted least
#'   squares is used with weights weights (that is, minimizing sum(w*e^2));
#'   otherwise ordinary least squares is used. See also ‘Details’,
#'
#' @param na_action a function which indicates what should happen when the data
#'   contain NAs. The default is set by the \code{na.action} setting of
#'   \code{\link[base]{options}}, and is \code{\link[stats]{na.fail}} if that is
#'   unset. The ‘factory-fresh’ default is \code{\link[stats]{na.omit}}. Another
#'   possible value is NULL, no action. Value \code{\link[stats]{na.exclude}} can
#'   be useful.
#'
#' @param method the method to be used; for fitting, currently only \code{method
#'   = "qr"} is supported; \code{method = "procmod_model"} returns the model
#'   frame (the same as with \code{model = TRUE}, see below).
#'
#' @param singular_ok	a logical value. If \code{FALSE} a singular fit is an
#'   error.
#'
#' @param tol tolerance for the \code{\link[base]{qr}} decomposition. Default is
#'   1e-7.
#'
#' @param model,x,y,A	logicals. If \code{TRUE} the corresponding components of
#'   the fit (the procmod model frame, the model matrix, the response, the
#'   procrustean rotation matrices) are returned.
#'
#' @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.
#'
#' @examples
#'   library(vegan)
#'   data(bacteria)
#'   data(eukaryotes)
#'   data(soil)
#'   data(climat)
#'   data(geography)
#'
#'   dataset <- procmod_frame(euk = vegdist(decostand(eukaryotes,
#'                                                    method = "hellinger"),
#'                                          method = "euclidean"),
#'                            bac = vegdist(decostand(bacteria,
#'                                                    method = "hellinger"),
#'                                          method = "euclidean"),
#'                            soil = scale(soil,
#'                                         center = TRUE,
#'                                         scale  = TRUE),
#'                            clim = scale(climat,
#'                                         center = TRUE,
#'                                         scale  = TRUE),
#'                            geo = geography)
#'
#'    m <- pm(euk ~ bac + soil + clim + geo, data = dataset, nrand=100)
#'    m
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
pm <- function(formula, data, subset, weights, na_action, method = "qr",
               singular_ok = TRUE, tol = 1e-07,
               model = TRUE, x = TRUE, y = TRUE, A = TRUE,
               nrand = 100) {

  # Store if the model matrix and the response must be returned
  ret_x <- x
  ret_y <- y

  # Rewrite a call to procmod_model and add the drop.unused.levels argument set to TRUE
  cl <- match.call()
  mf <- match.call(expand.dots = FALSE)

  m <- match(
    c("formula", "data", "subset", "weights",
      "na_action"),
    table = names(mf),
    nomatch = 0L
  )

  mf <- mf[c(1L, m)]

  mf$drop.unused.levels <- TRUE

  mf[[1L]] <- quote(procmod_model)

  # Build the procmod_model

  mf <- eval(mf, enclos = parent.frame())


  if (method == "procmod_model") {
    return(mf)
  } else if (method != "qr") {
    warning(gettextf(
      "method = '%s' is not supported. Using 'qr'",
      method
    ), domain = NA)
  }

  mt <- attr(mf, "terms")

  Y <- mf[attr(mt, "response"), drop = FALSE]
  Y[[1]] <- as_procmod_data_matrix(Y[[1]])

  w <- as.vector(model.weights(mf))

  if (!is.null(w) && !is.numeric(w)) {
    stop("'weights' must be a numeric vector")
  }

  if (is.empty.model(mt)) {
    x <- NULL
    z <- list(
      coefficients = NULL,
      anova = NULL,
      TSS = TSS,
      residuals = Y,
      fitted.values = 0 * Y,
      weights = w,
      rank = 0L,
      df.residual = if (!is.null(w)) {
        sum(w != 0)
      } else {
        nrow(Y)
      }
    )
    if (ret_x) {
      z$x <- NULL
    }
    if (!A) {
      z$A <- NULL
    }
  }
  else {
    vars <- vars_procmod(mt, mf)
    #irep <- attr(vars, "response")

    vars <- as_procmod_frame(c(Y,vars))
    nvars <- ncol(vars)


    # data.cov <- varls(vars, nrand = nrand)
    # variances <- diag(data.cov)
    # std.dev <- sqrt(variances)
    #
    # print(data.cov)

    vars.norm <- as_procmod_frame(mapply(function(x) scale(x, scale = FALSE),
      vars,
      SIMPLIFY = FALSE
    ))



    if (is.null(w)) {
      subset.w <- rep(TRUE, nvars)
    }
    else {
      sw <- sqrt(w)

      vars.norm <- as_procmod_frame(lapply(vars.norm, function(v) v * sw))
      subset.w <- sw > 0

      vars.norm <- vars.norm[subset.w, ]
    }

    data.cov <- varls(vars.norm, nrand = nrand)

    z <- .pm_fit(data.cov,
      y = 1, xs = 2:nvars,
      singular_ok = singular_ok,
      tol = tol
    )

    z$cov <- data.cov
    variances <- diag(data.cov)
    std.dev <- sqrt(variances)

    y.sd <- std.dev[1]
    xs.sd <- std.dev[2:nvars]

    z$varpart <- (z$coefficients * xs.sd / y.sd) * cov2cor(data.cov)[-1,1]


    Y <- vars.norm[[1]]
    Xs <- vars.norm[2:nvars, drop = FALSE]

    Ymean <- colMeans(Y)
    Xmeans <- lapply(Xs, colMeans)

    # Shall we compute rotation on weigthed matrix or not ... ?

    XYs <- lapply(Xs, function(x) crossprod(Y, x))
    sol_yxs <- lapply(XYs, svd)

    A_xys <- lapply(sol_yxs, function(x) x$v %*% t(x$u))


    Xrots <- mapply(function(x, a) x %*% a,
      Xs, A_xys,
      SIMPLIFY = FALSE
    )

    # Intercept estimation

    scales <- z$coefficients

    b <- Ymean - Reduce(
      function(a, b) a + b,
      mapply(function(d, coef, rot) coef * (d %*% rot),
        Xmeans, scales, A_xys,
        SIMPLIFY = FALSE
      )
    )



    yhat <- mapply(function(coef, xrot) coef * xrot,
      scales, Xrots,
      SIMPLIFY = FALSE
    )

    init <- matrix(rep(0, nrow(yhat[[1]]) * ncol(yhat[[1]])),
      nrow = nrow(yhat[[1]])
    )

    yhat <- Reduce(
      function(a, b) a + b,
      yhat,
      init
    )

    yhat <- sweep(yhat, 2, b, "+")

    z$residuals <- Y - yhat
    z$fitted.values <- yhat
    z$weights <- w
    z$df.residual <- ((if (!is.null(w)) {
      sum(w != 0)
    } else {
      nrow(Y)
    }) - nvars )

    if (ret_x) {
      z$x <- vars.norm[2:nvars]
    }

    ##    if (!A)
    z$A <- A_xys
  }


  class(z) <- "pm"
  z$na_action <- attr(mf, "na_action")
  # z$contrasts <- attr(x, "contrasts")
  # z$xlevels <- .getXlevels(mt, mf)
  z$call <- cl
  z$terms <- mt

  z$TSS <- sum(scale(Y, scale = FALSE)^2)
  z$intercept <- b

  if (model) {
    z$model <- mf
  }

  if (ret_y) {
    z$y <- Y
  }

  return(z)
}

#' Default display function for `pm` objects.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
print.pm <- function(x, ...) {
  cat(sprintf(
    "\nCall:\n%s\n\nCoefficients:\n",
    deparse(x$call)
  ))
  print(x$coefficients)
  invisible(x)
}



summary.pm <- function(object,
                       correlation = FALSE,
                       symbolic.cor = FALSE,
                       ...) {
  results <- list(
    call = object$call,
    terms = object$terms
  )

  return(results)
}

#' Compute the Bayesian Information criterion (BIC) for a procruste model.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
BIC.pm <- function(object, ..., k = length(object$coefficients)) {
  RSS <- sum(object$residuals^2)
  n <- nrow(object$fitted.values)
  return(n * log(RSS / n) + log(n) * k)
}
