Skip to content

Commit 1c4eec7

Browse files
ma-z-amma-z-am
committed
Add possibility to add POIs and include csv for Berlin POI data.For legend of POIs a counter is described by poiType_counter() as a closure function
1 parent 49826dc commit 1c4eec7

9 files changed

Lines changed: 500 additions & 1 deletion

File tree

‎DESCRIPTION‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -23,3 +23,4 @@ Imports:
2323
Encoding: UTF-8
2424
Roxygen: list(markdown = TRUE)
2525
RoxygenNote: 7.3.3
26+
LazyData: true

‎NAMESPACE‎

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2,11 +2,12 @@
22

33
export(Berlin_add_boarder)
44
export(Berlin_add_catchments)
5+
export(Berlin_add_poi)
56
export(Berlin_add_waterbodies)
67
export(QSIM_prepare)
78
export(QSIM_prepare_multiple)
9+
export(add_POI)
810
export(add_coloredRivers)
9-
export(add_districts)
1011
export(add_inflow)
1112
export(add_logo)
1213
export(add_qsimVis_id)
@@ -50,6 +51,8 @@ importFrom(graphics,points)
5051
importFrom(graphics,polygon)
5152
importFrom(graphics,rasterImage)
5253
importFrom(graphics,rect)
54+
importFrom(graphics,strheight)
55+
importFrom(graphics,strwidth)
5356
importFrom(graphics,text)
5457
importFrom(methods,as)
5558
importFrom(methods,is)
@@ -58,5 +61,6 @@ importFrom(stats,quantile)
5861
importFrom(stats,sd)
5962
importFrom(utils,View)
6063
importFrom(utils,data)
64+
importFrom(utils,read.csv)
6165
importFrom(utils,read.table)
6266
importFrom(utils,unstack)

‎R/add_POI.R‎

Lines changed: 58 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,58 @@
1+
#' Add a point of interest (POI) with a labeled marker on a plot
2+
#'
3+
#' This function plots a "Point of Interest" (POI) at the specified latitude and longitude on the current plot.
4+
#' It adds a colored triangular marker and an optional text label. If the label extends beyond the plot boundary,
5+
#' its position is automatically adjusted to remain visible. The function is designed for use in spatial or map-based plotting contexts.
6+
#'
7+
#' @param lat,lon Numeric. Latitude (y-coordinate) and longitude (x-coordinate)
8+
#' of the POI.
9+
#' @param pch Point type of POI
10+
#' @param lineColor,fillColor Character string or [rgb()] for the frame and fill
11+
#' color of the POI, respectively
12+
#' @param textbg Background color for text, if a title is provided
13+
#' @param title Character. Text label to display next to the POI marker.
14+
#' Default is an empty string.
15+
#' @param cex A factor of the point size
16+
#'
17+
#' @details
18+
#' The function calculates text dimensions to draw a rectangular background behind the label and places
19+
#' the text and marker such that they fit within the plot region.
20+
#' The marker is drawn using pch = 25 (downward-pointing triangle).
21+
#'
22+
#' @return Invisibly returns NULL. The function is called for its side effects (adding graphics to an existing plot).
23+
#'
24+
#' @seealso [points()], [text()], [rect()]
25+
#'
26+
#' @importFrom graphics strheight strwidth
27+
#' @export
28+
#'
29+
add_POI <- function(
30+
lat, lon, pch = 25, lineColor = "white", fillColor = "blue",
31+
textbg = rgb(1, 1, 1, 0.5), title = "", cex = 1.5
32+
){
33+
x <- lon
34+
y <- lat
35+
if(title != ""){
36+
x_width <- strwidth(paste0(" ", title, " "))
37+
x_offset <- strwidth("M", cex = 1)
38+
y_width <- strheight(title, cex = 1.3)
39+
40+
x_right <- x + x_width
41+
if(x_right > par("usr")[2]){
42+
pos <- 2
43+
rect(xleft = lon - x_width - 0.5 * x_offset, xright = lon,
44+
ybottom = lat - y_width / 2, ytop = lat + y_width / 2,
45+
col = textbg, border = NA)
46+
} else {
47+
pos <- 4
48+
rect(xleft = lon, xright = lon + x_width + 0.5 * x_offset,
49+
ybottom = lat - y_width / 2, ytop = lat + y_width / 2,
50+
col = textbg, border = NA)
51+
}
52+
text(x = lon, y = lat, pos = pos, labels = title)
53+
}
54+
points(
55+
x = lon, y = lat,
56+
pch = pch, cex = cex,
57+
col = lineColor, bg = fillColor, lwd = 2)
58+
}

