Urodziny w Wikipedii

Przedstawiciele jakiego zawodu są najczęściej opisywani w Wikipedii? Czy miesiąc urodzenia predysponuje do wykonywania danego zawodu? Czy w polskiej Wiki więcej jest o Polakach czy innych nacjach?

Pomysł

Któregoś dnia, siedzimy w knajpie z J.P. a właściwie z J.A., z okazji jego urodzin. I tak od słowa do słowa pada “a dzisiaj urodziny ma też Putin”. Sprawdzamy w Wikipedii - faktycznie. A oprócz J.A. i Putina urodziny ma cała masa piłkarzy. I aktorów. I to mnie natchnęło - czym zajmują się (albo zajmowali) osoby opisane w Wikipedii? Którego zawodu jest najwięcej? Wydawałoby się, że ludzi kultury, sztuki i polityki - tak by wypadało, bo tak było zawsze w encyklopedii. Sprawdzimy jak jest naprawdę.

Pobranie danych z Wikipedii

Za listę osób posłużą strony poświęcone każdemu z dni roku. Na każdej takiej stronie (pracujemy z polską Wikipedią) mamy sekcje:

• Święta
• Wydarzenia w Polsce
• Wydarzenia na świecie
• Urodzili się
• Zmarli

Nas interesują osoby urodzone danego dnia. Jeśli technikalia Cię nie interesują - przewiń trochę stronę w dół, do pierwszego wykresu. Przy pomocy kilku funkcji zawartych w pakietach

library(tidyverse)
library(tidytext)
library(stringr)
library(lubridate)

rozpracujemy ten problem. Przygotujemy odpowiednią funkcję, która:

• przygotuje adres strony (na bazie dwóch parametrów - numeru dnia i numeru miesiąca) z Wikipedii
• pobierze tę sronę
• znajdzie odpowiednią sekcję (poświęconą urodzinom)
• wydobędzie z niej listę osób urodzonych, razem z rokiem urodzenia i opisem kim dana osoba jest/była

Funkcja zwróci nam ramkę interesujących nas danych, gotową do dalszej obróbki. Oto i ona, komentarze tłumaczą co i jak:

GetBorn <- function(p_dzien, p_miesiac) {

   html_offset <- 1
   
   # budujemy urla do wikipedii
   miesiace <- c("stycznia", "lutego", "marca", "kwietnia", "maja", "czerwca", "lipca", "sierpnia", "września", "października", "listopada", "grudnia")
   url <- paste0("https://pl.wikipedia.org/wiki/", p_dzien, "_", miesiace[p_miesiac])
   
   
   # pobieramy odpowiedni kawałek strony
   page <- read_html(url)
   page <- page %>% html_node("div.mw-parser-output")
   
   
   # szukamy fragmentu "Urodzili się"
   urodziny <- page %>% html_children() %>% str_detect("Urodzili się") %>% which(arr.ind = TRUE) %>% .[[length(.)]]
   
   # czasem przed listą osób jest coś jeszcze w HTMLu (np. obrazek z Lincolnem 12 lutego)
   if(page %>% html_children() %>% .[[urodziny + 1]] %>% html_name() != "ul")
      html_offset <- html_offset + 1
   
   # bierzemy w kolejnych liniach kolejne osoby
   lista_urodzin <- page %>% html_children() %>% .[[urodziny + html_offset]] %>% html_nodes("li")  %>% html_text()
   
   # rozdzielamy linie na części składowe: rok, osoba
   lista_urodzin <- data_frame(opis = lista_urodzin) %>%
      rowwise() %>%
      mutate(data = str_sub(opis, 1, 6)) %>%
      mutate(rok = gsub("[^0-9]", "", data)) %>%
      mutate(osoba = str_sub(opis, 1 , str_locate(opis, ",")[1]-1)) %>%
      ungroup()
   
   # dla lat gdzie wymienionych jest więcej osób trzeba zrobić wyjątki
   l_rok <- 0
   for(i in 1:nrow(lista_urodzin)) {
      if(nchar(lista_urodzin[i, "rok"]) == 0) {
         lista_urodzin[i, "data"] <- "_" # jakiś unikalny znacznik
         lista_urodzin[i, "rok"] <- l_rok
      }
      else {
         l_rok <- lista_urodzin[i, "rok"]
      }
   }
   
   # wyczyszczenie zbędnych informacji
   lista_urodzin2 <- lista_urodzin %>%
      rowwise() %>%
      mutate(opis2 = gsub(paste0(osoba, ", "), "", opis, fixed = TRUE)) %>%
      mutate(opis2 = gsub(" \\(zm. [0-9]*\\)", "", opis2)) %>%
      mutate(osoba = gsub(data, "", osoba, fixed = TRUE)) %>%
      mutate(osoba = trimws(gsub("–", "", osoba))) %>%
      ungroup() %>%
      filter(!str_detect(data, ":")) %>%
      mutate(rok = as.numeric(rok)) %>%
      mutate(dzien = p_dzien,
             miesiac = p_miesiac) %>%
      mutate(data = make_date(rok, miesiac, dzien)) %>%
      select(rok, miesiac, dzien, data, osoba, opis = opis2)
   
   return(lista_urodzin2)
}

