R/trajeRmodelSelection.R

In trajeR: Group Based Modeling Trajectory

# -----------------------------------
# compute the BIC function to a model
# -----------------------------------
#' BIC function to an trajectory object
#'
#' Calculate the BIC value to an trajectory object.
#'
#' @param sol Trajectory's object. An object of type trajectory.
#' @return A real. 
#' @export
#' @examples
#' data = read.csv(system.file("extdata", "CNORM2gr.csv", package = "trajeR"))
#' data = as.matrix(data)
#' sol = trajeR(Y = data[, 2:6], A = data[, 7:11], degre = c(2,2), Model = "CNORM", Method = "EM")
#' trajeRBIC(sol)
trajeRBIC <- function(sol){
  -2*sol$Likelihood + log(sol$Size)*(nrow(sol$tab) - 1)
}
# -----------------------------------
# compute the AIC function to a model
# -----------------------------------
#' AIC function to an trajectory object
#'
#' Calculate the AIC value to an trajectory object.
#'
#' @param sol Trajectory's object. An object of type trajectory.
#' @return A real. 
#' @export
#' @examples
#' data = read.csv(system.file("extdata", "CNORM2gr.csv", package = "trajeR"))
#' data = as.matrix(data)
#' sol = trajeR(Y = data[, 2:6], A = data[, 7:11], degre = c(2,2), Model = "CNORM", Method = "EM")
#' trajeRAIC(sol)
trajeRAIC <- function(sol){
  -2*sol$Likelihood + 2*(nrow(sol$tab) - 1)
}
# -----------------------------------
# compute the SH function to a model
# -----------------------------------
#' SH function to an trajectory object
#'
#' Calculate the Slope Heuristic value to a list of trajectory objects.
#'
#' @param l List. A list of objects of type trajectory.
#' @return A vector of real. 
#' @export
#' @examples
#' data = read.csv(system.file("extdata", "CNORM2gr.csv", package = "trajeR"))
#' data = as.matrix(data)
#' degre = list(c(2,2), c(1,1), c(1,2), c(2,1), c(0,0), c(0,1), c(1,0), c(0,0), c(0,2), c(2,0))
#' sol = list()
#' for (i in 1:10){
#'   sol[[i]] = trajeR(Y = data[, 2:6], A = data[, 7:11], 
#'                     degre = degre[[i]], Model = "CNORM", Method = "EM")
#'   }
#' trajeRSH(sol)
trajeRSH <- function(l){
  data = data.frame(model = l[[1]]$groups, pen = (nrow(l[[1]]$tab) - 1)/l[[1]]$Size, complexity = nrow(l[[1]]$tab) - 1,
  contrast = -l[[1]]$Likelihood)
  for (i in 2:length(l)){
    data = rbind(data, c(l[[i]]$groups, (nrow(l[[i]]$tab) - 1)/l[[i]]$Size, nrow(l[[i]]$tab) - 1,
                 -l[[i]]$Likelihood))
  }
  return(capushe::DDSE(data))
}