‎R/berlin.R‎

Lines changed: 282 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,282 @@
1+
#' Add Berlin combined sewer catchments to a map
2+
#'
3+
#' Polygons are drawn in different types of gray
4+
#' @param plot_names If TRUE, names of the districts will be included in the plot
5+
#' @param highlight_catchments Character vector containing the catchments names
6+
#' of catchments to be highlighted
7+
#' @param highlight_style Either "shaded" (default) or a specific color, which
8+
#' cab also be defined by [rgb()]
9+
#'
10+
#' @importFrom graphics polygon abline text
11+
#' @export
12+
#'
13+
Berlin_add_catchments <- function(
14+
plot_names = FALSE, highlight_catchments = NULL, highlight_style = "shaded"
15+
){
16+
ezg <- NULL
17+
load(file.path(system.file(package = "qsimVis"),
18+
"extdata/berlin_data/catch_polygon.RData"))
19+
20+
if(plot_names){
21+
ezg_namePositions <- lapply(ezg, function(loc_df) {
22+
data.frame("x" = mean(loc_df[,1]), "y" = mean(loc_df[,2]))
23+
})
24+
25+
ezg_namePositions$`Bln II`$y <- ezg_namePositions$`Bln II`$y - 0.01
26+
ezg_namePositions$`Bln III`$x <- ezg_namePositions$`Bln III`$x + 0.01
27+
ezg_namePositions$`Bln III`$y <- ezg_namePositions$`Bln III`$y - 0.003
28+
ezg_namePositions$`Bln IIIa`$x <- ezg_namePositions$`Bln IIIa`$x - 0.01
29+
ezg_namePositions$`Bln IIIa`$y <- ezg_namePositions$`Bln IIIa`$y - 0.04
30+
ezg_namePositions$`Bln VIII`$x <- ezg_namePositions$`Bln VIII`$x + 0.005
31+
ezg_namePositions$`Bln VIII`$y <- ezg_namePositions$`Bln VIII`$y + 0.005
32+
ezg_namePositions$`Bln IX`$x <- ezg_namePositions$`Bln IX`$x + 0.005
33+
ezg_namePositions$`Bln IX`$y <- ezg_namePositions$`Bln IX`$y + 0.005
34+
ezg_namePositions$`Bln IX`$y <- ezg_namePositions$`Bln IX`$y + 0.005
35+
ezg_namePositions$`Bln XI`$x <- ezg_namePositions$`Bln XI`$x - 0.013
36+
ezg_namePositions$`Chb I`$y <- ezg_namePositions$`Chb I`$y - 0.005
37+
ezg_namePositions$`Chb Ia`$y <- ezg_namePositions$`Chb Ia`$y + 0.02
38+
ezg_namePositions$`Chb Ia`$x <- ezg_namePositions$`Chb Ia`$x - 0.08
39+
ezg_namePositions$`Chb III`$y <- ezg_namePositions$`Chb III`$y + 0.002
40+
ezg_namePositions$`Ruh`$x <- ezg_namePositions$`Ruh`$x + 0.015
41+
ezg_namePositions$`Spa1`$x <- ezg_namePositions$`Spa1`$x - 0.008
42+
ezg_namePositions$`Wil`$y <- ezg_namePositions$`Wil`$y + 0.01
43+
}
44+
45+
if(length(highlight_catchments) > 0L){
46+
wrong_names <- !(highlight_catchments %in% names(ezg))
47+
if(any(wrong_names)){
48+
warning(paste(highlight_catchments[wrong_names], collapse = ", "),
49+
": no defined catchment name(s) -> will not be highlighted")
50+
}
51+
}
52+
53+
colCircle <- rep(paste0("gray",c(60,70,80,90)), 10)
54+
for(i in seq_along(ezg)){
55+
col <- colCircle[i]
56+
shading <- NULL
57+
if(names(ezg)[i] %in% highlight_catchments){
58+
if(highlight_style == "shaded"){
59+
shading <- 30
60+
} else {
61+
col <- highlight_style
62+
}
63+
}
64+
polygon(x = ezg[[i]][,1], y = ezg[[i]][,2], col = col, density = shading)
65+
if(plot_names){
66+
text(x = ezg_namePositions[[i]]$x, y = ezg_namePositions[[i]]$y,
67+
labels = names(ezg_namePositions)[i])
68+
69+
}
70+
71+
}
72+
73+
if(plot_names){
74+
lines(
75+
x = c(ezg_namePositions$`Chb Ia`$x + 0.012, min(ezg$`Chb Ia`[,1]) + 0.004),
76+
y = c(ezg_namePositions$`Chb Ia`$y - 0.002, max(ezg$`Chb Ia`[,2]) - 0.002))
77+
lines(
78+
x = c(ezg_namePositions$`Bln IIIa`$x, mean(ezg$`Bln IIIa`[,1]) + 0.0005),
79+
y = c(ezg_namePositions$`Bln IIIa`$y + 0.002, mean(ezg$`Bln IIIa`[,2])))
80+
}
81+
abline(v = par("usr")[1:2])
82+
abline(h = par("usr")[3:4])
83+
84+
}
85+
86+
#' Add Berlin boarder to a map
87+
#'
88+
#' Polygons is drawn in lightgray
89+
#' @param bg_color Character string or [rgb()] for the polygon background color
90+
#' @param frame The color of the polygon frame. If NA, no frame will be drawn.
91+
#'
92+
#' @importFrom graphics polygon
93+
#' @export
94+
#'
95+
Berlin_add_boarder <- function(bg_color = "gray60", frame = "black"){
96+
geo <- load_geo(region = "berlin", Rdata_file = "berlin_boarder")
97+
polygon(
98+
x = geo$gis_coordinates[,"X"],
99+
y = geo$gis_coordinates[,"Y"],
100+
col = bg_color, border = frame
101+
)
102+
}
103+
104+
#' Add Berlin boarder to a map
105+
#'
106+
#' Polygons is drawn in lightgray
107+
#' @param bg_color Character string or [rgb()] for the polygon background color
108+
#'
109+
#' @importFrom graphics polygon
110+
#' @export
111+
#'
112+
Berlin_add_waterbodies <- function(bg_color = "lightblue"){
113+
geo <- load_geo(region = "berlin", Rdata_file = "berlin_waterbodies_ordnung1")
114+
polies <- unique(geo$gis_coordinates[,"L2"])
115+
for(poly in polies){
116+
poly_rows <- geo$gis_coordinates[geo$gis_coordinates[,"L2"] == poly,]
117+
polygon(
118+
x = poly_rows[,"X"],
119+
y = poly_rows[,"Y"],
120+
col = bg_color, border = NA
121+
)
122+
}
123+
}
124+
125+
#' Add Points of interest in Berlin
126+
#'
127+
#' Polygons is drawn in lightgray
128+
#' @param poiType One of the types defined in the poi-Table ("wwtp", "dwtp", or
129+
#' further manually added types)
130+
#' @param poiTitle A character describing the POI type, which is used as legend
131+
#' text.
132+
#' @param sw_connection If TRUE an arrow is drawn from the POI to i) the point
133+
#' on the map defined by link_longitued and link_latitude or ii) a specified
134+
#' outlet into or inlet from a water body. If both locations are defined, the
135+
#' second one is used.
136+
#' @param plotNames If TRUE, names of the POI will be plotted next to the points
137+
#' @param lineColor,fillColor Character string or [rgb()] for the frame and fill
138+
#' color of the POI, respectively
139+
#' @param pch,pCex The point type (see pch in [plot()]) and size (numeric value)
140+
#' of the POI
141+
#' @param dashed_connection If TRU (and sw_connection is TRUE) the connection
142+
#' line will be a dashed line of both colors, lineColor and fillColor
143+
#' @param legendPosition Position of the legend ("topleft" or "topright").
144+
#' If NULL, no POI legend will be plotted.
145+
#' @param rivers A list of rivers loaded by [prepare_rivers()]. Only needed if
146+
#' connections to surface waters are drawn and defined by river parameters, such
147+
#' as ID and river kilometer.
148+
#'
149+
#' @importFrom graphics strheight
150+
#' @importFrom utils read.csv
151+
#' @export
152+
#'
153+
#'
154+
Berlin_add_poi <- function(
155+
poiType, poiTitle = "", sw_connection = FALSE, plotNames = FALSE, lineColor = "white",
156+
fillColor = "brown", pch = 21, pCex = 1.5, dashed_connection = TRUE,
157+
legendPosition = "topleft", rivers = NULL
158+
){
159+
160+
poi <- read.csv(file = file.path(
161+
system.file(package = "qsimVis"),
162+
"extdata/berlin_data/poi.csv"
163+
), header = TRUE, sep = ";")
164+
165+
df_plot <- poi[poi$type == poiType,]
166+
167+
168+
if(sw_connection){
169+
if(is.null(rivers) & any(df_plot$link_river_id != "")){
170+
stop("In the POI table river IDs and kilometers are given.",
171+
" In that case a list of rivers needs to be provided as argument to this function.")
172+
}
173+
r <- rivers
174+
175+
for(i in 1:nrow(df_plot)){
176+
if(!is.na(df_plot$link_river_id[i]) & !is.na(df_plot$link_river_km[i])){
177+
sw <- df_plot$link_river_id[i]
178+
if(sw %in% names(r)){
179+
r_df <- r[[sw]]$data
180+
closest_location <- order(abs(r_df$km - df_plot$link_river_km[i]))[1]
181+
r_df[closest_location,]
182+
df_plot$link_longitude[i] <- r_df$x[closest_location]
183+
df_plot$link_latitude[i] <- r_df$y[closest_location]
184+
} else {
185+
warning(sw, " is not part of the river IDs and no connection can be drawn")
186+
}
187+
}
188+
if(!is.na(df_plot$link_longitude[i]) & !is.na(df_plot$link_latitude[i])){
189+
lines(x = c(df_plot$x_longitude[i], df_plot$link_longitude[i]),
190+
y = c(df_plot$y_latitude[i], df_plot$link_latitude[i]),
191+
col = fillColor, lwd = 2)
192+
lines(x = c(df_plot$x_longitude[i], df_plot$link_longitude[i]),
193+
y = c(df_plot$y_latitude[i], df_plot$link_latitude[i]),
194+
col = lineColor, lwd = 2, lty = "dotted")
195+
}
196+
}
197+
}
198+
for(i in 1:nrow(df_plot)){
199+
if(plotNames){
200+
add_POI(lat = df_plot$y_latitude[i], lon = df_plot$x_longitude[i],
201+
lineColor = lineColor, fillColor = fillColor,
202+
title = df_plot$name[i], pch = pch, cex = pCex)
203+
} else {
204+
add_POI(lat = df_plot$y_latitude[i], lon = df_plot$x_longitude[i],
205+
lineColor = lineColor, fillColor = fillColor,
206+
title = "", pch = pch, cex = pCex)
207+
}
208+
}
209+
210+
if(!is.null(legendPosition)){
211+
n <- nTypes()
212+
213+
x_plot_value_range <- diff(par("usr")[1:2])
214+
y_plot_value_range <- diff(par("usr")[3:4])
215+
x_width <- strwidth("A", cex = 1.2)
216+
y_width <- strheight("A", cex = 1)
217+
218+
if(legendPosition == "topright"){
219+
xP <- par("usr")[2] - x_plot_value_range / 10 * 0.2
220+
} else if(legendPosition == "topleft"){
221+
xP <- par("usr")[1] + x_plot_value_range / 10 * 0.2
222+
}
223+
ytop <- par("usr")[4] - y_plot_value_range / 10 * 0.2
224+
225+
points(
226+
x = xP, y = ytop - (n -1) * y_width * 1.5,
227+
pch = pch, cex = pCex,
228+
col = lineColor, bg = fillColor, lwd = 2)
229+
230+
if(legendPosition == "topleft"){
231+
text(
232+
x = xP + x_width,
233+
y = ytop - (n -1) * y_width * 1.5,
234+
labels = poiTitle,
235+
pos = 4)
236+
} else if(legendPosition == "topright"){
237+
text(
238+
x = xP - x_width,
239+
y = ytop - (n -1) * y_width * 1.5,
240+
labels = poiTitle,
241+
pos = 2
242+
)
243+
}
244+
}
245+
}
246+
247+
#' Create a counter for the number of added points
248+
#'
249+
#' Creates a closure that keeps track of how many times it has been incremented.
250+
#' Calling the returned function without `reset = TRUE` increases the counter by
251+
#' one and returns the updated value. If `reset = TRUE`, the counter is reset to
252+
#' zero.
253+
#'
254+
#' @return A function that increments or resets an internal counter.
255+
#' @examples
256+
#' counter <- qsimVis:::poiType_counter()
257+
#' counter() # 1
258+
#' counter() # 2
259+
#' counter(TRUE) # 0
260+
#'
261+
poiType_counter <- function() {
262+
n <- 0 # Local state inside the closure
263+
264+
function(reset = FALSE) {
265+
n <<- if (!reset) {
266+
n + 1
267+
} else {
268+
0
269+
}
270+
return(n)
271+
}
272+
}
273+
274+
#' Counter function instance
275+
#'
276+
#' A function created by `poiType_counter()` that keeps track of the number of
277+
#' added points.
278+
#' @param reset If `TRUE`, the internal counter is reset to 0. If `FALSE` (default),
279+
#'
280+
#' @return A function with an internal counter.
281+
#'
282+
nTypes <- poiType_counter()

‎inst/extdata/berlin_data/poi.csv‎

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,10 @@
1+
type;name;x_longitude;y_latitude;link_longitude;link_latitude;link_river_id;link_river_km
2+
wwtp;KA Ruhleben;13.23225321;52.53158651;13.225601760489246;52.53385962214757;;
3+
wwtp;KA Ruhleben;13.23225321;52.53158651;13.305434746878896;52.42357612260182;;
4+
wwtp;KA Stahnsdorf;13.24586253;52.37576922;;;;
5+
wwtp;KA Münchehofe;13.65923931;52.48793154;;;;
6+
wwtp;KA Schönerlinde;13.41541749;52.66086029;;;;
7+
wwtp;KA Schönerlinde;13.41541749;52.66086029;;;;
8+
wwtp;KA Waßmannsdorf;13.46827876;52.38368496;;;TeK;36
9+
dwtp;WW Tegel;13.26554469;52.5761761;;;;
10+
dwtp;WW Friedrichshagen;13.64806107;52.45319514;;;;

0 commit comments

Comments
 (0)