#' Summary of Class "lefkoCondMat"
#' 
#' This function provides basic information summarizing the characteristics of
#' conditional matrices derived from a \code{lefkoCondMat} object.
#' 
#' @name summary.lefkoCondMat
#' 
#' @param object An object of class \code{lefkoCondMat}.
#' @param ... Other parameters.
#' 
#' @return A text summary of the object shown on the console, showing the number
#' of historical matrices, as well as the number of conditional matrices nested
#' within each historical matrix.
#' 
#' @examples
#' # Lathyrus example
#' data(lathyrus)
#' 
#' sizevector <- c(0, 100, 13, 127, 3730, 3800, 0)
#' stagevector <- c("Sd", "Sdl", "VSm", "Sm", "VLa", "Flo", "Dorm")
#' repvector <- c(0, 0, 0, 0, 0, 1, 0)
#' obsvector <- c(0, 1, 1, 1, 1, 1, 0)
#' matvector <- c(0, 0, 1, 1, 1, 1, 1)
#' immvector <- c(1, 1, 0, 0, 0, 0, 0)
#' propvector <- c(1, 0, 0, 0, 0, 0, 0)
#' indataset <- c(0, 1, 1, 1, 1, 1, 1)
#' binvec <- c(0, 100, 11, 103, 3500, 3800, 0.5)
#' 
#' lathframe <- sf_create(sizes = sizevector, stagenames = stagevector,
#'   repstatus = repvector, obsstatus = obsvector, matstatus = matvector,
#'   immstatus = immvector, indataset = indataset, binhalfwidth = binvec,
#'   propstatus = propvector)
#' 
#' lathvert <- verticalize3(lathyrus, noyears = 4, firstyear = 1988,
#'   patchidcol = "SUBPLOT", individcol = "GENET", blocksize = 9,
#'   juvcol = "Seedling1988", sizeacol = "Volume88", repstracol = "FCODE88",
#'   fecacol = "Intactseed88", deadacol = "Dead1988",
#'   nonobsacol = "Dormant1988", stageassign = lathframe, stagesize = "sizea",
#'   censorcol = "Missing1988", censorkeep = NA, censor = TRUE)
#' 
#' lathsupp3 <- supplemental(stage3 = c("Sd", "Sd", "Sdl", "Sdl", "Sd", "Sdl", "mat"),
#'   stage2 = c("Sd", "Sd", "Sd", "Sd", "rep", "rep", "Sdl"),
#'   stage1 = c("Sd", "rep", "Sd", "rep", "npr", "npr", "Sd"),
#'   eststage3 = c(NA, NA, NA, NA, NA, NA, "mat"),
#'   eststage2 = c(NA, NA, NA, NA, NA, NA, "Sdl"),
#'   eststage1 = c(NA, NA, NA, NA, NA, NA, "NotAlive"),
#'   givenrate = c(0.345, 0.345, 0.054, 0.054, NA, NA, NA),
#'   multiplier = c(NA, NA, NA, NA, 0.345, 0.054, NA),
#'   type = c(1, 1, 1, 1, 3, 3, 1), type_t12 = c(1, 2, 1, 2, 1, 1, 1),
#'   stageframe = lathframe, historical = TRUE)
#' 
#' ehrlen3 <- rlefko3(data = lathvert, stageframe = lathframe, year = "all", 
#'   stages = c("stage3", "stage2", "stage1"), supplement = lathsupp3,
#'   yearcol = "year2", indivcol = "individ")
#' 
#' lathcondmats <- cond_hmpm(ehrlen3)
#' summary(lathcondmats)
#' 
#' # Cypripedium  example
#' data(cypdata)
#'  
#' sizevector <- c(0, 0, 0, 0, 0, 0, 1, 2.5, 4.5, 8, 17.5)
#' stagevector <- c("SD", "P1", "P2", "P3", "SL", "D", "XSm", "Sm", "Md", "Lg",
#'   "XLg")
#' repvector <- c(0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1)
#' obsvector <- c(0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1)
#' matvector <- c(0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1)
#' immvector <- c(0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0)
#' propvector <- c(1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
#' indataset <- c(0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1)
#' binvec <- c(0, 0, 0, 0, 0, 0.5, 0.5, 1, 1, 2.5, 7)
#' 
#' cypframe_raw <- sf_create(sizes = sizevector, stagenames = stagevector,
#'   repstatus = repvector, obsstatus = obsvector, matstatus = matvector, 
#'   propstatus = propvector, immstatus = immvector, indataset = indataset,
#'   binhalfwidth = binvec)
#' 
#' cypraw_v1 <- verticalize3(data = cypdata, noyears = 6, firstyear = 2004,
#'   patchidcol = "patch", individcol = "plantid", blocksize = 4, 
#'   sizeacol = "Inf2.04", sizebcol = "Inf.04", sizeccol = "Veg.04", 
#'   repstracol = "Inf.04", repstrbcol = "Inf2.04", fecacol = "Pod.04",
#'   stageassign = cypframe_raw, stagesize = "sizeadded", NAas0 = TRUE,
#'   NRasRep = TRUE)
#' 
#' cypsupp3r <- supplemental(stage3 = c("SD", "SD", "P1", "P1", "P2", "P3", "SL",
#'     "D", "XSm", "Sm", "D", "XSm", "Sm", "mat", "mat", "mat", "SD", "P1"),
#'   stage2 = c("SD", "SD", "SD", "SD", "P1", "P2", "P3", "SL", "SL", "SL", "SL",
#'     "SL", "SL", "D", "XSm", "Sm", "rep", "rep"),
#'   stage1 = c("SD", "rep", "SD", "rep", "SD", "P1", "P2", "P3", "P3", "P3",
#'     "SL", "SL", "SL", "SL", "SL", "SL", "mat", "mat"),
#'   eststage3 = c(NA, NA, NA, NA, NA, NA, NA, "D", "XSm", "Sm", "D", "XSm", "Sm",
#'     "mat", "mat", "mat", NA, NA),
#'   eststage2 = c(NA, NA, NA, NA, NA, NA, NA, "XSm", "XSm", "XSm", "XSm", "XSm",
#'     "XSm", "D", "XSm", "Sm", NA, NA),
#'   eststage1 = c(NA, NA, NA, NA, NA, NA, NA, "XSm", "XSm", "XSm", "XSm", "XSm",
#'     "XSm", "XSm", "XSm", "XSm", NA, NA),
#'   givenrate = c(0.1, 0.1, 0.2, 0.2, 0.2, 0.2, 0.25, NA, NA, NA, NA, NA, NA,
#'     NA, NA, NA, NA, NA),
#'   multiplier = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,
#'     NA, 0.5, 0.5),
#'   type = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 3, 3),
#'   type_t12 = c(1, 2, 1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1),
#'   stageframe = cypframe_raw, historical = TRUE)
#' 
#' cypmatrix3r <- rlefko3(data = cypraw_v1, stageframe = cypframe_raw, 
#'   year = "all", patch = "all", stages = c("stage3", "stage2", "stage1"),
#'   size = c("size3added", "size2added", "size1added"), 
#'   supplement = cypsupp3r, yearcol = "year2", patchcol = "patchid",
#'   indivcol = "individ")
#' 
#' cypcondmats <- cond_hmpm(cypmatrix3r)
#' 
#' summary(cypcondmats)
#' 
#' @export
summary.lefkoCondMat <- function(object, ...) {
  
  histmatrices <- object$Mcond
  condmatrices <- histmatrices[[1]]
  firstcondmat <- condmatrices[[1]]
  
  numhistmats <- length(histmatrices)
  prevstages <- length(condmatrices)
  matdim <- dim(firstcondmat)
  
  writeLines(paste0("\nThis lefkoCondMat object contains ", prevstages,
      " conditional matrices per historical matrix."))
  writeLines(paste0("It covers ", numhistmats, " main historical matrices."))
  writeLines(paste0("Each conditional matrix is a square matrix with ", matdim[1],
      " rows and columns, and a total of ", matdim[1]*matdim[1], " elements."))
  writeLines(paste0("\nThe order of conditional matrices corresponding to stage in occasion t-1 is:\n",
      paste(object$ahstages$stage, collapse = " ")))
  writeLines("\nThe order of historical matrices is: \n")
  print.data.frame(object$labels)
  
  writeLines("\nThe order of conditional matrices matches the stage column in object $ahstages.")
  writeLines("The order of historical matrices follows that shown in object $labels.")
}

