r-statistics-fanの日記

統計好きの現場の臨床医の覚書のようなもの

慶応がベスト1()~何の雑誌だコレ

https://twitter.com/dankogai/status/522047534022156289

ツイッターで面白い記事が流れていた。コラ画像??

更に追記:
[Stan]「使える大学・使えない大学」の事例から考えるアンケートの解析方法
丁度本日Rstanをインストールしたところですが、beroberoさんの
読み応えのある分析が出ました。勉強になります。
自分で勝手に想定した各個人の使える使えないの評価ではなかったようです。
とりあえず簡単なRstanコードが書けるようになりたい。


10/16追記:週刊ダイヤモンドだったようです
全文表示 | 「使えない大学」特集1位に法政大学 本当か?「週刊ダイヤモンド」調査に反響 : J-CASTニュース
10/16更に追記
Haruhiko Okumura先生に、ツイッターで二項分布でもないよとご指摘いただいた。
って、昔からめちゃくちゃお世話になっているサイトの
先生ではないですか。先生のサイトでは本当に勉強させて
いただいております。

言うまでもないことですが、どのように調査したかわから
ないのに、分析するのは本来ご法度です。

この記事はお遊びと考えてね。

とりあえず、上位()の部分だけ入力して、元の本知らないので前提が分かんないけど適当に解析してみた。
(良い子は真似しちゃダメですよ)

二項分布の比率の95%信頼区間をplot
f:id:r-statistics-fan:20141016213613j:plain

good = c( 2170,1838,1041,580,1596,496,374,520,250,256,209,231,163,144,230,113,140,103,217,110,65,123,57,50,24,68,22,16,21,18,139 )
bad = c( 536,684,328,115,1161,79,108,322,62,81,41,105,52,59,165,52,82,50,171,66,28,88,22,18,0,44,5,0,9,7,128 )
univ = as.character(c( "慶応大学","早稲田大学","京都大学","一橋大学","東京大学","東京工業大学","大阪大学","明治大学","東北大学","東京理科大学","国際基督教大学","同志社大学","神戸大学","北海道大学","上智大学","名古屋大学","関西学院大学","筑波大学","中央大学","九州大学","東京外国語大学","横浜国立大学","電気通信大学","津田塾大学","ハーバード大学","千葉大学","広島大学","国際教養大学","小樽商科大学","京都工芸繊維大","立教大学" ))
data <- data.frame( univ = univ,good = good,bad = bad )
data$univ <- as.factor(data$univ)
data$univ <- relevel(data$univ, ref="keio")      


library(binom)
ci.calc <- function(x){
as.numeric(binom.confint(as.integer(x[2]), as.integer(x[2]+x[3]), conf.level=0.95, methods = "exact")[c(4,5,6)])
}

res <- matrix(0, nrow = nrow(data), ncol = 3)
for (i in 1:nrow(data)){
      res[i,] <- ci.calc(data[i,])
}

rownames(res) <- data$univ
colnames(res) <- c("mean", "lower", "upper")

windows()
par(mar = c(5, 10, 4, 2))
plot(x = rev(res[,1]*100),y = seq_len(nrow(res)), xlim=c(40, 100), ylim = c(0, nrow(res)),
     ylab = "", xlab = "使える率(%)", yaxt = "n")
axis(side=2, labels=rev(rownames(res)), at = seq_len(nrow(res)), las = 1)
arrows(y0 = rev(seq_len(nrow(res))),x0 = res[,2]*100, y1 =rev(seq_len(nrow(res))),
      x1 = res[,3]*100,length=.05,angle=90,code=3) 
abline(v = c(res[1,2], res[1,3])*100, lty= 3)

fit1 <- glm(cbind(good, bad) ~ factor(univ), data = data, family = binomial)
summary(fit1)

fisher.p.value <- NULL #numeric(nrow(data))
for (i in 2:nrow(data)){
fisher.p.value[i] <- fisher.test(rbind(data[1,-1], data[i,-1]))$p.value
}
data$good.rate <- (data$good / (data$bad + data$good))
data$p.value <- fisher.p.value
data$fdr.adjust.p <- c(NA, p.adjust((data$p.value[-1]), method = "fdr"))
data$holm.adjust.p <- c(NA, p.adjust((data$p.value[-1]), method = "holm"))

data

Call:
glm(formula = cbind(good, bad) ~ factor(univ), family = binomial, 
    data = data)

Deviance Residuals: 
 [1]  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0

Coefficients:
                                 Estimate  Std. Error z value        Pr(>|z|)    
