読んだ。
日本評論社の基本シリーズのひとつで、基本刑法や基本憲法などとクロスリファレンスがある。ページ参照が1章2節、のようなシケタイの感じなので、参照しようとすると非常に読みづらい。
読んだ。
フリマサイトで投げ売られていたので初版だが買った。とにかくゴツいが、頻出論点は図を多用して説明してあることが多い。
既判力は、実務では使わないが、理論的な部分で試験的に問われるから重要、と裏事情的なことが書かれていることが多い。既判力の項や、相殺などは非常にページが割かれている。
こんなツイートを観測した。
もしかして…減少傾向？ pic.twitter.com/ifHbTJE7bq
— 中高一貫校データ分析 (@ML_of_JandSHS) 2026年3月13日
2025, 2026年でなんとなく減少傾向に見えるので全体的になんとなく減少傾向に見えている。
が、実際にどうなのか。
東大、京大、医学部、東工大（東京科学大学）、一橋大学、のしかも現役、浪人混ぜのデータのようなので、灘高現役生の合格実績がどうかデータを取ってきた。
2008-2009年の東大理Ⅲ、京大医学部の現役合格者数が抜けていたのでこちらも参照した。
2008年度 東京大学合格者数 | 受験教育情報サイト：インターエデュ・ドットコム
東工大や一橋大の現役浪人まで確認していると面倒だったので、東大、京大、医学部、の現役浪人をなんとか調べた。
stan 的に考えると、各年度 に灘高3年生が
人いるとして、合格者数
は、合格率
から二項分布でサンプリングされるとする。
合格率 は、モデルとしては難ありだが実装が簡単なので一次線形
として、が0より有意に離れているかが経時的な合格率の増減、
が切片としてベースの合格率、となる。
モデルとして難あり、というのは、合格率は以前の年度の影響を受けるだろうが説明変数を何も考えずに年度としているからであるが、許してほしい。
理Ⅲのみ、理Ⅲと京医学部、国公立医学部（理Ⅲと京医除く）、東大と京大（理Ⅲと京医除く）、東大と京大（理Ⅲと京医除く）と国公立医学部、で分けた結果が図となる。
結果として、経時的にはどの区分も合格率は95%信用区間的には増減していない。
理Ⅲの現役合格率は概ね6%、京医も合わせると13%が現役合格している。
n <- read.table(text=" 入試年 卒業数 東大合格 東大現役 理3 理3現役 京大合格 京大現役 京医合格 京医現役 医学部合計 医学部現役 2003 217 88 66 6 4 55 32 15 5 48 23 2004 214 89 56 15 8 44 22 15 9 58 28 2005 215 101 72 21 18 54 34 22 19 82 53 2006 213 80 57 13 8 51 36 25 16 70 33 2007 216 100 73 11 9 33 18 15 9 65 31 2008 216 114 82 19 14 23 12 14 8 72 35 2009 217 103 66 15 9 37 24 22 15 68 39 2010 219 103 74 21 19 35 25 23 16 93 60 2011 219 99 75 17 14 45 28 25 15 88 51 2012 219 98 81 16 14 34 25 22 15 74 40 2013 224 105 80 27 21 41 27 24 19 91 55 2014 220 104 76 12 8 30 18 16 8 64 29 2015 219 94 72 15 11 36 22 21 14 66 37 2016 218 94 72 20 17 47 26 25 13 95 42 2017 220 95 75 19 17 39 30 21 18 83 52 2018 219 92 70 15 11 42 25 22 14 97 48 2019 219 74 59 21 17 48 33 26 19 90 58 2020 220 79 57 14 11 49 31 24 15 81 48 2021 216 97 75 12 10 34 21 14 9 50 38 2022 221 92 62 10 8 48 36 20 15 86 41 2023 220 86 66 15 14 42 31 17 14 76 46 2024 218 94 71 12 12 53 38 25 14 95 35 2025 214 77 59 9 7 50 37 19 14 84 46 2026 224 95 77 7 6 47 31 13 8 44 18 ", header=TRUE) library(rstan) library(vioplot) library(stringr) rstan_options(auto_write=TRUE) options(mc.cores=parallel::detectCores()) code <- " data { int N; int Y[N]; // 合格者数 int D[N]; // 一学年 } parameters{ real a; real b; real<lower=0> s; } transformed parameters{ real<lower=0, upper=1> theta[N]; for(i in 1:N){ theta[i] = a*i + b; } } model{ a ~ normal(0, 5); b ~ normal(0, 5); s ~ exponential(1); for(i in 1:N){ Y[i] ~ binomial(D[i], theta[i]); } } " m0 <- stan_model(model_code=code) standata <- list(N=nrow(n), D=n$卒業数, Y=list("東大・京大・医学部"=n$東大現役 + n$京大現役 - 2*n$理3現役 - 2*n$京医現役 + n$医学部現役, "東大・京大"=n$東大現役 + n$京大現役 - n$理3現役 - n$京医現役, "理Ⅲ・京医"=n$理3現役 + n$京医現役, "理Ⅲ"=n$理3現役, "国公立医学部"=n$医学部現役) ) # 上記パターンを一気にやる fits <- mapply(function(z) sampling(m0, c(standata[c(1,2)], Y=list(z)), iter=2000, warmup=1000, chain=20), standata$Y) ex <- mapply(function(z) extract(z, pars=head(z@model_pars, -1)), fits, SIMPLIFY=FALSE) #p <- mapply(function(z) 100/(1+exp(-z$theta)), ex, SIMPLIFY=FALSE) p <- mapply(function(z) 100*z$theta, ex, SIMPLIFY=FALSE) cols <- c("red", "pink", "green", "skyblue", "orange") alpha <- c(0.025, 0.5, 0.975) x <- 1:nrow(n) #png("nada.png", 840, 480) par(mar=c(4, 5, 2, 10), cex.lab=1.5) plot(range(x), c(0, 5)*10, type="n", xlab="", ylab="", frame=FALSE, xaxt="n", yaxt="n") abline(h=seq(0, 5, by=1)*10, lty=3) for(i in seq(standata$Y)){ vioplot(p[[i]], add=TRUE, ylim=100*c(0, 0.5), las=1, frame.plot=FALSE, rectCol=NA, lineCol=NA, colMed=NA, col=cols[i], xlab="", ylab="") } for(i in seq(standata$Y)){ if(i == 1){ mtext("20XX年度", side=1, line=2.5, cex=1.5) mtext("現役合格率 [%]", side=2, line=3, cex=1.5) } y <- 100*standata$Y[[i]]/standata$D lines(x, y, col=cols[i], lwd=3) points(x, y, col=cols[i], pch=15) lines(x, y, lwd=1) pa <- par()$usr y1 <- tail(colMeans(p[[i]]), 1) pp <- quantile(ex[[i]]$a, alpha)*100 pb <- quantile(ex[[i]]$b, alpha)*100 txt <- sprintf("%s %.1f%s [%.1f, %.1f]\n%.2f%s/年 [%.2f, %.2f]", names(standata$Y)[i], pb[2], "%", pb[1], pb[3], pp[2], "%", pp[1], pp[3]) txt <- sprintf("%.1f%s [%.1f, %.1f]\n%.2f%s/年 [%.2f, %.2f]", pb[2], "%", pb[1], pb[3], pp[2], "%", pp[1], pp[3]) #text(pa[2], y1, txt, xpd=TRUE, pos=4) #legend(pa[2], y1, legend=txt, xpd=TRUE, col=cols[i], pch=15, yjust=0.5, bty="n") legend(pa[2], y1, legend=txt, title=names(standata$Y)[i], xpd=TRUE, col=cols[i], pch=15, yjust=0.5, bty="n", pt.cex=2, title.adj=c(NA, 0.5)) } text(pa[2], pa[4], "現役合格率 (%) [CI]\n年次増減 (%/年) [CI]", xpd=TRUE, pos=4) axis(1, at=seq(nrow(n)), labels=str_extract(n$入試年, "\\d{2,2}$"), lwd=0, lwd.ticks=1) axis(2, lwd=0, lwd.ticks=1, las=2) box() dev.off()
読んだ。
2020年発行だが妙に評価が高くて中古でもそこそこの値段だった。基本的に判旨のみが突然載っているので、有名判例の概要は知っていて当然、となる。ただし、予備校本でも普通に出てくるものばかりであるので、一通り勉強していたらたぶんなんとかなる。
本書のレビューでよく見かける「判例を論点ごとにグルーピング」というのがわかりやすく、かつ求めていたものであったのでそれはよかった。
憲法判例の射程と「判例で書く」ためのインプット - だいたい正しそうな司法試験の勉強法
だが結局射程はよく理解できていない。
買ったけど手放した。
xperia tablet compact が未だに手放させないが、PDFを読もうとおもってSideBooks を開くとメモリが足りないのかPDFファイルの一覧の読み込みに時間がかかって操作を受け付けなくなるので、なんとかしたいと思った。
しかし8インチアンドロイドタブレット界隈はもう中華タブしかないのだが、ALLDOCUBE はネット上での評判がよかったので買ってみた。
結果としてはゴミ。
メモリ12GBでSnaptragon gen7でアンツツスコアがうん十万、というがそもそも起動して2秒以内になんらかのアプリをタッチして起動させようとすると、強制終了する。
タブレット自体がおそらく2秒以上かけて完全に目覚めないと、アプリを起動できない。ほんとクソすぎる。
タッチも指がちょっとでも汗ばんでいるとスクロールしすぎて思ったとおりに操作できない。
アンドロイド14の仕様なのか、画面の左右端をスワイプすると、アプリ自体を中断してメイン画面に戻るが、アプリ内部自体の戻る操作を受け付ける端の部分と近接しすぎているのか、PDFを読んでいて前のページに戻りたいのにアプリ自体を閉じてしまう。ほんとクソすぎる。
SDカードが入るのはよいが、SDカードを入れるとカード受けから微妙に浮いていて、挿入するのに非常にコツが要る。SDカードが割れるかと思った。
電池持ちはバッテリー容量がそれなりにあるので意外に保つかと思ったが、アイドル時間は確かにもつが、PDFを読んでいると3分で2%ぐらい減る。移動や出張では充電無しでは1日は保たないと思った。
原神とかいうスマホベンチマークゲーム(?)でもないのにこの操作性の悪さなので案件もらっているインフルエンサーはマジでCOI にまみれている。それかPDF閲覧が原神を超える負荷なのか?
その他にクソだったのが、ケースとフィルムがセットになっている商品をアマゾンで買ったが、中国から発送だったので到着予定が当初2週間となっていて気長に待っていたらその期限になる日に突然到着予想が3日間延長され、その3日間を過ぎてももちろん届かなかったのでアマゾンでキャンセルをしたら商品返品をしなくても返金された。1ヶ月以上経つが未だに商品は届いていないので契約解除したが原状回復できていない。大丈夫か?
パワポケ1はやり込んだが当時はN64を持っておらず、パワプロ6 は友達の家で遊びまくった。
当時の投手サクセスの変化球レベルアップのシステムは、経験値ではなく練習コマンドを何回かやると運がよければ変化球レベルが上がる。
変化球レベルが低く、かつ球種が少ないと上がりやすいが、たくさん球種を持つと全然上がらなかった。
当時はネットなど発達しておらず、全然情報がなかったが、内部的にはこんなアルゴリズムらしい。
いまとなってはゲームをする元気もなく、TAS動画を見ているが、パワプロのプレイ動画を上げる思い出ホイホイの投稿者がこんな動画を上げていた。
www.youtube.com
www.youtube.com
というわけで変化球レベルの効率のよい上げ方と、必要とされる練習回数を推定というかシミュレーションする。
サイトを参考に練習後における最大乱数と、実際にサンプリングされる乱数を一様分布から取ってくる。
投法（オーバーかサイド/アンダーか）とシンカーの関係はやってみてもいいが、単純化してシンカー以外の4方向をレベル上げしたらどうなるかを検討する。
5方向かつシンカーを考慮しても0-7レベル分の8段階とシンカーかどうかで計算量が16倍されるので暇があれば検討してもよい。
パワプロ５サクセス変化球講座基本編
パワプロ６サクセス変化球講座
シンカー以外の4方向は何からレベルを上げていっても数学的には対称性があるので、4方向を0から7まで上げるやり方は0から7の玉を4回重複を許して取り出す組み合わせなとなり 通りある。これらをすべてvertex として、1ポイント変化球レベルが上がったときの推移の仕方をグラフで考える。
このグラフについて変化球のパターン（vertex もしくはnode）
とレベルが1ポイント上がったときの推移はエッジ
となる。ここである変化球パターン
から
に推移するときのエッジ
について、何回か練習をして溜まった変化球習得ポイントと、上記乱数を比較して変化球レベルが1ポイント上がるが、ここで変化球レベルが上がるのに何回（何週）練習が必要になるかは、確率分布になる。これを
としておくと、各エッジで簡単にレベルが上がる（練習回数が少なくて済む）場合となかなかレベルが上がらない（練習回数がたくさん必要）場合とがあるので、これは重みになる。分布でもっていてもよいが、グラフに実装するには練習回数分布
の平均値でも最頻値でもいいが
としておく。
これで変化球のレベルの上がり方パターンのグラフを作成する。
グラフができたのでshortest_pathsで最適な（必要練習回数が最も少ない）レベルの上げ方のパスを取得する。
いでにクラスター検出もしてみる。レベルがあがって球種も増えるほど強そうなクラスターになる。
ここでは総変化量が21となる(7,7,7,0) と(6,5,5,5) を比較のために最短経路とノードを描出した。クラスター数は自動で決定され、この2つの変化球パターンとしては別グループに属するようだ。(6,5,5,5) のほうが変化球種類が多く複雑なのでおそらくこちらのグループのほうが高度というか投手力が強いグループと思われる。
Rとigraphを使ったネットワーク解析と可視化
グラフの描出にいくつかlayout 関数を使ってみたが、sugiyama というのが見栄えがよかった。これは階層グラフに対していい感じになるアルゴリズムらしく、総変化量と球種が段階的に増えていくので最適と思った。
https://igraph.org/r/html/1.2.6/layout_with_sugiyama.html
https://orsj.org/wp-content/corsj/or63-1/or63_1_20.pdf
総変化量が21のパターンについてどの変化量の組み合わせが最も効率的かを検討する。このパターンは、(7,7,7,0), (7,7,6,1), ..., と11通りある。総変化量21に達するまでに必要な週数の分布はこのようになる。
必要練習回数の最頻値のみを考慮すれば、(7,6,6,2) がもっとも早く99週で到達すると見込まれる。
一方で、すべての組み合わせについて分布を比較してみると、確率は引き分けがだいたい5%くらいあって、一方のパターンが勝つ（練習回数が少なくて済む）確率はせいぜい55%くらいなのでやる気の増減やあかつき大学一軍補正の50%の確率で+1、みたいなもので容易にブレる程度の勝率と考えられるので、有意にレベルが上がりやすい、とは言えないと思われる。(7,6,5,3) がすべての組み合わせで勝負して勝ち越すことが多いので、単なる分布でみれば(7,6,6,2) が平均（最頻値）がもっとも低いが、(7,6,5,3) のほうが分布の裾が中心に寄っているのでその影響で対比較をしたら(7,6,5,3) のほうが勝ちやすい（はやくレベルが上がりやすい）のだろうか。
別に総変化量21 のみにこだわらずすべての総変化量で検討すればよいと思ったのでやってみたが、一度にプロットするのは数が多すぎてできなかったので
20〜24については以下の通り。
すべてを無理やりプロット（boxplotにした）すると以下の通り。動画の後編の2:30くらいで(5,5,5,2) から(5,5,5,3) にレベルを上げるのに8週程度、と言っているのでだいたいよかろう。
もともとの解析リンクとは週数が微妙に異なっているので、もしかしたら変化球ポイントの(i) 現在の総変化量が11以上の場合はさらに2倍、(ii) 新しい球種を覚える場合はさらに1.5倍+10、の効果が重複する、のところで+10 の扱いが間違っているのかもしれない。
本当のサクセスはやる気によるポイントの上下や、リリーフ選択のタイミングなどでもっとばらつくだろうが、ここでは簡単に絶好調で、サクセス最初からリリーフ選択、ということにして条件を減らしている。
やる気があれば上記のシンカーと同様に、いつのタイミングでやる気を回復させるか、させないかなど検討できる。
# http://pawapuro56success.web.fc2.com/5henkakyuu.html # http://pawapuro56success.web.fc2.com/6henkakyuu.html # 2:31 # https://www.nemotos.net/igraph-tutorial/NetSciX_2016_Workshop_ja.html yakuki <- 2 throw <- 0 # オーバースローは0 サイドかアンダーなら1 # 2回生（1年目）4月1週から、月4週、勝ち進めば最大4回生（3年目）11月1週目まで練習の機会がある # 1年目11月2週にリリーフを希望する Nweek <- c(list(4:12), list(1:12), list(1:11)) Week <- matrix(0, 4, length(unlist(Nweek)), dimnames=list(1:4, unlist(mapply(function(z) paste0(z, "_", Nweek[[z]]), seq(Nweek))))) rensyu <- function(yaruki=0, throw=0, sinker=0, akatsuki=1, relief=1){ # やる気 +4, +2, 0, -2, -4 # オーバースロー 0 サイド・アンダー 1 # オーバースローがシンカー練習をすると -1 # あかつき一軍は +2, パワフル大学は50% の確率で -1 # リリーフ希望だと50% の確率で +1 ifelse(sinker == 1, 5 + 2*yaruki - 1 + throw, 5 + 2*yaruki) + akatsuki + sample(0:relief, size=1) } # 球種とレベル henkakyu <- list(over=rep(0, 4), sinker=0) # 最大乱数 = (1)基本乱数 + (2)球種補正 + (3)変化量補正 # (1)基本乱数 # 現在の総変化量が11以上の場合はさらに2倍 # 新しい球種を覚える場合はさらに1.5倍+10 # (2)球種補正 kyusyuhosei <- c("0"=0, "1"=0, "2"=0, "3"=15, "4"=32, "5"=55) # (3)変化量補正 levelhosei <- c("0"=0, "1"=10, "2"=20, "3"=30, "4"=40, "5"=75, "6"=90) # 実際のシミュレーションに必要なのはここから # 変化球のレベル・球種パターン e <- expand.grid(rep(list(0:7), 4)) pattern <- e[e[,1]>=e[,2] & e[,2]>=e[,3] & e[,3]>=e[,4],] v <- do.call(rbind, mapply(function(z) cbind(pattern, z), 0:7, SIMPLIFY=FALSE)) # vt <- t(v) vt <- t(pattern) # ある変化球パターンのときから1レベルあげるときの最大乱数 M <- rep(0, nrow(e)) for(i in 1:nrow(e)){ e0 <- vt[, e[i, 1]] # 前 e1 <- vt[, e[i, 2]] # 後 idx <- which(e0 != e1) ifnew <- (e0[idx] == 0) s <- sum(e0) maxransu <- c( kihon=(5*s) * ((s > 10) + 1) * ifelse(ifnew, 1.5, 1) + 10*ifnew, kyusyu=kyusyuhosei[sum(e0 > 0) + 1], level=levelhosei[e0[idx]+1] ) M[i] <- sum(maxransu) } # シミュレーションする maxtry <- 100 iter <- 1000 success <- matrix(0, nrow(e), iter) for(i in 1:nrow(e)){ for(j in 1:iter){ r <- replicate(maxtry, rensyu()) R <- sample(0:M[i], replace=TRUE, size=maxtry) success[i, j] <- which(cumsum(r) >= R)[1] } } # 平均（最頻値だが）的なレベルアップの乱数（週数） med <- apply(success, 1, quantile, 0.5, type=1) # あるパターンから1レベルあげるときの推移をグラフにする library(igraph) vmat <- matrix(0, ncol(vt), ncol(vt)) for(i in 1:ncol(vt)){ tmp <- vt[, i] for(j in 1:5){ idx <- which(apply(vt == replace(tmp, j, tmp[j]+1), 2, all)) if(length(idx) > 0){ vmat[i, idx] <- 1 } } } diag(vmat) <- 0 lcols <- c("pink", rev(heat.colors(max(colSums(vt))))) # 総変化量 kcols <- c("pink", "darkcyan", "black", "darkcyan", "black") # 球種 shape <- c("circle", "circle", "circle", "square", "square") ecols <- topo.colors(max(med)) g <- graph_from_adjacency_matrix(vmat) layoutsugiyama <- layout_with_sugiyama(g) e <- get.edgelist(g) #V(g)$label <- NA V(g)$label <- colSums(vt) V(g)$label.cex <- 0.5 V(g)$color <- lcols[colSums(vt)+1] V(g)$color[1] <- "pink" V(g)$frame.color <- kcols[colSums(vt > 0) + 1] V(g)$frame.width <- 1.5 V(g)$size <- 5 V(g)$shape <- c("circle", "square")[(colSums(vt >= 1) >= 4) + 1] V(g)$shape <- shape[colSums(vt != 0)+1] #E(g)$color <- gray(0.8) E(g)$color <- ecols[med] E(g)$width <- med/1.5 E(g)$arrow.size <- 0.3 E(g)$weight <- med pch <- c(16, 21, 21, 22, 22) par(mar=c(0, 0.2, 0.4, 2.5), xpd=TRUE) plot(g, layout=layoutsugiyama, vertex.label.font=2, vertex.label.color="black") legend("bottomleft", legend=c(0:4), horiz=FALSE, pch=pch, col=kcols, pt.cex=2, title="球種", pt.lwd=3) legend("topleft", legend=seq(ecols), pch=15, pt.cex=3, col=ecols, title="", bty="n", xpd=TRUE, x.intersp=-0.3, inset=0) legend("topleft", legend=NA, title="1レベル上がるのに平均的にかかる週数", bty="n") legend("right", legend=seq(lcols)-1, pch=15, pt.cex=3, col=lcols, title="総変化量", bty="n", xpd=TRUE, x.intersp=0.05, inset=-0.10, adj=c(0.5, 0.5), xjust=-1, title.adj=-2) i <- 316 # 5,5,5,5 i <- 119 # 7,7,6,0 i <- 317 # 6,5,5,5 i <- 120 # 7,7,7,0 spath <- shortest_paths(g, from=1, output="both", weights=med) es <- mapply(function(z) as.numeric(as.character(z)), spath$epath) # 最短エッジ E(g)$color[es[[i]]] <- "black" V(g)$frame.width[spath$vpath[[i]]] <- 3 V(g)$size[spath$vpath[[i]]] <- 7 plot(g, layout=layoutsugiyama) # ceb <- cluster_edge_betweenness(g, bridge=FALSE) # これは警告 ceb <- cluster_fast_greedy(as_undirected(g)) dendPlot(ceb, mode="hclust") par(mar=c(0, 0.2, 0.4, 2.5), xpd=TRUE) plot(ceb, g, layout=layoutsugiyama, edge.color=E(g)$color, col=V(g)$color, mark.border=NA, vertex.label.font=2) legend("bottomleft", legend=c(0:4), horiz=FALSE, pch=pch, col=kcols, pt.cex=2, title="球種", pt.lwd=3) legend("topleft", legend=seq(ecols), pch=15, pt.cex=3, col=ecols, title="", bty="n", xpd=TRUE, x.intersp=-0.3, inset=0) legend("topleft", legend=NA, title="1レベル上がるのに平均的にかかる週数", bty="n") legend("right", legend=seq(lcols)-1, pch=15, pt.cex=3, col=lcols, title="総変化量", bty="n", xpd=TRUE, x.intersp=0.05, inset=-0.10, adj=c(0.5, 0.5), xjust=-1, title.adj=-2) # 総変化量21のノードをテキストで指示する x <- c("(6,5,5,5)"=317, "(7,7,7,0)"=120) for(i in seq(x)){ xy <- norm_coords(layoutsugiyama$layout)[x[i],] text(xy[1], xy[2], names(x)[i], adj=c(1.3, 1.3), font=2) } # 総変化量の全パターンで解析 res <- NULL ll <- 20:24 # 描出する量が多いので一部分にする ll <- 1:28 # 全部描出する。barplot #for(l in 1:max(colSums(vt))){ for(l in ll){ i21 <- which(colSums(vt) == l) y <- mapply(function(w) mapply(function(z) success[z,], es[[w]]), i21, SIMPLIFY=FALSE) y21 <- mapply(rowSums, y) colnames(y21) <- paste0("(", apply(vt[,i21, drop=FALSE], 2, paste0, collapse=","), ")") res <- cbind(res, y21) } lidx <- unlist(mapply(rep, seq(ll), table(match(colSums(vt), ll)))) vcols <- rainbow(length(ll)) ymed <- apply(res, 2, quantile, 0.5, type=1) library(vioplot) par(mar=c(4, 7, 1, 1)) vioplot(res, horizontal=TRUE, side="right", col=vcols[lidx], axes=FALSE, xaxt="n", yaxt="n", border=NA, lineCol=NA, rectCol=NA, xlim=c(2, length(lidx)-1)) axis(1, lwd=0, lwd.ticks=1) #axis(2, lwd=0, lwd.ticks=1, at=1:ncol(res), labels=colnames(res), las=1) abline(h=1:ncol(res), lty=3) mtext("総変化量に達するまでにかかる練習回数（週数）", side=1, line=2.5) mtext("変化球のパターンと総変化量", side=2, line=6.0) text(ymed, 1:ncol(res), ymed) box() sw <- strwidth(colnames(res))[1]/2 sw0 <- 1.10 sh <- strheight(colnames(res))[1]/2 sh0 <- 1.50 xat <- par("usr")[1] - (par("mgp")[2] * diff(grconvertX(c(0, 1), from="lines", to="user"))) xat0 <- xat - sw for(l in seq(ll)){ y01 <- which(lidx == l) y01 <- y01[c(1, length(y01))] xpoly <- xat0 + c(-1, 1, 1, -1)*sw*sw0 ypoly <- y01[c(1, 1, 2, 2)] + c(-1, -1, 1, 1)*sh*sh0 polygon(xpoly, ypoly, xpd=TRUE, border=NA, lwd=2, col=adjustcolor(vcols[l], 0.4)) text(xpoly[1], mean(ypoly), ll[l], xpd=TRUE, pos=2) } axis(2, lwd=0, lwd.ticks=1, at=1:ncol(res), labels=colnames(res), las=1) # 透過性の上から描出したほうが見栄えがよい resmed <- tapply(apply(res, 2, median), lidx, quantile, 0.5, type=1) par(mar=c(4, 7, 1, 1)) boxplot(res, horizontal=TRUE, col=vcols[lidx], axes=FALSE, border=NA, xlim=c(10, length(lidx)-10)) mtext("総変化量に達するまでにかかる練習回数（週数）", side=1, line=2.5) mtext("変化球のパターンと総変化量", side=2, line=6.0) axis(1, lwd=0, lwd.ticks=1) #axis(2, lwd=0, lwd.ticks=1, at=1:ncol(res), labels=colnames(res), las=1) abline(h=cumsum(rle(lidx)$lengths)+0.5, lty=3) text(resmed, tapply(1:ncol(res), lidx, mean), resmed) box() # このあと上のpolygon を実行する l <- 21 i21 <- which(colSums(vt) == l) y <- mapply(function(w) mapply(function(z) success[z,], es[[w]]), i21, SIMPLIFY=FALSE) y21 <- mapply(rowSums, y) colnames(y21) <- paste0("(", apply(vt[,i21], 2, paste0, collapse=","), ")") ymed <- apply(y21, 2, median) vcols <- rainbow(length(i21)) names(vcols) <- colnames(y21) library(vioplot) par(mar=c(4, 6, 1, 1)) vioplot(y21, horizontal=TRUE, side="right", col=vcols) axis(1, lwd=0, lwd.ticks=1) axis(2, lwd=0, lwd.ticks=1, at=1:ncol(y21), labels=colnames(y21), las=1) abline(h=1:ncol(y21), lty=3) mtext(sprintf("総変化量%dに達するまでにかかる練習回数（週数）", l), side=1, line=2.5) mtext("変化球のパターン", side=2, line=4.5) text(ymed, 1:ncol(y21), ymed, pos=1) wlmat <- matrix(0, length(i21), length(i21), dimnames=replicate(2, colnames(y21), simplify=FALSE)) for(i in 1:nrow(wlmat)){ for(j in 1:ncol(wlmat)){ wlmat[i, j] <- mean(y21[,i] < y21[,j]) } } # 総当り結果 w <- graph_from_adjacency_matrix(wlmat > t(wlmat)) we <- get.edgelist(w) wlayout <- layout_in_circle(w) win <- rowSums(as.matrix(as_adjacency_matrix(w))) V(w)$label <- paste0(colnames(y21), "\n", win) V(w)$color <- vcols V(w)$label.color <- "black" V(w)$size <- 4+1.5*win V(w)$frame.color <- "white" E(w)$color <- vcols[we[,1]] E(w)$width <- 3 E(w)$arrow.size <- 1.0 par(mar=c(0, 0, 0, 0)) plot(w, layout=wlayout, vertex.label.font=2) w <- tapply(ymed, mapply(function(z) sum(eval(parse(text=z))), paste0("c", names(ymed))), c) wx <- unlist(mapply(rep, as.numeric(names(w)), sapply(w, length))) plot(wx, unlist(w), pch=16, las=1, xlab="総変化量", ylab="総変化量に達するまでにかかる練習回数（週数）")