Teraz trzeba uruchomić ją 366 razy (tyle ile dni w roku, licząc z 29 lutego) i wszystkie wyniki zapisać w jednej tabeli:

liczba_dni_w_miesiacu <- c(31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)

tabela <- data_frame()

for(miesiac in 1:12) {
   # dla każdego miesiąca
   for(dzien in 1:liczba_dni_w_miesiacu[miesiac]) {
      # i każdego możliwego dnia w tym miesiącu
      
      # pobierz dane
      tabela <- tabela %>% bind_rows(GetBorn(dzien, miesiac))
      
      # progress bar :) - bo trochę to trwa
      cat(paste("m =", miesiac, "d =", dzien, "\n")) 
   }
}

rm(dzien, miesiac, liczba_dni_w_miesiacu)

Przegląd danych

Mamy zgromadzone dane, zobaczmy co w nich jest:

tabela %>%
   count(rok) %>%
   ggplot() +
   geom_line(aes(rok, n))

Wyżej widzimy liczbę osób urodzonych w kolejnych latach. Oczywiście tylko tych wymienionych w Wikipedii. Widać tutaj pierwszą ciekawostkę: im bliżej teraźniejszości tym więcej osób, o których pisze się na Wiki. To dość naturalne. Postacie historyczne muszą być bardzo interesujące, żeby komuś (szacun dla redaktorów) chciało się tworzyć hasło. Bo czy jakiś burmistrz małego miasteczka z XII wieku jest interesujący? Może wyjątki się znajdą, ale w przeważającej większości raczej nie. A na przykład obecny prezydent Opola już jest - bo człowiek ten występuje gdzieś w przestrzeni publicznej, być może dział PR taki czy inny (z urzędu miasta lub partii, którą reprezentuje) przygotował to hasło. W każdym razie według mnie nie ma nic dziwnego w kształcie powyższej krzywej. Przybliżmy ją trochę, ograniczając ją od XVIII wieku do teraźniejszości:

tabela %>%
   filter(rok >= 1700) %>%
   count(rok) %>%
   ggplot() +
   geom_line(aes(rok, n))

Im bliżej teraźniejszości tym więcej źródeł informacji. Łatwiej więc przygotować hasło. Ale też rozwój nauki (ogólnopojętej) czy kultury większy - więcej ludzi, tańszy druk, tańszy dostęp do wiedzy (szkoły i uniwersytety, prasa). Wszystko to miało wpływ na szersze grono odbiorców rzeczy, które konkretny człowiek wyprodukował (napisał, namalował, odkrył). Zobaczmy jak wygląda rozkład liczy urodzonych osób w zależności od dnia i miesiąca urodzenia:

tabela %>% 
   count(miesiac, dzien) %>%
   ggplot() +
   geom_tile(aes(miesiac, dzien, fill = n), color = "black", show.legend = FALSE) +
   scale_y_reverse() +
   scale_x_continuous(breaks = 1:12) +
   scale_fill_distiller(palette = "RdYlGn") +
   theme(legend.position = "bottom")

