R/local.models.r

In gastonstat/plspm2: Tools for Partial Least Squares Path Modeling

#' @title PLS-PM for global and local models
#' 
#' @description
#' Calculates PLS-PM for global and local models from a given partition
#' 
#' @param pls An object of class \code{"plspm"}
#' @param y One object of the following classes: \code{"rebus"}, 
#' \code{"integer"}, or \code{"factor"}, that provides the class partitions.
#' @param Y Optional dataset (matrix or data frame) used when 
#' argument \code{dataset=NULL} inside \code{pls}.
#' 
#' @details
#' \code{local.models} calculates PLS-PM for the global model 
#' (i.e. over all observations) as well as PLS-PM for local models 
#' (i.e. observations of different partitions).
#' 
#' When \code{y} is an object of class \code{"rebus"}, \code{local.models} 
#' is applied to the classes obtained from the REBUS algorithm.
#' 
#' When \code{y} is an \code{integer} vector or a \code{factor}, 
#' the values or levels are assumed to represent the group to which each 
#' observation belongs. In this case, the function \code{local.models} 
#' calculates PLS-PM for the global model, as well as PLS-PM for 
#' each group (local models).
#' 
#' When the object \code{pls} does not contain a data matrix 
#' (i.e. \code{pls$data=NULL}), the user must provide the data matrix 
#' or data frame in \code{Y}. 
#' 
#' The original parameters \code{modes}, \code{scheme}, \code{scaled}, 
#' \code{tol}, and \code{iter} from the object \code{pls} are taken.
#' 
#' @return An object of class \code{"local.models"}, basically a list of 
#' length \code{k+1}, where \code{k} is the number of classes. 
#' @return \item{glob.model}{PLS-PM of the global model}
#' @return \item{loc.model.1}{PLS-PM of segment (class) 1}
#' @return \item{loc.model.2}{PLS-PM of segment (class) 2}
#' @return \item{loc.model.k}{PLS-PM of segment (class) k}
#' @note Each element of the list is an object of class \code{"plspm"}. 
#' Thus, in order to examine the results for each local model, 
#' it is necessary to use the \code{summary} function.
#' @author Laura Trinchera, Gaston Sanchez
#' @seealso \code{\link{rebus.pls}}
#' @example R/sim-rebus-ex.r
#' @export
local.models <- function(pls, y, Y = NULL)
{
  # =======================================================
  # checking arguments
  # =======================================================
  if (class(pls) != "plspm") 
    stop("\n'local.models()' requires an object of class 'plspm'")
  if (!is.element(class(y), c("rebus","integer","factor")))   
    stop("\n'y' must be of class 'rebus', 'integer' or 'factor'")
  if (class(y) == "rebus") {
    if (length(y$segments) != nrow(pls$scores))
      stop("\n'pls' and 'y' are incompatible")
  } else {
    if (length(y) != nrow(pls$scores))
      stop("\n'pls' and 'y' are incompatible")
  }
  # test availibility of dataset (either Y or pls$data)
  test_dataset(Y, pls$data, pls$model$gens$obs)
  
  # =======================================================
  # inputs settings
  # =======================================================
  IDM = pls$model$IDM
  blocks = pls$model$blocks
  scaling = pls$model$specs$scaling  
  modes = pls$model$specs$modes
  tol = pls$model$specs$tol
  maxiter = pls$model$specs$maxiter
  scheme = pls$model$specs$scheme
  scaled = pls$model$specs$scaled

  # data matrix DM
  if (!is.null(pls$data)) {
    DM = pls$data
    dataset = TRUE
  } else {         
    dataset = FALSE
    # building data matrix 'DM'
    DM = get_manifests(Y, blocks)
  }
  
  lvs = pls$model$gens$lvs
  lvs.names = pls$model$gens$lvs_names
  mvs = pls$model$gens$mvs
  endo = rowSums(IDM)
  endo[endo!=0] = 1
  aux_blocks = lengths(blocks)
  end.ind <- cumsum(aux_blocks)
  ini.ind <- cumsum(aux_blocks) - aux_blocks + 1
  new.sets <- as.list(1:lvs)
  for (j in 1:lvs)
    new.sets[[j]] <- ini.ind[j]:end.ind[j]
  if (class(y) == "rebus") {
    segments <- as.factor(y$segments)
  } else {
    segments <- as.factor(y)
  }
  n.clus <- length(table(segments))
  
  # =======================================================
  # final models computation (global and local models)
  # =======================================================
  # final plspm models
  final.mod <- as.list(1:(n.clus+1))
  for (k in 1:(n.clus+1))
  {
    if (k==1) {
      # global model
      final.mod[[1]] = plspm(DM, IDM, new.sets, scaling, modes, scheme, scaled, 
                             tol, maxiter, dataset=dataset)
    } else
    {
      units.k <- which(segments == levels(segments)[k-1])
      # local models
      final.mod[[k]] = plspm(DM[units.k,], IDM, new.sets, scaling, modes, 
                             scheme, scaled, tol, maxiter, dataset=dataset)
    }
  }
  names(final.mod) = c("glob.model", 
                       paste(rep("loc.model", n.clus), 1:n.clus, sep="."))
  class(final.mod) = "local.models"
  return(final.mod)
}