Vignette Rmd source code
main rdwd vignette
Interactive map vignette
Clausius-Clapeyron scaling holds even for very high temperatures, we just don’t have enough data yet to have observed the expected extreme rainfall intensities.
Code (with a much older version of rdwd
, might not run out of the box any more): https://github.com/brry/prectemp/blob/master/Code_analysis.R
Publication: http://www.nat-hazards-earth-syst-sci-discuss.net/nhess-2016-183
library(rdwd)
links <- selectDWD(res="daily", var="more_precip", per="hist")
length(links) # ca 5k stations - would take very long to download
## [1] 5930
# select only the relevant files:
data("metaIndex")
myIndex <- metaIndex[
metaIndex$von_datum < 20140101 &
metaIndex$bis_datum > 20161231 & metaIndex$hasfile , ]
data("fileIndex")
links <- fileIndex[
suppressWarnings(as.numeric(fileIndex$id)) %in% myIndex$Stations_id &
fileIndex$res=="daily" &
fileIndex$var=="more_precip" &
fileIndex$per=="historical" , "path" ]
length(links) # 2001 elements - much better
## [1] 2142
If some downloads fail (mostly because you’ll get kicked off the FTP server), you can just run the same code again and only the missing files will be downloaded.
If you really want to download 2k historical (large!) datasets, you definitely want to set sleep
to a much higher value.
For speed, we’ll only work with the first 3 urls.
2k large datasets probably is way too much for memory, so we’ll use a custom reading function. It will only select the relevant time section and rainfall column. The latter will be named with the id extracted from the filename.
## Par Kurz Einheit
## NSH_TAG NSH_TAG Schneehoehe_Neu cm
## RS RS Niederschlagshoehe mm
## RSF RSF Niederschlagsform numerischer Code
## SH_TAG SH_TAG Schneehoehe cm
read2014_2016 <- function(file, fread=TRUE, ...)
{
out <- readDWD(file, fread=fread, ...)
out <- out[out$MESS_DATUM > as.POSIXct(as.Date("2014-01-01")) &
out$MESS_DATUM < as.POSIXct(as.Date("2016-12-31")) , ]
out <- out[ , c("MESS_DATUM", "RS")]
out$MESS_DATUM <- as.Date(out$MESS_DATUM) # might save some memory space...
# Station id as column name:
idstringloc <- unlist(gregexpr(pattern="tageswerte_RR_", file))
idstring <- substring(file, idstringloc+14, idstringloc+18)
colnames(out) <- c("date", idstring)
return(out)
}
str(read2014_2016(localfiles[1])) # test looks good
## 'data.frame': 1090 obs. of 2 variables:
## $ date : Date, format: "2014-01-02" "2014-01-03" ...
## $ 00006: num 1.8 0.4 2.3 0.7 0.2 0 0 8.3 0 4 ...
Now let’s apply this to all our files and merge the result.
library(pbapply) # progress bar for lapply loop
rain_list <- pblapply(localfiles, read2014_2016)
rain_df <- Reduce(function(...) merge(..., all=T), rain_list)
str(rain_df) # looks nice!
## 'data.frame': 1094 obs. of 4 variables:
## $ date : Date, format: "2014-01-02" "2014-01-03" ...
## $ 00006: num 1.8 0.4 2.3 0.7 0.2 0 0 8.3 0 4 ...
## $ 00015: num 1.2 0.2 1.5 1.5 0 0 0 5.1 0.3 0.6 ...
## $ 00019: num 3.3 0.4 2.9 0 0.2 0.1 0 6.3 0.2 3.1 ...
## date 00006 00015 00019
## Min. :2014-01-02 Min. : 0.000 Min. : 0.000 Min. : 0.000
## 1st Qu.:2014-10-02 1st Qu.: 0.000 1st Qu.: 0.000 1st Qu.: 0.000
## Median :2015-07-02 Median : 0.100 Median : 0.000 Median : 0.100
## Mean :2015-07-02 Mean : 2.142 Mean : 1.647 Mean : 2.152
## 3rd Qu.:2016-03-31 3rd Qu.: 1.900 3rd Qu.: 1.500 3rd Qu.: 1.900
## Max. :2016-12-30 Max. :68.400 Max. :54.000 Max. :53.600
## NA's :5
plot(rain_df$date, rain_df[,2], type="n", ylim=range(rain_df[,-1], na.rm=T),
las=1, xaxt="n", xlab="Date", ylab="Daily rainfall sum [mm]")
berryFunctions::monthAxis()
for(i in 2:ncol(rain_df)) lines(rain_df$date, rain_df[,i], col=sample(colours(), size=1))
Let’s see the locations of our stations in an interactive map.
data(geoIndex) ; library(leaflet)
mygeoIndex <- geoIndex[geoIndex$id %in% as.numeric(colnames(rain_df)[-1]),]
leaflet(data=mygeoIndex) %>% addTiles() %>%
addCircleMarkers(~lon, ~lat, popup=~display, stroke=T)
For a static map with scaleBar, OSMscale works nicely but currently still has a Java dependency, see https://github.com/brry/OSMscale#installation
library(OSMscale)
pointsMap("lat", "lon", mygeoIndex, fx=2, fy=1, pargs=list(lwd=3),
col="blue", zoom=5)
m <- nearbyStations(49.211784, 9.812475, radius=30,
res=c("daily","hourly"), var=c("precipitation","more_precip","kl"),
mindate=20160530, statname="Braunsbach catchment center")
# Remove duplicates. if kl and more_precip are both available, keep only more_precip:
library("berryFunctions")
m <- sortDF(m, "var")
m <- m[!duplicated(paste0(m$Stations_id, m$res)),]
m <- sortDF(m, "res")
m <- sortDF(m, "dist", decreasing=FALSE)
rownames(m) <- NULL
head(m[,-14]) # don't show url column with long urls
## Stations_id von_datum bis_datum Stationshoehe geoBreite geoLaenge
## 1 NA NA NA NA 49.21178 9.812475
## 2 2848 19310101 20190527 458 49.25750 9.859400
## 3 5988 20180523 20190527 415 49.16380 9.916200
## 4 2787 20050101 20190527 354 49.24280 9.678600
## 5 2787 19410101 20190527 354 49.24280 9.678600
## 6 5206 20081103 20161111 396 49.11750 9.897200
## Stationsname Bundesland res var
## 1 Braunsbach catchment center <NA> z <NA>
## 2 Langenburg-Atzenrod Baden-Wuerttemberg daily more_precip
## 3 Ilshofen Baden-Wuerttemberg daily more_precip
## 4 Kupferzell-Rechbach Baden-Wuerttemberg hourly precipitation
## 5 Kupferzell-Rechbach Baden-Wuerttemberg daily more_precip
## 6 Vellberg-Kleinaltdorf Baden-Wuerttemberg hourly precipitation
## per hasfile dist
## 1 <NA> NA 0.000000
## 2 historical TRUE 6.119540
## 3 historical TRUE 9.235422
## 4 historical TRUE 10.315219
## 5 historical TRUE 10.315219
## 6 historical TRUE 12.159814
Interactive map of just the meteo station locations:
Download and process data for the stations, get the rainfall sums of a particular day (Braunsbach flood May 2016):
## Warning in readDWD.data(file[i], fread = fread[i],
## varnames = varnames[i], : File contains no rows: C:/
## Dropbox/Rpack/rdwd/localtests/CreateVignettes/DWDdata/
## daily_more_precip_historical_tageswerte_RR_05988_20180523_20181231_hist.zip
## Warning in readDWD.data(file[i], fread = fread[i],
## varnames = varnames[i], : File contains no rows: C:/
## Dropbox/Rpack/rdwd/localtests/CreateVignettes/DWDdata/
## daily_more_precip_historical_tageswerte_RR_05989_20180523_20181231_hist.zip
## Warning in readDWD.data(file[i], fread = fread[i],
## varnames = varnames[i], : File contains no rows: C:/
## Dropbox/Rpack/rdwd/localtests/CreateVignettes/DWDdata/
## daily_more_precip_historical_tageswerte_RR_07233_20060915_20181231_hist.zip
## Warning in readDWD.data(file[i], fread = fread[i],
## varnames = varnames[i], : File contains no rows: C:/
## Dropbox/Rpack/rdwd/localtests/CreateVignettes/DWDdata/
## daily_more_precip_historical_tageswerte_RR_07491_20061125_20181231_hist.zip
## Warning in readDWD.data(file[i], fread = fread[i],
## varnames = varnames[i], : File contains no rows: C:/
## Dropbox/Rpack/rdwd/localtests/CreateVignettes/DWDdata/
## daily_more_precip_historical_tageswerte_RR_15011_20140501_20181231_hist.zip
## Warning in readDWD.data(file[i], fread = fread[i],
## varnames = varnames[i], : File contains no rows: C:/
## Dropbox/Rpack/rdwd/localtests/CreateVignettes/DWDdata/
## daily_more_precip_historical_tageswerte_RR_07231_20060915_20161109_hist.zip
## Warning in readDWD.data(file[i], fread = fread[i],
## varnames = varnames[i], : File contains no rows: C:/
## Dropbox/Rpack/rdwd/localtests/CreateVignettes/DWDdata/
## daily_more_precip_historical_tageswerte_RR_07495_20070114_20181231_hist.zip
names(prec) <- m$Stations_id[-1]
prec29 <- sapply(prec[m$res[-1]=="daily"], function(x)
{
if(nrow(x)==0) return(NA)
col <- "RS"
if(!col %in% colnames(x)) col <- "R1"
if(!col %in% colnames(x)) col <- "RSK"
x[x$MESS_DATUM==as.POSIXct(as.Date("2016-05-29")), col]
})
prec29 <- data.frame(Stations_id=names(prec29), precsum=unname(prec29))
prec29 <- merge(prec29, m[m$res=="daily",c(1,4:7,14)], sort=FALSE)
head(prec29[,-7]) # don't show url column with long urls
## Stations_id precsum Stationshoehe geoBreite geoLaenge
## 1 2848 105.0 458 49.2575 9.8594
## 2 5988 NA 415 49.1638 9.9162
## 3 2787 72.0 354 49.2428 9.6786
## 4 5206 82.2 396 49.1175 9.8972
## 5 2575 94.0 426 49.1804 9.9800
## 6 3416 82.5 294 49.3423 9.8073
## Stationsname
## 1 Langenburg-Atzenrod
## 2 Ilshofen
## 3 Kupferzell-Rechbach
## 4 Vellberg-Kleinaltdorf
## 5 Kirchberg/Jagst-Herboldshausen
## 6 Mulfingen/Jagst
For a quick look without a map, this works:
plot(geoBreite~geoLaenge, data=m, asp=1)
textField(prec29$geoLaenge, prec29$geoBreite, prec29$precsum, col=2)
But it’s nicer to have an actual map. If OSMscale installation fails, go to https://github.com/brry/OSMscale#installation
library(OSMscale)
map <- pointsMap(geoBreite,geoLaenge, data=m, type="osm", plot=FALSE)
pp <- projectPoints("geoBreite", "geoLaenge", data=prec29, to=map$tiles[[1]]$projection)
prec29 <- cbind(prec29,pp) ; rm(pp)
pointsMap(geoBreite,geoLaenge, data=m, map=map, scale=FALSE)
scaleBar(map, cex=1.5, type="line", y=0.82)
textField(prec29$x, prec29$y, round(prec29$precsum), font=2, cex=1.5)
title(main="Rainfall sum 2016-05-29 7AM-7AM [mm]", line=-1)
Shapefile of Landkreis districts:
https://public.opendatasoft.com/explore/dataset/landkreise-in-germany/export/ (file size 4 MB, unzipped 10 MB)
# Select monthly climate data:
data("metaIndex") ; m <- metaIndex
m <- m[m$res=="monthly" & m$var=="kl" & m$per=="recent" & m$hasfile, ]
# Transform into spatial object:
msf <- sf::st_as_sf(m, coords=c("geoLaenge", "geoBreite"), crs=4326)
# Read district shapefile, see link above:
lk <- sf::st_read("landkreise/landkreise-in-germany.shp", quiet=TRUE)
# intersections: list with msf rownumbers for each district:
int <- sf::st_intersects(lk, msf)
## although coordinates are longitude/latitude, st_intersects assumes that they are planar
https://gis.stackexchange.com/a/318629/36710
# plot to check projection:
plot(lk[,"id_2"], reset=FALSE)
colPoints("geoLaenge", "geoBreite", "Stationshoehe", data=m, add=T, legend=F)
# berryFunctions::colPointsLegend + sf plots = set margins, see note there!
axis(1, line=-1); axis(2, line=-1, las=1)
points(m[int[[2]], c("geoLaenge", "geoBreite")], pch=16, col=2, cex=1.8)
Running analysis for a few selected districts only to reduce computation time.
Monthly rainfall average per Landkreis.
landkreis_rain <- function(lki) # LandKreisIndex (row number in lk)
{
rnr <- int[[lki]] # msf row number
if(length(rnr)<1)
{
warning("No rainfall data available for Landkreis ", lki, ": ", lk$name_2[lki], call.=FALSE)
out <- data.frame(NA,NA)[FALSE,]
colnames(out) <- c("MESS_DATUM", as.character(lk$name_2[lki]))
return(out)
}
urls <- selectDWD(id=m[rnr, "Stations_id"], # set dir if needed
res="monthly", var="kl", per="r", outvec=TRUE)
clims <- dataDWD(urls, varnames=FALSE, quiet=TRUE)
if(length(urls)==1)
{rainmean <- clims$MO_RR
monthlyrain <- clims[c("MESS_DATUM", "MO_RR")]
} else
{
monthlyrain <- lapply(seq_along(clims), function(n)
{
out <- clims[[n]][c("MESS_DATUM", "MO_RR")]
colnames(out)[2] <- names(clims)[n] # no duplicate names
out
})
monthlyrain <- Reduce(function(...) merge(..., by="MESS_DATUM",all=TRUE), monthlyrain)
rainmean <- rowMeans(monthlyrain[,-1], na.rm=TRUE) # check also with median, variation is huge!
}
out <- data.frame(monthlyrain[,1], rainmean)
colnames(out) <- c("MESS_DATUM", as.character(lk$name_2[lki]))
return(out)
}
rainLK <- pbapply::pblapply(c(133,277,300,389), landkreis_rain)
## Warning: No rainfall data available for Landkreis 300: Offenbach
## MESS_DATUM Hohenlohekreis Bodenseekreis Offenbach Berlin
## 1 2017-10-15 56.25 48.4 NA 84.183333
## 2 2017-11-15 103.40 96.7 NA 69.616667
## 3 2017-12-15 90.85 94.4 NA 39.866667
## 4 2018-01-15 124.65 114.9 NA 67.816667
## 5 2018-02-15 24.75 53.3 NA 3.183333
## 6 2018-03-15 46.75 51.1 NA 47.700000
Any feedback on this package (or this vignette) is very welcome via github or berry-b@gmx.de!