#' Create Matrix Image
#' 
#' Function \code{image3()} is a generic function that creates matrix plots.
#' 
#' @name image3
#' 
#' @param mats A lefkoMat object, or a single projection matrix, for which the
#' dominant eigenvalue is desired.
#' @param ... Other parameters
#' 
#' @return Produces a single matrix image, or a series of images, depending on
#' the input. Non-zero elements appear as red space, while zero elements appear
#' as white space.
#' 
#' @seealso \code{\link{image3.lefkoMat}()}
#' @seealso \code{\link{image3.matrix}()}
#' 
#' @examples
#' # Lathyrus example
#' data(lathyrus)
#' 
#' sizevector <- c(0, 100, 13, 127, 3730, 3800, 0)
#' stagevector <- c("Sd", "Sdl", "VSm", "Sm", "VLa", "Flo", "Dorm")
#' repvector <- c(0, 0, 0, 0, 0, 1, 0)
#' obsvector <- c(0, 1, 1, 1, 1, 1, 0)
#' matvector <- c(0, 0, 1, 1, 1, 1, 1)
#' immvector <- c(1, 1, 0, 0, 0, 0, 0)
#' propvector <- c(1, 0, 0, 0, 0, 0, 0)
#' indataset <- c(0, 1, 1, 1, 1, 1, 1)
#' binvec <- c(0, 100, 11, 103, 3500, 3800, 0.5)
#' 
#' lathframe <- sf_create(sizes = sizevector, stagenames = stagevector,
#'   repstatus = repvector, obsstatus = obsvector, matstatus = matvector,
#'   immstatus = immvector, indataset = indataset, binhalfwidth = binvec,
#'   propstatus = propvector)
#' 
#' lathvert <- verticalize3(lathyrus, noyears = 4, firstyear = 1988,
#'   patchidcol = "SUBPLOT", individcol = "GENET", blocksize = 9,
#'   juvcol = "Seedling1988", sizeacol = "Volume88", repstracol = "FCODE88",
#'   fecacol = "Intactseed88", deadacol = "Dead1988",
#'   nonobsacol = "Dormant1988", stageassign = lathframe, stagesize = "sizea",
#'   censorcol = "Missing1988", censorkeep = NA, censor = TRUE)
#' 
#' lathsupp3 <- supplemental(stage3 = c("Sd", "Sd", "Sdl", "Sdl", "Sd", "Sdl", "mat"),
#'   stage2 = c("Sd", "Sd", "Sd", "Sd", "rep", "rep", "Sdl"),
#'   stage1 = c("Sd", "rep", "Sd", "rep", "npr", "npr", "Sd"),
#'   eststage3 = c(NA, NA, NA, NA, NA, NA, "mat"),
#'   eststage2 = c(NA, NA, NA, NA, NA, NA, "Sdl"),
#'   eststage1 = c(NA, NA, NA, NA, NA, NA, "NotAlive"),
#'   givenrate = c(0.345, 0.345, 0.054, 0.054, NA, NA, NA),
#'   multiplier = c(NA, NA, NA, NA, 0.345, 0.054, NA),
#'   type = c(1, 1, 1, 1, 3, 3, 1), type_t12 = c(1, 2, 1, 2, 1, 1, 1),
#'   stageframe = lathframe, historical = TRUE)
#' 
#' ehrlen3 <- rlefko3(data = lathvert, stageframe = lathframe, year = "all", 
#'   stages = c("stage3", "stage2", "stage1"), supplement = lathsupp3,
#'   yearcol = "year2", indivcol = "individ")
#' 
#' image3(ehrlen3, used = 1, type = "U")
#' 
#' @export
image3 <- function(mats, ...) UseMethod("image3")

#' Create Matrix Image(s) for lefkoMat Object
#' 
#' Function \code{image3.lefkoMat} plots matrix images for matrices supplied
#' within \code{lefkoMat} objects.
#' 
#' @name image3.lefkoMat
#' 
#' @param mats A \code{lefkoMat} object.
#' @param used A numeric value or vector designating the matrices to plot. Can
#' also take the value \code{"all"}, which plots all matrices. Defaults to
#' \code{"all"}.
#' @param type Character value indicating whether to plot \code{A}, \code{U}, or
#' \code{F} matrices. Defaults to \code{"A"}.
#' @param ... Other parameters.
#' 
#' @return Plots a matrix image, or series of matrix images, denoting non-zero
#' elements as red space and zero elements as white space.
#' 
#' @examples 
#' # Lathyrus example
#' data(lathyrus)
#' 
#' sizevector <- c(0, 100, 13, 127, 3730, 3800, 0)
#' stagevector <- c("Sd", "Sdl", "VSm", "Sm", "VLa", "Flo", "Dorm")
#' repvector <- c(0, 0, 0, 0, 0, 1, 0)
#' obsvector <- c(0, 1, 1, 1, 1, 1, 0)
#' matvector <- c(0, 0, 1, 1, 1, 1, 1)
#' immvector <- c(1, 1, 0, 0, 0, 0, 0)
#' propvector <- c(1, 0, 0, 0, 0, 0, 0)
#' indataset <- c(0, 1, 1, 1, 1, 1, 1)
#' binvec <- c(0, 100, 11, 103, 3500, 3800, 0.5)
#' 
#' lathframe <- sf_create(sizes = sizevector, stagenames = stagevector,
#'   repstatus = repvector, obsstatus = obsvector, matstatus = matvector,
#'   immstatus = immvector, indataset = indataset, binhalfwidth = binvec,
#'   propstatus = propvector)
#' 
#' lathvert <- verticalize3(lathyrus, noyears = 4, firstyear = 1988,
#'   patchidcol = "SUBPLOT", individcol = "GENET", blocksize = 9,
#'   juvcol = "Seedling1988", sizeacol = "Volume88", repstracol = "FCODE88",
#'   fecacol = "Intactseed88", deadacol = "Dead1988",
#'   nonobsacol = "Dormant1988", stageassign = lathframe, stagesize = "sizea",
#'   censorcol = "Missing1988", censorkeep = NA, censor = TRUE)
#' 
#' lathsupp3 <- supplemental(stage3 = c("Sd", "Sd", "Sdl", "Sdl", "Sd", "Sdl", "mat"),
#'   stage2 = c("Sd", "Sd", "Sd", "Sd", "rep", "rep", "Sdl"),
#'   stage1 = c("Sd", "rep", "Sd", "rep", "npr", "npr", "Sd"),
#'   eststage3 = c(NA, NA, NA, NA, NA, NA, "mat"),
#'   eststage2 = c(NA, NA, NA, NA, NA, NA, "Sdl"),
#'   eststage1 = c(NA, NA, NA, NA, NA, NA, "NotAlive"),
#'   givenrate = c(0.345, 0.345, 0.054, 0.054, NA, NA, NA),
#'   multiplier = c(NA, NA, NA, NA, 0.345, 0.054, NA),
#'   type = c(1, 1, 1, 1, 3, 3, 1), type_t12 = c(1, 2, 1, 2, 1, 1, 1),
#'   stageframe = lathframe, historical = TRUE)
#' 
#' ehrlen3 <- rlefko3(data = lathvert, stageframe = lathframe, year = "all", 
#'   stages = c("stage3", "stage2", "stage1"), supplement = lathsupp3,
#'   yearcol = "year2", indivcol = "individ")
#' 
#' image3(ehrlen3, used = 1, type = "U")
#' 
#' @export
image3.lefkoMat <- function(mats, used = "all", type = "A", ...) {
  
  allmats <- c(1:length(mats$A))
  
  if (!is.character(type)) {
    stop("Please enter A, F, or U for type option.", call. = FALSE)
  }
  
  type <- tolower(type)
  if (!is.element(type, c("a", "u", "f"))) {
    stop("Please enter A, F, or U for type option.", call. = FALSE)
  }
  
  if (all(is.character(used))) {
    if (all(tolower(used) != "all")) {
      stop("Value entered for matrix option not recognized.", call. = FALSE)
    } else {
      chosen_mat <- allmats
    }
  } else if (is.numeric(used) & is.element(used, allmats)) {
    chosen_mat <-  used
  } else {
    stop("Value entered for matrix option not recognized.", call. = FALSE)
  }
  
  if (type == "u") {
    chosen_list <- mats$U[chosen_mat]
  } else if (type == "f") {
    chosen_list <- mats$F[chosen_mat]
  } else {
    chosen_list <- mats$A[chosen_mat]
  }
  
  if (is(chosen_list[[1]], "dgCMatrix")) {
    lapply(chosen_list, function(X) {Matrix::image(X, xlab = "", ylab = "", 
      sub = "", col.regions = c("white", "red"), lwd = 0,
      at = c(0, 0.0000000000001, Inf), drop.unused.levels = FALSE)})
  } else {
    lapply(chosen_list, function(X) {Matrix::image(Matrix::Matrix(X, sparse = TRUE),
      xlab = "", ylab = "", sub = "", col.regions = c("white", "red"), lwd = 0,
      at = c(0, 0.0000000000001, Inf), drop.unused.levels = FALSE)})
  }
}

