Dieses Dokument beschreibt die Vorprozessierung und explorative Analyse des Datensatzes, der Grundlage des auf srf.ch veröffentlichten Artikel Hier verkaufen sich GA und Halbtax am besten ist.
SRF Data legt Wert darauf, dass die Datenvorprozessierung und -Analyse nachvollzogen und überprüft werden kann. SRF Data glaubt an das Prinzip offener Daten, aber auch offener und nachvollziehbarer Methoden. Zum anderen soll es Dritten ermöglicht werden, auf dieser Vorarbeit aufzubauen und damit weitere Auswertungen oder Applikationen zu generieren.
Die Vorprozessierung und Analyse wurde im Statistikprogramm R vorgenommen. Das zugrunde liegende Script sowie die prozessierten Daten können unter diesem Link heruntergeladen werden. Durch Ausführen von main.Rmd
kann der hier beschriebene Prozess nachvollzogen und der für den Artikel verwendete Datensatz generiert werden. Dabei werden Daten aus dem Ordner input
eingelesen und Ergebnisse in den Ordner output
geschrieben.
SRF Data verwendet das rddj-template von Timo Grossenbacher als Grundlage für seine R-Scripts. Entstehen bei der Ausführung dieses Scripts Probleme, kann es helfen, die Anleitung von rddj-template zu studieren.
Debug-Informationen: This report was generated on 2018-12-07 13:03:13. R version: 3.3.3 on x86_64-pc-linux-gnu. For this report, CRAN packages as of 2017-06-01 were used.
Der Code für die vorliegende Datenprozessierung ist auf https://github.com/srfdata/2017-09-sbb-ga-halbtax zur freien Verwendung verfügbar.
2017-09-sbb-ga-halbtax von SRF Data ist lizenziert unter einer Creative Commons Namensnennung - Weitergabe unter gleichen Bedingungen 4.0 International Lizenz.
Code & Daten von SRF Data sind unter http://srfdata.github.io verfügbar.
Die veröffentlichten Informationen sind sorgfältig zusammengestellt, erheben aber keinen Anspruch auf Aktualität, Vollständigkeit oder Richtigkeit. Es wird keine Haftung übernommen für Schäden, die durch die Verwendung dieses Scripts oder der daraus gezogenen Informationen entstehen. Dies gilt ebenfalls für Inhalte Dritter, die über dieses Angebot zugänglich sind.
Die Informationen zur interaktiven Karte und den Werten im Artikel stammen aus dem Datensatz des Direkten Verkehrs Schweiz (opentransportdata.swiss) zur Verbreitung von GA und Halbtax zwischen 2012-2016. Der Fokus der vorliegenden Analyse bezieht sich auf die Daten von 2016 (Datenauszug KW 51, 2016). In einem ersten Schritt erfolgt die Zuordnung zu den zu diesem Zeitpunkt gültigen Daten der ständigen Wohnbevölkerung anhand der Postleitzahl (31.12.2015). Für den anschliessenden Abgleich zwischen Postleitzahl und Gemeinde wird die vom BFS publizierte GWR-Korrespondenztabelle (Stand 01.01.2017) verwendet. Damit kann ein direkter Bezug zu den durch das BFS publizierten, generalisierten Gemeindegrenzen mit Stand 1.1.2017 sowie der Raumgliederung der Schweiz hergestellt werden.
## [1] "package package:rmarkdown detached"
## Loading required package: knitr
## Loading required package: rstudioapi
# von https://mran.revolutionanalytics.com/web/packages/checkpoint/vignettes/using-checkpoint-with-knitr.html
# alle Packages, die nicht gebraucht werden, können hier entfernt werden (auskommentieren reicht nicht!)
# tidyverse: see https://blog.rstudio.org/2016/09/15/tidyverse-1-0-0/
cat("
library(tidyverse) # ggplot2, dplyr, tidyr, readr, purrr, tibble
library(magrittr) # pipes
library(stringr) # string manipulation
library(readxl) # excel
library(scales) # scales for ggplot2
library(jsonlite) # json
library(forcats) # easier factor handling,
library(lintr) # code linting, auf keinen Fall entfernen ;-)
library(googlesheets) # googlesheets (replace with googlesheets4 asap)
library(rmarkdown) # muss für automatisches knitting in deploy.sh eingebunden werden",
file = "manifest.R")
# system for the first time)
if (!require(checkpoint)) {
if (!require(devtools)) {
install.packages("devtools", repos = "http://cran.us.r-project.org")
require(devtools)
}
devtools::install_github("RevolutionAnalytics/checkpoint",
ref = "v0.3.2", # could be adapted later,
# as of now (beginning of July 2017
# this is the current release on CRAN)
repos = "http://cran.us.r-project.org")
require(checkpoint)
}
## Loading required package: checkpoint
##
## checkpoint: Part of the Reproducible R Toolkit from Microsoft
## https://mran.microsoft.com/documents/rro/reproducibility/
# nolint start
if (!dir.exists("~/.checkpoint")) {
dir.create("~/.checkpoint")
}
# nolint end
# install packages for the specified CRAN snapshot date
checkpoint(snapshotDate = package_date,
project = path_to_wd,
verbose = T,
scanForPackages = T,
use.knitr = F,
R.version = R_version)
## Scanning for packages used in this project
## rmarkdown files found and will not be parsed. Set use.knitr = TRUE
## - Discovered 12 packages
## All detected packages already installed
## checkpoint process complete
## ---
rm(package_date)
source("manifest.R")
## Loading tidyverse: ggplot2
## Loading tidyverse: tibble
## Loading tidyverse: tidyr
## Loading tidyverse: readr
## Loading tidyverse: purrr
## Loading tidyverse: dplyr
## Conflicts with tidy packages ----------------------------------------------
## filter(): dplyr, stats
## lag(): dplyr, stats
##
## Attaching package: 'magrittr'
## The following object is masked from 'package:purrr':
##
## set_names
## The following object is masked from 'package:tidyr':
##
## extract
##
## Attaching package: 'scales'
## The following object is masked from 'package:purrr':
##
## discard
## The following object is masked from 'package:readr':
##
## col_factor
##
## Attaching package: 'jsonlite'
## The following object is masked from 'package:purrr':
##
## flatten
unlink("manifest.R")
sessionInfo()
## R version 3.3.3 (2017-03-06)
## Platform: x86_64-pc-linux-gnu (64-bit)
## Running under: Ubuntu 18.04.1 LTS
##
## locale:
## [1] LC_CTYPE=en_US.UTF-8 LC_NUMERIC=C
## [3] LC_TIME=en_US.UTF-8 LC_COLLATE=en_US.UTF-8
## [5] LC_MONETARY=en_US.UTF-8 LC_MESSAGES=en_US.UTF-8
## [7] LC_PAPER=en_US.UTF-8 LC_NAME=C
## [9] LC_ADDRESS=C LC_TELEPHONE=C
## [11] LC_MEASUREMENT=en_US.UTF-8 LC_IDENTIFICATION=C
##
## attached base packages:
## [1] stats graphics grDevices utils datasets methods base
##
## other attached packages:
## [1] rmarkdown_1.5 googlesheets_0.2.2 lintr_1.0.0
## [4] forcats_0.2.0 jsonlite_1.4 scales_0.4.1
## [7] readxl_1.0.0 stringr_1.2.0 magrittr_1.5
## [10] dplyr_0.5.0 purrr_0.2.2.2 readr_1.1.1
## [13] tidyr_0.6.3 tibble_1.3.3 ggplot2_2.2.1
## [16] tidyverse_1.1.1 checkpoint_0.4.0 rstudioapi_0.8
## [19] knitr_1.16
##
## loaded via a namespace (and not attached):
## [1] Rcpp_0.12.11 cellranger_1.1.0 plyr_1.8.4 tools_3.3.3
## [5] digest_0.6.12 lubridate_1.6.0 evaluate_0.10 nlme_3.1-131
## [9] gtable_0.2.0 lattice_0.20-34 rlang_0.1.1 rex_1.1.1
## [13] psych_1.7.5 DBI_0.6-1 yaml_2.1.14 parallel_3.3.3
## [17] haven_1.0.0 xml2_1.1.1 httr_1.2.1 hms_0.3
## [21] rprojroot_1.2 grid_3.3.3 R6_2.2.1 foreign_0.8-67
## [25] modelr_0.1.0 reshape2_1.4.2 backports_1.1.0 htmltools_0.3.6
## [29] rvest_0.3.2 assertthat_0.2.0 mnormt_1.5-5 colorspace_1.3-2
## [33] stringi_1.1.5 lazyeval_0.2.0 munsell_0.4.3 broom_0.4.2
# Contains data number of GA and HTA by PLZ
# For cases with less than 20 GA or HTA the data provider calculated
# the average quantity of GA travelcards for all districts
# that share the same first number in their PLZ.
# read SBB raw data
SBB <- read_excel("input/SBB_GA_HTA_2016.xlsx")
# rename column names
SBB %<>%
rename(Jahr_SBB = Jahr_An_Anno,
PLZ = PLZ_NPA,
GA = GA_AG,
GA_flag = GA_AG_flag,
HTA = `HTA_ADT_meta-prezzo`,
HTA_flag = `HTA_ADT_meta-prezzo_flag`)
# define PLZ as numeric
SBB %<>%
mutate(PLZ = as.numeric(PLZ))
# create data frame with all years
SBB_years <- SBB
# filter for 2016 only
SBB %<>% filter(Jahr_SBB == 2016)
# Total population per PLZ
# create empty list
bevoelk <- list()
# loop for reading excel file with 5 sheets
for (i in 1:6){
temp_df <- read_excel("input/BFS_Wohnbevoelkerung_PLZ_2010-2016.xlsx", sheet = i, skip = 3)
temp_df <- temp_df[-1, ] # delete unnecessary row
temp_df <- temp_df[1:min(which(is.na(temp_df$X__1))) - 1, ]
temp_df$Jahr <- 2017 - i
bevoelk[[i]] <- temp_df
}
# remove temp loop variables: i, temp_df
rm(i)
rm(temp_df)
# binding data frames by row
Population <- bind_rows(bevoelk)
rm(bevoelk) # remove unused list
# Create data frame total population for all years (2012-2015)
Population_years <- Population %>%
group_by(Jahr) %>%
summarize(Einw = sum(Total)) %>%
slice(1:5)
# Select poplation data of 31.12.2015
Population %<>%
filter(Jahr == 2015)
# rename variables and change variable type
Population %<>%
rename(PLZ = X__1) %>%
rename(Anzahl_Einw = Total) %>%
rename(Jahr_BFS = Jahr) %>%
mutate(PLZ = as.numeric(PLZ))
### Providing correspondance between PLZ and BFS-GDE-NR.
# read BFS GWR Gemeinde-Daten 01.01.2017 #
Gemeinden <- read_excel("input/BFS_GWR_Korrespondenztabelle_2017_Januar.xls",
sheet = 2, skip = 11)
# rename variables
Gemeinden %<>%
rename(PLZ = PLZ4,
Anteil_GDE = `%_IN_GDE`,
Kanton = GDENR, # wrong column name in source file
Gde_Nr = KTKZ, # wrong column name in source file
Gde_Nam = GDENAMK)
# check number of rows (should contain 2255 rows)
count(Gemeinden, Gde_Nr)
## # A tibble: 2,255 x 2
## Gde_Nr n
## <dbl> <int>
## 1 1 1
## 2 2 2
## 3 3 1
## 4 4 3
## 5 5 1
## 6 6 1
## 7 7 1
## 8 8 1
## 9 9 1
## 10 10 1
## # ... with 2,245 more rows
# Plausibility check of variable summe_anteil (if outside range)
Gemeinden %>%
group_by(PLZ) %>%
summarize(summe_anteil = sum(Anteil_GDE)) %>%
mutate(outside_range = ifelse(abs(100 - summe_anteil) > .5, TRUE, FALSE)) %>%
count(outside_range)
## # A tibble: 1 x 2
## outside_range n
## <lgl> <int>
## 1 FALSE 3185
# provides several classifcations for structural analisys
# on the level of municipalities
# read excel data
Spatial_structure <- read_excel(
"input/BFS_Raumgliederung_Schweiz_2017_Januar.xlsx",
sheet = 1, range = "A8:Z2262", col_names = F)
# read column names
colnames_df <- read_excel(
"input/BFS_Raumgliederung_Schweiz_2017_Januar.xlsx",
sheet = 1, range = "A4:Z4", col_names = F)
# change colnames in target data frame
Spatial_structure <- rbind(colnames_df, Spatial_structure)
colnames(Spatial_structure) <- Spatial_structure[1, ]
Spatial_structure <- Spatial_structure[-1, ]
rm(colnames_df) # remove unused data frame
# specify column types
Spatial_structure[, 1] <- lapply(Spatial_structure[, 1], as.numeric)
Spatial_structure[, 3:26] <- lapply(Spatial_structure[, 3:26], as.numeric)
# Select colmuns of interest
Population %<>%
select(Jahr_BFS, PLZ, Anzahl_Einw)
# Combine data frames
SBB %<>%
left_join(Population, by = c("PLZ"))
# filter out rows with NA's = no Population data
SBB %<>%
filter(!is.na(Anzahl_Einw))
# the variable "Anteil GDE" contains the ratio of the buildings
# of this specific PLZ that belong to the municipality. We thereby
# can estimate how many GA belong approximately to each municipality.
# Combine data frames
SBB %<>%
full_join(Gemeinden, by = "PLZ")
# RM NA's from merge (Gemeinden without SBB Data)
SBB %<>%
filter(!is.na(Jahr_SBB))
# calculate ratios of GA, HTA and number of inhabitants in relation to share of PLZ
SBB %<>%
mutate(GA = round(GA * Anteil_GDE / 100, 4)) %>%
mutate(HTA = round(HTA * Anteil_GDE / 100, 4)) %>%
mutate(Anzahl_Einw = round(Anzahl_Einw * Anteil_GDE / 100, 4))
# Plausibility Flags, percentage of flagged GAs
sum(SBB$GA)
## [1] 466494
SBB %>%
filter(!is.na(GA_flag)) %>%
.[["GA"]] %>%
sum() / sum(SBB$GA)
## [1] 0.02144881
# remove unused columns
SBB %<>%
select(-Anteil_GDE, -ends_with("_flag"))
# left join SBB with Spatial structure
SBB %<>%
left_join(Spatial_structure, by = c("Gde_Nr" = "BFS Nr."))
# rename variables
SBB %<>%
rename(Sprache = `Sprachgebiete 2016`,
Gem_Klasse = `Gemeinde-Grössenklasse 2015`,
Stadt_Land = `Stadt/Land-Typologie 2012`,
Kanton = Kanton.x)
# Select variables of interest
SBB %<>%
select(Jahr_SBB, Jahr_BFS, PLZ, Gde_Nam, Gde_Nr, GA,
HTA, Anzahl_Einw, Kanton, Grossregionen,
Sprache, Gem_Klasse, Stadt_Land)
# create data frame for analysis community level
SBB_2016 <- SBB %>%
select(Gde_Nr, Gde_Nam, PLZ, Kanton,
GA, HTA, Anzahl_Einw, Grossregionen,
Sprache, Gem_Klasse, Stadt_Land)
# group and summarize by Gde-Nr and normalize data with population to get relative ratios
SBB_2016 %<>%
group_by(Gde_Nr, Gde_Nam, Kanton, Grossregionen,
Sprache, Gem_Klasse, Stadt_Land) %>%
summarize(GA = sum(GA),
HTA = sum(HTA),
Anzahl_Einw = sum(Anzahl_Einw)) %>%
ungroup() %>%
mutate(Anteil_GA = round(GA * 100 / Anzahl_Einw, 1),
Anteil_HTA = round(HTA * 100 / Anzahl_Einw, 1)) %>%
arrange(Gde_Nr) %>%
mutate(Anzahl_Einw = round(Anzahl_Einw, 0))
# mean ratios GA and HTA over CH
sum(SBB_2016$GA) / sum(SBB_2016$Anzahl_Einw) * 100
## [1] 5.608326
sum(SBB_2016$HTA) / sum(SBB_2016$Anzahl_Einw) * 100
## [1] 28.16421
# mean ratios GA and HTA over municipalities
mean(SBB_2016$Anteil_GA)
## [1] 4.598404
mean(SBB_2016$Anteil_HTA)
## [1] 24.65029
# total 2016
sum(SBB_2016$HTA)
## [1] 2342666
sum(SBB_2016$GA)
## [1] 466494
Für die Schlüssel in den nachfolgenden Grafiken siehe jeweils die Datei input/BFS_Raumgliederung_Schweiz_2017_Januar.xlsx
.
# city vs. countryside
SBB_Stadt_Land <- SBB %>%
group_by(Stadt_Land) %>%
summarize(GA = sum(GA),
HTA = sum(HTA),
Anzahl_Einw = sum(Anzahl_Einw)) %>%
ungroup() %>%
mutate(Anteil_GA = round(GA * 100 / Anzahl_Einw, 1)) %>%
mutate(Anteil_HTA = round(HTA * 100 / Anzahl_Einw, 1)) %>%
mutate(Anzahl_Einw = round(Anzahl_Einw, 0))
# plot city vs. countryside
ggplot(SBB_Stadt_Land, aes(x = Stadt_Land, y = Anteil_GA)) +
geom_col(position = "identity")
# type of municipality
SBB_Gde_Klasse <- SBB %>%
group_by(Gem_Klasse) %>%
summarize(GA = sum(GA),
HTA = sum(HTA),
Anzahl_Einw = sum(Anzahl_Einw)) %>%
ungroup() %>%
mutate(Anteil_GA = round(GA * 100 / Anzahl_Einw, 1)) %>%
mutate(Anteil_HTA = round(HTA * 100 / Anzahl_Einw, 1)) %>%
mutate(Anzahl_Einw = round(Anzahl_Einw, 0))
# Plot type of municipality
ggplot(SBB_Gde_Klasse, aes(x = Gem_Klasse, y = Anteil_GA)) +
geom_col(position = "identity")
# language affiliation
SBB_Sprache <- SBB %>%
group_by(Sprache) %>%
summarize(GA = sum(GA),
HTA = sum(HTA),
Anzahl_Einw = sum(Anzahl_Einw)) %>%
ungroup() %>%
mutate(Anteil_GA = round(GA * 100 / Anzahl_Einw, 1)) %>%
mutate(Anteil_HTA = round(HTA * 100 / Anzahl_Einw, 1)) %>%
mutate(Anzahl_Einw = round(Anzahl_Einw, 0))
# plot language affiliation
ggplot(SBB_Sprache, aes(x = Sprache, y = Anteil_GA)) +
geom_col(position = "identity")
# canton ratios
SBB_Kantone <- SBB %>%
group_by(Kanton) %>%
summarize(GA = sum(GA),
HTA = sum(HTA),
Anzahl_Einw = sum(Anzahl_Einw)) %>%
ungroup() %>%
mutate(Anteil_HTA = round(HTA * 100 / Anzahl_Einw, 1)) %>%
mutate(Anteil_GA = round(GA * 100 / Anzahl_Einw, 1)) %>%
mutate(Anzahl_Einw = round(Anzahl_Einw, 0))
# canton ratios GA
ggplot(SBB_Kantone, aes(x = reorder(Kanton, -Anteil_GA),
y = Anteil_GA, fill = Anteil_HTA)) +
geom_bar(stat = "identity")
# canton ratios HTA
ggplot(SBB_Kantone, aes(x = reorder(Kanton, -Anteil_HTA),
y = Anteil_HTA, fill = Anteil_GA)) +
geom_bar(stat = "identity")
# canton ratios GA and HTA combined
SBB_Kantone_GA_HTA <- SBB_Kantone %>%
bind_rows( (SBB_Kantone)) %>%
mutate(ID = c(1:52)) %>%
mutate(GA_HTA = ifelse(ID <= 26, "GA", "HTA")) %>%
mutate(Anteil = ifelse(ID <= 26, Anteil_GA, Anteil_HTA)) %>%
arrange(desc(Anteil_GA)) %>%
select(-c(Anteil_GA, Anteil_HTA, ID)) %>%
mutate(ID = c(1:52))
# plot GA and HTA canton ratios combined
ggplot(SBB_Kantone_GA_HTA, aes(x = reorder(Kanton, ID),
y = Anteil, fill = GA_HTA)) +
geom_col(position = "dodge")
# seven greater regions
SBB_Grossregionen <- SBB %>%
group_by(Grossregionen) %>%
summarize(GA = sum(GA),
HTA = sum(HTA),
Anzahl_Einw = sum(Anzahl_Einw)) %>%
ungroup() %>%
mutate(Anteil_GA = round(GA * 100 / Anzahl_Einw, 1)) %>%
mutate(Anteil_HTA = round(HTA * 100 / Anzahl_Einw, 1)) %>%
mutate(Anzahl_Einw = round(Anzahl_Einw, 0))
# plot seven greater regions
ggplot(SBB_Grossregionen, aes(x = Grossregionen, y = Anteil_GA)) +
geom_col(position = "identity")
# create sbb years
SBB_years %<>%
group_by(Jahr_SBB) %>%
summarize(GA = sum(GA), HTA = (sum(HTA)))
# add population data and calculate ratio
SBB_years <- bind_cols(SBB_years, Population_years) %>%
select(-Jahr) %>%
mutate(Anteil_GA = round(GA * 100 / Einw, 2)) %>%
mutate(Anteil_HTA = round(HTA * 100 / Einw, 2))
# plot absolut numbers of GA
ggplot(SBB_years, aes(x = Jahr_SBB, y = GA)) +
geom_bar(stat = "identity") +
coord_cartesian(ylim = c(400000, 500000))
# plot absolut numbers of HTA
ggplot(SBB_years, aes(x = Jahr_SBB, y = HTA)) +
geom_bar(stat = "identity") +
coord_cartesian(ylim = c(2000000, 2500000))
# plot ratio of GA
ggplot(SBB_years, aes(x = Jahr_SBB, y = Anteil_GA)) +
geom_bar(stat = "identity") +
coord_cartesian(ylim = c(4, 6))
# ratio of HTA
ggplot(SBB_years, aes(x = Jahr_SBB, y = Anteil_HTA)) +
geom_bar(stat = "identity") +
coord_cartesian(ylim = c(20, 35))
# total number of GA 2012-2016
SBB_years %>%
group_by(Jahr_SBB) %>%
summarise(sum_GA = sum(GA), n = n())
## # A tibble: 5 x 3
## Jahr_SBB sum_GA n
## <dbl> <dbl> <int>
## 1 2012 436100.6 1
## 2 2013 436593.9 1
## 3 2014 447676.4 1
## 4 2015 453709.8 1
## 5 2016 466614.1 1
# total number of HTA 2012-2016
SBB_years %>%
group_by(Jahr_SBB) %>%
summarise(sum_HTA = sum(HTA), n = n())
## # A tibble: 5 x 3
## Jahr_SBB sum_HTA n
## <dbl> <dbl> <int>
## 1 2012 2330150 1
## 2 2013 2286801 1
## 3 2014 2295260 1
## 4 2015 2281742 1
## 5 2016 2346779 1
Der Code in diesem RMarkdown wird mit lintr automatisch auf den Wickham’schen tidyverse style guide überprüft.
lintr::with_defaults(commented_code_linter = NULL) # does not work yet
lintr::lint("main.Rmd")
## main.Rmd:137:1: style: lines should not be more than 80 characters.
## library(rmarkdown) # muss für automatisches knitting in deploy.sh eingebunden werden",
## ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## main.Rmd:228:1: style: lines should not be more than 80 characters.
## temp_df <- read_excel("input/BFS_Wohnbevoelkerung_PLZ_2010-2016.xlsx", sheet = i, skip = 3)
## ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## main.Rmd:269:2: style: Commented code should be removed.
## ### Providing correspondance between PLZ and BFS-GDE-NR.
## ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## main.Rmd:642:3: style: Commented code should be removed.
## # lintr::lint("scripts/my_script.R")
## ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# lintr::lint("scripts/my_script.R")