Jest stosunkowo równomiernie (przy tej liczbie osób powinno). Pojedyncze czerwone (1 stycznia może być przyczyną złego parsowania wpisów w naszej funkcji pobierającej - napisana jest na szybko, na pewno nie najlepiej jak można) i zielone punkty to być może wyniki błędów przy przekształceniach danych podczas pobierania. Na razie nie dowiedzieliśmy się niczego ciekawego :) Przejdźmy zatem dalej - spróbujmy wydzielić narodowość i zajęcie poszczególnych osób z ich opisów. Potrzebne będzie

rozbicie opisów na słowa

tabela_txt <- tabela %>%
   unnest_tokens(slowa, opis, token = "words") %>%
   distinct()

oraz przygotowanie słowników, bo słowa są różne - przede wszystkim w męskiej i żeńskiej formie (poeta i poetka to to samo zajęcie, dla maszyny jednak inne). Przygotowanie słownika polegać będzie niestety na obróbce ręcznej. Wybierzemy słowa, które w opisach występują co najmniej sto razy (żeby nie było ich zbyt wiele - możecie wszystkie):

tabela_slownik <- count(tabela_txt, slowa, sort = TRUE) %>% ungroup() %>% filter(n > 100)

i zapiszemy je w pliku CSV:

write_csv2(tabela_slownik, file="slownik.csv")

Ten słownik przeedytujemy w Excelu. Każde ze słów sprowadzimy do jednego rodzaju (ja sprowadziłem do rodzaju męskiego - więc ze wspomnianej poetki zostaje poeta), a dodatkowo dodałem znacznik czy słowo określa narodowość (literka a) czy zajęcie (literka z). Teraz można użyć słowników do odpowiedniej zmiany w tabeli z opisami. Najpierw wczytujemy słownik i rozdzielamy na dwa (narodowości i zajęć):

# wczytujemy przeedytowany słownik
slownik <- read_csv2("slownik.csv")
   
# słownik zawodów/zajęć
zawody <- slownik %>% filter(typ == "z") %>% select(-typ) %>% set_names(c("zawod", "kategoria"))

# słownik narodowości
narodowosci <- slownik %>% filter(typ == "a") %>% select(-typ) %>% set_names(c("narodowosc", "kraj"))

a później łączymy je z danymi:

tabela_txt <- left_join(tabela_txt, zawody, by = c("slowa" = "zawod"))
tabela_txt <- left_join(tabela_txt, narodowosci, by = c("slowa" = "narodowosc"))

Dzięki temu zabiegowi możemy zobaczyć o osobach jakich narodowości pisze się najwięcej:

tabela_txt %>%
   filter(rok >= 1800) %>%
   count(rok, kraj) %>%
   na.omit() %>%
   ggplot() +
   geom_line(aes(rok, n, color = kraj), size = 1, show.legend = FALSE) +
   facet_wrap(~kraj)

Kliknij w obrazek, żeby zobaczyć go w większej rozdzielczości. Widać, że wyróżna się oczywiście Polska, Ameryka (w sensie Stany Zjednoczone) oraz europejskie ośrodki kulturalno-naukowo-polityczne (czyli kraje, które mają znaczenie w historii naszej europejskiej cywilizacji): Niemcy, Francja, Włochy czy też Rosja i Anglia (Wielka Brytania). Zobaczmy popularność osób dla tych wybranych narodowości:

wybrane_kraje <- c("amerykański", "brytyjski", "francuski", "niemiecki", "polski", "rosyjski")

tabela_txt %>%
   filter(rok >= 1800) %>%
   count(rok, kraj) %>%
   na.omit() %>%
   filter(kraj %in% wybrane_kraje) %>%
   ggplot() +
   geom_line(aes(rok, n, color = kraj), size = 1) +
   scale_x_continuous(breaks = seq(1800, 2020, 20))

Dominują Polacy i Amerykanie, reszta jest mniej więcej na jednym poziomie. Co ciekawe - młodszych obecnych na Wikipedii mamy więcej Amerykanów niż Polaków. Z czego to wynika? Uprzedzając fakty zdradzę, że z tego jakie zajęcia dominują: aktorzy, piłkarze, osoby znane z pop-kultury. Show bussines w USA jest zdecydowanie większy niż w Polsce, to też tych osób więcej.

Urodzenia według zajęcia

Jak wygląda analogiczny rozkład według zajęcia wykonywanego przez wymienione osoby?

