ID Problems solved and Berlin Board shape included

DESCRIPTION

@@ -15,8 +15,6 @@ Depends:
 Suggests: 
     covr
 Imports:
-    writexl,
-    readxl,
     geosphere,
     ggmap
 Encoding: UTF-8

NAMESPACE

@@ -1,20 +1,26 @@
 # Generated by roxygen2: do not edit by hand
 
+export(Berlin_add_boarder)
 export(QSIM_prepare)
+export(add_catchments)
 export(add_coloredRivers)
+export(add_districts)
 export(add_inflow)
-export(add_polygons)
+export(add_site_info)
 export(adverse_deviation_from_reference)
 export(critical_events)
 export(deviating_hours)
+export(extend_riverTable)
 export(filter_parameter_data)
 export(getDimensions)
+export(insert_downstreamNA)
 export(interpolate_multipleNA)
+export(load_geo)
 export(load_rivers)
 export(load_timeframes)
 export(plot_empty_map)
 export(qsim_to_verknet_id)
-export(save_as_excel)
+export(site_info_from_qsimID)
 import(ggmap)
 importFrom(geosphere,distHaversine)
 importFrom(grDevices,dev.new)
@@ -29,4 +35,3 @@ importFrom(graphics,polygon)
 importFrom(utils,data)
 importFrom(utils,read.table)
 importFrom(utils,unstack)
-importFrom(writexl,write_xlsx)

R/add_coloured_rivers.R

@@ -1,9 +1,9 @@
 #' Adds colour scaled riverdata to a map
 #'
-#' @param rivers A list of rivers loaded with [load_rivers()]
+#' @param ext_rivers A list of rivers loaded with [load_rivers()] and extended
+#' with [extend_riverTable()]
 #' @param aggregated_data A dataframe created by one of [deviating_hours()],
 #' [adverse_deviation_from_reference()] or [critical_events()]
-#' @param varName The column name of the agregated data in the output_table
 #' @param sixBreaks Breaks defining the lower limits of the categories.
 #' @param dataType Used only for the Legend. If "time" is used, it is assumed
 #' that the first water quality category is between 0 and a value above 0, while
