Merge branch 'master' of gitea:christian/hateimparlament

.Rbuildignore

@@ -0,0 +1,2 @@
+^doc$
+^Meta$

.gitignore

@@ -1 +1,6 @@
 *.xml
+/doc/
+/Meta/
+/reports/
+!/reports/*.pdf
+!/reports/*.tex

DESCRIPTION

@@ -17,10 +17,13 @@ RoxygenNote: 7.1.1
 Imports: 
     dplyr,
     pbapply,
+    purrr,
     rvest,
     stringr,
+    tibble,
     xml2
 Suggests: 
     rmarkdown,
-    knitr
+    knitr,
+    ggplot2
 VignetteBuilder: knitr

NAMESPACE

@@ -1,7 +1,12 @@
 # Generated by roxygen2: do not edit by hand
 
+export(fetch_all)
+export(read_all)
+export(repair)
 import(dplyr)
 import(pbapply)
+import(purrr)
 import(stringr)
 import(tibble)
+import(utils)
 import(xml2)

R/fetch.R

@@ -30,7 +30,31 @@ fetch_batch <- function(offset, download_dir) {
 # TODO: error handling
 # - what if: page not reachable
 # - wrong format, etc.
-fetch_all <- function(download_dir="records/") {
+
+#' Download available records
+#'
+#' This fetches all available records of the 19th legislative period of the german Bundestag.
+#'
+#' @param download_dir character
+#'
+#' @export
+fetch_all <- function(download_dir="records/", create=FALSE) {
+    # check if download_dir path is a directory path
+    if (str_sub(download_dir, -1) != .Platform$file.sep)
+        download_dir <- str_c(download_dir, .Platform$file.sep)
+
+    # check if download_dir exists
+    if(file.access(download_dir, mode=0) == -1) {
+        if (create) {
+            tryCatch(dir.create(download_dir),
+                     error = stop_dir_not_creatable,
+                     warning = stop_dir_not_creatable)
+        } else {
+            stop("Directory does not exist. Use create = TRUE if you wish to create the directory.")
+        }
+    } else if (file.access(download_dir, mode=2) == -1) {
+        stop("Directory exists, but is not writeable.")
+    }
     cat("Fetching all available records from bundestag.de. This may take a while ...\n")
 
     # create progress bar
@@ -38,9 +62,18 @@ fetch_all <- function(download_dir="records/") {
     progress <<- 0
     # close progress bar on exit (also on error)
     on.exit({close(pb); cat("Done.\n")})
+
     # fetch batch by batch
     offset <- 0
     while(fetch_batch(offset, download_dir)) offset <- offset + 10
+
     # if successful, set progressbar to 100%
     setTimerProgressBar(pb, 250)
 }
+
+stop_dir_not_creatable <- function(cond) {
+    # currently this has call: dir.create(download_dir)
+    # do we want to change this to fetch_all(...) ?
+    cond$message <- "Directory does not exist and can't be created. Probably because the path is not writeable."
+    stop(cond)
+}

R/hateimparlament-package.R

@@ -5,6 +5,8 @@
 #' @import pbapply
 #' @import stringr
 #' @import xml2
+#' @import utils
+#' @import purrr
 #' @keywords internal
 "_PACKAGE"
 

R/helpers.R

@@ -1,4 +1,5 @@
 `%$%` <- function(f, x) f(x)
 `%.%` <- function(f, g) function(...) f(g(...))
+flip <- function(f) function(x, y) f(y, x)
 
 clear_na <- function(xs) xs[!is.na(xs)]

R/parse.R

@@ -1,5 +1,13 @@
 # for usage see the example at the end
 
+#' Parse xml records
+#'
+#' Creates a list of tibbles containing relevant information from all records
+#' stored in the input directory.
+#'
+#' @param path character
+#'
+#' @export
 read_all <- function(path="records/") {
     cat("Reading all records from", path, "\n")
     available_protocols <- list.files(path)
@@ -20,7 +28,14 @@ read_all <- function(path="records/") {
         distinct() ->
         talks
 
-    list(redner = redner, reden = reden, talks = talks)
+    lapply(res, `[[`, "comments") %>%
+        bind_rows() %>%
+        distinct() ->
+        comments
+
+    if (length(available_protocols) == 0)
+        warning("The given directory is empty or does not exist.")
+    list(redner = redner, reden = reden, talks = talks, comments = comments)
 }
 
 # this reads all currently parseable data from one xml
@@ -42,7 +57,7 @@ read_one <- function(name, path) {
         parse_redenliste() ->
         res
 
-    list(redner = redner, reden = res$reden, talks = res$talks)
+    list(redner = redner, reden = res$reden, talks = res$talks, comments = res$comments)
 }
 
 xml_get <- function(node, name) {
@@ -78,23 +93,39 @@ parse_rede <- function(rede_xml) {
     principal_redner <- NA_character_
     cur_content <- ""
     reden <- list()
+    comments <- list()
     for (node in cs) {
-        if (xml_name(node) == "p") {
+        if (xml_name(node) == "p" || xml_name(node) == "name") {
             klasse <- xml_attr(node, "klasse")
-            if (!is.na(klasse) && klasse == "redner") {
+            if ((!is.na(klasse) && klasse == "redner") || xml_name(node) == "name") {
                 if (!is.na(cur_redner)) {
                     rede <- c(rede_id = rede_id,
                               redner = cur_redner,
                               content = cur_content)
                     reden <- c(reden, list(rede))
                     cur_content <- ""
-                } else {
+                } 
+                if (is.na(principal_redner) && xml_name(node) != "name") {
                     principal_redner <- xml_child(node) %>% xml_attr("id")
                 }
+                if (xml_name(node) == "name") {
+                    cur_redner <- "BTP"
+                } else {
                     cur_redner <- xml_child(node) %>% xml_attr("id")
+                }
             } else {
                 cur_content <- paste0(cur_content, xml_text(node), sep="\n")
             }
+        } else if (xml_name(node) == "kommentar") {
+            # comments are of the form
+            # <kommentar>(blabla [Fraktion] – blabla liasdf – bla)</kommentar>
+            xml_text(node) %>%
+                str_sub(2, -2) %>%
+                str_split("–") %>%
+                `[[`(1) %>%
+                lapply(parse_comment, rede_id = rede_id, on_redner = cur_redner) ->
+                cs
+            comments <- c(comments, cs)
         }
     }
     rede <- c(rede_id = rede_id,
@@ -102,7 +133,30 @@ parse_rede <- function(rede_xml) {
               content = cur_content)
     reden <- c(reden, list(rede))
     list(rede = c(id = rede_id, redner = principal_redner),
-         parts = reden)
+         parts = reden,
+         comments = comments)
+}
+
+fraktionspattern <- "BÜNDNIS(SES)?\\W*90/DIE\\W*GRÜNEN|CDU/CSU|AfD|SPD|DIE LINKE|FDP|LINKEN"
+fraktionsnames <- c("BÜNDNIS 90/DIE GRÜNEN", "CDU/CSU", "AfD", "SPD", "DIE LINKE", "FDP")
+
+parse_comment <- function(comment, rede_id, on_redner) {
+    base <- c(rede_id = rede_id, on_redner = on_redner)
+    str_extract_all(comment, fraktionspattern) %>%
+        `[[`(1) %>%
+        sapply(partial(flip(head), 1) %.% agrep, x=fraktionsnames, max=0.2, value=T) %>%
+        str_c(collapse=",") ->
+        by
+    # classify comment
+    # TODO:
+    # - actually separate content properly
+    # - differentiate between [AfD] and AfD in by
+    if(str_detect(comment, "Beifall")) {
+        c(base, type = "applause", fraktion = by, kommentator = NA_character_, content = comment)
+    } else {
+        ps <- str_match(comment, "(.*) \\[(.*?)\\]: (.*)")[1,]
+        c(base, type = "comment", fraktion = ps[3], kommentator = ps[2], content = ps[4])
+    }
 }
 
 # creates a tibble of reden and a tibble of talks from a list of xml nodes representing reden
@@ -110,10 +164,17 @@ parse_redenliste <- function(redenliste_xml) {
     d <- sapply(redenliste_xml, parse_rede)
     reden <- simplify2array(d["rede", ])
     parts <- simplify2array %$% unlist(d["parts", ], recursive=FALSE)
+    comments <- simplify2array %$% unlist(d["comments", ], recursive=FALSE)
     list(reden = tibble(id = reden["id",], redner = reden["redner",]),
          talks = tibble(rede_id = parts["rede_id", ],
                         redner = parts["redner", ],
-                        content = parts["content", ]))
+                        content = parts["content", ]),
+         comments = tibble(rede_id = comments["rede_id",],
+                           on_redner = comments["on_redner",],
+                           type = comments["type",],
+                           fraktion = comments["fraktion",],
+                           kommentator = comments["kommentator",],
+                           content = comments["content", ]))
 }
 
 # create a tibble of redner from a list of xml nodes representing redner
@@ -132,7 +193,7 @@ parse_rednerliste <- function(rednerliste_xml) {
 # EXAMPLE USE
 
 # make sure data ist downloaded via fetch.R
-# res <- read_one("19126-data.xml")
+# res <- read_one("records/19126-data.xml")
 # 
 # res$redner
 # res$reden

R/repair.R

@@ -23,25 +23,68 @@ collect_unique <- function(xs) xs %>% clear_na() %>% unique() %>% str_c(collapse
 
 # expects a tibble of redner and repairs
 repair_redner <- function(redner) {
-    redner %>% mutate(fraktion = Vectorize(repair_fraktion)(fraktion)) %>% # fix fraktion
-        group_by(id, vorname, nachname) %>%
-        summarize(fraktion = collect_unique(fraktion),
+    if (nrow(redner) == 0) return(redner)
+    redner %>%
+        filter(id != "10000") %>% # invalid id's
+        mutate(fraktion = Vectorize(repair_fraktion)(fraktion)) %>% # fix fraktion
+        group_by(id) %>%
+        summarize(vorname = head(vorname, 1),
+                  nachname = head(nachname, 1),
+                  fraktion = collect_unique(fraktion),
                   titel = longest_titel(titel),
                   rolle_kurz = collect_unique(str_squish(rolle_kurz)),
-                  rolle_lang = collect_unique(str_squish(rolle_lang)))
+                  rolle_lang = collect_unique(str_squish(rolle_lang))) %>%
+        ungroup() #%>%
+        # arrange(id) %>%
+        # distinct(vorname, nachname, fraktion, titel)
 }
 
 repair_reden <- function(reden) {
+    if (nrow(reden) == 0) return(reden)
     # TODO: fill with content
     reden
 }
 
 repair_talks <- function(talks) {
+    if (nrow(talks) == 0) return(talks)
     # TODO: fill with content
     talks
 }
 
-# repairs all tables
+# tries to find the correct redner id given a name
+# this is sufficient since every prename lastname combination in the bundestag is
+# unique (luckily :D)
+# returns a lookup table
+lookup_redner <- function(comments, redner) {
+    tobereplaced <- "[-–—‑­­-­­­ ]"
+    redner %>%
+        unite(name, vorname, nachname, sep=".*") %>%
+        mutate(name = str_replace_all(name, tobereplaced, ".*")) ->
+        rs
+    find_match <- function(komm) {
+        if (komm == "") return (NA_character_)
+        # I tried with agrep (levensthein distance) but results are better that way
+        matches <- str_which(komm, rs$name)
+        if (length(matches) == 0) return(NA_character_)
+        rs[head(matches, 1), ]$id
+    }
+    comments %>%
+        distinct(kommentator) %>%
+        mutate(redner = Vectorize(find_match)(str_replace_all(kommentator, tobereplaced, "")))
+}
+
+repair_comments <- function(comments, redner) {
+    # try to find a redner id for each actual comment
+    comments %>%
+        filter(!is.na(kommentator)) %>%
+        lookup_redner(redner) %>%
+        left_join(comments, ., by="kommentator") %>%
+        select(-kommentator)
+}
+
+#' Repair parsed tables
+#'
+#' @export
 repair <- function(parse_output) {
     list(redner = repair_redner(parse_output$redner),
          reden = repair_reden(parse_output$reden),

man/fetch_all.Rd

@@ -0,0 +1,14 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/fetch.R
+\name{fetch_all}
+\alias{fetch_all}
+\title{Download available records}
+\usage{
+fetch_all(download_dir = "records/", create = FALSE)
+}
+\arguments{
+\item{download_dir}{character}
+}
+\description{
+This fetches all available records of the 19th legislative period of the german Bundestag.
+}

man/read_all.Rd

@@ -0,0 +1,15 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/parse.R
+\name{read_all}
+\alias{read_all}
+\title{Parse xml records}
+\usage{
+read_all(path = "records/")
+}
+\arguments{
+\item{path}{character}
+}
+\description{
+Creates a list of tibbles containing relevant information from all records
+stored in the input directory.
+}

man/repair.Rd

@@ -0,0 +1,11 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/repair.R
+\name{repair}
+\alias{repair}
+\title{Repair parsed tables}
+\usage{
+repair(parse_output)
+}
+\description{
+Repair parsed tables
+}

reports/zwischenbericht.tex

@@ -0,0 +1,47 @@
+\documentclass{article}
+\usepackage[top=2.5cm, bottom=2.5cm]{geometry}
+
+\begin{document}
+    \section*{Was wurde bisher gemacht?}
+    \begin{itemize}
+        \item Website scrapen
+        \item Protokolle fetchen
+        \item Protokolle parsen
+        \begin{itemize}
+            \item Redner ermitteln
+            \item Redebeiträge extrahieren
+            \item Ordnungskommentare filtern
+            \item Kommentare extrahieren
+            \item Fehler in Redner Tabelle bereinigen
+        \end{itemize}
+    \end{itemize}
+    \section*{Wie ist der Zustand aktuell?}
+    Protokolle sind heruntergeladen und geparsed in einer großen Tabelle.
+    Es gibt noch ein paar Issues, aber das meiste was wir haben funktioniert auch soweit.
+    \section*{Was muss noch gemacht werden?}
+    \begin{itemize}
+        \item Parsen verbessern (muss nicht alles gemacht werden, aber wäre vielleicht schön)
+        \begin{itemize}
+            \item Kommentare in Kategorien einteilen, z.B. Kategorie Beifall mit Liste der applaudierenden Parteien
+            \item Metadaten vom Anfang extrahieren
+            \item Fehler weiter bereinigen (in talks, reden)
+        \end{itemize}
+        \item Error Handling beim Fetchen
+        \item Daten auf bestimmte Fragestellungen untersuchen
+        \begin{itemize}
+            \item Wer redet am häufigsten / längsten?
+            \item Was ist typisches Vokabular für einzelne Fraktionen?
+            \item Welche Fraktion gibt / bekommt den meisten Beifall / die meisten Zwischenrufe?
+            \item Ab wann wird Pandemie-Vokabular (Virus, Corona, Maske, $\dots$ ) genutzt?
+            \item Hat die Pandemie andere Themen wie Klimawandel verdrängt?
+        \end{itemize}
+        \item Ergebnisse visualisieren
+    \end{itemize}
+    \section*{Wie sieht der Plan für die nächsten Wochen aus?}
+    \begin{itemize}
+        \item[-24.07.] Klausurenphase
+        \item[25.07.-31.07.] Datenanalyse
+        \item[01.08.-07.08.] Visualisierung, Bugfixes und Improvements
+        \item[08.08.-11.08.] Präsentation machen 
+    \end{itemize}
+\end{document}

vignettes/funwithdata.Rmd

@@ -14,23 +14,36 @@ knitr::opts_chunk$set(
 )
 ```
 
+```{r setup}
+library(hateimparlament)
+library(dplyr)
+library(ggplot2)
+```
+
+## Preparation of data
+
+First, you need to download all records of the current legislative period.
 ```r
-read_all() %>% repair() -> res
+fetch_all("../records/") # path to directory where records should be stored
+```
+Second, those `.xml` files, need to be parsed into `R` `tibbles`. This is accomplished by:
+```{r}
+read_all("../records/") %>% repair() -> res
 
 reden <- res$reden
 redner <- res$redner
 talks <- res$talks
+```
+We also used `repair` to fix a bunch of formatting issues in the records and unpacked
+the result into more descriptive variables.
 
-# first tries
+## Analysis
 
+Now we can start analysing our parsed dataset, e.g. find out which party gives the most talks:
+```{r}
 left_join(reden, redner, by=c("redner" = "id")) %>%
     group_by(fraktion) %>%
     summarize(n = n()) %>%
     ggplot(aes(x = fraktion, y = n)) +
     geom_bar(stat = "identity")
 ```
-
-
-```{r setup}
-library(hateimparlament)
-```