#' Create a Matrix Image for a Single Matrix
#' 
#' Function \code{image3.matrix} plots a matrix image for a single matrix.
#' 
#' @name image3.matrix
#' 
#' @param mats A \code{matrix} class object.
#' @param ... Other parameters.
#' 
#' @return Plots a matrix image, or series of matrix images, denoting non-zero
#' elements as red space and zero elements as white space.
#' 
#' @examples 
#' # Lathyrus example
#' data(lathyrus)
#' 
#' sizevector <- c(0, 100, 13, 127, 3730, 3800, 0)
#' stagevector <- c("Sd", "Sdl", "VSm", "Sm", "VLa", "Flo", "Dorm")
#' repvector <- c(0, 0, 0, 0, 0, 1, 0)
#' obsvector <- c(0, 1, 1, 1, 1, 1, 0)
#' matvector <- c(0, 0, 1, 1, 1, 1, 1)
#' immvector <- c(1, 1, 0, 0, 0, 0, 0)
#' propvector <- c(1, 0, 0, 0, 0, 0, 0)
#' indataset <- c(0, 1, 1, 1, 1, 1, 1)
#' binvec <- c(0, 100, 11, 103, 3500, 3800, 0.5)
#' 
#' lathframe <- sf_create(sizes = sizevector, stagenames = stagevector,
#'   repstatus = repvector, obsstatus = obsvector, matstatus = matvector,
#'   immstatus = immvector, indataset = indataset, binhalfwidth = binvec,
#'   propstatus = propvector)
#' 
#' lathvert <- verticalize3(lathyrus, noyears = 4, firstyear = 1988,
#'   patchidcol = "SUBPLOT", individcol = "GENET", blocksize = 9,
#'   juvcol = "Seedling1988", sizeacol = "Volume88", repstracol = "FCODE88",
#'   fecacol = "Intactseed88", deadacol = "Dead1988",
#'   nonobsacol = "Dormant1988", stageassign = lathframe, stagesize = "sizea",
#'   censorcol = "Missing1988", censorkeep = NA, censor = TRUE)
#' 
#' lathsupp3 <- supplemental(stage3 = c("Sd", "Sd", "Sdl", "Sdl", "Sd", "Sdl", "mat"),
#'   stage2 = c("Sd", "Sd", "Sd", "Sd", "rep", "rep", "Sdl"),
#'   stage1 = c("Sd", "rep", "Sd", "rep", "npr", "npr", "Sd"),
#'   eststage3 = c(NA, NA, NA, NA, NA, NA, "mat"),
#'   eststage2 = c(NA, NA, NA, NA, NA, NA, "Sdl"),
#'   eststage1 = c(NA, NA, NA, NA, NA, NA, "NotAlive"),
#'   givenrate = c(0.345, 0.345, 0.054, 0.054, NA, NA, NA),
#'   multiplier = c(NA, NA, NA, NA, 0.345, 0.054, NA),
#'   type = c(1, 1, 1, 1, 3, 3, 1), type_t12 = c(1, 2, 1, 2, 1, 1, 1),
#'   stageframe = lathframe, historical = TRUE)
#' 
#' ehrlen3 <- rlefko3(data = lathvert, stageframe = lathframe, year = "all", 
#'   stages = c("stage3", "stage2", "stage1"), supplement = lathsupp3,
#'   yearcol = "year2", indivcol = "individ", sparse_output = FALSE)
#' 
#' image3(ehrlen3$U[[1]])
#' 
#' @export
image3.matrix <- function(mats, ...) {
  
  Matrix::image(Matrix::Matrix(mats, sparse = TRUE), xlab = "", ylab = "",
    sub = "", col.regions = c("white", "red"), lwd = 0,
    at = c(0, 0.0000000000001, Inf), drop.unused.levels = FALSE)
}

#' Create a Matrix Image for a Single Sparse Matrix
#' 
#' Function \code{image3.dgCMatrix} plots a matrix image for a single sparse
#' matrix.
#' 
#' @name image3.dgCMatrix
#' 
#' @param mats A \code{matrix} class object.
#' @param ... Other parameters.
#' 
#' @return Plots a matrix image, or series of matrix images, denoting non-zero
#' elements as red space and zero elements as white space.
#' 
#' @examples 
#' # Lathyrus example
#' data(lathyrus)
#' 
#' sizevector <- c(0, 100, 13, 127, 3730, 3800, 0)
#' stagevector <- c("Sd", "Sdl", "VSm", "Sm", "VLa", "Flo", "Dorm")
#' repvector <- c(0, 0, 0, 0, 0, 1, 0)
#' obsvector <- c(0, 1, 1, 1, 1, 1, 0)
#' matvector <- c(0, 0, 1, 1, 1, 1, 1)
#' immvector <- c(1, 1, 0, 0, 0, 0, 0)
#' propvector <- c(1, 0, 0, 0, 0, 0, 0)
#' indataset <- c(0, 1, 1, 1, 1, 1, 1)
#' binvec <- c(0, 100, 11, 103, 3500, 3800, 0.5)
#' 
#' lathframe <- sf_create(sizes = sizevector, stagenames = stagevector,
#'   repstatus = repvector, obsstatus = obsvector, matstatus = matvector,
#'   immstatus = immvector, indataset = indataset, binhalfwidth = binvec,
#'   propstatus = propvector)
#' 
#' lathvert <- verticalize3(lathyrus, noyears = 4, firstyear = 1988,
#'   patchidcol = "SUBPLOT", individcol = "GENET", blocksize = 9,
#'   juvcol = "Seedling1988", sizeacol = "Volume88", repstracol = "FCODE88",
#'   fecacol = "Intactseed88", deadacol = "Dead1988",
#'   nonobsacol = "Dormant1988", stageassign = lathframe, stagesize = "sizea",
#'   censorcol = "Missing1988", censorkeep = NA, censor = TRUE)
#' 
#' lathsupp3 <- supplemental(stage3 = c("Sd", "Sd", "Sdl", "Sdl", "Sd", "Sdl", "mat"),
#'   stage2 = c("Sd", "Sd", "Sd", "Sd", "rep", "rep", "Sdl"),
#'   stage1 = c("Sd", "rep", "Sd", "rep", "npr", "npr", "Sd"),
#'   eststage3 = c(NA, NA, NA, NA, NA, NA, "mat"),
#'   eststage2 = c(NA, NA, NA, NA, NA, NA, "Sdl"),
#'   eststage1 = c(NA, NA, NA, NA, NA, NA, "NotAlive"),
#'   givenrate = c(0.345, 0.345, 0.054, 0.054, NA, NA, NA),
#'   multiplier = c(NA, NA, NA, NA, 0.345, 0.054, NA),
#'   type = c(1, 1, 1, 1, 3, 3, 1), type_t12 = c(1, 2, 1, 2, 1, 1, 1),
#'   stageframe = lathframe, historical = TRUE)
#' 
#' ehrlen3 <- rlefko3(data = lathvert, stageframe = lathframe, year = "all", 
#'   stages = c("stage3", "stage2", "stage1"), supplement = lathsupp3,
#'   yearcol = "year2", indivcol = "individ", sparse_output = TRUE)
#' 
#' image3(ehrlen3$U[[1]])
#' 
#' @export
image3.dgCMatrix <- function(mats, ...) {
  
  Matrix::image(mats, xlab = "", ylab = "", sub = "",
    col.regions = c("white", "red"), lwd = 0, at = c(0, 0.0000000000001, Inf),
    drop.unused.levels = FALSE)
}

