R/clean.R

In kamapu/vegtables: Handling Vegetation Data Sets

#' @name clean
#'
#' @title Clean orphaned records in vegtable object
#'
#' @description
#' Delete entries in slots `header` and `species` orphaned by manipulation of
#' slots.
#'
#' Orphaned records generated by modifications in some slots may cause a loss
#' on the validity of [vegtable-class] objects.
#' This function should be applied to optimise the allocated size of a
#' [vegtable-class] object, as well. Since running cleaning only
#' once does not assure the deletion of all orphaned entries, it is recommended
#' to run it at least twice. This repetition of cleaning is controlled by the
#' argument `times`.
#'
#' @param object A [vegtable-class] object.
#' @param times Numeric value indicating how many times should be the cleaning
#'     be repeated.
#' @param ... Further arguments passed from or to other methods.
#' @return A clean [vegtable-class] object.
#' @author Miguel Alvarez \email{kamapu78@@gmail.com}
#'
#' @examples
#' ## Create an invalid object
#' veg <- Kenya_veg
#' veg@header <- veg@header[1:10, ]
#'
#' ## Resolve invalidity
#' veg <- clean(veg)
#'
#' @rdname clean
clean_once <- function(object) {
  # delete orphan species records
  object@samples <- object@samples[object@samples$ReleveID %in%
    object$ReleveID, , drop = FALSE]
  # delete layer entries missing in samples
  for (i in names(object@layers)) {
    object@layers[[i]] <- object@layers[[i]][object@layers[[i]][, i] %in%
      object@samples[, i], ]
  }
  # compare species and samples (delete observations
  # not included in species list)
  object@samples <- object@samples[object@samples$TaxonUsageID %in%
    object@species@taxonNames$TaxonUsageID, ]
  # delete header variables without data
  object@header <- object@header[, (colnames(object@header) == "ReleveID") |
    (!apply(object@header, 2, function(x) all(is.na(x)))), drop = FALSE]
  # delete samples variables without data
  object@samples <- object@samples[, (colnames(object@samples) %in%
    c("ReleveID", "TaxonUsageID")) |
    (!apply(object@samples, 2, function(x) all(is.na(x)))),
  drop = FALSE
  ]
  # delete orphaned relations
  object@relations <- object@relations[names(object@relations) %in%
    colnames(object@header)]
  # delete orphaned layers
  object@layers <- object@layers[names(object@layers) %in%
    colnames(object@samples)]
  # delete orphaned cover conversions
  object@coverconvert@value <- object@coverconvert@value[
    names(object@coverconvert@value) %in% colnames(object@samples)
  ]
  object@coverconvert@conversion <- object@coverconvert@conversion[
    names(object@coverconvert@conversion) %in%
      names(object@coverconvert@value)
  ]
  # output
  return(object)
}

#' @rdname clean
#'
#' @aliases clean,vegtable-method
#'
#' @exportMethod clean
#'
setMethod(
  "clean", signature(object = "vegtable"),
  function(object, times = 2, ...) {
    count <- 0
    repeat {
      count <- count + 1
      object <- clean_once(object)
      if (count == times) break
    }
    return(object)
  }
)