Traufgänge Albstadt

In this post, I want to visualise some hiking paths near my hometown.

The so called ‘Traufgänge’ are some panoramic tours, that pass through spectacular natural scenery along a steeply declining Albtrauf.

This post will describe the progress to scrap, preprocess and visualise the data. The whole process is put together in one big drake plan. I will describe the most important functions, data frames and plots in more detail:

Data

The gpx files of the hiking paths are available online. Create all the links, by inserting a unique id into a base url.

glue_trauf_urls <- function(ids) {
  str_glue(
    "http://www.outdooractive.com/download.tour.gpx?i=", 
    "{ids}&proj=api-albstadt&key=TQSXFTL4-EMWGKXWF-4OSSHXDG&lang=de")
}
glue_collapse(links, sep = " \n")
## http://www.outdooractive.com/download.tour.gpx?i=1508840&proj=api-albstadt&key=TQSXFTL4-EMWGKXWF-4OSSHXDG&lang=de 
## http://www.outdooractive.com/download.tour.gpx?i=1515629&proj=api-albstadt&key=TQSXFTL4-EMWGKXWF-4OSSHXDG&lang=de 
## http://www.outdooractive.com/download.tour.gpx?i=1561121&proj=api-albstadt&key=TQSXFTL4-EMWGKXWF-4OSSHXDG&lang=de 
## http://www.outdooractive.com/download.tour.gpx?i=1526041&proj=api-albstadt&key=TQSXFTL4-EMWGKXWF-4OSSHXDG&lang=de 
## http://www.outdooractive.com/download.tour.gpx?i=1484741&proj=api-albstadt&key=TQSXFTL4-EMWGKXWF-4OSSHXDG&lang=de 
## http://www.outdooractive.com/download.tour.gpx?i=1515671&proj=api-albstadt&key=TQSXFTL4-EMWGKXWF-4OSSHXDG&lang=de 
## http://www.outdooractive.com/download.tour.gpx?i=1547041&proj=api-albstadt&key=TQSXFTL4-EMWGKXWF-4OSSHXDG&lang=de 
## http://www.outdooractive.com/download.tour.gpx?i=26035570&proj=api-albstadt&key=TQSXFTL4-EMWGKXWF-4OSSHXDG&lang=de 
## http://www.outdooractive.com/download.tour.gpx?i=4480506&proj=api-albstadt&key=TQSXFTL4-EMWGKXWF-4OSSHXDG&lang=de 
## http://www.outdooractive.com/download.tour.gpx?i=4480579&proj=api-albstadt&key=TQSXFTL4-EMWGKXWF-4OSSHXDG&lang=de

Read all the gpx files and extract the name of each hiking path from the xml file. Shorten the name of the hiking path.

read_gpx <- function(links) {
  tibble(
    path = links, gpx = map(path, ~ xml_ns_strip(read_xml(.))), 
    name = map_chr(
      gpx, ~ xml_text(xml_find_first(., "//name")))) %>% 
    mutate(
      name = str_trim(str_remove_all(
        name, "Traufgang|in Albstadt|Premium-Winterwanderweg")),
      trackpoints = map(gpx, xml_find_all, xpath = "//trkpt"),
      attrs = map(trackpoints, xml_attrs),
      ele = map(
        trackpoints, ~ xml_text(xml_find_all(.x, "ele"))))
}
dplyr::select(df_gpx, name, gpx)
## # A tibble: 10 x 2
##    name                     gpx       
##    <chr>                    <list>    
##  1 Wacholderhöhe            <xml_dcmn>
##  2 Schlossfelsenpfad        <xml_dcmn>
##  3 Zollernburg-Panorama     <xml_dcmn>
##  4 Felsenmeersteig          <xml_dcmn>
##  5 Hossinger Leiter         <xml_dcmn>
##  6 Ochsenbergtour           <xml_dcmn>
##  7 Wiesenrunde              <xml_dcmn>
##  8 Traufgängerle Hexenküche <xml_dcmn>
##  9 Schneewalzer             <xml_dcmn>
## 10 Wintermärchen            <xml_dcmn>

Get all attributes and elevation nodes from every gpx file and unnest the data and perform some basic preprocessing:

