#' Diagnostic cross-validation tool including ordination based on fitted values
#'
#' Function performs a leave-one-out cross-validation estimate (method = "fit")
#' or ordination scores from estimates (method = "PC").  
#' The latter can be helpful for determining if apparent
#' group differences in ordination plots arise merely from data dimensionality.  
#' The choice of method
#' essentially chooses one of two functions.
#' 
#' The fit method is standard, using n - 1 observations as training
#' data, and estimating the response for 1 datum, not included in the training
#' data, based on the model design of an original model fit.  This method
#' provides alternative fitted values than the original fit.
#' 
#' The PC method uses the strategy of Thioulouse et al. (2021) to perform N
#' ordinations for N observations, in which each of the N observations are left
#' out of the estimation of linear model coefficients, but the vector of data for
#' the left-out observation is projected on the eigenvectors of the fitted values 
#' obtained from the leave-one-out cross-validation (jackknife) strategy.
#' The purpose of this diagnostic tool is to determine whether apparent "group differences"
#' in an ordination plot (using the function, \code{\link{ordinate}}) are
#' because of high-dimensional data (number of variables exceed number of observations)
#' rather than real differences.  An apparent group difference is common for high-dimensional
#' data, when variables are far greater in number than observations (Cardini et al., 2019).
#' However, leave-one-out cross-validation can help elucidate whether an observed visual 
#' difference is spurious.
#' 
#' This function differs from the strategy of Thioulouse et al. (2021) in two important 
#' ways.  First, this function uses the linear model design from a \code{\link{lm.rrpp}}
#' fit, and can contain any number of independent variables, rather than a single factor 
#' for groups.  Second, after obtaining leave-one-out cross-validated scores, a Procrustes
#'  alignment between cross-validated scores and "observed" (real) scores is performed, which 
#' minimizes summed squared distances between the alternative ordinations.  This latter
#' step assures comparisons are appropriate.
#' 
#' The type = "PC" plot from \code{\link{plot.lm.rrpp}} has the same scores as obtained
#' from ordinate(Y, A = H), using the \code{\link{ordinate}} function, where H is a hat
#' matrix (that can be calculated from \code{\link{plot.lm.rrpp}} output), and Y is a matrix 
#' of data.  This function updates H for every possible case that one row of Y is left out
#' (meaning the rotation matrix from \code{\link{ordinate}} is updated N times).  If
#' the H matrix is robust in spite of dropped data and design matrix parameters, the result
#' will be similar to the original ordination.  If apparent group differences are spurious,
#' H will tend to change, as will data projections.
#' 
#' The functions \code{\link{summary.looCV}} and \code{\link{plot.looCV}} are essential for 
#' evaluating results.  These support functions compare eigenvalues and 
#' projected scores, between observed and cross-validated cases.  
#' 
#' This function should be viewed as a diagnostic tool and not as a data transformation tool!
#' The cross-validated scores will not retain Euclidean distances among observations.  This
#' could cause problems in analyses that substitute cross-validated scores as data.
#' 
#' 
#' @param fit A \code{\link{lm.rrpp}} fit.
#' @param method Whether to find cross-validated fitted values (fit) or 
#' principal component scores (PC) of fitted values.
#' @param ... Arguments passed to \code{\link{ordinate}}
#' @keywords analysis
#' @export
#' @author Michael Collyer
#' @return An object of class \code{looCV} is a list containing 
#' the following
#' \item{d}{List of eigenvalues, for observed and cross-validated cases.}
#' \item{scores}{List of principal component scores, 
#' for observed and cross-validated cases.}
#' @references Thioulouse, J., Renaud, S., Dufour, A. B., & Dray, S. (2021). 
#' Overcoming the Spurious Groups Problem in Between-Group PCA. 
#' Evolutionary Biology, In press.
#' @references Cardini, A., O’Higgins, P., & Rohlf, F. J. (2019). Seeing distinct groups 
#' where there are none: spurious patterns from between-group PCA. 
#' Evolutionary Biology, 46(4), 303-316.
#' 
#' @seealso \code{\link{summary.looCV}}, 
#' \code{\link{plot.looCV}}, \code{\link{looCV_table}}
#' @examples
#' 
#' # Example with real group differences
#' 
#' data(Pupfish)
#' fit <- lm.rrpp(coords ~ Pop * Sex, 
#' data = Pupfish, iter = 0)
#' CV1f <- looCV(fit)
#' 
#' summary(CV1f)
#' 
#' CV1p <- looCV(fit, method = "PC")
#' 
#' summary(CV1p)
#' 
#' group <- interaction(Pupfish$Pop, Pupfish$Sex)
#' plot(CV1p, flip = 1, pch = 19, col = group)
#' 
#' # Example with apparent but not real group differences
#' 
#' n <- NROW(Pupfish$coords)
#' p <- NCOL(Pupfish$coords)
#' set.seed(1001)
#' Yr <- matrix(rnorm(n * p), n, p) # random noise
#' 
#' fit2 <-lm.rrpp(Yr ~ Pop * Sex, 
#' data = Pupfish, iter = 0)
#' CV2p <- looCV(fit2, method = "PC")
#' summary(CV2p)
#' group <- interaction(Pupfish$Pop, Pupfish$Sex)
#' plot(CV2p, pch = 19, col = group) 
#' 
looCV <- function(fit, method = c("fit", "PC"),
                  ...){
  method <- match.arg(method)
  
  out <- list(fitted = NULL, cv_fitted = NULL,
              residuals = NULL, cv_residuals = NULL,
              RSS = NULL, cv_RSS = NULL,
              MSE = NULL, cv_MSE = NULL,
              d = NULL, scores = NULL,
              df_model = NULL, df_residual = NULL,
              method = method, 
              model = NULL)
       
  out$model <- deparse(substitute(fit))
  Df <- fit$ANOVA$df
  dfl <- length(Df)
  df_residual <- out$df_residual <- Df[dfl - 1]
  df_model <- out$df_model <- sum(Df[-c(dfl - 1, dfl)])
  
  if(method == "PC"){
    res <- looPCAll(fit, ...)
    d <- list(obs = res$raw$d, cv = res$cv$d)
    scores <- list(obs = res$raw$x, cv = res$cv$x)
    out$d <- d
    out$scores <- scores
  }
  
  if(method == "fit"){
    gls <- fit$LM$gls
    Pcov <- try(getModelCov(fit, type = "Pcov"),
                silent = TRUE)
    if(gls && inherits(Pcov, "try-error")){
      w <- sqrt(fit$LM$weights)
      Pcov <- diag(1/w)
    }
    n <- fit$LM$n
    
    yhat <- fitted(fit)
    cv_yhat <- looCVAll(fit)
    res <- resid(fit)
    cv_res <- fit$LM$Y - cv_yhat
    RSS <- if(gls) sum((Pcov %*% res)^2) else
      sum(res^2)
    cv_RSS <- if(gls) sum((Pcov %*% cv_res)^2) else
      sum(cv_res^2)
    out$fitted <- yhat
    out$cv_fitted <- cv_yhat
    out$residuals <- res
    out$cv_residuals <- cv_res
    out$RSS <- RSS
    out$cv_RSS <- cv_RSS
    out$MSE <- RSS / df_residual
    out$cv_MSE <- cv_RSS / df_residual
    
  }

  class(out) <- "looCV"
  out
}

