R/ConsoleDropOutliers.R

In bmcnellis/sapflux: Analyze Sapflux Traces

#' @title Identifies outliers in each flux plot.
#'
#' @description
#'
#' Not implemented yet!
#'
#' @param flux    An object of class 'flux'
#'
#' @family preprocess
#' @examples
#' dataflux <- IdentifyFluxOutliers(flux)
ConsoleDropOutliers <- function(flux, drop.fails = TRUE) {
  stop("ConsoleDropOutliers not implemented yet! See also the
       'identify' method for class 'flux'")
  CheckFluxObject(flux)
  params <- LoadDefaults(flux = flux)
  ncols <- ncol(data)
  # Run identifier function on each plot
  for (i in 1:ncols) {
    if (!(names(dev.cur()) == "null device")) {
      dev.off()
    }
    fail <- FALSE
    err <- NULL
    drops <- numeric()
    good.coords <- list()
    tryCatch(expr = {
      plot(x = flux, y = i, fastplot = TRUE, quietly = TRUE)
    }, warning = function(cond) {
      cat("Column", i, "failed to plot...")
      if (drop.fails) {
        cat("dropping column from dataset.\n")
        drops <- append(x = drops, values = i)
      } else {
        cat("skipping.\n")
      }
      fail <- TRUE
      invisible()
    }, error = function(cond) {
      err <- cond
    }, finally = {
      if (fail) {
        next
      }
      if (length(err)) {
        print(err[[2]])
        stop(cat("Critical plot failure", err[[1]]))
      }
      drop <- readline("Drop this probe? TRUE or FALSE: ")
      if (drop) {
        drops <- append(drops, i)
        next
      }
      message("Click on the good data bounds!
              First click starts, second click ends")
      i.coords <- identify(x = flux, y = i)
      if (any(c(
        i.coords == 1,
        !is.integer(coords / 2)
        ))) {
        warning("Bad click inputs, skipping")
        next
      }
      good.coords <- c(coords, i.coords)
    })
  }
  # Drop the 'drops' vector and cut out the good coordinates
  data <- slot(object = flux, name = "data")
  data <- data[, -drops]
  slot(object = flux, name = "data") <- data
  if (!identical(slot(flux, "metadata"), metadata)) {
    message("Updating metadata...")
    slot(object = flux, name = "metadata") <- metadata
  }
  return(flux)
}