Merge pull request #67 from KWB-R/dev

Release v0.14.0

Author: hsonne

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: fhpredict
 Title: R Package for the Project Flusshygiene
-Version: 0.13.0
+Version: 0.14.0
 Authors@R:
     c(person(given = "Wolfgang",
              family = "Seis",
@@ -66,5 +66,5 @@ Remotes:
     github::cloudyr/aws.s3@v0.3.12
 Encoding: UTF-8
 LazyData: true
-RoxygenNote: 6.1.1
+RoxygenNote: 7.1.0
 VignetteBuilder: knitr

NEWS.md

@@ -1,3 +1,14 @@
+# fhpredict latest developments
+
+# fhpredict 0.14.0 (2020-05-28)
+
+* Fix bug in api_replace_predictions(): do not fail on missing data in db
+* Fix bug in get_indipendent_variables(): use all.vars()
+* predict_quality(): Add argument "return_debug_info"
+* provide_input_data():
+    + Add argument "require_hygiene"
+    + Actually return purification plant and generic time series
+
 # fhpredict 0.13.0 (2020-04-10)
 
 * Let predict_quality() not delete all existing predictions before adding the 

R/predict.R

@@ -48,7 +48,11 @@ api_replace_predictions <- function(user_id, spot_id, percentiles)
   predictions_db <- api_get_timeseries(path)
 
   # Date strings of the predictions in the database
-  date_strings_db <- format(get(predictions_db, "dateTime"), "%Y-%m-%d")
+  date_strings_db <- if (nrow(predictions_db)) {
+    format(get(predictions_db, "dateTime"), "%Y-%m-%d")
+  } else {
+    character()
+  }
 
   # Date strings of the new predictions
   date_strings_new <- as.character(get(percentiles, "dateTime"))

R/predict_quality.R

@@ -16,15 +16,25 @@
 #'   of the time period to be predicted. Default: "tomorrrow"
 #' @param import logical telling whether to import new rain data or not.
 #'   Default: \code{TRUE}.
-#' @return list with elements \code{data}, \code{success}, \code{message}
+#' @param return_debug_info logical with default \code{FALSE}. If \code{TRUE}
+#'   the prediction is not written to the database. Instead, what would be send
+#'   to the database is returned with all relevant variables that were used to
+#'   prepare the prediction being set as attributes.
+#' @return list with elements \code{data}, \code{success}, \code{message} or (if
+#'   \code{return_debug_info = TRUE}) data frame representing the predictions
+#'   with attributes \code{spot_data}, \code{riverdata_raw}, \code{riverdata},
+#'   \code{newdata_raw}, \code{newdata}, \code{prediction} representing
+#'   intermediate variables that were used to prepare the prediction  (see
+#'   source code of \code{fhpredict::predict_quality} to understand their
+#'   meaning)
 #' @export
 predict_quality <- function(
-  user_id, spot_id, from = Sys.Date() - 1L, to = Sys.Date() + 1L, import = TRUE
+  user_id, spot_id, from = Sys.Date() - 1L, to = Sys.Date() + 1L, import = TRUE,
+  return_debug_info = FALSE
 )
 {
   #kwb.utils::assignPackageObjects("fhpredict")
-  #user_id=8;spot_id=43;from=Sys.Date()-1L;to=Sys.Date()+1L;import=TRUE
-  #user_id=9;spot_id=41
+  #user_id=11;spot_id=57;from=Sys.Date()-1L;to=Sys.Date()+1L;import=FALSE
 
   # Try to get the model that was added last (if any)
   model <- try(get_last_added_model(user_id, spot_id))
@@ -45,7 +55,7 @@ predict_quality <- function(
     }
 
     # Collect all data that are available for the given bathing spot
-    spot_data <- provide_input_data(user_id, spot_id)
+    spot_data <- provide_input_data(user_id, spot_id, require_hygiene = FALSE)
 
     # Prepare the data (filter for bathing season, log-transform rain)
     riverdata_raw <- prepare_river_data(spot_data)
@@ -101,6 +111,19 @@ predict_quality <- function(
     #   data = percentiles
     # )
 
+    if (return_debug_info) {
+
+      return(structure(
+        percentiles,
+        spot_data = spot_data,
+        riverdata_raw = riverdata_raw,
+        riverdata = riverdata,
+        newdata_raw = newdata_raw,
+        newdata = newdata,
+        prediction = prediction
+      ))
+    }
+
     api_replace_predictions(user_id, spot_id, percentiles)
   })
 

R/provide_input_data.R

@@ -6,10 +6,15 @@
 #'
 #' @param user_id user id
 #' @param spot_id bathing spot id
+#' @param require_hygiene logical. If \code{TRUE} (default) the function will
+#'   raise an error if there are no hygienic data
 #' @export
 #'
-provide_input_data <- function(user_id, spot_id)
+provide_input_data <- function(user_id, spot_id, require_hygiene = TRUE)
 {
+  #kwb.utils::assignPackageObjects("fhpredict")
+  #user_id=11;spot_id=57
+
   # Define shortcut to kwb.utils::selectColumns()
   get <- kwb.utils::selectColumns
 
@@ -24,11 +29,9 @@ provide_input_data <- function(user_id, spot_id)
 
   # Add microbiological measurements to the result or return if there are no
   # measurements
-  if (nrow(measurements) == 0) {
-    clean_stop(get_text(
-      "no_measurements", user_id = user_id, spot_id = spot_id
+  if (nrow(measurements) == 0 && require_hygiene) clean_stop(
+    get_text("no_measurements", user_id = user_id, spot_id = spot_id
     ))
-  }
 
   # Create "hygiene" data frame
   result[[result_element("hygiene")]] <- data.frame(
@@ -72,15 +75,27 @@ provide_input_data <- function(user_id, spot_id)
     )
   }
 
-  # Look for purification plant measurements
-  plant_measurements <- collect_series_measurements(
-    type = "plant", prefix = "ka", user_id, spot_id
-  )
+  # Helper function to add further list entries (or not if length(x) == 0)
+  add_series <- function(result, type, prefix, x) {
 
-  # Look for generic input measurements
-  generic_measurements <- collect_series_measurements(
-    type = "generic", prefix = "gen", user_id, spot_id
-  )
+    x <- collect_series_measurements(type, prefix, user_id, spot_id)
+
+    if (length(x)) {
+
+      result[[result_element(prefix)]] <- kwb.utils::renameColumns(
+        merge_series_measurements(x),
+        list(dateTime = "datum")
+      )
+    }
+
+    result
+  }
+
+  # Add purification plant measurements if there are any
+  result <- add_series(result, type = "plant", prefix = "ka")
+
+  # Add generic input measurements if there are any
+  result <- add_series(result, type = "generic", prefix = "gen")
 
   # Rename the elements in the result data frame?
 
@@ -115,3 +130,19 @@ collect_series_measurements <- function(type, prefix, user_id, spot_id)
     )
   }
 }
+
+# merge_series_measurements ----------------------------------------------------
+merge_series_measurements <- function(x)
+{
+  stopifnot(is.list(x))
+
+  merged <- kwb.utils::mergeAll(
+    lapply(x, kwb.utils::removeColumns, "id"),
+    by = "dateTime",
+    all = TRUE
+  )
+
+  names(merged) <- gsub("^value\\.", "", names(merged))
+
+  merged
+}

R/utils.R

@@ -207,7 +207,7 @@ get_indipendent_variables <- function(x)
 {
   stopifnot(rlang::is_formula(x))
 
-  unlist(lapply(x[[3L]][-1L], as.character))
+  all.vars(x)[-1L]
 }
 
 # get_prefix -------------------------------------------------------------------