Czy przekroczą 55 milionów?

Już jutro finał 24. Wielkiej Orkiestry Świątecznej Pomocy. Z roku na rok WOŚP zbiera coraz więcej środków, w tym roku na wsparcie oddziałów pediatrycznych i opieki medycznej seniorów. Jak myślicie ile pieniędzy uda się zebrać?
Zobaczmy co na ten temat mają do powiedzenia modele liniowe 😉

Screen Shot 2016-01-09 at 02.34.59

Dane n.t. kwot zebranych podczas kolejnych finałów pobieramy z Wikipedii. Używając pakietu rvest są to w sumie dwie linijki (plus jedna na oczyszczenie napisów). Do roku 2010 na oficjalnej stronie WOŚP kwoty są w USD, ostrożnie z porównaniami.

library(rvest)
tabela <- html("https://pl.wikipedia.org/wiki/Wielka_Orkiestra_%C5%9Awi%C4%85tecznej_Pomocy")
cast <- html_nodes(tabela, "td:nth-child(5)")
as.numeric(gsub(gsub(html_text(cast), pattern="[^0-9,]", replacement=""), pattern = ",", replacement="."))
# [1]  2422465  4134072  6867951  6315296  8818754 12498909 15748393 25229564 24366828 26291937 30116786 27244441 28415177 30690085 30377335
#[16] 32147539 40458625 42877958  2644507 47248415 50638801 50657748 52448765 53109703       NA

Mamy liczby, trzeba je narysować. Oczywiście użyjemy ggplot2. Dwie długaśne linijki i jako wynik otrzymujemy tytułowy wykres z słupkami.

library(ggplot2)
dane <- data.frame(rok = 1993:2015,
                   zebraneWiki = as.numeric(gsub(gsub(html_text(cast), pattern="[^0-9,]", replacement=""), pattern = ",", replacement="."))[c(-25,-19)]/1000000)

ggplot(dane, aes(rok, zebraneWiki)) + 
  geom_bar(stat="identity", alpha=0.5, fill="red4") + 
  theme_minimal() + 
  ylab("Zebrane [mln PLN]\n") + scale_y_continuous(breaks=seq(0,60,5)) + xlab("")+
  ggtitle("Kwoty zebrane w kolejnych edycjach WOŚP\n")

Czas na predykcje, oczywiście będzie przedziałowa.
Ograniczymy się do aproksymacji trendem liniowym bazując wyłącznie na zmiennej rok/edycja (*), ograniczając się do danych z ostatnich 5 lat.
Gdyby ktoś chciał doczytać jak wyznaczać przedziały dla predykcji może zajrzeć na stronę 19 tutaj. W R wystarczy użyć funkcji predict.lm z parametrem interval = „prediction”.

predict(lm(zebraneWiki~rok, data=dane[19:23,]), data.frame(rok=2016), 
  interval = "prediction", level=0.9)
#         fit      lwr     upr
# 1 54.88045 51.83139 57.9295

Tak więc 90% przedział dla predykcji jest dosyć szeroki 52-58 milionów PLN, wartość oczekiwana na tegoroczny finał to 54,88 milionów PLN.

Ciekawe, czy uda się przekroczyć w tym roku 55 milionów PLN? W poprzednim roku zebrano 53.1 mln.

(*) Sprawdzałem czy zebrana kwota zależy od PKB (zaskoczenie, jeżeli uwzględnić trend związany z rokiem, to PKB ma już marginalne znaczenie), od kursu dolara i wygląda na to, że nie są to bardzo decydujące czynniki. Najistotniejszym czynnikiem był rok (dodatni trend). Aproksymacja wielomianami pokazała, że można pozostać przy liniowym trendzie.

*Update:* (za komentarzami) W 2016 roku WOŚP zebrała 72 mln 696 tys. 501 pln. Znacznie powyżej liniowych predykcji. Poniższy wykres pokazuje jak znaczący jest to skok w porównaniu do poprzednich lat.

5 thoughts on “Czy przekroczą 55 milionów?”

  1. Może zastosować też model logistyczny ?
    (np. dla asymptoty = 65)

    Zmienna zależna (Y): z
    yhat = 65 / (1 + exp(-X*b))

    współczynnik błąd standardowy t-Studenta wartość p
    —————————————————————
    const −2,73466 0,141612 −19,31 7,55e-15 ***
    t 0,193515 0,0103281 18,74 1,38e-14 ***

    Podstawowe statystki dla transformowanych danych:

    Suma kwadratów reszt 2,266949
    Błąd standardowy reszt 0,328557
    Wsp. determ. R-kwadrat 0,943558
    Skorygowany R-kwadrat 0,940870
    F(1, 21) 351,0641
    Wartość p dla testu F 1,38e-14

    Logarytm wiarygodności −5,989403
    Kryt. inform. Akaike’a 15,97881
    Kryt. bayes. Schwarza 18,24979
    Kryt. Hannana-Quinna 16,54995
    Autokorel.reszt – rho1 0,638759
    Stat. Durbina-Watsona 0,505713

  2. Tę wartość można oszacować. Ale model jest dla wszystkich lat.

    Formula: z ~ theta1/(1 + exp(-(theta2 + theta3 * t)))

    Parameters:
    Estimate Std. Error t value Pr(>|t|)
    theta1 63.6715 7.6774 8.293 6.65e-08 ***
    theta2 -2.3718 0.1720 -13.788 1.13e-11 ***
    theta3 0.1741 0.0269 6.471 2.61e-06 ***

    Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
    Residual standard error: 3.659 on 20 degrees of freedom

Pozostaw odpowiedź smarterpoland Anuluj pisanie odpowiedzi

Twój adres email nie zostanie opublikowany. Pola, których wypełnienie jest wymagane, są oznaczone symbolem *