#' @include internals.R
#' @include model.procmod.R
#'
#' @title ProcMod
#' @description blabla
#' @author Christelle Gonindard-Melodelima
#'
NULL


#' Compute the variance, covariance matrix of K coordinate matrices.
#'
#' Covariance between two matrices is defined as the sum of the
#' sigular values of the X'Y matrix. All the matrices must have
#' the same number of rows.
#'
#' @param ... the set of matrices
#'
#' @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
#'    mvar(A,B,C)
#'    mvar(A=A,B=B,C=C)
#'
#' @author Eric Coissac & Christelle Gonindard-Melodelima
#' @export
mvar = function(...) {

  Xs <- list(...)
  if (length(Xs)==1)
    if (is.list(Xs[[1]]))
      Xs=as.procmod.frame(Xs[[1]])
    else if (is.procmod.frame(Xs[[1]]))
      Xs=Xs[[1]]
    else
      Xs=procmod.frame(Xs[[1]])
  else
    Xs=as.procmod.frame(Xs)

  Xnames=names(Xs)

  Xs <- lapply(Xs,scale,scale = FALSE)

  nX = length(Xs)

  Xx <- rep(1:nX,nX)
  Xy <- rep(1:nX,rep(nX,nX))

  XXs <- mapply(function(x,y) crossprod(Xs[[x]], Xs[[y]]),
                Xx,Xy,
                SIMPLIFY = FALSE)

  sol_xxs <- lapply(XXs,svd)

  CovXXs  = sapply(sol_xxs, function(sol) sum(sol$d))


  dim(CovXXs)=c(nX,nX)
  colnames(CovXXs)=Xnames
  rownames(CovXXs)=Xnames

  return(CovXXs)
}

#' Compute the person correlation matrix of K coordinate matrices
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
mcor = function(...) {
  cov = mvar(...)
  s = sqrt(diag(cov))
  vv= outer(s,s)
  return(cov/vv)
}

pm.fit = function(covmat,y,xs,
                  singular.ok = singular.ok,
                  tol) {

  xy.cov = covmat[xs,y]
  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   = qr.coef(xx.qr,xy.cov)


  return(list(coefficients=coef,
              rank=xx.qr$rank + 1
             )
        )
}

.ctrace <- function(MAT) sum(MAT^2)

#' Performs a procruste model on a set of coordinate matrices
#'
#' @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 ,
               scale = TRUE, return.scale = TRUE) {

  ret.x <- x
  ret.y <- y

  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.procmod.default)

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

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

  mt <- attr(mf, "terms")

  Y <- model.response(mf, "numeric")
  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,
              SCT = SCT,
              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)
    nvars=ncol(vars)
    irep = attr(vars,"response")

    data.cov = mvar(vars)
    variances= diag(data.cov)
    std.dev = sqrt(variances)

    if (scale)
      vars.norm = mapply(function(x,s) scale(x,scale = FALSE)/s, vars,std.dev)
    else
      vars.norm = as.procmod.frame(mapply(function(x) scale(x,scale = FALSE), vars))

    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 = mvar(vars.norm)

    z = pm.fit(data.cov,
               y = irep, xs = seq_len(nvars)!=irep,
               singular.ok = singular.ok,
               tol = tol)

    if (! scale) {
      y.sd = std.dev[irep]
      xs.sd= std.dev[seq_len(nvars)!=irep]

      z$varpart = (z$coefficients * xs.sd / y.sd) ^ 2
    }
    else {
      z$varpart = z$coefficients ^ 2
    }


    Y = vars.norm[[irep]]
    Xs= vars.norm[seq_len(nvars)!=irep]

    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)

    if (ret.x)
      z$x <- vars.norm[-irep]

    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$SCT = .ctrace(scale(Y,scale=FALSE))

  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(m,...) {
  cat(sprintf("\nCall:\n%s\n\nCoefficients:\n",
              deparse(m$call)))
  print(m$coefficients)
  invisible(m)
}


