sapflux: Analyze Sapflux Traces

#' @title Loads sapflux parameters
#' @description
#'
#' Parameters can be set in the "./data/sapflux_datatype_defaults.csv"
#' file that are associated with datatypes - this includes units as well
#' as processing parameters.
#'
#' @param flux    Input 'flux' object, required to pull out the datatype.
#'
#' @return A named numeric vector of the parameter values.
#'
#' @family utils
#' @keywords internal
#' @examples
#' function.defaults <- LoadDefaults(fluxdata)
#' # Pull out the highest value allowed for the datatype -
#' # FluxProcess will kill any values higher than this as
#' # obvious outliers, e.g. >40C dT for datatype = "temperatures"
#' maxT <- function.defauts['maximum']
LoadDefaults <- function(flux = NULL) {
  # Find package directory
  path_revert <- getwd()
  on.exit(expr = setwd(path_revert))
  setwd(find.package("sapflux"))
  # Import the data tables
  datatype_defaults <- read.csv("sapflux_datatype_defaults.csv",
                                stringsAsFactors = FALSE)
  if (length(flux) < 1) {
    return(datatype_defaults)
  }
  datatype <- slot(object = flux, name = "datatype")
  # Fix for multiple-datatypes?
  params = data.frame(matrix(nrow = 0, ncol = 6))
  for (i in 1:length(datatype)) {
    params_row <- datatype_defaults[which(
      datatype_defaults$datatype == datatype[i]
    ),]
    params <- rbind(params, params_row)
  }
  stopifnot(
    colnames(params) == c(
      "datatype", "column_tag", "units", "reasonable_max",
      "maximum", "minimum"
    )
  )
  return(params)
}
#' @title Compute thermocouple coefficients
#'
#' @description
#'
#' Computes the Seebeck coefficient of a Type-T thermocouple junction.
#'
#' @details
#' A regression is carried out on NIST tabular data (0-40 deg C) and the
#' coefficients are used to compute a coefficient from the input.
#'
#' The relationship between reference probe temperature and coefficient is
#' empirical, but here the relationship is estimated.
#'
#' @param C Temperature of reference thermocouple junction, in deg C
#'
#' @family utils
#' @keywords internal
#' @examples
#' Seebeck(0.4)
#' Seebeck(12.2)
CalcSeebeck <- function(C) {
  typeT <- c(
    0.038748, 0.038815, 0.038884, 0.038953, 0.039024,
    0.039095, 0.039168, 0.039242, 0.039316, 0.039391,
    0.039468, 0.039545, 0.039622, 0.039701, 0.039780,
    0.039859, 0.039939, 0.040020, 0.040101, 0.040183,
    0.040265, 0.040348, 0.040431, 0.040515, 0.040598,
    0.040682, 0.040767, 0.040851, 0.040936, 0.041021,
    0.041106, 0.041192, 0.041277, 0.041363, 0.041449,
    0.041534, 0.041620, 0.041706, 0.041792, 0.041878
    )
  typeT.lm <- lm(typeT ~ c(1:40))
  coeffs <- coefficients(typeT.lm)
  seebeck <- as.numeric(coeffs[1] + coeffs[2] * C)
  return(seebeck)
}
#' @describeIn GranierConversions Granier's original 1987 conversion factor
#' @family zero
#' @keywords internal
GranierEqn <- function(K) {
  # See Granier 1985, 1987 for full methods
  # Species used for this calibration:
  # Pseudotsuga menzeisii
  # Pinus nigra
  # Quercus pedunculata
  a <- 0.000119
  b <- 1.231
  u <- a * (K ^ b)
  return(u)
}
#' @keywords internal
#' @family utils
DiameterToArea <- function(diameter) {
  area <- pi * ((diameter / 2) ^ 2)
  return(area)
}
#' @keywords internal
EllipseToCircle <- function(large, small) {
  stopifnot(
    is.numeric(large),
    is.numeric(small),
    length(large) == length(small)
    )
  for (i in length(large)) {
    if (large[i] < small[i]) {
      new.large <- small[i]
      new.small <- large[i]
      large[i] <- new.large
      small[i] <- new.small
    }
  }
  ellipseArea <- pi * large * small
  circleDiam <- 2 * sqrt(ellipseArea / pi)
  return(circleDiam)
}
#' @keywords internal
#' @family utils
MergeFluxByMetadata <- function(flux, from, to, weights) {
  # Pull slots
  validObject(flux)
  data      <- slot(object = flux, name = "data")
  datatype  <- slot(object = flux, name = "datatype")
  data.tags <- slot(object = flux, name = "data.tags")
  metadata  <- slot(object = flux, name = "metadata")
  # Load the datatype table
  defaults <- LoadDefaults()
  defaults <- defaults[, 1:2]
  stopifnot(
    to   %in% defaults[["datatype"]],
    from %in% defaults[["datatype"]]
    )
  to       <- which(defaults[["datatype"]] == to)
  from     <- which(defaults[["datatype"]] == from)
  to.col   <- defaults[to, which(colnames(defaults) == "column_tag")]
  from.col <- defaults[from, which(colnames(defaults) == "column_tag")]
  # Check other inputs ####
  stopifnot(
    length(weights) == 1,
    is.character(weights),
    length(metadata[[from.col]]) == length(metadata[[to.col]]),
    length(metadata[[from.col]]) == length(metadata[[weights]]),
    to == (from + 1),
    to.col != from.col
  )
  # Prep the vectors ####
  to.datatype <- defaults[["datatype"]][to]
  # New tags to be assigned the merged data:
  to.tags <- as.character(unique(metadata[[to.col]]))
  # List of previous tags associated with their soon-to-be new tag:
  from.tags <- vector(mode = "list", length = length(to.tags))
  for (i in 1:length(to.tags)) {
    from.tags[[i]] <-
      metadata[[from.col]][which(metadata[[to.col]] == to.tags[i])]
  }
  names(from.tags) <- to.tags
  # This 'stopifnot' will check for extraneous/improperly assigned tags relative
  # to the metadata.
  stopifnot(length(unlist(data.tags)) == length(unique(unlist(from.tags))))
  # Merge the data by 'to' and scale according to 'weights' ####
  data.return <- matrix(data = NA, nrow = nrow(data), ncol = length(to.tags))
  data.tags.return <- vector(mode = "character", length = length(to.tags))
  for (i in 1:length(to.tags)) {
    from.index <- which(data.tags[[1]] %in% from.tags[[i]])
    if (length(from.index) > 1) {
      from.sub <- data[, which(data.tags[[1]] %in% from.tags[[i]])]
      weight.sub <- metadata[[weights]][which(data.tags[[1]] %in% from.tags[[i]])]
      from.sub <- apply(from.sub, 1, function(x) {
        weighted.sub <- weighted.mean(x = x, w = weight.sub, na.rm = TRUE)
        return(weighted.sub)
      })
      data.return[, i] <- from.sub
    } else {
      data.return[, i] <- data[, from.index]
    }
    data.tags.return[i] <- to.tags[i]
  }
  # Update slot variables
  data <- data.return
  data.tags <- list(data.tags.return)
  names(data.tags) <- to.col
  log.message <- paste("NULL\n")
  log <- c(slot(flux, "log"), log.message)
  slot(flux, "log")       <- log
  slot(flux, "data")      <- data.return
  slot(flux, "data.tags") <- data.tags
  slot(flux, "datatype")  <- to.datatype
  return(flux)
}
#' @keywords internal
#' @family utils
SetFileInfo <- function(st) {
  # Sets the read.table() parameters for ImportRawFlux.
  stopifnot(st %in% c('CampbellSci', 'csv', 'tab'))
  if (st == 'CampbellSci') {
    vals <- list(
      sep = ',',
      header = FALSE,
      skip = 4,
      row.names = NULL,
      na.strings = c(NA, NaN, "", " ", "  ", "   "),
      #colClasses = c("character", "NULL", ...)
      stringsAsFactors = FALSE
    )
  }
  if (st == 'csv') {
    vals <- list(
      sep = ',',
      header = TRUE,
      skip = 0,
      row.names = NULL,
      na.strings = c(NA, NaN, "", " ", "  ", "   "),
      stringsAsFactors = FALSE
    )
  }
  if (st == 'tab') {
    vals <- list(
      sep = "\t",
      header = TRUE,
      skip = 0,
      row.names = NULL,
      na.strings = c(NA, NaN, "", " ", "  ", "   "),
      stringsAsFactors = FALSE
    )
  }
  return(vals)
}
#' @keywords internal
#' @family utils
SetHeaderInfo <- function(x, st) {
  # Optional header retrieval function for ImportRawFlux.
  if (st == 'CampbellSci') {
    FUN <- function(x) {
      rt <- read.table(file = x, header = F, sep = ',', nrow = 4,
                       fill = T, quote = '', colClasses = 'character')
      ah <- apply(rt, 2, function(x) {
        gsub(pattern = '"', replacement = '', x = x)
      })
      return(ah)
    }
  } else {
    FUN <- function(x) {
      invisible()
    }
  }
  return(FUN)
}