hateimparlament/R/analyze.R

#' @export
find_word <- function(res, word) {
    talks <- res$talks
    mutate(talks, occurences = sapply(str_match_all(talks$content, regex(word, ignore_case = TRUE)),
           nrow))
}

#'Assign speaker-name to speaker-ID
#'
#' Assign speaker-name to speaker-ID.
#'
#' @param tb tibble
#' @param res list of tibbles
#' @param fraction_only If TRUE select only from "fraction"
#' 
#' @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
}

#'Assignment of the official colors to the parties
#'
#' @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 of the fractions
#'
#' @param tb The tibble to be analyzed. 
#' @param x_variable Default is fraction.
#' @param y_variable Default is n.
#' @param fill Default is fraction.
#' @param title Title of the chart.
#' @param xlab Description of x-Lab. Default is Fraction.
#' @param ylab Description of y-Lab. Default is n.
#' @param filllab Default is Fraction.
#' @param flipped Default is TRUE. If TRUE draw bars horizontally, else vertically.
#' @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).
#'
#' @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
}