@@ -15,25 +15,15 @@
 #' @export
 #'
 add_coloredRivers <- function(
-    rivers, aggregated_data, sixBreaks, varName, dataType = "time",
-    LegendTitle = dataType, LegendLocation ="right"
+    ext_rivers,
+    aggregated_data,
+    sixBreaks,
+    dataType = "time",
+    LegendTitle = dataType,
+    LegendLocation ="right"
 ){
 
-  # if data frame was not stored and loaded qsim sites must added.They correspond
-  # to the rownames of the table
-  if(!("river" %in% colnames(aggregated_data))){
-    aggregated_data$qsim_site <- rownames(aggregated_data)
-  }
-
-  ext_rivers <- lapply(seq_along(rivers), function(i) {
-    qsimVis:::extend_riverTable(
-      river_table = rivers[[i]],
-      aggregated_data = aggregated_data,
-      varName = varName,
-      sixBreaks = sixBreaks)
-  })
 
-  sixBreaks <- c(sixBreaks, Inf)
   MisaColor <- NULL
   data("MisaColor", envir = environment())
 

R/add_polygons.R

@@ -1,12 +1,32 @@
-#' Add polygons to a map
+#' Load a package geo file
 #'
-#' Polygons are drawn in different types of gray and names are added, without
-#' overlapping the catchment boundaries or any river
+#' in the package geo files are stored as Rdata with three objects
+#' gis_coordinates (geomitries), gis_data (everything except for geometries)
+#' and readme (list of further information)
+#'
+#' @param region The region of Geo data as defined in the package extdata folder
+#' @param Rdata_file The name of the file (without ".RData")
+#'
+#' @export
+#'
+load_geo <- function(region, Rdata_file){
+  load(file.path(
+    system.file(package = "qsimVis"),
+    paste0(
+      "extdata/", region, "_data/", Rdata_file, ".RData")
+  ))
+  rm("region", "Rdata_file")
+  mget(ls())
+}
+
+#' Add Berlin combined sewer catchments to a map
+#'
+#' Polygons are drawn in different types of gray
 #'
 #' @importFrom graphics polygon
 #' @export
 #'
-add_polygons <- function(){
+add_catchments <- function(){
 
   ezg <- NULL
   load(file.path(system.file(package = "qsimVis"),
@@ -21,3 +41,37 @@ add_polygons <- function(){
       col = col)
   }
 }
+
+#' Add Berlin districts to a map
+#'
+#' Polygons are drawn in lightgray
+#'
+#' @importFrom graphics polygon
+#' @export
+#'
+add_districts <- function(){
+  geo <- load_geo(region = "Berlin", Rdata_file = "berlin_boarder")
+  polygon(
+    x = geo$gis_coordinates[,1],
+    y = geo$gis_coordinates[,2],
+    col = "gray80")
+
+}
+
+#' Add Berlin boarder to a map
+#'
+#' Polygons is drawn in lightgray
+#' @param bg_color Character string or [rgb()] for the polygon background color
+#'
+#' @importFrom graphics polygon
+#' @export
+#'
+Berlin_add_boarder <- function(bg_color = "gray80"){
+  geo <- load_geo(region = "Berlin", Rdata_file = "berlin_boarder")
+  polygon(
+    x = geo$gis_coordinates[,"X"],
+    y = geo$gis_coordinates[,"Y"],
+    col = bg_color
+  )
+}
+

R/extend_river_table.R

@@ -0,0 +1,97 @@
+#' Adds quality categories to the river table
+#'
+#' As a result, each location is linked to a water quality value.
+#'
+#' @param rivers List of rivers loaded with [load_rivers()]
+#' @param river_id Character with verknet river ID that is one of the names of
+#' the rivers list
+#' @param aggregated_data A dataframe created by one of [deviating_hours()],
+#' [adverse_deviation_from_reference()] or [critical_events()]
+#' @param varName The column name of the agregated data in the output_table
+#' @param sixBreaks Breaks defining the lower limits of the categories.
+#' @param NA_processing Either "interpolation" or "continuing".
+#' Defines if NA values between two sides are either interpolated (default) or
+#' kept constant based on an upstream value.
+#'
+#' @details
+#' The qsim_misa_table does not provide information for every location within
+#' the river, since the local resolution of the qsim output differs from the
+#' river course data. Values between two known river sites are interpolated.
+#' The color scale cannot be changed. Since in all misa assessment parameters
+#' low values refer to a good water quality, the colors range from green for low
+#' values to red for high values.
+#'
+#' @return
+#' The input river_table extended by three columns: 1) "value" containing the
+#' exact value, 2) "quality" containing 6 different quality categories based on
+#' the defined breaks, 3) "color" assigning th color for plotting
+#'
+#' @importFrom utils data
+#' @export
+#'
+extend_riverTable <- function(
+    rivers, river_id, aggregated_data, varName, sixBreaks,
+    NA_processing = "interpolation"
+){
+
+  river_table <- rivers[[river_id]]
+  # river table needs to be ordered by river km
+  river_table <- river_table[order(river_table$km),]
+
+  MisaColor <- NULL
+  data("MisaColor", envir = environment())
+
+  river_table[["value"]] <- NA
+  # filter results for river id
+  data_table <- aggregated_data[aggregated_data$verknet_river == river_id &
+                                  !is.na(aggregated_data$verknet_river),]
+
+  # apply results to closest verknet node, if not already defined
+  km_verknet <- river_table$km
+  for(i in seq_len(nrow(data_table))){
+    km_result <- data_table$km[i]
+    km_diff <- abs(km_result - km_verknet)
+    node_match <- which(km_diff == min(km_diff))
+    single_node_match <- node_match[which(is.na(river_table$value[node_match]))]
+    if(length(single_node_match) == 1L){
+      river_table$value[single_node_match] <- data_table[[varName]][i]
+    } else if(length(single_node_match) > 1L){
+      river_table$value[single_node_match[1]] <- data_table[[varName]][i]
+    }
+  }
+
+  # if the last and the first verknet node are not defined, use the closest
+  # data node, depennding on distance
+  tolerable_distance <- 0.5 # km
+  if(is.na(river_table$value[1])){
+    first_value <- which(!is.na(river_table$value))[1]
+    if(river_table$km[first_value] - river_table$km[1] < tolerable_distance){
+      river_table$value[1] <- river_table$value[first_value]
+    }
+  }
+
+  l <- nrow(river_table)
+  if(is.na(river_table$value[l])){
+    last_value <- rev(which(!is.na(river_table$value)))[1]
+    if(river_table$km[l] - river_table$km[last_value] < tolerable_distance){
+      river_table$value[l] <- river_table$value[last_value]
+    }
+  }
+
+  river_table$value <-
+    if(NA_processing == "interpolation"){
+      round(interpolate_multipleNA(
+        data_vector = river_table$value,
+        max_na = 1000,
+        diff_x = river_table$distance_to_neighbour)[[1]], 1)
+    } else if(NA_processing == "continuing"){
+      insert_downstreamNA(data_vector = river_table$value)
+    }
+
+  river_table$quality <-
+    cut(river_table$value, breaks = sixBreaks,
+        include.lowest = TRUE, ordered_result = TRUE)
+
+  river_table$color <- MisaColor[as.numeric(river_table$quality)]
+  river_table
+}

R/interpolate_multipleNA.R

@@ -56,3 +56,89 @@ interpolate_multipleNA <- function(
        c("NA's interpolated" = sum(rfi$repeats),
          "NA's in total" =  sum(nas$repeats)))
 }
+
+#' Substitution of one or more missing downstream values
+#'
+#'
+#' @param data_vector Numeric vector of measurements (including NA values).
+#' Values must correspond to ascending river length (from downstream to
+#' upstream site)
+#'
+#' @return
+#' Data vector with substituted NA values
+#'
+#' @export
+#'
+insert_downstreamNA <- function(
+    data_vector
+){
+  nas <- is.na(data_vector)
+  to_fill <- which(nas)
+  by_using <- which(!nas)
+
+  sapply(to_fill, function(x){
+    rank_diff <- (x - by_using)
+    upper_value <- by_using[which(rank_diff < 0)[1]]
+    data_vector[x] <- data_vector[upper_value]
+  })
+}
+
+#' Linear interpolation for one or more missing values
+#'
+#' All sections of NA values that are smaller or equal as a defined maximal
+#' number of NA's are interpolated
+#'
+#' @param data_vector Numeric vector of measurements (including NA values)
+#' @param max_na the maximal number of NA values in a row to be interpolated
+#' @param diff_x (optional) Numeric vector with x value difference corresponding
+#' to the data_vector. Only needed if the difference is not constant.
+#'
+#' @return
+#' A list containing the data vector with interpolated NA value as well as an
+#' information about the amount of NA's interpolated
+#'
+#' @export
+#'
+interpolate_multipleNA <- function(
+    data_vector,
+    max_na,
+    diff_x = NULL
+){
+  # find NA data
+  nas <- same_inarow(v = is.na(data_vector))
+
+  nas <- nas[nas$Value, ]
+
+  # if the first or last is NA, interpolation is not possible
+  rfi <- nas[nas$repeats <= max_na &
+               nas$starts_at != 1 &
+               nas$ends_at != length(data_vector), ]
+
+  if(nrow(rfi) > 0){
+    for(i in 1:nrow(rfi)){
+      beg_i <- rfi$starts_at[i] - 1
+      end_i <- rfi$ends_at[i] + 1
+      before <- data_vector[beg_i]
+      after <- data_vector[end_i]
+
+      new_values <-  if(is.null(diff_x)){
+        # interpolated values
+        seq(before, after, length.out = rfi$repeats[i] + 2)
+
+      } else {
+        x <- cumsum(diff_x[beg_i:end_i])
+        new_values <- (x - min(x)) / diff(range(x)) * (before - after) + after
+      }
+
+      new_values <- new_values[-c(1, length(new_values))]
+
+
+      # Replace NAs
+      data_vector[rfi$starts_at[i]:rfi$ends_at[i]] <- new_values
+    }
+  }
+  list(data_vector,
+       c("NA's interpolated" = sum(rfi$repeats),
+         "NA's in total" =  sum(nas$repeats)))
+}
+

R/load_rivers.R

@@ -51,40 +51,13 @@ load_rivers <- function(aggregated_data){
     qsim_km <- aggregated_data$km[i]
     if(verknet_river %in% names(rivers)){
     site_distance <- abs(rivers[[verknet_river]]$km - qsim_km)
-    nearest_location<- which(site_distance == min(site_distance))
+    nearest_location <- which(site_distance == min(site_distance))
     rivers[[verknet_river]]$qsim_site[nearest_location] <-
-      paste(aggregated_data$river[i],
-            aggregated_data$section[i],
-            aggregated_data$km[i],
-            sep = "_")
+      paste0(aggregated_data$river_name[i], "_",
+            aggregated_data$section_id[i], ".",
+            aggregated_data$section_name[i], "_",
+            aggregated_data$km[i])
     }
   }
-
   rivers
 }
-
-#' Changes Qsim Ids to Verknet IDs
-#'
-#'
-#' @param aggregated_data A dataframe created by one of [deviating_hours()],
-#' [adverse_deviation_from_reference()] or [critical_events()]
-#' @param translation_table Data frame of at least two columns: column number 1:
-#' Verknet ID, column with name "sim_ID": Qsim ID
-#'
-#' @export
-#'
-qsim_to_verknet_id <- function(aggregated_data, translation_table){
-  qsim_ids <- unlist(strsplit(x = translation_table$sim_ID, ","))
-  aggregated_data$verknet_river <- aggregated_data$river
-  for(qsim_id in qsim_ids){
-    df_row <- grep(pattern = qsim_id, x = translation_table$sim_ID)
-    verknet_id <- translation_table[[1]][df_row]
-    aggregated_data$verknet_river <-
-      gsub(
-        pattern = qsim_id,
-        replacement = verknet_id,
-        x = aggregated_data$verknet_river
-      )
-  }
-  aggregated_data
-}