tabela_txt %>%
   filter(rok >= 1800) %>%
   count(rok, kategoria) %>%
   na.omit() %>%
   ggplot() +
   geom_line(aes(rok, n, color = kategoria), size = 1, show.legend = FALSE) +
   scale_y_log10() +
   facet_wrap(~kategoria) +
   theme(axis.text.x = element_text(angle=90, size = 8))

Kliknij w obrazek, żeby zobaczyć go w większej rozdzielczości. Dla osi pionowej zastosowałem skalę logarytmiczną, dzięki czemu lepiej widać dynamikę zmian. A co widać? Ano widać to co już wiemy - im bliżej teraźniejszości tym więcej osób. Ale też to, że aktorów przybywa z roku na rok. Mniej więcej stała na przestrzeni lat jest liczba osób zajmujących się naukami ścisłymi (fizyka, matmatyka, biologia, zoolog) czy też humanistycznymi. W pewnym momencie zaczęły znikać poszczególne zawody: męczennik, jezuita, etnograf, admirał czy święty. To wynika z dwóch rzeczy: po pierwsze już tego typu zajęć się nie praktykuje na skalę która pozwoliłaby znaleźć się w Wikipedii (bo np. wszystko zostało odkryte), a po drugie (co pewnie bardziej prawdopodobnie) - aby dokonać czegoś w danej dziedzinie może potrzeba lat (więc osoby urodzone na przykład w drugiej połowie XX wieku są jeszcze za młode) a może jakiegoś uznania (na przykład tak jest w przypadku świętych). Z drugiej strony pojawiają się nowe kategorie - szeroko rozumiany sport czy kultura masowa. Taki na przykład model/modelka - ktoś kto pokazuje jak wyglądają ubrania ma swoje hasło w Wikipedii (rozumianej jako nowoczesna encyklopedia) - czujecie to? Dla mnie to jest absurdalne… ale wynika z tego, że ta osoba jest jednoczenie na przykład aktorką (lub aktorem). Ciekawie widać jeszcze jedną kategorię: zawody, które trwały jakiś czas i się skończyły. Tak jest z kosmonautami, pułkownikami i w dużym uproszczeniu żołnierzami. Ci ostatni wyjdą nam pod koniec tekstu. Zobaczmy teraz porównanie liczby naukowców, pisarzy, polityków z popkulturą i sportem:

wybrane_zawody <- c("aktor", "piłkarz", "pisarz", "polityk", "wolakista", "piosenkarz", "malarz", "fizyk", "matematyk", "filozof")

tabela_txt %>%
   filter(rok >= 1800) %>%
   count(rok, kategoria) %>%
   na.omit() %>%
   filter(kategoria %in% wybrane_zawody) %>%
   ggplot() +
   geom_line(aes(rok, n, color = kategoria), size = 1)

Potwierdzają się wcześniejsze obserwacje i wnioski: liczba przedstawicieli zawodów wymagających wieloletniej pracy i doświadczenia spada im bliżej roku 2017, a ci, którzy osiągają wyniki w młodości (sportowcy, aktorzy i piosenkarze) już są wymieniani w Wikipedii. W długim (sto lat?) terminie teoretycznie może się to wyrównać. Pisarze urodzeni w latach 90-tych nie zdążyli się jeszcze wsławić i pojawić w Wiki. Albo się nie rodzą. W słownikach warto dodać jeszcze jedną informację, mianowicie dziedzinę danego zajęcia: sport, literatura, polityka, nauki ścisłe, nauki humanistyczne itd. Tak samo można dodać informację o płci. Możecie pobawić się w wolnej chwili.

Najpopularniejsze imiona

Możemy zobaczyć kilka innych przekrojów tych samych danych - na przykład jakie imię występuje naczęściej wśród wymienianych Polaków?

tabela_txt %>%
   filter(kraj == "polski") %>%
   unnest_tokens(txt, osoba) %>%
   filter(!txt %in% c("de", "von", "van")) %>%
   count(txt, sort=T) %>%
   top_n(25, n) %>%
   mutate(txt = factor(txt, levels = rev(unique(txt)))) %>% 
   ggplot() +
   geom_col(aes(txt, n), fill = "lightgreen", color = "gray50") +
   coord_flip()

