hateimparlament/R/analyze.R

#' Count number of occurences of a given word
#' 
#' @param res tibble
#' @param word character
#'
#' Add number of occurences of word to talks
#' 
#' @export
find_word <- function(res, word) {
    talks <- res$talks
    mutate(
        talks, 
        occurences = sapply(
            str_match_all(talks$content, regex(word, ignore_case = TRUE)),
            nrow
        )
    )
}

#' add information from speaker table to a tibble containing speaker id
#' 
#' @param tb tibble
#' @param res list of tibbles
#' @param fraction_only if TRUE, only select fraction from the resulting joined tibble
#' 
#' left join speaker information from res$speaker into tb.
#' if fraction_only 
#'
#' @export
join_speaker <- function(tb, res, fraction_only = F) {
    joined <- left_join(tb, res$speaker, by=c("speaker" = "id"))
    if (fraction_only) select(joined, "fraction")
    else joined
}

#' lookup table for official party colors
#'
#' @export
party_colors <- c(
  AfD="#1A9FDD",
  FDP="#FEEB34",
  "CDU/CSU"="#000000", 
  SPD="#DF0B25",
  "BÜNDNIS 90 / DIE GRÜNEN"="#4A932B",
  "DIE LINKE"="#BC3475",
  "AfD&Fraktionslos"="#AAAAFF",
  Fraktionslos="#AAAAAA"
)

party_order <- factor(c("Fraktionslos", "AfD&Fraktionslos",
                        "DIE LINKE", "BÜNDNIS 90 / DIE GRÜNEN", "SPD", "CDU/CSU",
                        "FDP", "AfD", NA_character_))

#' Bar chart visualizing fraction based data
#' 
#' Can be configured to also visualize data not related to fractions.
#' 
#' @param tb tibble
#' @param x_variable column in tb, default is fraction
#' @param y_variable column in tb, default is n
#' @param fill column in tb, default is fraction
#' @param title plot title
#' @param xlab label for x axis, default is fraction
#' @param ylab label for y axis, default is n
#' @param filllab default is 'Fraction'
#' @param flipped if TRUE draw bars horizontally, else vertically. Default is TRUE
#' @param position default is 'dodge'
#' @param reorder Either reorder fraction factor by variable value or reorder fraction factor by party seat order in parliament (default).
#' 
#' plot data from tb in the following way: for each item in x_variable show the corresponding value in y_variable.
#' Then color the plot depending on the fill value.
#' Give the plot a title and a label for x-axis and y-axis,
#' color the legend according to filllab and finally
#' improve positioning details according to position
#' 
#' @export
bar_plot_fractions <- function(tb,
                                x_variable = NULL, # default is fraction
                                y_variable = NULL, # default is n
                                fill = NULL, # default is fraction
                                title = NULL,
                                xlab = "Fraction",
                                ylab = "n",
                                filllab = "Fraction",
                                flipped = TRUE,
                                position = "dodge",
                                reorder = FALSE) {
    # capture expressions in arguments
    fill <- enexpr(fill)
    y_variable <- enexpr(y_variable)
    x_variable <- enexpr(x_variable)

    # set default values
    if (is.null(fill)) fill <- expr(fraction)
    if (is.null(y_variable)) y_variable <- expr(n)
    if (is.null(x_variable)) x_variable <- expr(fraction)

    # either reorder fraction factor by variable value
    if (reorder) maps <- aes(x = reorder(!!x_variable, -!!y_variable),
                             y = !!y_variable,
                             fill = reorder(!!fill, -!!y_variable))
    # or reorder fraction factor by party seat order in parliament (default)
    else maps <- aes(x = factor(!!x_variable, levels = party_order),
                     y = !!y_variable,
                     fill = factor(!!fill, levels = party_order))
    # make a bar plot
    ggplot(tb, maps) +
        scale_fill_manual(values = party_colors, na.value = "#555555") +
        xlab(xlab) +
        ylab(ylab) +
        labs(fill = filllab) +
        ggtitle(title) +
        geom_bar(stat = "identity", position = position) ->
        plt
    # if flipped == TRUE, draw bars horizontally (default TRUE)
    if (flipped) plt + coord_flip() else plt
}

#' Word usage summarised by date
#'
#' Counts how many talks do match a given pattern and summarises by date.
#'
#' @param res List of Tibbles to be analysed.
#' @param patterns Words to look up.
#' @param name ?
#' @param tidy default is FALSE.
#'
#' @export
word_usage_by_date <- function(res, patterns, name, tidy=F) {
    tb <- res$talks
    nms <- names(patterns)
    for (i in seq_along(patterns)) {
        if (!is.null(nms)) name <- nms[[i]]
        else name <- patterns[[i]]
        tb <- mutate(tb, {{name}} := str_count(content, patterns[[i]]))
    }
    left_join(tb, res$speeches, by=c("speech_id" = "id")) %>%
        group_by(date) %>%
        summarize(across(where(is.numeric), sum)) %>%
        arrange(date) -> tb
    if (!tidy) pivot_longer(tb, where(is.numeric) , names_to = "pattern", values_to="count")
    else tb
}