#' Create Matrix Images for Matrices in a List
#' 
#' Function \code{image3.list} plots matrix images for matrices contained in a
#' list of matrices.
#' 
#' @name image3.list
#' 
#' @param mats A \code{list} class object.
#' @param used A numeric vector of projection matrices within \code{mats} to
#' represent as matrix images. Can also take the text value \code{"all"}, which
#' will produce images of all matrices. Defaults to \code{"all"}.
#' @param ... Other parameters.
#' 
#' @return Plots a matrix image, or series of matrix images, denoting non-zero
#' elements as red space and zero elements as white space.
#' 
#' @examples 
#' # Lathyrus example
#' data(lathyrus)
#' 
#' sizevector <- c(0, 100, 13, 127, 3730, 3800, 0)
#' stagevector <- c("Sd", "Sdl", "VSm", "Sm", "VLa", "Flo", "Dorm")
#' repvector <- c(0, 0, 0, 0, 0, 1, 0)
#' obsvector <- c(0, 1, 1, 1, 1, 1, 0)
#' matvector <- c(0, 0, 1, 1, 1, 1, 1)
#' immvector <- c(1, 1, 0, 0, 0, 0, 0)
#' propvector <- c(1, 0, 0, 0, 0, 0, 0)
#' indataset <- c(0, 1, 1, 1, 1, 1, 1)
#' binvec <- c(0, 100, 11, 103, 3500, 3800, 0.5)
#' 
#' lathframe <- sf_create(sizes = sizevector, stagenames = stagevector,
#'   repstatus = repvector, obsstatus = obsvector, matstatus = matvector,
#'   immstatus = immvector, indataset = indataset, binhalfwidth = binvec,
#'   propstatus = propvector)
#' 
#' lathvert <- verticalize3(lathyrus, noyears = 4, firstyear = 1988,
#'   patchidcol = "SUBPLOT", individcol = "GENET", blocksize = 9,
#'   juvcol = "Seedling1988", sizeacol = "Volume88", repstracol = "FCODE88",
#'   fecacol = "Intactseed88", deadacol = "Dead1988",
#'   nonobsacol = "Dormant1988", stageassign = lathframe, stagesize = "sizea",
#'   censorcol = "Missing1988", censorkeep = NA, censor = TRUE)
#' 
#' lathsupp3 <- supplemental(stage3 = c("Sd", "Sd", "Sdl", "Sdl", "Sd", "Sdl"), 
#'   stage2 = c("Sd", "Sd", "Sd", "Sd", "rep", "rep"),
#'   stage1 = c("Sd", "rep", "Sd", "rep", "all", "all"), 
#'   givenrate = c(0.345, 0.345, 0.054, 0.054, NA, NA),
#'   multiplier = c(NA, NA, NA, NA, 0.345, 0.054),
#'   type = c(1, 1, 1, 1, 3, 3), type_t12 = c(1, 2, 1, 2, 1, 1),
#'   stageframe = lathframe, historical = TRUE)
#' 
#' ehrlen3 <- rlefko3(data = lathvert, stageframe = lathframe, year = "all", 
#'   stages = c("stage3", "stage2", "stage1"), supplement = lathsupp3,
#'   yearcol = "year2", indivcol = "individ")
#' 
#' image3(ehrlen3$A, used = 1)
#' 
#' @export
image3.list <- function(mats, used = "all", ...) {
  
  allmats <- c(1:length(mats))
  
  if (all(is.character(used))) {
    if (all(tolower(used) != "all")) {
      stop("Value entered for matrix option not recognized.", call. = FALSE)
    } else {
      chosen_mat <- allmats
    }
  } else if (is.numeric(used) & is.element(used, allmats)) {
    chosen_mat <-  used
  } else {
    stop("Value entered for matrix option not recognized.", call. = FALSE)
  }
  
  chosen_list <- mats[chosen_mat]
  
  if (is(chosen_list[[1]], "dgCMatrix")) {
    lapply(chosen_list, function(X) {Matrix::image(X, xlab = "", ylab = "", 
      sub = "", col.regions = c("white", "red"), lwd = 0,
      at = c(0, 0.0000000000001, Inf), drop.unused.levels = FALSE)})
  } else if (is.matrix(chosen_list[[1]])) {
    lapply(chosen_list, function(X) {Matrix::image(Matrix::Matrix(X, sparse = TRUE),
      xlab = "", ylab = "", sub = "", col.regions = c("white", "red"), lwd = 0,
      at = c(0, 0.0000000000001, Inf), drop.unused.levels = FALSE)})
  } else {
    stop("Chosen elements include non-matrix objects. Please choose only list
      elements containing matrix objects.", call. = FALSE)
  }
}

#' Create Matrix Image(s) for lefkoSens Object
#' 
#' Function \code{image3.lefkoSens} plots matrix images for sensitivity matrices
#' supplied within \code{lefkoSens} objects.
#' 
#' @name image3.lefkoSens
#' 
#' @param mats A \code{lefkoSens} object.
#' @param used A numeric value or vector designating the matrices to plot. Can
#' also take the value \code{"all"}, which plots all matrices. Defaults to
#' \code{"all"}.
#' @param type Character value indicating whether to plot \code{"a"}historical or
#' \code{"h"}istorical sensitivity matrices. Defaults to \code{"a"}historical,
#' but will plot a historical sensitivity matrix image if no ahistorical
#' sensitivity matrix exists.
#' @param ... Other parameters.
#' 
#' @return Plots a matrix image, or series of matrix images, denoting non-zero
#' elements as red space and zero elements as white space.
#' 
#' @examples 
#' # Lathyrus example
#' data(lathyrus)
#' 
#' sizevector <- c(0, 100, 13, 127, 3730, 3800, 0)
#' stagevector <- c("Sd", "Sdl", "VSm", "Sm", "VLa", "Flo", "Dorm")
#' repvector <- c(0, 0, 0, 0, 0, 1, 0)
#' obsvector <- c(0, 1, 1, 1, 1, 1, 0)
#' matvector <- c(0, 0, 1, 1, 1, 1, 1)
#' immvector <- c(1, 1, 0, 0, 0, 0, 0)
#' propvector <- c(1, 0, 0, 0, 0, 0, 0)
#' indataset <- c(0, 1, 1, 1, 1, 1, 1)
#' binvec <- c(0, 100, 11, 103, 3500, 3800, 0.5)
#' 
#' lathframe <- sf_create(sizes = sizevector, stagenames = stagevector,
#'   repstatus = repvector, obsstatus = obsvector, matstatus = matvector,
#'   immstatus = immvector, indataset = indataset, binhalfwidth = binvec,
#'   propstatus = propvector)
#' 
#' lathvert <- verticalize3(lathyrus, noyears = 4, firstyear = 1988,
#'   patchidcol = "SUBPLOT", individcol = "GENET", blocksize = 9,
#'   juvcol = "Seedling1988", sizeacol = "Volume88", repstracol = "FCODE88",
#'   fecacol = "Intactseed88", deadacol = "Dead1988",
#'   nonobsacol = "Dormant1988", stageassign = lathframe, stagesize = "sizea",
#'   censorcol = "Missing1988", censorkeep = NA, censor = TRUE)
#' 
#' lathsupp3 <- supplemental(stage3 = c("Sd", "Sd", "Sdl", "Sdl", "Sd", "Sdl", "mat"),
#'   stage2 = c("Sd", "Sd", "Sd", "Sd", "rep", "rep", "Sdl"),
#'   stage1 = c("Sd", "rep", "Sd", "rep", "npr", "npr", "Sd"),
#'   eststage3 = c(NA, NA, NA, NA, NA, NA, "mat"),
#'   eststage2 = c(NA, NA, NA, NA, NA, NA, "Sdl"),
#'   eststage1 = c(NA, NA, NA, NA, NA, NA, "NotAlive"),
#'   givenrate = c(0.345, 0.345, 0.054, 0.054, NA, NA, NA),
#'   multiplier = c(NA, NA, NA, NA, 0.345, 0.054, NA),
#'   type = c(1, 1, 1, 1, 3, 3, 1), type_t12 = c(1, 2, 1, 2, 1, 1, 1),
#'   stageframe = lathframe, historical = TRUE)
#' 
#' ehrlen3 <- rlefko3(data = lathvert, stageframe = lathframe,
#'   year = c(1989, 1990), stages = c("stage3", "stage2", "stage1"),
#'   supplement = lathsupp3, yearcol = "year2", indivcol = "individ")
#' 
#' ehrlen_sens <- sensitivity3(ehrlen3)
#' 
#' image3(ehrlen_sens, used = 1, type = "h")
#' 
#' @export
image3.lefkoSens <- function(mats, used = "all", type = "a", ...) {
  
  allahmats <- c(1:length(mats$ah_sensmats))
  allhmats <- c(1:length(mats$h_sensmats))
  
  allmats <- c(1:max(c(allahmats, allhmats)))
  
  if (!is.character(type)) {
    stop("Please enter a or h for type option.", call. = FALSE)
  }
  
  type <- tolower(type)
  if (!is.element(type, c("a", "h"))) {
    stop("Please enter a or h for type option.", call. = FALSE)
  }
  
  if (all(is.character(used))) {
    if (all(tolower(used) != "all")) {
      stop("Value entered for matrix option not recognized.", call. = FALSE)
    } else {
      chosen_mat <- allmats
    }
  } else if (is.numeric(used) & is.element(used, allmats)) {
    chosen_mat <-  used
  } else {
    stop("Value entered for matrix option not recognized.", call. = FALSE)
  }
  
  if (type == "h") {
    if (any(is.null(mats$h_sensmats))) {
      stop("This object does not appear to have historical sensitivity matrices. Please try ahistorical option.",
        call. = FALSE)
    }
    chosen_list <- mats$h_sensmats[chosen_mat]
  } else {
    if (any(is.null(mats$ah_sensmats))) {
      warning("This object does not appear to have ahistorical sensitivity matrices. Will use historical sensitivity matrices instead.",
        call. = FALSE)
      
      chosen_list <- mats$h_sensmats[chosen_mat]
    } else {
      chosen_list <- mats$ah_sensmats[chosen_mat]
    }
  }
  
  if (is(chosen_list[[1]], "dgCMatrix")) {
    lapply(chosen_list, function(X) {Matrix::image(X, xlab = "", ylab = "", 
      sub = "", col.regions = c("white", "red"), lwd = 0,
      at = c(0, 0.0000000000001, Inf), drop.unused.levels = FALSE)})
  } else {
    lapply(chosen_list, function(X) {Matrix::image(Matrix::Matrix(X, sparse = TRUE),
      xlab = "", ylab = "", sub = "", col.regions = c("white", "red"), lwd = 0,
      at = c(0, 0.0000000000001, Inf), drop.unused.levels = FALSE)})
  }
}

#' Create Matrix Image(s) for lefkoElas Object
#' 
#' Function \code{image3.lefkoElas} plots matrix images for elasticity matrices
#' supplied within \code{lefkoElas} objects.
#' 
#' @name image3.lefkoElas
#' 
#' @param mats A \code{lefkoElas} object.
#' @param used A numeric value or vector designating the matrices to plot. Can
#' also take the value \code{"all"}, which plots all matrices. Defaults to
#' \code{"all"}.
#' @param type Character value indicating whether to plot \code{"a"}historical or
#' \code{"h"}istorical elasticity matrices. Defaults to \code{"a"}historical,
#' but will plot a historical elasticity matrix image if no ahistorical
#' elasticity matrix exists.
#' @param ... Other parameters.
#' 
#' @return Plots a matrix image, or series of matrix images, denoting non-zero
#' elements as red space and zero elements as white space.
#' 
#' @examples 
#' # Lathyrus example
#' data(lathyrus)
#' 
#' sizevector <- c(0, 100, 13, 127, 3730, 3800, 0)
#' stagevector <- c("Sd", "Sdl", "VSm", "Sm", "VLa", "Flo", "Dorm")
#' repvector <- c(0, 0, 0, 0, 0, 1, 0)
#' obsvector <- c(0, 1, 1, 1, 1, 1, 0)
#' matvector <- c(0, 0, 1, 1, 1, 1, 1)
#' immvector <- c(1, 1, 0, 0, 0, 0, 0)
#' propvector <- c(1, 0, 0, 0, 0, 0, 0)
#' indataset <- c(0, 1, 1, 1, 1, 1, 1)
#' binvec <- c(0, 100, 11, 103, 3500, 3800, 0.5)
#' 
#' lathframe <- sf_create(sizes = sizevector, stagenames = stagevector,
#'   repstatus = repvector, obsstatus = obsvector, matstatus = matvector,
#'   immstatus = immvector, indataset = indataset, binhalfwidth = binvec,
#'   propstatus = propvector)
#' 
#' lathvert <- verticalize3(lathyrus, noyears = 4, firstyear = 1988,
#'   patchidcol = "SUBPLOT", individcol = "GENET", blocksize = 9,
#'   juvcol = "Seedling1988", sizeacol = "Volume88", repstracol = "FCODE88",
#'   fecacol = "Intactseed88", deadacol = "Dead1988",
#'   nonobsacol = "Dormant1988", stageassign = lathframe, stagesize = "sizea",
#'   censorcol = "Missing1988", censorkeep = NA, censor = TRUE)
#' 
#' lathsupp3 <- supplemental(stage3 = c("Sd", "Sd", "Sdl", "Sdl", "Sd", "Sdl", "mat"),
#'   stage2 = c("Sd", "Sd", "Sd", "Sd", "rep", "rep", "Sdl"),
#'   stage1 = c("Sd", "rep", "Sd", "rep", "npr", "npr", "Sd"),
#'   eststage3 = c(NA, NA, NA, NA, NA, NA, "mat"),
#'   eststage2 = c(NA, NA, NA, NA, NA, NA, "Sdl"),
#'   eststage1 = c(NA, NA, NA, NA, NA, NA, "NotAlive"),
#'   givenrate = c(0.345, 0.345, 0.054, 0.054, NA, NA, NA),
#'   multiplier = c(NA, NA, NA, NA, 0.345, 0.054, NA),
#'   type = c(1, 1, 1, 1, 3, 3, 1), type_t12 = c(1, 2, 1, 2, 1, 1, 1),
#'   stageframe = lathframe, historical = TRUE)
#' 
#' ehrlen3 <- rlefko3(data = lathvert, stageframe = lathframe,
#'   year = c(1989, 1990), stages = c("stage3", "stage2", "stage1"),
#'   supplement = lathsupp3, yearcol = "year2", indivcol = "individ")
#' 
#' ehrlen_elas <- elasticity3(ehrlen3)
#' 
#' image3(ehrlen_elas, used = 1, type = "h")
#' 
#' @export
image3.lefkoElas <- function(mats, used = "all", type = "a", ...) {
  
  allahmats <- c(1:length(mats$ah_elasmats))
  allhmats <- c(1:length(mats$h_elasmats))
  
  allmats <- c(1:max(c(allahmats, allhmats)))
  
  if (!is.character(type)) {
    stop("Please enter a or h for type option.", call. = FALSE)
  }
  
  type <- tolower(type)
  if (!is.element(type, c("a", "h"))) {
    stop("Please enter a or h for type option.", call. = FALSE)
  }
  
  if (all(is.character(used))) {
    if (all(tolower(used) != "all")) {
      stop("Value entered for matrix option not recognized.", call. = FALSE)
    } else {
      chosen_mat <- allmats
    }
  } else if (is.numeric(used) & is.element(used, allmats)) {
    chosen_mat <-  used
  } else {
    stop("Value entered for matrix option not recognized.", call. = FALSE)
  }
  
  if (type == "h") {
    if (any(is.null(mats$h_elasmats))) {
      stop("This object does not appear to have historical sensitivity matrices. Please try ahistorical option.",
        call. = FALSE)
    }
    chosen_list <- mats$h_elasmats[chosen_mat]
  } else {
    if (any(is.null(mats$ah_elasmats))) {
      warning("This object does not appear to have ahistorical sensitivity matrices. Will use historical sensitivity matrices instead.",
        call. = FALSE)
      
      chosen_list <- mats$h_elasmats[chosen_mat]
    } else {
      chosen_list <- mats$ah_elasmats[chosen_mat]
    }
  }
  
  if (is(chosen_list[[1]], "dgCMatrix")) {
    lapply(chosen_list, function(X) {Matrix::image(X, xlab = "", ylab = "", 
      sub = "", col.regions = c("white", "red"), lwd = 0,
      at = c(0, 0.0000000000001, Inf), drop.unused.levels = FALSE)})
  } else {
    lapply(chosen_list, function(X) {Matrix::image(Matrix::Matrix(X, sparse = TRUE),
      xlab = "", ylab = "", sub = "", col.regions = c("white", "red"), lwd = 0,
      at = c(0, 0.0000000000001, Inf), drop.unused.levels = FALSE)})
  }
}

#' Calculate Difference Matrices Between lefkoMat Objects of Equal Dimensions
#' 
#' Function \code{diff_lM()} takes two \code{lefkoMat} objects with completely
#' equal dimensions, including both the size and number of matrices, and
#' gives the matrix differences between each corresponding set.
#' 
#' @name diff_lM
#' 
#' @param mpm1 The first \code{lefkoMat} object.
#' @param mpm2 The second \code{lefkoMat} object.
#' 
#' @return An object of class \code{lefkoDiff}, which is a set of \code{A},
#' \code{U}, and \code{F} matrices corresponding to the differences between each
#' set of matrices, followed by the \code{hstages}, \code{ahstages}, and
#' \code{labels} elements from each input \code{lefkoMat} object. Elements
#' labelled with a \code{1} at the end refer to \code{mpm1}, while those
#' labelled \code{2} at the end refer to \code{mpm2}.
#' 
#' @section Notes:
#' The exact difference is calculated as the respective matrix in \code{mpm1}
#' minus the corresponding matrix in \code{mpm2}.
#' 
#' This function first checks to see if the number of matrices is the same, and
#' then whether the matrix dimensions are the same. If the two sets differ in at
#' least one of these characteristics, then the function will yield a fatal
#' error.
#' 
#' If the lengths and dimensions of the input \code{lefkoMat} objects are the
#' same, then this will check if the \code{labels} element is essentially the
#' same. If not, then the function will yield a warning, but will still operate.
#' 
#' @examples
#' sizevector <- c(0, 0, 0, 0, 0, 0, 1, 3, 6, 11, 19.5)
#' stagevector <- c("SD", "P1", "P2", "P3", "SL", "D", "XSm", "Sm", "Md", "Lg",
#'   "XLg")
#' repvector <- c(0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1)
#' obsvector <- c(0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1)
#' matvector <- c(0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1)
#' immvector <- c(0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0)
#' propvector <- c(1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
#' indataset <- c(0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1)
#' binvec <- c(0, 0, 0, 0, 0, 0.5, 0.5, 1.5, 1.5, 3.5, 5)
#' comments <- c("Dormant seed", "1st yr protocorm", "2nd yr protocorm",
#'   "3rd yr protocorm", "Seedling", "Dormant adult",
#'   "Extra small adult (1 shoot)", "Small adult (2-4 shoots)",
#'   "Medium adult (5-7 shoots)", "Large adult (8-14 shoots)",
#'   "Extra large adult (>14 shoots)")
#' cypframe_raw <- sf_create(sizes = sizevector, stagenames = stagevector, 
#'   repstatus = repvector, obsstatus = obsvector, matstatus = matvector,
#'   propstatus = propvector, immstatus = immvector, indataset = indataset, 
#'   binhalfwidth = binvec, comments = comments)
#' 
#' cypraw_v1 <- verticalize3(data = cypdata, noyears = 6, firstyear = 2004, 
#'   patchidcol = "patch", individcol = "plantid", blocksize = 4,
#'   sizeacol = "Inf2.04", sizebcol = "Inf.04", sizeccol = "Veg.04",
#'   repstracol = "Inf.04", repstrbcol = "Inf2.04", fecacol = "Pod.04",
#'   stageassign = cypframe_raw, stagesize = "sizeadded", NAas0 = TRUE,
#'   NRasRep = TRUE)
#' 
#' seeds_per_pod <- 5000
#' 
#' cypsupp2_raw <- supplemental(stage3 = c("SD", "P1", "P2", "P3", "SL", "SL", "D", 
#'     "XSm", "SD", "P1"),
#'   stage2 = c("SD", "SD", "P1", "P2", "P3", "SL", "SL", "SL", "rep", "rep"),
#'   eststage3 = c(NA, NA, NA, NA, NA, NA, "D", "XSm", NA, NA),
#'   eststage2 = c(NA, NA, NA, NA, NA, NA, "XSm", "XSm", NA, NA),
#'   givenrate = c(0.03, 0.15, 0.1, 0.1, 0.1, 0.05, NA, NA, NA, NA),
#'   multiplier = c(NA, NA, NA, NA, NA, NA, NA, NA, (0.5 * seeds_per_pod),
#'     (0.5 * seeds_per_pod)),
#'   type =c(1, 1, 1, 1, 1, 1, 1, 1, 3, 3),
#'   stageframe = cypframe_raw, historical = FALSE)
#' cypsupp3_raw <- supplemental(stage3 = c("SD", "SD", "P1", "P1", "P2", "P3",
#'     "SL", "SL", "SL", "D", "D", "SD", "P1"),
#'   stage2 = c("SD", "SD", "SD", "SD", "P1", "P2", "P3", "SL", "SL", "SL", "SL",
#'     "rep", "rep"),
#'   stage1 = c("SD", "rep", "SD", "rep", "SD", "P1", "P2", "P3", "SL", "P3",
#'     "SL", "mat", "mat"),
#'   eststage3 = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, "XSm", "D", NA, NA),
#'   eststage2 = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, "XSm", "XSm", NA, NA),
#'   eststage1 = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, "XSm", "XSm", NA, NA),
#'   givenrate = c(0.01, 0.05, 0.10, 0.20, 0.1, 0.1, 0.05, 0.05, 0.05, NA, NA,
#'     NA, NA),
#'   multiplier = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,
#'     (0.5 * seeds_per_pod), (0.5 * seeds_per_pod)),
#'   type = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 3, 3),
#'   type_t12 = c(1, 2, 1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1),
#'   stageframe = cypframe_raw, historical = TRUE)
#' 
#' cypmatrix2rp <- rlefko2(data = cypraw_v1, stageframe = cypframe_raw,
#'   year = "all", patch = "all", stages = c("stage3", "stage2"),
#'   size = c("size3added", "size2added"), supplement = cypsupp2_raw, 
#'   yearcol = "year2", patchcol = "patchid", indivcol = "individ")
#' 
#' cypmatrix2r <- rlefko2(data = cypraw_v1, stageframe = cypframe_raw,
#'   year = "all", stages = c("stage3", "stage2"),
#'   size = c("size3added", "size2added"), supplement = cypsupp2_raw, 
#'   yearcol = "year2", patchcol = "patchid", indivcol = "individ")
#' 
#' cypmatrix3rp <- rlefko3(data = cypraw_v1, stageframe = cypframe_raw,
#'   year = "all", patch = "all", stages = c("stage3", "stage2", "stage1"), 
#'   size = c("size3added", "size2added", "size1added"), supplement = cypsupp3_raw, 
#'   yearcol = "year2", patchcol = "patchid", indivcol = "individ")
#' 
#' cypmatrix3r <- rlefko3(data = cypraw_v1, stageframe = cypframe_raw,
#'   year = "all", stages = c("stage3", "stage2", "stage1"), 
#'   size = c("size3added", "size2added", "size1added"), supplement = cypsupp3_raw, 
#'   yearcol = "year2", patchcol = "patchid", indivcol = "individ")
#' 
#' cypmatrix2r_3 <- hist_null(cypmatrix2r)
#' cypmatrix2r_3 <- delete_lM(cypmatrix2r_3, year = 2004)
#' diff_r <- diff_lM(cypmatrix3r, cypmatrix2r_3)
#' 
#' cypmatrix2rp_3 <- hist_null(cypmatrix2rp)
#' cypmatrix2rp_3 <- delete_lM(cypmatrix2rp_3, year = 2004)
#' diff_rp <- diff_lM(cypmatrix3rp, cypmatrix2rp_3)
#' 
#' @export
diff_lM <- function(mpm1, mpm2) {
  if (is.null(mpm1) | is.null(mpm2)) {
    stop("Function diff_lM() requires two lefkoMat objects as input.",
      call. = FALSE)
  } else if (all(is.na(mpm1)) | all(is.na(mpm2))) {
    stop("Function diff_lM() requires two lefkoMat objects as input.",
      call. = FALSE)
  }
  if (!is(mpm1, "lefkoMat") | !is(mpm2, "lefkoMat")) {
    stop("Function diff_lM() requires two lefkoMat objects as input.",
      call. = FALSE)
  }
  
  if (length(mpm1$A) != length(mpm2$A)) {
    stop("Objects mpm1 and mpm2 must have the same number of matrices.",
      call. = FALSE)
  }
  if (dim(mpm1$A[[1]])[1] != dim(mpm2$A[[1]])[1]) {
    stop("Objects mpm1 and mpm2 must include matrices of the same dimensions.",
      call. = FALSE)
  }
  
  new_diffs_A <- lapply(c(1:length(mpm1$A)), function(X) {
    newmat <- mpm1$A[[X]] - mpm2$A[[X]]
    
    return(newmat)
  })
  
  new_diffs_U <- lapply(c(1:length(mpm1$A)), function(X) {
    newmat <- mpm1$U[[X]] - mpm2$U[[X]]
    
    return(newmat)
  })
  
  new_diffs_F <- lapply(c(1:length(mpm1$A)), function(X) {
    newmat <- mpm1$F[[X]] - mpm2$F[[X]]
    
    return(newmat)
  })
  
  if (any((mpm1$labels$year2 != mpm2$labels$year2))) {
    warning("Input lefkoMat objects have seemingly different labels objects.",
      call. = FALSE)
  }
  
  output <- list(A = new_diffs_A, U = new_diffs_U, F = new_diffs_F,
    hstages1 = mpm1$hstages, hstages2 = mpm2$hstages, ahstages1 = mpm1$ahstages,
    ahstages2 = mpm2$ahstages, labels1 = mpm1$labels, labels2 = mpm2$labels)
  
  class(output) <- "lefkoDiff"
  
  return(output)
}

#' Summary of Classes "hfvdata" and "hfvlist
#'
#' A function to simplify the viewing of basic information describing
#' demographic data in historical vertical format (data frames of class
#' \code{hfvdata}, or bootstrapped data frames in lists of class
#' \code{hfvlist}).
#' 
#' @name summary_hfv
#' 
#' @param object An object of either class \code{hfvdata} or class
#' \code{hfvlist}.
#' @param popid A string denoting the name of the variable denoting population
#' identity.
#' @param patchid A string denoting the name of the variable denoting patch
#' identity.
#' @param individ A string denoting the name of the variable denoting individual
#' identity.
#' @param year2id A string denoting the name of the variable denoting the year
#' in time \emph{t}.
#' @param full A logical value indicating whether to include basic data frame
#' summary information in addition to hfvdata-specific summary information.
#' Defaults to \code{FALSE}.
#' @param err_check A logical value indicating whether to check for errors in
#' stage assignment.
#' @param ... Other parameters.
#' 
#' @return A summary of the object. If an object of class \code{hfvdata} is
#' entered, then the first line of output shows the numbers of populations,
#' patches, individuals, and time steps. If \code{full = TRUE}, then this is
#' followed by a standard data frame summary of the hfv dataset. If
#' \code{err_check = TRUE}, then a subset of the original data frame input as
#' \code{object} is exported with only rows showing stage assignment issues.
#' 
#' If an object of class \code{hfvlist} in entered, then the first line of
#' output shows the number of bootstrapped datasets. This is followed by lines
#' showing the mean number of rows and variables per data frame, as well as the
#' mean numbers of populations, patches, individuals, and years per data frame.
#' This is followed by lines showing the total number of unique populations,
#' patches, individuals, and years sampled across the bootstrapped data frames.
#' If \code{full = TRUE}, then this is followed by standard data frame summaries
#' of all bootstrapped data frames. If \code{err_check = TRUE}, then a data
#' frame is output with all of the problem rows across all bootstrapped data
#' frames, starting with a new variable giving the bootstrap number of origin.
#' 
#' @section Notes:
#' Stage assignment issue identified by option \code{err_check} fall under two
#' categories. First, all rows showing \code{NoMatch} as the identified stage
#' for \code{stage1}, \code{stage2}, or \code{stage3} are identified. Second,
#' all rows showing \code{stage1 = "NotAlive"} and \code{alive1 = 1},
#' \code{stage2 = "NotAlive"} and \code{alive2 = 1}, or
#' \code{stage3 = "NotAlive"} and \code{alive3 = 1} are identified.
#' 
#' @examples
#' data(cypdata)
#' 
#' sizevector <- c(0, 0, 0, 0, 0, 0, 1, 2.5, 4.5, 8, 17.5)
#' stagevector <- c("SD", "P1", "P2", "P3", "SL", "D", "XSm", "Sm", "Md", "Lg",
#'   "XLg")
#' repvector <- c(0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1)
#' obsvector <- c(0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1)
#' matvector <- c(0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1)
#' immvector <- c(0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0)
#' propvector <- c(1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
#' indataset <- c(0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1)
#' binvec <- c(0, 0, 0, 0, 0, 0.5, 0.5, 1, 1, 2.5, 7)
#' 
#' cypframe_raw <- sf_create(sizes = sizevector, stagenames = stagevector,
#'   repstatus = repvector, obsstatus = obsvector, matstatus = matvector,
#'   propstatus = propvector, immstatus = immvector, indataset = indataset,
#'   binhalfwidth = binvec)
#' 
#' cypraw_v1 <- verticalize3(data = cypdata, noyears = 6, firstyear = 2004,
#'   patchidcol = "patch", individcol = "plantid", blocksize = 4,
#'   sizeacol = "Inf2.04", sizebcol = "Inf.04", sizeccol = "Veg.04",
#'   repstracol = "Inf.04", repstrbcol = "Inf2.04", fecacol = "Pod.04",
#'   stageassign = cypframe_raw, stagesize = "sizeadded", NAas0 = TRUE,
#'   NRasRep = TRUE)
#' 
#' summary_hfv(cypraw_v1)
#' 
#' cypraw_v1_boot <- bootstrap3(cypraw_v1, reps = 3)
#' 
#' summary_hfv(cypraw_v1_boot)
#' 
#' @export
summary_hfv <- function(object, popid = "popid", patchid = "patchid",
  individ = "individ", year2id = "year2", full = FALSE, err_check = TRUE, ...) {
  
  pops_across <- patches_across <- indivs_across <- years_across <- NULL
  input_class <- 0 # 1 is hfvdata and 2 is hfvlist, 0 is an error
  
  identified_problems <- NULL
  need_return <- FALSE
  
  demodata <- object
  
  if (is(demodata, "hfvdata")) {
    input_class <- 1
  } else if (is(demodata, "hfvlist")) {
    input_class <- 2
  } else {
    stop("This summary function requires an object of class hfvdata or class hfvlist as input.",
      call. = FALSE)
  }
  
  if (input_class == 1) {
    matdim <- dim(demodata)
    
    if (!is.element(popid, names(demodata))) {
      stop("Population ID variable not found.", call. = FALSE)
    }
    if (!is.element(patchid, names(demodata))) {
      stop("Patch ID variable not found.", call. = FALSE)
    }
    if (!is.element(individ, names(demodata))) {
      stop("Individual ID variable not found.", call. = FALSE)
    }
    if (!is.element(year2id, names(demodata))) {
      stop("Year at time t ID variable not found.", call. = FALSE)
    }
    
    totalpops <- length(unique(demodata[, popid]))
    totalpatches <- length(unique(demodata[, patchid]))
    totalindivs <- length(unique(demodata[, individ]))
    totalyears <- length(unique(demodata[, year2id]))
    
    grammar_rows <- " rows, "
    grammar_vars <- " variables, "
    grammar_pops <- " populations, "
    grammar_patches <- " patches, "
    grammar_indivs <- " individuals, and "
    grammar_years <- " time steps."
    if (matdim[1] == 1) grammar_rows <- " row, "
    if (matdim[2] == 1) grammar_vars <- " variable, "
    if (totalpops == 1) grammar_pops <- " population, "
    if (totalpatches == 1) grammar_patches <- " patch, "
    if (totalindivs == 1) grammar_indivs <- " individual, and "
    if (totalyears == 1) grammar_years <- " time step."
    
    writeLines(paste0("\nThis hfv dataset contains ", matdim[1], grammar_rows,
        matdim[2], grammar_vars, totalpops, grammar_pops))
    writeLines(paste0(totalpatches, grammar_patches, totalindivs, grammar_indivs,
        totalyears, grammar_years))
    
    if (err_check) {
      stage1_NoMatches <- which(demodata[, "stage1"] == "NoMatch")
      stage2_NoMatches <- which(demodata[, "stage2"] == "NoMatch")
      stage3_NoMatches <- which(demodata[, "stage3"] == "NoMatch")
      
      stage1_NotAlive <- which(demodata[, "stage1"] == "NotAlive")
      stage2_NotAlive <- which(demodata[, "stage2"] == "NotAlive")
      stage3_NotAlive <- which(demodata[, "stage3"] == "NotAlive")
      
      alive1 <- which(demodata[, "alive1"] == 1)
      alive2 <- which(demodata[, "alive2"] == 1)
      alive3 <- which(demodata[, "alive3"] == 1)
      
      s1_NotA_al <- intersect(stage1_NotAlive, alive1)
      s2_NotA_al <- intersect(stage2_NotAlive, alive2)
      s3_NotA_al <- intersect(stage3_NotAlive, alive3)
      
      problem_rows <- sort(unique(c(stage1_NoMatches, stage2_NoMatches,
        stage3_NoMatches, s1_NotA_al, s2_NotA_al, s3_NotA_al)))
      
      if (length(problem_rows) > 0) {
        need_return <- TRUE
        writeLines(paste0("Problems in stage assignment identified in rows:\n"))
        print(problem_rows)
        
        identified_problems <- demodata[problem_rows,]
      }
    }
    
    if (full) {
      dethonthetoilet <- summary.data.frame(demodata)
      print(dethonthetoilet, digits = 3)
    }
    
    if (err_check & need_return) return(identified_problems)
    
  } else {
    hfvlist_length <- length(demodata)
    
    df_rows_vec <- rep(0, hfvlist_length)
    df_vars_vec <- rep(0, hfvlist_length)
    totalpops_vec <- rep(0, hfvlist_length)
    totalpatches_vec <- rep(0, hfvlist_length)
    totalindivs_vec <- rep(0, hfvlist_length)
    totalyears_vec <- rep(0, hfvlist_length)
    
    problem_list <- vector(mode = "list", hfvlist_length)
    problem_counter <- 0
    
    for (i in c(1:hfvlist_length)) {
      matdim <- dim(demodata[[i]])
      
      current_rows <- matdim[1]
      current_vars <- matdim[2]
      df_rows_vec[i] <- current_rows
      df_vars_vec[i] <- current_vars
      
      if (!is.element(popid, names(demodata[[i]]))) {
        stop(paste("Population ID variable not found in data frame", i), call. = FALSE)
      }
      if (!is.element(patchid, names(demodata[[i]]))) {
        stop(paste("Patch ID variable not found in data frame", i), call. = FALSE)
      }
      if (!is.element(individ, names(demodata[[i]]))) {
        stop(paste("Individual ID variable not found in data frame", i), call. = FALSE)
      }
      if (!is.element(year2id, names(demodata[[i]]))) {
        stop(paste("Year at time t ID variable not found in data frame", i), call. = FALSE)
      }
      
      totalpops <- length(unique(demodata[[i]][, popid]))
      totalpatches <- length(unique(demodata[[i]][, patchid]))
      totalindivs <- length(unique(demodata[[i]][, individ]))
      totalyears <- length(unique(demodata[[i]][, year2id]))
      
      totalpops_vec[i] <- totalpops
      totalpatches_vec[i] <- totalpatches
      totalindivs_vec[i] <- totalindivs
      totalyears_vec[i] <- totalyears
      
      if (i == 1) {
        pops_across <- unique(demodata[[i]][, popid])
        patches_across <- unique(demodata[[i]][, patchid])
        indivs_across <- unique(demodata[[i]][, individ])
        years_across <- unique(demodata[[i]][, year2id])
      } else {
        pops_across <- c(pops_across, unique(demodata[[i]][, popid]))
        patches_across <- c(patches_across, unique(demodata[[i]][, patchid]))
        indivs_across <- c(indivs_across, unique(demodata[[i]][, individ]))
        years_across <- c(years_across, unique(demodata[[i]][, year2id]))
      }
      
      if (err_check) {
        stage1_NoMatches <- which(demodata[[i]][, "stage1"] == "NoMatch")
        stage2_NoMatches <- which(demodata[[i]][, "stage2"] == "NoMatch")
        stage3_NoMatches <- which(demodata[[i]][, "stage3"] == "NoMatch")
        
        stage1_NotAlive <- which(demodata[[i]][, "stage1"] == "NotAlive")
        stage2_NotAlive <- which(demodata[[i]][, "stage2"] == "NotAlive")
        stage3_NotAlive <- which(demodata[[i]][, "stage3"] == "NotAlive")
        
        alive1 <- which(demodata[[i]][, "alive1"] == 1)
        alive2 <- which(demodata[[i]][, "alive2"] == 1)
        alive3 <- which(demodata[[i]][, "alive3"] == 1)
        
        s1_NotA_al <- intersect(stage1_NotAlive, alive1)
        s2_NotA_al <- intersect(stage2_NotAlive, alive2)
        s3_NotA_al <- intersect(stage3_NotAlive, alive3)
        
        problem_rows <- sort(unique(c(stage1_NoMatches, stage2_NoMatches,
          stage3_NoMatches, s1_NotA_al, s2_NotA_al, s3_NotA_al)))
        
        if (length(problem_rows) > 0) {
          need_return <- TRUE
          problem_counter = problem_counter + 1
          
          prlength <- length(problem_rows)
          
          problem_rows_headrow <- data.frame(bootstrap = rep(i, prlength))
          
          chittle_fiddle <- cbind.data.frame(problem_rows_headrow, demodata[[i]][problem_rows,])
          
          if (problem_counter == 1) {
            identified_problems <- chittle_fiddle
            
          } else {
            identified_problems <- rbind.data.frame(identified_problems, chittle_fiddle)
          }
        }
      }
    }
    
    mean_rows <- mean(df_rows_vec, na.rm = TRUE)
    mean_vars <- mean(df_vars_vec, na.rm = TRUE)
    mean_pops <- mean(totalpops_vec, na.rm = TRUE)
    mean_patches <- mean(totalpatches_vec, na.rm = TRUE)
    mean_indivs <- mean(totalindivs_vec, na.rm = TRUE)
    mean_years <- mean(totalyears_vec, na.rm = TRUE)
    
    if (mean_rows != floor(mean_rows)) mean_rows <- round(mean_rows, digits = 3)
    if (mean_vars != floor(mean_vars)) mean_vars <- round(mean_vars, digits = 3)
    if (mean_pops != floor(mean_pops)) mean_pops <- round(mean_pops, digits = 3)
    if (mean_patches != floor(mean_patches)) mean_patches <- round(mean_patches, digits = 3)
    if (mean_indivs != floor(mean_indivs)) mean_indivs <- round(mean_indivs, digits = 3)
    if (mean_years != floor(mean_years)) mean_years <- round(mean_years, digits = 3)
    
    total_pops_across <- length(unique(pops_across))
    total_patches_across <- length(unique(patches_across))
    total_indivs_across <- length(unique(indivs_across))
    total_years_across <- length(unique(years_across))
   
    grammar_rows_mean <- " rows, "
    grammar_vars_mean <- " variables, "
    grammar_pops_mean <- " populations, "
    grammar_patches_mean <- " patches, "
    grammar_indivs_mean <- " individuals, and "
    grammar_years_mean <- " time steps."
    if (mean_rows == 1) grammar_rows_mean <- " row, "
    if (mean_vars == 1) grammar_vars_mean <- " variable, "
    if (mean_pops == 1) grammar_pops_mean <- " population, "
    if (mean_patches == 1) grammar_patches_mean <- " patch, "
    if (mean_indivs == 1) grammar_indivs_mean <- " individual, and "
    if (mean_years == 1) grammar_years_mean <- " time step."
    
    grammar_pops <- " unique populations, "
    grammar_patches <- " unique patches, "
    grammar_indivs <- " unique individuals, and "
    grammar_years <- " unique time steps."
    if (total_pops_across == 1) grammar_pops <- " unique population, "
    if (total_patches_across == 1) grammar_patches <- " unique patch, "
    if (total_indivs_across == 1) grammar_indivs <- " unique individual, and "
    if (total_years_across == 1) grammar_years <- " unique time step."
    
    writeLines(paste0("\nThis hfvlist object contains ", hfvlist_length, " hfvdata demographic data frames."))
    writeLines(paste0("Each data frame contains an average of ", mean_rows, grammar_rows_mean,
      mean_vars, grammar_vars_mean, mean_pops, grammar_pops_mean))
    writeLines(paste0(mean_patches, grammar_patches_mean, mean_indivs, grammar_indivs_mean,
      mean_years, grammar_years_mean))
    
    writeLines(paste0("\nAcross all data frames, there are ", total_pops_across, grammar_pops, total_patches_across,
      grammar_patches, total_indivs_across, grammar_indivs, total_years_across, grammar_years))
    
    if (full) {
      for (i in c(1:hfvlist_length)) {
        dethonthetoilet <- summary.data.frame(demodata)
        print(dethonthetoilet, digits = 3)
      }
    }
    
    if (err_check & need_return) return(identified_problems)
  }
}