Albo to samo dla jednej z najliczniejszych grup - piłkarzy (już globalnie):

tabela_txt %>%
   filter(kategoria == "piłkarz") %>%
   unnest_tokens(txt, osoba) %>%
   filter(!txt %in% c("de", "von", "van", "el", "al", "da")) %>%
   count(txt, sort=T) %>%
   top_n(25, n) %>%
   mutate(txt = factor(txt, levels = rev(unique(txt)))) %>% 
   ggplot() +
   geom_col(aes(txt, n), fill = "lightgreen", color = "gray50") +
   coord_flip()

W którym miesiącu rodzą się dane zawody?

Wierzycie w horoskopy? Ja nie bardzo, ale sprawdźmy czy znak zodiaku (tutaj w uproszczeniu do miesiąca) w jakiś sposób określa zajęcie wykonywane przez osobę:

tabela_txt %>%
   filter(!is.na(kategoria)) %>%
   count(miesiac, kategoria) %>%
   group_by(kategoria) %>%
   mutate(sn = sum(n), p = 100*n/sum(n)) %>% mutate(maxp = max(p)) %>%
   ungroup() %>%
   filter(sn > quantile(n, 0.99)) %>%
   mutate(kategoria = factor(kategoria, levels = rev(unique(kategoria)))) %>%
   ggplot() +
   geom_tile(aes(miesiac, kategoria, fill = p), color = "gray50") +
   scale_x_continuous(breaks = 1:12) +
   scale_fill_distiller(palette = "RdYlGn") +
   theme(legend.position = "bottom")

Wykres powyżej pokazuje tylko 1% najpopularniejszych zawodów. Widać, że duchownymi, biskupami czy arcybiskupami są osoby urodzone głównie w czerwcu. Z kolei prawnicy, premierzy i prezydenci rodzą się w październiku (podobnie jak zapaśnicy). Czy to prowadzi do wniosku, że znak zodiaku określa predyspozycje zawodowe? Do tej pory korzystaliśmy z danych ułożonych dość specyficznie - w kolumnie kategoria mamy rozpoznane zawody, w kolumnie kraj mamy narodowość. Dla przykładu:

tabela_txt %>% filter(osoba == "Krzysztof Kieślowski")

Z takich danych nie jest łatwo wyciągnąć informację czy reżyserów (skoro jesteśmy przy Kieślowskim) jest więcej Polaków czy Amerykanów - nie da się nałożyć filtru kraj == polski oraz kategoria == reżyser. A to może być ciekawa obserwacja. Zatem musimy odpowiednio przygotować dane:

# unikalne osoby - nie tylko po nazwisku, ale też po dacie urodznia
unique_persons <- tabela_txt %>%
   filter(!is.na(osoba)) %>%
   select(rok, miesiac, dzien, osoba) %>%
   distinct()


# tutaj będziemy zbierać pełne dane
all_persons <- tibble()

n <- nrow(unique_persons) # na potrzeby progress bara

for(i in 1:n) {
   # progress bar :)
   cat(sprintf("\r%d = %.1f%%", i, round(100*i/n, 1)))
   
   # tymczasowa tabelka
   wynik <- tibble()
   
   # wybieramy część danych - tylko dla konkretnej osoby
   tab <- tabela_txt %>%
      filter(rok == as.numeric(unique_persons[i,"rok"])) %>%
      filter(miesiac == as.numeric(unique_persons[i,"miesiac"])) %>%
      filter(dzien == as.numeric(unique_persons[i,"dzien"])) %>%
      filter(osoba == as.character(unique_persons[i,"osoba"]))
      
   if(nrow(tab) > 0) {
      # unpivot danych
      tab2 <- tab %>%
         mutate(kategoria = ifelse(is.na(kategoria), "kategoriaNA", kategoria)) %>% 
         mutate(v = 1) %>%
         spread(kategoria, v, fill = 0)
      
      # jeśli (najczęściej tak, ale nie zawsze) w kategoriach było NA - usuwamy powstałą kolumnę
      if(sum(colnames(tab2) == "kategoriaNA")) tab2 <- select(tab2, -kategoriaNA)
      
      # czy powstały kolumny z unpivotowania?
      if(ncol(tab2) > 7) {
         # wyciągamy je z wielu wierszy do jednego wiersza
         tab2_c <- colSums(tab2[, 8:ncol(tab2)]) %>% as.data.frame() %>% set_names("l") %>% rownames_to_column() %>% spread(rowname, l)
         
         # wyciągamy wiersz z wartością w kolumnie kraj
         tab2 <- tab2 %>% filter(!is.na(kraj)) %>% select(rok, miesiac, dzien, data, osoba, kraj) 
         
         # jeśli coś zostało - łączymy z kolumnami po unpivocie
         # (jeden losowy wiersz jeśli do osoby przypisany był więcej niż jeden kraj)
         if(nrow(tab2) > 0) wynik <- bind_cols(tab2 %>% sample_n(1), tab2_c)
      }
   }
   
   # łączymy do pełnej tabeli
   all_persons <- all_persons %>% bind_rows(wynik)

   # co 1000 iteracji zapisujemy na wszelki wypadek :)
   if(i %% 1000 == 0) saveRDS(all_persons, file="all_persons_part.RDS")
}

