Komu rośnie, a komu spada? Czy PSL przekroczy próg 5% i załapie się do Sejmu? Czy “totalna opozycja” już przegrywa z partią rządzącą czy jeszcze nie? Takie pytania rozgrzewają komentatorów polskiej sceny politycznej mniej więcej raz w tygodniu, przy okazji publikacji kolejnych sondaży przedwyborczych.
Zajmiemy się więc tymi sondażami.
Długo szukałem archiwalnych danych sondażowych, aż w końcu na Twitterze ktoś podrzucił linka do serwisu ewybory.eu. Przeglądając stronę znalazłem tabelę z tym co mnie interesowało – pełną historią sondaży. Po zerknięciu w kod strony okazuje się, że jest to osadzony arkusz Google Spreadsheets i wystarczy się do niego dobrać. Do samego arkusza się nie dostałem (więc nie udało się wykorzystać mechanizmów jak w poście z podsumowaniem wyników mojej ankiety), ale dane można pobrać z publicznego widoku HTML tego arkusza:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
library(tidyverse) library(rvest) library(lubridate) library(forecast) url <- "https://docs.google.com/spreadsheets/d/1P9PG5mcbaIeuO9v_VE5pv6U4T2zyiRiFK_r8jVksTyk/htmlembed?single=true&gid=0&range=a10:o400&widget=false&chrome=false" page <- read_html(url) # pobieramy tabelę z treści strony sondaze <- page %>% html_nodes("table") %>% html_table(fill = TRUE) %>% .[[1]] # potrzebujemy tabeli bez górnych wierszy sondaze <- sondaze[3:nrow(sondaze),c(2,4,5,6,8:16)] # nadajemy nazwy kolumnom colnames(sondaze) <- c("Osrodek", "Publikacja", "Metoda", "UwzgNiezdecydowani", "PiS", "PO", "K15", "N", "PSL", "SLD", "Razem", "Wolnosc", "NieZdec") # poprawiamy typ daty sondaze$Publikacja <- dmy(sondaze$Publikacja) # zmieniamy przecinki na kropki, a później ciąg na liczbę for(nc in 5:13) { sondaze[,nc] <- as.numeric(gsub(",", ".", sondaze[,nc], fixed = TRUE)) } |
Mamy pobrane dane, zobaczmy notowania dla jednej z partii – czy wyglądają sensownie (czyli czy pobraliśmy to co chcieliśmy)? Niech będzie PiS:
|
1 2 3 4 |
sondaze %>% ggplot() + geom_point(aes(Publikacja, PiS, group = Osrodek, color = Osrodek)) + geom_smooth(aes(Publikacja, PiS)) |
Trend jest wyraźny (i zgodny z tym co słyszymy w mediach), mimo że rozstrzał pomiędzy różnymi ośrodkami jest całkiem spory. Spróbujmy wybrać konkretną metodę przygotowania sondażu oraz ośrodki badawcze robiące najwięcej pomiarów (z czego – trochę może na wyrost – można wnioskować, że są to ośrodki dobre, znające się na swojej robocie).
Zatem który ośrodek badawczy i jaką metodą przygotował najwięcej sondaży?
|
1 2 3 4 |
sondaze %>% count(Osrodek, Metoda) %>% ggplot() + geom_tile(aes(Metoda, Osrodek, fill = n), color = "gray80") |
Widzimy, że metoda CATI (czyli wywiad przez telefon) jest najpopularniejsza w ośmiu sondażowniach:
|
1 2 3 |
sondaze %>% filter(Metoda == "CATI") %>% count(Osrodek, sort = TRUE) |
| Ośrodek badawczy | Liczba sondaży przeprowadzonych metodą CATI |
|---|---|
| IBRiS | 62 |
| MillwardBrown | 14 |
| Kantar Public | 13 |
| IPSOS | 11 |
| TNS Polska | 8 |
| Kantar MB | 6 |
| Estymator | 4 |
| Kantar TNS | 1 |
Tutaj uwaga – pary:
- Millward Brown i Kantar MB
- TNS Polska, Kantar Public oraz Kantar TNS
to są te same podmioty (zmiana nazw ze względu na przekształcenia na rynku badawczym), wybierzemy więc do dalszych prac po prostu wszystkie sondaże przeprowadzone metodą CATI.
Jak wyglądały notowania poszczególnych partii?
|
1 2 3 4 5 6 7 8 9 10 |
sondaze %>% # tylko metoda CATI filter(Metoda == "CATI") %>% select(-Metoda, -UwzgNiezdecydowani) %>% # tabela z szerokiej na długą - na potrzeby wykresu gather(Partia, Procent, -Osrodek, -Publikacja) %>% ggplot() + geom_point(aes(Publikacja, Procent, color = Osrodek), show.legend = FALSE) + geom_smooth(aes(Publikacja, Procent, color = Partia), method = "loess", show.legend = FALSE) + facet_wrap(~Partia, scales = "free_y") |
Kolor punktu oznacza sondażownię (dla porządku), ale interesują nas trendy. Co widzimy (idąc od góry):
- Kukiz’15 powoli, falami zyskuje poparcie – w moim odczuciu to ciekawe, bo osobiście sądziłem, że ugrupowanie czeka los Samoobrony i Ruchu Palikota z poprzednich kadencji: wejście do Sejmu na poziomie około 10% i brak posłów w kolejnej kadencji
- Nowoczesna straciła po “wycieczce na Maderę” rok temu i właściwie została na poziomie około 10%. To nie wróży niczego dobrego dla partii, którą chyba najczęściej widać w TVN24 (widzowie tej stacji to potencjalni wyborcy .N)…
- Niezdecydowani – nie w każdym sondażu są uwzględniani (co jest błędem – to o tych ludzi toczy się gra), a jak widać jest to poziom porównywalny z poparciem dla Kukiz’15 przez całą kadencję czy też obecnym poparciem dla Nowoczesnej. Ugrupowanie “Niezdecydowani” przy obecnych notowaniach wchodzi do Sejmu (próg to 5%)
- Prawo i Sprawiedliwość – tutaj od tegorocznych wakacji widać szaloną jazdę w górę, wygrana w kolejnych wyborach jest niezagrożona, co więcej – może okazać się, że PiS zdobędzie 2/3 miejsc w parlamencie (miejsca w Sejmie nie przeliczają się łatwo z poparcia). To mnie wcale nie zdziwi.
- Platforma Obywatelska w 2017 roku nieco zyskała, najprawdopodobniej kosztem Nowoczesnej. To największa siła opozycyjna, chociaż w moim odczuciu medialnie lepiej wypada Nowoczesna. Brak konkretnych programów czy działań (to dotyczy również .N) a jedynie retoryka anty-PiS partii nie pomaga, co widać na zagięciu trendu w dół w ostatnim czasie
- PSL zawsze łapie się do Sejmu, zawsze lekko mijając próg (i prawie zawsze jest w koalicji ;) – tym razem wygląda na dokładnie to samo. Brak PSL w kolejnej kadencji były niespodzianką. Wynik ponad 6% również.
- Partia Razem – to taka partia, która dobrze sobie radzi w internecie, ale na niewiele się to przekłada w notowaniach. Oczywiście możemy powiedzieć, że z jakichś 2.7% urosło do 3.2% (co oznacza wzrost liczby popierających o jakąś 1/6), ale nadal nie daje to miejsc w Parlamencie. Nawet w połączeniu z SLD (wówczas potrzeba 8%)
- z SLD jest trochę jak PSL (w kontekście notowań): o ile PSL się łapie lekko przekraczając próg, o tyle SLD lekko brakuje do progu. Nic z ugrupowań lewicowych w tym kraju nie będzie w najbliższym czasie…
- Wolność, czyli partia Korwin-Mikke – poziom jak zawsze w okolicach 2-3%, tutaj nie ma żadnych zaskoczeń
Jaka będzie przyszłość?
Zanim przejdziemy dalej potrzebujemy lekkiej transformacji danych – uśrednimy je po miesiącach, odrywając się od sondażowni. Policzymy również poparcie w czterech grupach:
- PiS jako partia rządząca,
- Kukiz’15 jako taka nie do końca partia koalicyjna i jednocześnie nie do końca opozycja,
- Wolność – ja nie wiem czy to opozycja? to swego rodzaju fenomen,
- Opozycja – czyli połączone PO, Nowoczesna, PSL oraz ugrupowania lewicowe (SLD i Razem).
|
1 2 3 4 5 6 7 8 9 10 11 12 13 |
sondaze_agr <- sondaze %>% select(-NieZdec, -Metoda, -UwzgNiezdecydowani) %>% rowwise() %>% # dodajemy sumę poparcia dla "opozycji" mutate(Opozycja = sum(PO, N, PSL, SLD, Razem, na.rm = TRUE)) %>% ungroup() %>% # potrzebujemy długiej tabeli gather(Partia, Procent, -Osrodek, -Publikacja) %>% # będziemy uśredniać po kolejnych miesiącach mutate(miesiac = make_date(year(Publikacja), month(Publikacja), 1)) %>% group_by(miesiac, Partia) %>% summarise(Proc = mean(Procent)) %>% ungroup() |
Czas na wykres nadający się idealnie do Wiadomości TVP: Opozycja vs PiS vs Kukiz vs Korwin, uśrednione miesięcznie. Totalne zwycięstwo nad totalną opozycją powinien się ten wykres nazywać:
|
1 2 3 4 5 6 7 |
sondaze_agr %>% filter(Partia %in% c("PiS", "Opozycja", "K15", "Wolnosc")) %>% ggplot() + geom_point(aes(miesiac, Proc, color = Partia), alpha = 0.3) + geom_smooth(aes(miesiac, Proc, color = Partia), size = 2, method = "loess") + scale_x_date(date_breaks = "2 months", date_labels = "%m'%y") + scale_y_continuous(breaks = seq(0, 60, 5)) |
Pozwolę sobie tego nie komentować. Zastanówcie się sami (zgodnie ze swoimi poglądami politycznymi) dlaczego tak jest.
Bo najciekawsze są nie tyle same wyniki co stojące za nimi powody. Dlaczego ludzie chcą głosować tak, a nie inaczej? Tego z sondaży się nie dowiemy, chociaż sondażownie pewnie mają takie dane, chociażby dodatkowo: miejsce zamieszkania (powiat, wielkość miejscowości), płeć, wiek, wykształcenie, średni dochód (najlepiej rozporządzalny) na członka rodziny i jak zmienił się w ostatnich dwóch latach (co dało 500+). Ale takich danych nie mamy. Chyba, że jakiś insider z sondażowni się podzieli…
Spróbujmy za to przewidzieć w jakiś prosty sposób co będzie dalej.
Najpierw trochę gimnastyki:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 |
# potrzebujemy na powrót szerokiej tabeli sondaze_agr <- spread(sondaze_agr, Partia, Proc) # uzupełnienie brakujących notowań dla każdej z partii wartościami średnimi # braki są tylko w trzech przypadkach: sondaze_agr[is.na(sondaze_agr$N),"N"] <- mean(sondaze_agr$N, na.rm = TRUE) sondaze_agr[is.na(sondaze_agr$Razem),"Razem"] <- mean(sondaze_agr$Razem, na.rm = TRUE) sondaze_agr[is.na(sondaze_agr$Wolnosc),"Wolnosc"] <- mean(sondaze_agr$Wolnosc, na.rm = TRUE) # na ile miesięcy w przód robimy predykcję? n_okresow <- 6 # żeby nie było to więcej niż połowa danych historycznych n_okresow <- ifelse(n_okresow > nrow(sondaze_agr)/2, nrow(sondaze_agr)/2, n_okresow) # generujemy "nazwy" miesięcy sondaz_pred <- as.character(make_date(2017, 12, 1) + months(0:24)) %>% substr(1, 7) %>% .[1:n_okresow] |
Predykcje dla każdej z kolejnych partii przeprowadzimy korzystając z modelu typu ARIMA.
Wyniki (uśrednione miesięcznie) dla każdej z partii potraktujemy jak szereg czasowy (zaczynający się w październiku 2015, z 12 wartościami na rok) i na nim przeprowadzimy prognozowanie. Współczynniki do ARIMA dobrałem testowo, wcześniej próbując inne (automatyczne – auto.arima() czy też ets()) modele. ARIMA(2, 0, 0) dała coś więcej niż linię prostą na aktualnym poziomie. Przyznam szczerze, że nie weryfikowałem poprawności predykcji (na próbkach testowych wyciągniętych z danych historycznych). Dla zainteresowanych: współczynnik AIC był w okolicach 60 dla większości z partii. Próbowałem też agregacji do tygodni – wyniki były podobne (trend taki sam, dokładność większa).
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
for(i in 2:ncol(sondaze_agr)) { # szereg czasowy dla konkretnej partii ts <- ts(sondaze_agr[,i], start = c(2015, 10), frequency = 12) # model model <- Arima(ts, order = c(2, 0, 0)) # predykcje pred <- forecast(model, h = n_okresow) # łączymy w całość sondaz_pred <- cbind(sondaz_pred, as.numeric(pred$mean)) } # zmiana typu części z predykcjami sondaz_pred <- as_tibble(sondaz_pred) # nazwy kolumn jak w danych historycznych colnames(sondaz_pred) <- colnames(sondaze_agr) # poprawiamy typy danych w kolumnach i oznaczamy, że są to predykcje sondaz_pred <- sondaz_pred %>% mutate(miesiac = make_date(substr(miesiac, 1, 4), substr(miesiac, 6, 7), 1)) %>% mutate_at(2:ncol(sondaz_pred), as.numeric) %>% mutate(type = "predykcja") # łączymy historię z przyszłością sondaze_pred_all <- bind_rows(sondaze_agr %>% mutate(type = "sondaż"), # oznaczamy, że to była historia sondaz_pred) |
Co wychodzi w predykcji?
|
1 2 3 4 5 |
sondaze_pred_all %>% gather(Partia, poparcie, -miesiac, -type) %>% ggplot() + geom_col(aes(miesiac, poparcie, fill = type)) + facet_wrap(~Partia, scales = "free_y") |
Ogólnie rzecz biorąc: jednym nieco urośnie, innym nieco spadnie, na koniec się wypłaszczy w okolicach obecnego wyniku. Ale to wynik zastosowanej metody.
Sprawdźmy jeszcze raz PiS, Opozycję, Kukiza i Korwina dodając predykcję:
|
1 2 3 4 5 6 7 |
sondaze_pred_all %>% gather(Partia, poparcie, -miesiac, -type) %>% filter(Partia %in% c("PiS", "Opozycja", "K15", "Wolnosc")) %>% ggplot() + geom_line(aes(miesiac, poparcie, color = Partia, linetype = type == "predykcja"), size = 2, show.legend = FALSE) + scale_x_date(date_breaks = "2 months", date_labels = "%m'%y") + scale_y_continuous(breaks = seq(0, 60, 5)) |
Wychodzi na to, że właściwie niewiele się zmieni. Czy to trafne przewidywania? Dowiemy się z biegiem kolejnych miesięcy.
Problem z takim podejściem do prognozy jest jeden, ale bardzo ważny: poparcie dla partii nie podlega zmianom okresowym, więc sam model predykcyjny jest właściwe bez sensu. Dla bezrobocia (które jest okresowe) przygotowałem swego czasu przewidywania w podobny sposób i sprawdzają się na razie świetnie.
Ciekawe byłoby zestawienie poparcia dla partii z czynnikami opisującymi:
- gospodarstwa domowe
- całą gospodarkę poprzez wskaźniki makro
- popularność konkretnych mediów (czy PiSowi rośnie, bo ludzie więcej oglądają TVP i wierzą w to co tam mówią, czy wręcz przeciwnie?)
- konkretne wydarzenia (przysłowiowy urlop na Maderze – dziwi mnie, że to miało aż tak duży wpływ… a może nie miało i to tylko zbieg okoliczności?)
- szum generowany w internecie (polecam tutaj świetny serwis Polityka w sieci)
- jakieś ogólne miary nastrojów społecznych
Wszystko to i tak o kant stołu potłuc, bo wystarczy jakieś niespodziewane wydarzenie (np. jakaś afera) i obraz na scenie polityczniej może się zmienić. W każdym razie zgromadzenie wszystkich powyższych danych w jednym miejscu byłoby ciekawe.
- Czy takie dane istnieją? Oczywiście.
- Czy ktoś robi takie analizy? Sądzę (jestem prawie pewien), że tak. Za grube pieniądze.
- Czy ktoś z nich korzysta? Myślę (już z mniejszą pewnością), że tak. A przynajmniej powinien.
- Kto? Powinny partie polityczne.
Tak się to robi w USA (wiem, bo oglądałem kilka filmów, chociażby “House of Cards” :) i pewnie wszystkich innych rozwiniętych państwach.
Nie ma co gdybać w prognozach na podstawie trendów – to wszystko zależy od kolejnych ruchów rządzących i opozycji. Sensowną jest próba wyciągnięcia wniosków z trendów.
Ryszard zaorał swoją Nowoczesną wylotem „na Maderę”(podobno wcale nie był na Maderę). Wybierając Misiłę na konkurenta do przewodzenia partii wbił kolejny gwóźdź do jej trumny. Jedynym ratunkiem dla tego ugrupowania byłaby pani Lubnauer. Pomysły i ambicje Rysia sugerują że na wspólną listę „zjednoczonej opozycji” raczej nie ma szans.
PSL i SLD raczej będą dalej balansować na progu, choć 500+ może być piórkiem które zadecyduje o tym po której stronie progu się znajdą w wyborach.
Opozycja przegrywa sprawę reformy sądów i mocno traci na komisjach AmberGold i ds reprywatyzacji w Warszawie.
Zupełnie w sondażach nie widać wpływu 500+, bo wątpliwe jest że po roku dopiero Polacy przekonali się że to był dobry pomysł.
Po ostatniej debacie i głosowaniu w PE nie wróżę wzrostów opozycji w najbliższym czasie. PiS może przegrać tylko:
1) sam ze sobą – np. ryzykując ze zmianą premiera
lub
2) z gospodarką – kryzys może przyjść w każdej chwili i opozycji bardzo zależy żeby przyszedł – choćby w wyniku nałożenia sankcji UE lub utraty zaufania w stabilność sytuacji politycznej inwestorów.
Pingback: Parsowanie XMLa w R | Łukasz Prokulski