#' Table for looCV comparisons
#'
#' Function simply produces a table of MSE and cross-validated
#' MSE for any number of compared models.  The table is sorted
#' from lowest to highest cross-validated MSE.  The looCV objects
#' must use method = 'fit' or a table cannot be generated.

#' @param ... Any number of \code{\link{looCV}} objects
#' @keywords analysis
#' @export
#' @author Michael Collyer

#' @seealso \code{\link{looCV}}, \code{\link{model.comparison}}
#' @examples
#' 
#' # Example with snakeHS data
#' 
#' data(snakeHS)
#' fitS <- lm.rrpp(HS ~ SVL, data = snakeHS,
#'                 iter = 0)
#' fitSR <- lm.rrpp(HS ~ SVL + Region, data = snakeHS,
#'                  iter = 0)
#' fitSxR <- lm.rrpp(HS ~ SVL * Region, data = snakeHS,
#'                   iter = 0)
#' 
#' CVS <- looCV(fitS)
#' CVSR <- looCV(fitSR)
#' CVSxR <- looCV(fitSxR)
#' 
#' summary(CVS)
#' summary(CVSR)
#' summary(CVSxR)
#' 
#' looCV_table(CVS, CVSR, CVSxR)
#' 
looCV_table <- function(...){
  dots <- list(...)
  isfit <- function(x) is.null(x$d)
  check <- unlist(lapply(dots, inherits, "looCV"))
  if(any(!check)) stop("\nObjects must be looCV of lm.rrpp fits.\n")
  check <- unlist(lapply(dots, isfit))
  if(any(!check)) stop("\nAll looCV objects must use method = 'fit'.\n")
  
  dot.names <- lapply(dots, function(x) x$model)
  
  getMSE <- function(x) {
    res <- c(x$df_model, x$df_residual,
             x$MSE, x$cv_MSE)
    names(res) <- c("Df Model", "Df Residual",
                    "Observed MSE",
                    "Cross-validated MSE")
    res
  }
    
  out <- as.data.frame(
    t(sapply(dots, getMSE)))
  rownames(out) <- dot.names
  
  out <- out[order(out[, 4]), ]
  out
}