# zmieniamy NA na 0 w kolumnach określających kategorie
all_persons[, 7:ncol(all_persons)][is.na(all_persons[, 7:ncol(all_persons)])] <- 0

# do wykresów potrzebujemy długiej tabeli
all_persons_long <- all_persons %>% 
   gather(key = "zawod", value = "Val", -rok, -miesiac, -dzien, -data, -osoba, -kraj) %>%
   filter(Val != 0) %>%
   select(-Val)

Powyższy kod dla każdej unikalnej osoby (zakładamy, że danego dnia urodziła się tylko jedna osoba o danym imieniu i nazwisku) wyciąga kawałek tabelki (taki sam jak wyżej dla Kieślowskiego) i rozkłada wartości kolumny kategoria w kolejne kolumny. Później wybiera wiersz z niepustą wartością kolumny kraj i dokłada do niego utworzone kolumny odpowiadające za wykonywane zajęcie. Na pewno da się to zrobić lepiej, a jeśli nie - warto to napisać w C (i wykorzystać pakiet Rcpp), bo jest straszliwie wolne. Szczególnie w tym przypadku, gdzie mamy informacje o 118869 osobach. Teraz już możemy sprawdzić z jakiego kraju pochodzą poszczególne zawody:

all_persons_long %>%
   count(kraj, zawod) %>%
   filter(n > quantile(n, 0.97)) %>%
   ggplot() +
   geom_tile(aes(kraj, zawod, fill=n), color = "gray50", show.legend = FALSE) +
   theme(axis.text.x = element_text(angle = 90, vjust = 0, hjust = 1)) +
   scale_fill_distiller(palette = "YlOrRd", direction = 1)

Powyżej tylko 3% najpopularniejszych. Widać, że najwięcej narodowości jest wśród polityków i piłkarzy. Widać, że najwięcej mamy amerykańskich aktorów. Wśród Polaków dominują aktorzy, politycy, działacze i pisarze. Weźmy więc pod lupę Polaków urodzonych w XX i XXI wieku - kogo jest najwięcej?

all_persons_long %>%
   filter(kraj == "polski", rok >= 1900) %>%
   count(zawod, sort = TRUE) %>%
   ungroup() %>%
   top_n(30, n) %>%
   mutate(zawod = factor(zawod, level=zawod)) %>%
   ggplot() +
   geom_col(aes(zawod, n), fill = "lightgreen", color = "gray50") +
   theme(axis.text.x = element_text(angle = 90, vjust = 0, hjust = 1))

Wygrywają aktorzy - w którym roku się urodzili?

all_persons_long %>%
   filter(kraj == "polski", rok >= 1900, zawod == "aktor") %>%
   count(rok) %>%
   ggplot() +
   geom_line(aes(rok, n), color = "blue") +
   scale_x_continuous(breaks = seq(1900, 2020, 5))

Z wykresu wynika, że najwięcej w 1977 roku - kto? Dodajmy od razu opisy bezpośrednio z Wikipedii:

all_persons_long %>%
   filter(kraj == "polski", rok == 1977, zawod == "aktor") %>%
   select(osoba, data) %>%
   arrange(data) %>%
   left_join(tabela, by = c("osoba" = "osoba", "data" = "data")) %>%
   select(osoba,  data, opis) %>%
   arrange(data)