(Intercept)                       1.39835     0.04823   28.99         < 2e-16 ***
factor(univ)chiba                -0.96303     0.19940   -4.83 0.0000013675077 ***
factor(univ)chuo                 -1.16011     0.11306  -10.26         < 2e-16 ***
factor(univ)denkitsushin         -0.44634     0.25559   -1.75         0.08075 .  
factor(univ)doushisha            -0.60989     0.12720   -4.79 0.0000016282277 ***
factor(univ)harvard              24.52548 52727.17227    0.00         0.99963    
factor(univ)hiroshima             0.08326     0.49778    0.17         0.86717    
factor(univ)hitotsubashi          0.21975     0.11290    1.95         0.05161 .  
factor(univ)hokkaido             -0.50607     0.16193   -3.13         0.00178 ** 
factor(univ)ICU                   0.23041     0.17749    1.30         0.19422    
factor(univ)jyouchi              -1.06621     0.11285   -9.45         < 2e-16 ***
factor(univ)kanseigakuin         -0.86343     0.14719   -5.87 0.0000000044613 ***
factor(univ)kobe                 -0.25584     0.16641   -1.54         0.12419    
factor(univ)kokusaikyouyou       24.14549 53403.16642    0.00         0.99964    
factor(univ)kyoto                -0.24342     0.07960   -3.06         0.00223 ** 
factor(univ)kyoutokousen         -0.45389     0.44804   -1.01         0.31104    
factor(univ)kyushu               -0.88752     0.16300   -5.44 0.0000000518252 ***
factor(univ)meiji                -0.91907     0.08576  -10.72         < 2e-16 ***
factor(univ)nagoya               -0.62220     0.17438   -3.57         0.00036 ***
factor(univ)osaka                -0.15622     0.11941   -1.31         0.19079    
factor(univ)otarushouka          -0.55105     0.40132   -1.37         0.16972    
factor(univ)rikkyou              -1.31590     0.13166  -10.00         < 2e-16 ***
factor(univ)tokyo                -1.08013     0.06176  -17.49         < 2e-16 ***
factor(univ)tokyogaikoku         -0.55617     0.23114   -2.41         0.01612 *  
factor(univ)touhoku              -0.00402     0.14985   -0.03         0.97859    
factor(univ)toukoudai             0.43878     0.13039    3.37         0.00076 ***
factor(univ)toukyourika          -0.24762     0.13630   -1.82         0.06926 .  
factor(univ)tsudajuku            -0.37670     0.27907   -1.35         0.17708    
factor(univ)tsukuba              -0.67564     0.17898   -3.77         0.00016 ***
factor(univ)waseda               -0.40987     0.06582   -6.23 0.0000000004755 ***
factor(univ)yokohamakokuritsu    -1.06350     0.14772   -7.20 0.0000000000006 ***
---
Signif. codes:  0***0.001**0.01*0.05 ‘.’ 0.1 ‘ ’ 1

(Dispersion parameter for binomial family taken to be 1)

    Null deviance: 751.30569842738942  on 30  degrees of freedom
Residual deviance:   0.00000000052277  on  0  degrees of freedom
AIC: 230

Number of Fisher Scoring iterations: 22

#fisher exact test, vs 慶応大学
> data
             univ good  bad good.rate      p.value fdr.adjust.p holm.adjust.p
1        慶応大学 2170  536 0.8019217           NA           NA            NA
2      早稲田大学 1838  684 0.7287867 4.784803e-10 2.050630e-09  1.148353e-08
3        京都大学 1041  328 0.7604091 2.344880e-03 4.689761e-03  3.751809e-02
4        一橋大学  580  115 0.8345324 5.179567e-02 8.076777e-02  6.215480e-01
5        東京大学 1596 1161 0.5788901 4.407055e-72 1.322116e-70  1.322116e-70
6    東京工業大学  496   79 0.8626087 6.265189e-04 1.412953e-03  1.127734e-02
7        大阪大学  374  108 0.7759336 1.961095e-01 2.262802e-01  1.000000e+00
8        明治大学  520  322 0.6175772 5.919734e-26 8.879601e-25  1.716723e-24
9        東北大学  250   62 0.8012821 1.000000e+00 1.000000e+00  1.000000e+00
10   東京理科大学  256   81 0.7596439 7.253240e-02 1.036177e-01  7.253240e-01
11 国際基督教大学  209   41 0.8360000 2.112273e-01 2.346970e-01  1.000000e+00
12     同志社大学  231  105 0.6875000 3.494767e-06 1.006661e-05  7.339011e-05
13       神戸大学  163   52 0.7581395 1.328087e-01 1.732288e-01  1.000000e+00
14     北海道大学  144   59 0.7093596 2.770101e-03 5.193939e-03  4.155151e-02
15       上智大学  230  165 0.5822785 5.673220e-20 3.403932e-19  1.475037e-18
16     名古屋大学  113   52 0.6848485 6.593782e-04 1.412953e-03  1.127734e-02
17   関西学院大学  140   82 0.6306306 1.659472e-08 6.223020e-08  3.816786e-07
18       筑波大学  103   50 0.6732026 2.794904e-04 6.987259e-04  5.310317e-03
19       中央大学  217  171 0.5592784 2.239980e-23 2.239980e-22  6.271943e-22
20       九州大学  110   66 0.6250000 1.575574e-07 5.251913e-07  3.466263e-06
21 東京外国語大学   65   28 0.6989247 1.802297e-02 3.003828e-02  2.342986e-01
22   横浜国立大学  123   88 0.5829384 5.699486e-12 2.849743e-11  1.424872e-10
23   電気通信大学   57   22 0.7215190 8.673398e-02 1.182736e-01  7.806058e-01
24     津田塾大学   50   18 0.7352941 1.695589e-01 2.034707e-01  1.000000e+00
25 ハーバード大学   24    0 1.0000000 8.260708e-03 1.457772e-02  1.156499e-01
26       千葉大学   68   44 0.6071429 3.691090e-06 1.006661e-05  7.382181e-05
27       広島大学   22    5 0.8148148 1.000000e+00 1.000000e+00  1.000000e+00
28   国際教養大学   16    0 1.0000000 5.384518e-02 8.076777e-02  6.215480e-01
29   小樽商科大学   21    9 0.7000000 1.692974e-01 2.034707e-01  1.000000e+00
30 京都工芸繊維大   18    7 0.7200000 3.141478e-01 3.365869e-01  1.000000e+00
31       立教大学  139  128 0.5205993 2.827325e-22 2.120494e-21  7.633779e-21

東京工業大学完全勝利って感じだった