tidy_gpx <- function(df_gpx) {
  df_gpx %>% 
    mutate(id = map(ele, ~ 1:length(.x))) %>% 
    unnest(cols = c(attrs, ele, id)) %>% 
    mutate(
      lat = map_chr(attrs, "lat"), lon = map_chr(attrs, "lon"),
      name = str_replace_all(name, c("ä" = "ae", "ö" = "oe"))) %>%
    select_if(negate(is_list)) %>% 
    mutate_at(vars(ele, lat, lon), parse_number)
}

Take a glimpse at the final data frame:

dplyr::select(df_gpx_tidy, -path)
## # A tibble: 2,774 x 5
##    name            ele    id   lat   lon
##    <chr>         <dbl> <int> <dbl> <dbl>
##  1 Wacholderhöhe  887.     1  48.3  9.04
##  2 Wacholderhöhe  886.     2  48.3  9.04
##  3 Wacholderhöhe  889.     3  48.3  9.04
##  4 Wacholderhöhe  890.     4  48.3  9.04
##  5 Wacholderhöhe  892.     5  48.3  9.04
##  6 Wacholderhöhe  889.     6  48.3  9.04
##  7 Wacholderhöhe  893.     7  48.3  9.04
##  8 Wacholderhöhe  898.     8  48.3  9.04
##  9 Wacholderhöhe  899.     9  48.3  9.04
## 10 Wacholderhöhe  897.    10  48.3  9.04
## # ... with 2,764 more rows

Visualisation

Create simple features data frame:

sf_gpx <- function(df_gpx_tidy) {
  df_gpx_tidy %>% 
    nest(data = -name) %>% 
    mutate(
      sf_obj = map(
        data, ~ st_linestring(as.matrix(.x[, c("lon", "lat", "ele")]))),
      dm = map(
        data, ~ st_distance(st_as_sf(.x, coords = c("lon", "lat", "ele")))),
      geometry = st_sfc(sf_obj)) %>% 
    st_sf(crs = 4326)
}

Calculate the bounding box for the simple features data frame:

trauf_bbox <- function(sf_trauf) {
  st_bbox(sf_trauf)
}

Based on the bounding box from the previous step, download a stamen map:

get_bbox_stamen_map <- function(bbox, tol_bbox) {
  map_toner <- get_stamenmap(c(
    left = bbox$xmin[[1]] - 2 * tol_bbox,
    right = bbox$xmax[[1]] + tol_bbox,
    bottom = bbox$ymin[[1]] - 2 * tol_bbox,
    top = bbox$ymax[[1]] + tol_bbox),
    zoom = 12, maptype = "toner-hybrid")
}
ggmap::ggmap(trauf_map)

Visualise the simple features data frame:

vis_sf <- function(df_gpx_sf, map) {
  plot_data <- df_gpx_sf %>%
    select(-dm)
  
  ggmap(map) +
    geom_sf(
      aes(color = name), 
      data = plot_data, inherit.aes = FALSE, size = 1.1) +
    theme(
      axis.line = element_blank(),
      axis.text.x = element_blank(),
      axis.text.y = element_blank(),
      axis.ticks = element_blank(),
      axis.title.x = element_blank(),
      axis.title.y = element_blank(),
      legend.position = "none",
      panel.background = element_blank(),
      panel.border = element_blank(),
      panel.grid.major = element_blank(),
      panel.grid.minor = element_blank(),
      plot.background = element_blank(),
      strip.text = element_blank())
}
p1
## Warning in `$.crs`(crs, "proj4string"): CRS uses proj4string, which is
## deprecated.

Visualise the elevation of every route and save the result for later:

vis_alt <- function(df_gpx) {
  df_gpx %>% 
    mutate(name = str_wrap(name, width = 10)) %>%
    ggplot(aes(x = id, y = ele, color = name)) +
    geom_line() + 
    facet_wrap(~ name, scales = "free_x") +
    labs(x = "", y = "Hoehenmeter", color = "Name") +
    theme(axis.text.x = element_blank(), legend.position = "bottom")
}
p2

Get the two plots in one plot and show the result:

comb_plots <- function(p1, p2) {
  p1 + p2 + 
    plot_layout(ncol = 2)
}
erg_plot
## Warning in `$.crs`(crs, "proj4string"): CRS uses proj4string, which is
## deprecated.