A teraz wrócimy na chwilę do wojskowych (obiecałem to wcześniej). Pojawią się, jeśli poszukamy kto urodził się w kolejnych latach biorąc pod uwagę narodowość radziecką (o ile można tak powiedzieć):

all_persons_long %>%
   filter(kraj == "radziecki", rok >= 1800) %>%
   count(rok, zawod) %>%
   ungroup() %>%
   group_by(zawod) %>%
   mutate(key_sum = sum(n)) %>%
   ungroup() %>%
   filter(key_sum > quantile(key_sum, 0.5)) %>%
   ggplot() +
   geom_tile(aes(rok, zawod, fill = n), color = "gray50", show.legend = FALSE) +
   scale_fill_distiller(palette = "YlOrRd", direction = 1)

Sprawdzaliśmy czy miesiąc urodzenia predysponuje do zawodu, ale dane nie były jeszcze gotowe do podziału po narodowościach. Teraz możemy to samo zrobić dla Polaków:

all_persons_long %>%
   filter(kraj == "polski") %>%
   count(miesiac, zawod) %>%
   ungroup() %>%
   group_by(zawod) %>%
   mutate(key_sum = sum(n),
          p = 100 * n/key_sum) %>%
   ungroup() %>%
   filter(key_sum > quantile(key_sum, 0.75)) %>%
   ggplot() +
   geom_tile(aes(miesiac, zawod, fill = p), color = "gray50") +
   scale_x_continuous(breaks = 1:12) +
   scale_fill_distiller(palette = "YlOrRd", direction = 1) +
   theme(legend.position = "bottom")

Senator, samorządowiec, filozof i ekonomista rodzi się najczęściej w czerwcu. Dla danych globalnych w czerwcu były osoby z hierarchii kościelnej (biskupi itd) - u nas biskup i duchowny to raczej październik.

Czy jakieś polskie nazwisko się powtarza?

all_persons_long %>%
   filter(kraj == "polski") %>%
   select(data, osoba) %>%
   distinct() %>% 
   count(osoba, sort = TRUE) %>%
   ungroup() %>%
   filter(n == max(n))

Spośród tych trzech najczęściej powtarzających się weźmy Andrzeja Nowaka:

tabela %>% filter(osoba == "Andrzej Nowak") %>% select(osoba, data, opis) %>% arrange(data)

W porównaniu z Wikipedią zabrakło nam jeszcze trzech Andrzejów Nowaków: tłumacza, psychologa i lekkoatlety. Dlaczego? Tłumacz urodzony w 1944 roku nie ma podanej dokładnej daty urodzenia (i tym samym nie znajdziemy go zapewne na stronie informującej o wydarzeniach konkretnego dnia), psycholog ma datę urodzenia (12 czerwca), ale nie ma go na stronie poświęconej temu dniu (a to tylko z niej zebraliśmy informacje). Zaś dla lekkoatlety nie ma przygotowanej żadnej strony (więc nie ma jak sprawdzić jakiego dnia się urodził). Pamiętajcie też, że Wikipedia nie uzupełnia automatycznie swoich stron - w przypadku Andrzeja Nowaka psychologa to wyraźnie widać: ktoś przygotował hasło o nim, ale nie wpisał go na listę osób urodzonych 12 czerwca. A reżyserów w polskiej Wikipedii najwięcej jest polskich, w drugiej kolejności amerykańskich:

all_persons_long %>% filter(zawod == "reżyser") %>% count(kraj, sort = TRUE) %>% top_n(5, n)

Z aktorami jest odwtornie (5059 amerykańskich, 3225 polskich). Na koniec tabelka z najmłodszymi Polakami w każdym z zawodów wymienionych w Wikipedii:

all_persons_long %>%
   filter(kraj == "polski") %>%
   group_by(zawod) %>%
   filter(data == max(data)) %>%
   ungroup() %>%
   select(osoba, data, zawod) %>%
   distinct() %>%
   arrange(desc(data))

Podobało się? Pokaż znajomym, wrzuć na Wykop czy co tam jeszcze uznasz za stosowne! :)