Reorganise repository using standard package layout

1 files changed, 109 insertions, 0 deletions

diff --git a/R/endpoint.R b/R/endpoint.R
new file mode 100644
index 0000000..56a314b
--- /dev/null
+++ b/R/endpoint.R
@@ -0,0 +1,109 @@
+#' Retrieve endpoint information from the chyaml field of a chent object
+#'
+#' R6 class objects of class chent represent chemical entities
+#' and can hold a list of information loaded from a chemical yaml file in their
+#' chyaml field. Such information is extracted and optionally aggregated by
+#' this function.
+#' 
+#' The functions \code{soil_*} are functions to extract soil specific endpoints.
+#' For the Freundlich exponent, the capital letter \code{N} is used in order to
+#' facilitate dealing with such data in R. In pesticide fate modelling, this
+#' exponent is often called 1/n.
+#'
+#' @export
+#' @param chent The chent object to get the information from
+#' @param medium The medium for which information is sought
+#' @param type The information type
+#' @param lab_field If not NA, do we want laboratory or field endpoints
+#' @param redox If not NA, are we looking for aerobic or anaerobic data
+#' @param value The name of the value we want. The list given in the 
+#'   usage section is not exclusive
+#' @param aggregator The aggregator function. Can be mean, 
+#'   \code{\link{geomean}}, or identity, for example.
+#' @param raw Should the number(s) be returned as stored in the chent
+#'   object (could be a character value) to retain original information
+#'   about precision?
+#' @param signif How many significant digits do we want
+#' @return The result from applying the aggregator function to
+#'   the values converted to a numeric vector, rounded to the
+#'   given number of significant digits, or, if raw = TRUE,
+#'   the values as a character value, retaining any implicit
+#'   information on precision that may be present.
+#' 
+endpoint <- function(chent, 
+                     medium = "soil",
+                     type = c("degradation", "sorption"), 
+                     lab_field = c(NA, "laboratory", "field"),
+                     redox = c(NA, "aerobic", "anaerobic"),
+                     value = c("DT50ref", "Kfoc", "N"),
+                     aggregator = geomean,
+                     raw = FALSE,
+                     signif = 3)
+{
+  if (!is(chent, "chent")) {
+    stop("Please supply a chent object as created using the package 'chents' available from jrwb.de")
+  }
+  ep_list <- chent$chyaml[[medium]][[type]] 
+  if (!is.na(lab_field[1])) {
+    ep_list <- ep_list[[lab_field]]
+  }
+  if (!is.na(redox[1])) {
+    ep_list <- ep_list[[redox]]
+  }
+  values <- ep_list$data[[value]]
+  if (raw) return(values)
+  else return(signif(aggregator(as.numeric(values)), signif))
+}
+
+#' @inheritParams endpoint
+#' @rdname endpoint
+#' @export
+soil_DT50 <- function(chent, aggregator = geomean, signif = 3, 
+                      lab_field = "laboratory", value = "DT50ref",
+                      redox = "aerobic", raw = FALSE) {
+  ep <- endpoint(chent, medium = "soil", type = "degradation", 
+                 lab_field = "laboratory", redox = redox,
+                 signif = signif,
+                 value = value, aggregator = aggregator, raw = raw)
+  return(ep)
+}
+
+#' @inheritParams endpoint
+#' @rdname endpoint
+#' @export
+soil_Kfoc <- function(chent, aggregator = geomean, signif = 3, 
+                      value = "Kfoc", raw = FALSE) {
+  ep <- endpoint(chent, medium = "soil", type = "sorption", 
+                 signif = signif,
+                 value = value, aggregator = aggregator, raw = raw)
+  return(ep)
+}
+
+#' @inheritParams endpoint
+#' @rdname endpoint
+#' @export
+soil_N <- function(chent, aggregator = mean, signif = 3, raw = FALSE) {
+  ep <- endpoint(chent, medium = "soil", type = "sorption", 
+                 signif = signif,
+                 value = "N", aggregator = aggregator, raw = raw)
+  return(ep)
+}
+
+#' @inheritParams endpoint
+#' @rdname endpoint
+#' @param values The values to be returned
+#' @param aggregators A named vector of aggregator functions to be used
+#' @export
+soil_sorption <- function(chent, values = c("Kfoc", "N"), 
+                          aggregators = c(Kfoc = geomean, Koc = geomean, N = mean), 
+                          signif = c(Kfoc = 3, N = 3),
+                          raw = FALSE) {
+  res <- sapply(values, 
+                function(x) {
+                  endpoint(chent, medium = "soil", type = "sorption",
+                           signif = signif[[x]],
+                           value = x, aggregator = aggregators[[x]], raw = raw)
+                }
+  )
+  return(res)
+}