Based on data from api.sejm.gov.pl
# Libraries
library(knitr)
library(dplyr, warn.conflicts = FALSE)
options(dplyr.summarise.inform = FALSE)
library(ggplot2)
library(treemapify)
library(DT)
library(lubridate, warn.conflicts = FALSE)
library(calendR)
library(deeplr)
library(igraph)
library(RColorBrewer)
# Data
mp_path <- "./Data/mp.csv"
clubs_path <- "./Data/clubs.csv"
mp <- read.csv(mp_path)
clubs <- read.csv(clubs_path)API_KEY <- Sys.getenv("DEEPL_API")
# educationLevel
mp$educationLevel = replace(mp$educationLevel,
mp$educationLevel=="wyższe",
"higher")
mp$educationLevel = replace(mp$educationLevel,
mp$educationLevel=="średnie ogólne",
"tertiary")
mp$educationLevel = replace(mp$educationLevel,
mp$educationLevel=="średnie zawodowe",
"vocational tertiary")
mp$educationLevel = replace(mp$educationLevel,
mp$educationLevel=="średnie policealne/pomaturalne",
"post-secondary")
# profession
mp$profession[is.na(mp$profession)] <- ''
mp$profession <- translate2(text = mp$profession,
source_lang = "PL",
target_lang = "EN",
auth_key = API_KEY)
mp$profession[mp$profession == ''] <- NA
# inactiveCause
mp$inactiveCause = replace(mp$inaciveCause,
mp$inactiveCause=="Zrzeczenie",
"abdication")
mp$inactiveCause = replace(mp$inactiveCause,
mp$inactiveCause=="Zgon",
"death")
# waiverDesc
mp$waiverDesc = replace(mp$waiverDesc,
mp$waiverDesc=="Zmarł",
"Died")
mp$waiverDesc = replace(mp$waiverDesc,
mp$waiverDesc=="Objął mandat posła do Parlamentu Europejskiego",
"Became a member of the European Parliament")
mp$waiverDesc = replace(mp$waiverDesc,
mp$waiverDesc=="Utrata prawa wybieralności",
"Loss of the right to be elected")
mp$waiverDesc = replace(mp$waiverDesc,
mp$waiverDesc=="Wybrany na funkcję Prezydenta Miasta Krakowa",
"Elected as Mayor of the City of Krakow")
mp$waiverDesc = replace(mp$waiverDesc,
mp$waiverDesc=="Wybrany na funkcję Prezydenta Miasta Leszna",
"Elected as Mayor of the City of Leszno")
mp$waiverDesc = replace(mp$waiverDesc,
mp$waiverDesc=="Powołany na członka Zarządu Narodowego Banku Polskiego",
"Appointed as a member of the Management Board of the National Bank of Poland")This data has been downloaded from API of Polish Parliament, to analyze the general statistics considering Polish MPs, and to give an insights on political processes of the Polish political body.
datatable(mp, filter = "top")active: Determines if MP is an active MP
birthDate: Date of birth
birthLocation: Location of birth
club: Club membership
districtName: Name of the district of the MP
districtNum: Number of the district of the MP
educationLevel: Education level of the MP
email: E-mail to the MP
firstLastName: First and last name of the MP
firstName: First name of the MP
id: Id of the MP
lastFirstName: Last and first name of the MP
lastName: Last name of the MP
numberOfVotes: Number of votes for the MP
profession: Profession of the MP
secondName: Second name
voivodeship: Voivodeship of the MP
inactiveCause: The cause why MP is inactive (if inactive)
waiverDesc: Description of the cause why MP is inactive (if inactive)
kable(clubs)| fax | id | membersCount | name | phone | |
|---|---|---|---|---|---|
| kp-ko@kluby.sejm.pl | (22) 694-25-92 | KO | 155 | Klub Parlamentarny Koalicja Obywatelska - Platforma Obywatelska, Nowoczesna, Inicjatywa Polska, Zieloni | NA |
| (22) 694-29-31 | Konfederacja | 18 | Klub Poselski Konfederacja | NA | |
| (22) 694-28-20 | Kukiz15 | 3 | Koło Poselskie Kukiz’15 | NA | |
| kp-lewica@kluby.sejm.pl | (22) 694-28-16 | Lewica | 26 | Koalicyjny Klub Parlamentarny Lewicy (Nowa Lewica, PPS, Razem, Unia Pracy) | NA |
| (22) 694-15-34 | niez. | 2 | Posłowie niezrzeszeni | NA | |
| kp-pis@kluby.sejm.pl | (22) 694-26-11 | PiS | 189 | Klub Parlamentarny Prawo i Sprawiedliwość | NA |
| kp-polska2050@kluby.sejm.pl | (22) 694-29-12 | Polska2050-TD | 32 | Klub Parlamentarny Polska 2050 - Trzecia Droga | NA |
| kp-psl@kluby.sejm.pl | (22) 694 23 21 | PSL-TD | 32 | Klub Parlamentarny Polskie Stronnictwo Ludowe - Trzecia Droga | NA |
email: E-mail of the club
fax: Fax of the club
id: Id of the club
membersCount: Number of members
name: Name of the club
phone: Phone number of the club
We would drop phone, email, and fax of the club, as it is data, we don’t need for the statistical analysis
clubs <- clubs %>%
select(id, membersCount, name)We would also drop firstLastName, and lastFirstName, as those are redundant in respect to firstName, secondName, and lastName
mp <- mp %>%
select(!c(lastFirstName))We also change birthDate to the date type
mp <- mp %>%
mutate(birthDate = as_date(birthDate))club_distribution <- mp %>% group_by(club) %>%
summarise(number_of_members = n()) %>%
arrange(desc(number_of_members))
kable(club_distribution)| club | number_of_members |
|---|---|
| PiS | 192 |
| KO | 159 |
| PSL-TD | 32 |
| Polska2050-TD | 32 |
| Lewica | 26 |
| Konfederacja | 18 |
| Kukiz15 | 3 |
| niez. | 2 |
As we can see from the table the biggest club in the parliament right now is PiS with 192 MPs.
voivodeship_distribution <- mp %>%
group_by(voivodeship, club) %>%
summarise(number_of_members = n()) %>%
arrange(voivodeship, desc(number_of_members))
per_voivodeship <- voivodeship_distribution %>%
group_by(voivodeship) %>%
summarise(number_of_members = sum(number_of_members))
ggplot(per_voivodeship, aes(x="", y=number_of_members, fill=voivodeship)) +
geom_bar(stat="identity") + coord_polar("y")
ggplot(voivodeship_distribution, aes(fill=club, y=number_of_members, x=club)) +
geom_bar(position="dodge", stat="identity") +
scale_x_discrete(labels = NULL, breaks = NULL) +
labs(x = NULL) +
facet_wrap(~voivodeship)
ggplot(mp, aes(x=educationLevel)) +
geom_bar()
professions <- mp %>%
group_by(profession) %>%
summarize(number = n()) %>%
filter(!is.na(profession)) %>%
arrange(desc(number))
datatable(professions, filter = "top")p <- professions %>% filter(number > 1)
ggplot(p, aes(x=profession, y=number)) +
geom_segment(aes(x=profession, xend=profession, y=0, yend=number)) +
theme(axis.text.x = element_text(size = 8, angle = 45, hjust = 1))
not_active <- mp %>% filter(!active) %>%
select(firstName, secondName, lastName, club, inactiveCause, waiverDesc)
kable(not_active)| firstName | secondName | lastName | club | inactiveCause | waiverDesc |
|---|---|---|---|---|---|
| Krzysztof | NA | Brejza | KO | abdication | Became a member of the European Parliament |
| Mariusz | NA | Kamiński | PiS | NA | Loss of the right to be elected |
| Rajmund | Tadeusz | Miller | KO | NA | Died |
| Aleksander | Jan | Miszalski | KO | abdication | Elected as Mayor of the City of Krakow |
| Grzegorz | Stanisław | Rusiecki | KO | abdication | Elected as Mayor of the City of Leszno |
| Artur | NA | Soboń | PiS | abdication | Appointed as a member of the Management Board of the National Bank of Poland |
| Maciej | NA | Wąsik | PiS | NA | Loss of the right to be elected |
treemap <- mp %>% mutate(secondName = ifelse(is.na(secondName), "", secondName))
ggplot(treemap, aes(area=numberOfVotes, fill=club,
label=paste(firstName, secondName, lastName), subgroup=club)) +
geom_treemap() +
geom_treemap_subgroup_border() +
geom_treemap_text(min.size=1) +
theme_void()
ggplot(mp, aes(x=club, y=numberOfVotes, fill=club)) +
geom_boxplot() +
theme_classic() +
theme(legend.position="none")
# https://r-charts.com/evolution/calendar-heatmap/
birthdays_per_day <- mp %>%
group_by(month = month(birthDate), day = day(birthDate)) %>%
summarise(number=n())
birthdays_per_day <- birthdays_per_day %>%
mutate(date = as.Date(paste("2024", month, day, sep="-"))) %>%
mutate(yday = yday(date))
all_days_df <- data.frame(yday = 1:366)
merged_df <- merge(all_days_df, birthdays_per_day, by = "yday", all.x = TRUE)
merged_df$number[is.na(merged_df$number)] <- 0
calendR(year = 2024,
special.days = merged_df$number,
gradient = TRUE,
low.col = "#FCFFDD",
special.col = "#00AAAE",
legend.pos = "bottom",
day.size=3.5,
title.size = 0,
weeknames.size=2)
The Polish Parliament API provides the data on all the voting, including the votes of a single MP. It provides a great opportunity to statistically analyze, and visualize the processes behind most important decisions in Poland.
# Two votings types: Yes/No; on list.
# Ignoring on list, as not significant number of entries.
votings_path <- "./Data/votings/"
# Yes/No votings
y_n_votings <- read.csv(paste0(votings_path, "y_n_votings.csv"))We are dropping yes column, as it contains number of yes votes, votes.firstName, votes.lastName, votes.secondName, votes.club, term, notParticipating, totalVoted, and no as those data is redundant or is not relevant. We would also drop kind as it has {R} length(unique(y_n_votings$kind)) unique value.
# Yes/No votings
y_n_votings <- y_n_votings %>% select(
!(c(yes,
notParticipating,
votes.firstName,
votes.lastName,
votes.secondName,
votes.club,
term,
totalVoted,
no,
kind)))
y_n_votings$date <- as.POSIXct(y_n_votings$date, format = "%Y-%m-%dT%H:%M:%S")The dataset after cleaning has the following columns:
names(y_n_votings) [1] "abstain" "date" "sitting" "sittingDay" "title"
[6] "votes.MP" "votes.vote" "votingNumber" "topic" "description" abstain: 1 if MP abstained during voting, 0 otherwise
date: Date of the voting
sitting: Number of sitting
sittingDay: Day of the sitting
title: Title of the voting
votes.MP: ID of the MP
votes.vote: Vote of the MP
votingNumber: Number of voting
topic: Topic of the voting
description: Description of the voting
Sessions of Polish Parliament are divided into points, and votings. In this data, title column regards the point of the session, when topis, and description regard voting.
votings_per_sitting <- y_n_votings %>%
group_by(sitting, sittingDay) %>%
summarise(number_of_votings = max(votingNumber))
# Plot data
ggplot(votings_per_sitting, aes(x = factor(sitting),
y = number_of_votings,
fill = factor(sittingDay))) +
geom_bar(stat = "identity", position = "dodge") +
labs(title = "Number of Votings per Sitting with Days Distinction",
x = "Sitting Number",
y = "Number of Votings",
fill = "Sitting Day") +
theme_minimal()
# https://r-charts.com/evolution/calendar-heatmap/
votings_per_day <- y_n_votings %>%
group_by(date) %>%
summarize(number = max(votingNumber))
votings_per_day <- votings_per_day %>%
mutate(yday = yday(date)) %>%
group_by(yday) %>%
summarize(number = max(number))
all_days_df <- data.frame(yday = 1:367)
merged_df <- merge(all_days_df, votings_per_day, by = "yday", all.x = TRUE)
merged_df <- merged_df %>%
mutate(yday = ifelse(yday <= 317, yday, yday-317))
merged_df$number[is.na(merged_df$number)] <- 0
calendR(year = 2024,
special.days = merged_df$number,
from=as.Date("2023-11-13"),
to=as.Date("2024-11-13"),
gradient = TRUE,
low.col = "#FCFFDD",
special.col = "#00AAAE",
legend.pos = "bottom",
day.size=3.5,
title.size = 0,
weeknames.size=2)
y_n_votings <- y_n_votings %>%
mutate(day_of_week = wday(date, label = TRUE, week_start = 1),
hour = hour(date))
votings_per_day_time <- y_n_votings %>%
group_by(day_of_week, hour) %>%
summarise(number_of_votings = max(votingNumber)) %>%
ungroup()
ggplot(votings_per_day_time, aes(x = hour, y = day_of_week,
fill = number_of_votings)) +
geom_tile(color = "white") +
scale_fill_gradient(low = "yellow", high = "red") +
labs(title = "Heatmap of Votings by Day and Time",
x = "Hour of Day",
y = "Day of Week",
fill = "Number of Votings") +
theme_minimal()
merged_data <- y_n_votings %>%
left_join(mp, by = c("votes.MP" = "id")) %>%
left_join(clubs, by = c("club" = "id"))
abstained_votes_percentage <- merged_data %>%
group_by(club) %>%
summarise(total_votes = n(),
abstained_votes = sum(abstain==1)) %>%
mutate(percentage_abstained = (abstained_votes / total_votes) * 100) %>%
ungroup()
ggplot(abstained_votes_percentage, aes(x = club, y = percentage_abstained)) +
geom_bar(stat = "identity", fill = "skyblue", width = 0.5) +
labs(title = "Percentage of Abstained Votes by Club",
x = "Club",
y = "Percentage of Abstained Votes") +
theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1))
abstaining <- y_n_votings %>%
inner_join(mp, by = c("votes.MP" = "id")) %>%
group_by(firstName, secondName, lastName, club) %>%
summarise(Abstain_Count = sum(abstain==1),
Total_Votes = n(),
Abstain_Rate = round(sum(abstain==1) / n() * 100, 2)) %>%
arrange(desc(Abstain_Rate))
datatable(abstaining, filter = "top")least_voting <- y_n_votings %>%
inner_join(mp, by = c("votes.MP" = "id")) %>%
group_by(firstName, secondName, lastName, club) %>%
summarise(Vote_Count = n()) %>%
arrange(Vote_Count)
datatable(least_voting, filter = "top")Let’s create a function to filter data for a specific MP
filter_mp_data <- function(mp_id, mp_data, voting_data) {
mp <- mp_data[mp_data$id == mp_id, ]
votes <- voting_data[voting_data$`votes.MP` == mp_id, ]
return(list(mp = mp, votes = votes))
}Let’s create a function to calculate the similarity of two MPs
calculate_similarity <- function(mp1_votes, mp2_votes) {
merged_votes <- merge(mp1_votes, mp2_votes,
by = c("sitting", "votingNumber"),
suffixes = c("_mp1", "_mp2"))
# Calculate similarity score (percentage of matching votes)
total_votes <- nrow(merged_votes)
if (total_votes == 0) {
return(0) # No common votes
}
matching_votes <-sum(merged_votes$votes.vote_mp1 ==
merged_votes$votes.vote_mp2, na.rm = TRUE)
similarity_score <- matching_votes / total_votes
return(similarity_score)
}We want to create the networks around leaders of the clubs
leaders_ids <- c(148, 400, 241, 133, 174, 58)build_similarity_network <- function(mp_data, voting_data, threshold = 0.6) {
mp_ids <- unique(mp_data$id)
n_mps <- length(mp_ids)
similarity_matrix <- matrix(0, nrow = n_mps, ncol = n_mps)
rownames(similarity_matrix) <- mp_ids
colnames(similarity_matrix) <- mp_ids
for (i in 1:(n_mps - 1)) {
for (j in (i + 1):n_mps) {
mp1_data <- filter_mp_data(mp_ids[i], mp_data, voting_data)
mp2_data <- filter_mp_data(mp_ids[j], mp_data, voting_data)
similarity_score <- calculate_similarity(mp1_data$votes, mp2_data$votes)
similarity_matrix[i, j] <- similarity_score
similarity_matrix[j, i] <- similarity_score
}
}
similarity_matrix <- (similarity_matrix + t(similarity_matrix)) / 2
graph <- graph_from_adjacency_matrix(similarity_matrix,
mode = "undirected",
weighted = TRUE,
diag = FALSE)
graph <- delete_edges(graph, E(graph)[E(graph)$weight < threshold])
# Print diagnostic information
print(paste("Number of vertices in graph:", vcount(graph)))
print(paste("Number of rows in mp_data:", nrow(mp_data)))
print(paste("Number of unique IDs in mp_data:", length(unique(mp_data$id))))
# Check if all graph vertex names are in mp_data$id
missing_ids <- setdiff(V(graph)$name, mp_data$id)
if (length(missing_ids) > 0) {
warning("Some vertex IDs are not present in mp_data$id")
print(paste("Number of missing IDs:", length(missing_ids)))
print("First few missing IDs:")
print(head(missing_ids))
}
# Create a data frame for vertex attributes, handling potential mismatches
vertex_attr <- data.frame(
name = V(graph)$name,
stringsAsFactors = FALSE
)
# Match attributes, using NA for any unmatched IDs
vertex_attr$club <- mp_data$club[match(vertex_attr$name, mp_data$id)]
vertex_attr$firstLastName <-
mp_data$firstLastName[match(vertex_attr$name, mp_data$id)]
# Add attributes to the graph
graph <- set_vertex_attr(graph, "club",
value = vertex_attr$club)
graph <- set_vertex_attr(graph, name = "firstLastName",
value = vertex_attr$firstLastName)
# Print diagnostic information about attributes
print(paste("Number of vertices with 'club' attribute:",
sum(!is.na(vertex_attr$club))))
print(paste("Number of vertices with 'firstLastName' attribute:",
sum(!is.na(vertex_attr$firstLastName))))
return(graph)
}# Function to assign colors to clubs
assign_club_colors <- function(graph) {
clubs <- unique(vertex_attr(graph, "club"))
clubs <- clubs[!is.na(clubs) & clubs != ""]
n_clubs <- length(clubs)
if (n_clubs > 0) {
color_palette <- brewer.pal(max(3, min(n_clubs, 9)), "Set1")
club_colors <- setNames(color_palette[1:min(n_clubs, 9)], clubs)
V(graph)$color <- club_colors[vertex_attr(graph, "club")]
} else {
V(graph)$color <- "lightblue"
}
V(graph)$color[is.na(V(graph)$color) | V(graph)$color == ""] <- "gray"
return(list(graph = graph, club_colors = club_colors))
}
# Function to set leader labels
set_leader_labels <- function(graph, leaders_ids) {
V(graph)$label <- rep(NA, vcount(graph))
leader_indices <- which(V(graph)$name %in% as.character(leaders_ids))
if (length(leader_indices) > 0 && "firstLastName" %in% vertex_attr_names(graph)) {
leader_names <- vertex_attr(graph, "firstLastName")[leader_indices]
valid_names <- !is.na(leader_names) & leader_names != ""
V(graph)$label[leader_indices[valid_names]] <- leader_names[valid_names]
}
return(list(graph = graph, leader_indices = leader_indices))
}
# Function to plot the graph
plot_network <- function(graph, layout, leader_indices) {
par(mar = c(1, 1, 2, 1), bg = "gray95")
plot(graph,
vertex.label = NA,
edge.width = E(graph)$weight * 0.4,
edge.color = adjustcolor("gray40", alpha.f = 0.4),
edge.curved = 0.2,
layout = layout,
rescale = TRUE,
asp = 0,
main = "Network Visualization")
grid(nx = NULL, ny = NULL, col = "gray90", lty = "dotted")
}
# Function to add leader labels
add_leader_labels <- function(graph, layout, leader_indices) {
for (i in seq_along(leader_indices)) {
idx <- leader_indices[i]
if (!is.na(V(graph)$label[idx])) {
angle <- 2 * pi * i / length(leader_indices)
x_offset <- cos(angle) * 0.15
y_offset <- sin(angle) * 0.15
coords <- layout[idx,]
arrows(coords[1], coords[2],
coords[1] + x_offset, coords[2] + y_offset,
length = 0.1, col = "black", lwd = 1.5)
text(coords[1] + x_offset * 1.2, coords[2] + y_offset * 1.2,
V(graph)$label[idx],
cex = 0.9, font = 2)
}
}
}
# Function to add legend
add_legend <- function(club_colors) {
legend_colors <- c(club_colors, "black")
legend_names <- c(names(club_colors), "Leaders")
legend_pch <- c(rep(19, length(club_colors)), 19) # Changed to 19 for leaders
legend("topright", legend = legend_names,
col = legend_colors, pch = legend_pch, pt.cex = 1,
title = "Clubs and Leaders", bty = "n", cex = 0.7,
ncol = 2, x.intersp = 0.5, y.intersp = 0.7)
}
# Main visualization function
visualize_network <- function(graph, leaders_ids) {
# Assign colors and set labels
color_result <- assign_club_colors(graph)
graph <- color_result$graph
club_colors <- color_result$club_colors
label_result <- set_leader_labels(graph, leaders_ids)
graph <- label_result$graph
leader_indices <- label_result$leader_indices
# Adjust node sizes
V(graph)$size <- 3
V(graph)$size[leader_indices] <- 8
# Calculate layout
layout <- layout_with_kk(graph)
# Plot the graph
plot_network(graph, layout, leader_indices)
# Add leader labels
add_leader_labels(graph, layout, leader_indices)
# Add legend
add_legend(club_colors)
}graph <- build_similarity_network(mp, y_n_votings)[1] "Number of vertices in graph: 464"
[1] "Number of rows in mp_data: 464"
[1] "Number of unique IDs in mp_data: 464"
[1] "Number of vertices with 'club' attribute: 464"
[1] "Number of vertices with 'firstLastName' attribute: 464"visualize_network(graph, leaders_ids)
mp <- mp %>% mutate(id = as.character(id))
most_similar <- as_data_frame(graph, what = "edges") %>%
arrange(desc(weight)) %>%
head(10)
most_similar <- most_similar %>%
left_join(mp %>% select(id, firstName, lastName, club),
by = c("from" = "id")) %>%
left_join(mp %>% select(id, firstName, lastName, club),
by = c("to" = "id"),suffix = c("_from", "_to"))
datatable(most_similar, filter = "top")The above tables with network visualize the connections between the MPs regarding their voting decisions in the parliament. It is left for the reader to interpret those information.
This project aimed to empower voters by providing a deeper understanding of political bodies through a detailed analysis of Members of Parliament and their voting patterns. By offering insights into general statistics and performing network analysis on voting behaviors, the project equips individuals with the knowledge needed to make more informed and thoughtful political decisions. Through data-driven insights, it promotes transparency and fosters greater civic engagement in the political process.
A work by Borys Łangowicz
borys.langowicz@mail.utoronto.ca