sapflux: Analyze Sapflux Traces

#' @title Validity check for 'flux' class
#'
#' @description
#'
#' Checks lengths of 'flux' class slots
#'
#' @family utils
#' @examples
#' CheckFluxObject(myflux)
CheckFluxObject <- function(object) {
  # Check metadata slot
  errors <- character()
  if (!any(length(object@raw_data) > 0,
           length(object@data) > 0)) {
    msg <- c('Raw data and data both missing from flux object.')
    errors <- c(errors, msg)
  }
  if (length(object@metadata) > 0 && length(object@data) > 0) {
    vc <- c('INCLUDE', 'BIND',
            'SAMPLE', 'SUB_SAMPLE', 'SUB_SAMPLE_REPLICATE',
            'FILE', 'COLUMN_NAME', 'DBH',
            'DATE_INSTALLED', 'DATE_REMOVED')
    if (!all(vc %in% colnames(object@data))) {
      msg <- c('Metadata missing required column names.')
      errors <- c(errors, msg)
    }
  }
  if (length(object@datatype) < 1) {
    msg <- c('Datatype is required to define a flux object')
    errors <- c(errors, msg)
  }
  if (length(object@raw_data) > 0) {
    if (length(object@time_id) != length(object@raw_data)) {
      msg <- c('time_id should be same length as raw_data, if present')
      errors <- c(errors, msg)
    }
    if (length(object@source_files) != length(object@raw_data)) {
      msg <- c('source_files should be same length as raw_data, if present')
      errors <- c(errors, msg)
    }
  }
  if (length(object@data_tags) > 1) {
    length_check <- length(object@data_tags)
  } else {
    length_check <- length(unlist(object@data_tags))
  }
  if (length_check < ncol(object@data)) {
    msg <- c('Not enough data tags for columns of data.')
    errors <- c(errors, msg)
  }
  if (all(length(object@date) > 0, length(object@time) > 0)) {
    msg <- c('Cant define both date and time slots simultaneously.')
    errors <- c(errors, msg)
  }
  if (length(errors) > 0) {
    return(errors)
  } else {
    return(TRUE)
  }
}
#' @title An S4 class to represent sapflux data and its associated metadata.
#'
#' @description
#'
#'
#' Defines the 'flux' class for use in sapflux package functions.
#'
#' The 'flux' object class stores all the information relevant to an analysis
#' of sapflux data in one form, and allows the use of seperate methods
#' for \code{plot}, \code{print}, and \code{summary}.
#'
#' @slot raw_data      The raw sapflux data sourced by FluxImport. Redundant
#'                     and optional.
#'
#' @slot source_files  A character vector of the filenames sourced by
#'                     FluxImport, in order of import.
#'
#' @slot time_id       Integer of length(raw_data) defining the timestamp
#'                     column in each dataframe of raw data.
#'
#' @slot data          The pre- and post-processed sapflow data, with each
#'                     column representing a unique probe and unique
#'                     metadata identifier.
#'
#' @slot time          Time vector associated with the sapflux data.
#'
#' @slot date          As time, but for dates.
#'
#' @slot datatype      The kind of data in the 'data/raw_data' slot. Can be:
#'                     voltages, temperatures, flux index, flux density,
#'                     stem flux, plant flux, stand flux, or land flux.
#'
#'                     Each data.type has processing parameter defaults,
#'                     set in "./data/sapflux_datatype_defaults.csv".
#'
#' @slot metadata      A dataframe of metadata, with each row associated
#'                     with a unique identifier that maps to a single
#'                     column in the processed sapflux data.
#'
#' @slot log           Character vector of log outputs.
flux <- setClass(
  # Set the class name
  'flux',
  slots = c(
    raw_data = 'list',
    source_files = 'character',
    time_id = 'numeric',
    data = 'matrix',
    data_tags = 'list',
    time = 'POSIXct',
    date = 'Date',
    datatype = 'character',
    metadata = 'data.frame',
    log = 'character'
  ),
  validity = CheckFluxObject
)
#' @describeIn flux Stores defaults for 'flux' class
#' @export
setMethod("initialize",
          signature(.Object = "flux"),
          function (.Object, ...)
          {
            # TODO: Maybe move the import functions to this? Would probably
            #       force good generalization. MetaDataImport probably deserves
            #       to be seperate, but maybe make it internal and call it using
            #       'initialize'
            slot(object = .Object, name = "time") <- .POSIXct(list())
            slot(object = .Object, name = "date") <-
              as.Date(x = character(), origin = "1970-01-01")
            return(.Object)
          }
)
#' @describeIn flux Plots flux traces sequentially using 'flux' object metadata.
#' 'y' parameter may be ommitted to plot all columns in data, or a numeric vector
#' of columns to plot.
#'
#' @export
setMethod("plot",
          signature(x = "flux"),
          function (x, y, ...) {
            validObject(x)
            # passable args: fastplot, quietly
            # Pull S4 slots ####
            data      <- slot(x, "data")
            data_tags <- slot(x, "data_tags")
            if (length(slot(x, "time")) > 0) {
              time <- slot(x, "time")
            } else {
              time <- slot(x, "date")
            }
            # Checking x/y input ####
            validObject(x)
            if (missing("y")) {
              y <- 1:ncol(data)
            } else {
              stopifnot(
                is.numeric(y),
                all(y %in% 1:ncol(data))
              )
            }
            # Argument intepretation: ####
            par_restore <- par(no.readonly = TRUE)
            on.exit(expr = par(par_restore), add = TRUE)
            arguments <- list(...)
            params <- LoadDefaults(flux = x)
            if (!("fastplot" %in% names(arguments))) {
              fastplot <- FALSE
            } else {
              fastplot <- arguments$fastplot
              arguments$fastplot <- NULL
            }
            if (!("quietly" %in% names(arguments))) {
              quietly <- FALSE
            } else {
              quietly <- arguments$quietly
              arguments$quietly <- NULL
            }
            # 'y' axis labels ####
            if (!("ylab" %in% arguments)) {
              arguments$ylab <- params[["units"]]
            }
            if (!("xlab" %in% arguments)) {
              arguments$xlab <- "Time"
            }
            # 'main' title label ####
            if (!("main" %in% arguments)) {
              main <- paste(names(data_tags)[1], data_tags[[1]])
            } else if (length(arguments$main) < length(y)) {
              if (length(main) == 1) {
                main <- rep(x = main, times = length(y))
              } else {
                main <- NULL
                warning("plot.flux failed to interpret 'main' argument passed
                        to 'title' - reverted to default NULL")
              }
            }
            # Bulk function execution ####
            if (!quietly) {
              message("Plotting data traces:")
            }
            par(ask = !(fastplot))
            for (i in 1:length(y)) {
              main_sub <- main[y[i]]
              if (all(is.na(data[, y[i]])) == TRUE |
                  length(data[, y[i]]) < 1) {
                cat("Skipping column", i, ": empty.\n")
                next
              }
              plot_args <- c(list(x = time, y = data[, y[i]],
                                  main = main_sub), arguments)
              plot_obj <- do.call(plot, args = plot_args)
              invisible(plot_obj)
            }
            # Clean-up and exit
            if (!quietly) {
              message("Done plotting.")
            }
            invisible()
          }
)
#' @describeIn flux Display summary statistics for 'flux' objects
setMethod("summary",
          signature(object = "flux"),
          function (object, ...)
          {
            validObject(object)
            cat("Haven't implemented summary yet!\n")
            invisible()
          }
)
#' @describeIn flux Interactive point identification
setMethod("identify",
          signature(x = "flux"),
          function (x, y = NULL, labels = seq_along(x), pos = FALSE, n = length(x),
                    plot = TRUE, atpen = FALSE, offset = 0.5, tolerance = 0.25,
                    ...)
          {
            stop("'identify' method for 'flux' isn't implemented yet...")
            # Note: doesn't really work, not implemented yet
            # Most of this method is default, with small additions to
            # allow class 'flux' input. Differences are commented ahead
            # of the change.
            if (length(extras <- list(...))) {
              opar <- par(extras)
              on.exit(par(opar))
            }
            # Check 'flux' object integrity
            CheckFluxObject(flux = x)
            # Modify the 'x' input to be compatible with the default
            # method skeleton
            # Add a catch for 'y' definition for this method
            if (length(y) > 1 |
                is.numeric(y) == FALSE) {
              stop("'y' input should be length-1 numeric identifying column")
            }
            col <- y
            y <- slot(object = x, name = "data")
            y <- y[, col]
            x <- slot(object = x, name = "time")
            # Resume default method definition...
            xy <- xy.coords(x, y)
            x <- xy$x
            y <- xy$y
            if (length(x) == 0) {
              if (pos)
                return(list(ind = numeric(), pos = numeric()))
              else return(numeric())
            }
            z <- .External2(C_identify, x, y, as.character(labels), n,
                            plot, offset, tolerance, atpen)
            i <- seq.int(z[[1L]])[z[[1L]]]
            if (pos)
              list(ind = i, pos = z[[2L]][z[[1L]]])
            else i
          }
)
#' @describeIn flux Flux header information.
#' @export
setMethod("head",
          signature(x = "flux"),
          function (x, n = 6L, ...) {
            stopifnot(class(x) == "flux")
            if (length(x@data) > 0) {
              message("Data:")
              x_tag <- names(x@data_tags)
              x_mat <- utils::head.matrix(x@data)
              if (ncol(x_mat) == length(x_tag)) {
                colnames(x_mat) <- x_tag
              } else {
                cat("Tags mismatch, not printing.")
              }
              print(utils::head.matrix(x_mat))
            } else {
              message("Raw data:")
              for (i in 1:length(x@raw_data)) {
                cat("File:", flux_data@source_files[i], "\n")
                print(head(x@raw_data[[i]]))
              }
            }
            message("Metadata:")
            x_df <- as.data.frame(x@metadata)
            # Copied utils::head.data.frame below, but
            # added some style for consistency.
            stopifnot(class(x_df) == "data.frame")
            stopifnot(length(n) == 1L)
            if (n < 0L) {
              n <- max(nrow(x_df) + n, 0L)
            } else {
              n <- min(n, nrow(x_df))
            }
            return(x_df[seq_len(n), , drop = FALSE])
          }
)
#' @describeIn flux Abbreviated flux structure information.
setMethod("str",
          signature(object = "flux"),
          function (object, ...) {
            stopifnot(class(object) == "flux")
            if (length(object@data) < 1) {
              utils::str(object@raw_data)
            } else {
              utils::str(object@data)
            }
            stop("I'll get to this later...")
          }
)