#' Anova function for `pm` objects.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
anova.pm = function(m,...) {

  VarY  = m$SCT
  SCE = sum(m$residuals^2)


  VarYhats = VarY * m$varpart
  names(VarYhats) = names(m$coefficients)
  SChat = sum(VarYhats)


  if (length(Xs)>1) {
    SCI = VarY - SCE - sum(SChat)
    SumSq  = c(VarYhats,Interactions=SCI,Residuals=SCE)
    Df     = c(rep(1,length(VarYhats)+1),m$df.residual)
  }
  else {
    SumSq  = c(VarYhats,Residuals=SCE)
    Df     = c(1,m$df.residual)
  }
  MeanSq = SumSq/Df
  Fvalue = c(MeanSq[-length(MeanSq)]/MeanSq[length(MeanSq)],NA)
  Pvalue = 1-pf(Fvalue,
                Df[-length(MeanSq)],
                Df[length(MeanSq)])

  result = data.frame(Df,
                      SumSq,
                      MeanSq,
                      Fvalue,
                      Pvalue)

  colnames(result)=c("Df","Sum Sq","Mean Sq","F value","Pr(>F)")


  attr(result, "heading")= paste("Analysis of Variance Table\n\nResponse:",
                                 all.vars(m$terms)[1]
                                )
  class(result)=c("anova",class(result))

  return(result)
}

summary.pm = function(object,
                      correlation = FALSE,
                      symbolic.cor = FALSE,
                      ...) {

  results = list(
    call = object$call,
    terms= object$terms

  )

  return(results)
}

#' Compute the Akaike Information criterion (AIC) for a procruste model.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
extractAIC.pm = function(fit, scale, k = 2,...) {
  n   = nrow(fit$residuals)
  RSS = sum(fit$residuals^2)
  p   = length(fit$coefficients)

  return(c(n,(n * log(RSS/n)+ p * k)))
}


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


#' Extract Model Residuals.
#'
#' @description residuals is a generic function which extracts model
#'              residuals from objects returned by modeling functions.
#'              The abbreviated form resid is an alias for residuals.
#'              It is intended to encourage users to access object
#'              components through an accessor function rather than by
#'              directly referencing an object slot.
#'
#' @param obj    R object of class `pm`
#' @param type	 the type of residuals which should be returned.
#'               Can be abbreviated.
#'
#' @return Numeric matrix of n rows, where n is the number
#'         of observations.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
residuals.pm = function (object, type = c("working", "response", "deviance",
                                          "pearson", "partial"), ...)
{
  type <- match.arg(type)
  r <- object$residuals
  res <- switch(type, working = , response = r, deviance = ,
                pearson = if (is.null(object$weights)) r else sweep(r,MARGIN = 1,
                                                                    STATS = sqrt(object$weights),
                                                                    FUN = "*"),
                partial = r)
  res <- naresid(object$na.action, res)
  if (type == "partial") {
    stop("'partial' residuals not yet implemented for procrustean models ")
    res <- res + predict(object, type = "terms")
  }
  res
}


#' Compute Weighted Residuals.
#'
#' @description Computed weighted residuals from a procrustean model fit.
#'
#' @param obj    R object of class `pm`
#' @param drop0	 logical. If `TRUE``, drop all cases with `weights` == 0.
#'
#' @return Numeric matrix of n' rows, where n' is the number
#'         of of non-0 weights (drop0 = TRUE) or
#'         the number of observations, otherwise.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
weighted.residuals = function (obj, drop0 = TRUE)
{
  w <- weights(obj)
  r <- residuals(obj, type = "deviance")
  if (drop0 && !is.null(w)) {
    if (is.matrix(r))
      r[w != 0, , drop = FALSE]
    else r[w != 0]
  }
  else r
}


#' Model Deviance for the procruste model.
#'
#' @description Returns the deviance of a fitted model object.
#'
#' @return The value of the deviance extracted from the object object.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
deviance.pm = function (object, ...)
  sum(weighted.residuals(object)^2, na.rm = TRUE)

#' 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)
}


