内科認定医受験の最低限の知識、
製薬会社の示してくる臨床データ、
論文の考察、
論文を書くときの正当性、
というのが、臨床統計の今までの目的の大きい部分でしたが、
AI=機械学習の基本も、結局は統計学と確率に支配されます。
そういう雑多な話をするスレです。
探検
臨床統計もおもしろいですよ、その１ [無断転載禁止]©2ch.net
■ このスレッドは過去ログ倉庫に格納されています
内科認定医受験の最低限の知識、
製薬会社の示してくる臨床データ、
論文の考察、
論文を書くときの正当性、
というのが、臨床統計の今までの目的の大きい部分でしたが、
AI=機械学習の基本も、結局は統計学と確率に支配されます。
そういう雑多な話をするスレです。
明日、正午から1時間お時間のある先生には、BSで放送大学の心理統計学の第二回を
見ていただくと、モンティ・ホール問題という常識をひっくり返す話があると思います。
これで、私も混乱しているので、一からやり直そうかと。
区間推計って1/√n-1で決まっていたんじゃないのかな、いえ、1/√nでもいいんじゃないか、
それだけって私にはお手上げなので...お願いします。
もちろん、いつも見ている2x2のΧ^2分析だけ話していてもおもしろくはないでしょ。
臨床医の知的トレーニング、サイコロでもRの話、何でも雑談してください。
http://potato.2ch.net/test/read.cgi/hosp/1439931587/
過去ログだがブラウザで読める
区間推定っていろんな方法があるね。
正規分布近似がよく用いられるけど。
MotulskyのIntuitive Biostastisticsには正規分布でなくｔ分布近似しろ、
正規分布近似のEXCELは間違いだという趣旨のことが書いてある。
ｔ分布の自由度を∞にすれば正規分布なのでさほど気にすることもないと思っている。
同様に√nも√n-1も大差がないと思っている。
それが結論を左右するならnが小さすぎだと思う。
Rのパッケージbinomに
binom.confint という関数があって種々の信頼区間を吐き出してくれて便利。極端な値でなければどれも一致する。
私には、どういう分布を採用していいのかという理論のところが分からなくて、
Excelなり、Rなりに後はデータを入れてしまう、認定試験も2x2の表が
まあまあ理解できないと分からないレベルでして（笑）。
正規分布を使うべきか、t分布を使うべきか、どうやって決められるのですか？
後、不偏分散と分散の差も分かってません（苦笑）。
ああ、二項分布やポアソン分布だったか、n → ∞になれば正規分布になるという理屈は
分かるのですが。
空腹で低血糖のため、日本語がおかしいですが、
2x2の有意差検定の表がまあまあ理解できるレベルで...
という意味です。
大学の教養学部の時代に、もう30年前の話ですが、分布関数を考えるときには、
積率母関数を考えなさいと教わりました。たぶん、ラプラス変換と同じで実数関数の
世界で収めたいという暖かい心遣いの講師の先生だったと思うのですが、今なら
虚数関数の特性関数の方が使いやすいなと思っております。基礎は堅いのですが
応用をどうして良いのか、迷ってます。
土曜日に5時まで医師としての仕事をしたとします。
あと1時間の先生も多いですよね。
で、他方、東京の普通の本社勤務のクリエイティブな仕事をしている人は、9連休でも経済的には
OKなんですよね？
医師はQOLを論じて議論するわけでしょ、統計学的に明らかに騙されていると思いますが。
ｎ=∞のtの分位関数は正規分布の分位関数と同じという話を書いたつもり。
Rで書けば
> qnorm(0.975)
[1] 1.959964
> qt(0.975,Inf)
[1] 1.959964
というだけの話。
ｔ分布を使う方が区間の幅が広くなるけど。
どの分布にしたがうかは経験則ではないかと思ってます。
たとえば所得の分布が対数正規分布に従うというのは理論的帰結ではないのだろうと。
過分散を避けるためにポアソン分布でなく負の二項分布を使うとか読んだけど理解できていない。
それが、わからぬままに
基礎からのベイズ統計学の 続編
実践 ベイズモデリング -解析技法と認知モデル
も読んだけど
さまざまなモデルが載っていたけれどモデルからの推論が現実と合致していればそれでいいのだろうと深く追求しておりません。
κ値（検査間や検者間の一致の指標）のMCMCサンプルの方法
和が1になる変数simplexと多項分布を使うことを思いつかなかったから、stanのスクリプトをみて眼から鱗。
これでκ値の信頼区間がだせる。
ちなみにMcGee Evidence-Based Physical Diagnosisの新版を買うかどうか迷っている。
旧版は持っているのでどれほど中身が変わったかな。 Google Bookで立ち読みしたけど髄膜炎のjolt accentuationのκ値の記載はなかったな。
>2x2の有意差検定のMCMCでのやり方が
基礎からのベイズ統計学の8章に書いてあったので
RのパッケージEpiのtwoby2とか、fisher.testとかprop.testが吐き出す信頼区間と一致するかで遊んだことがある。
シンプソンのパラドックスによく引用される男女の合格率の差
https://www.refsmmat.com/posts/2016-05-08-simpsons-paradox-berkeley.html
を使ってやってみたのが
http://egg.2ch.net/test/read.cgi/hosp/1428282054/759-761
今の俺の知識ではRのパッケージでできることを無理やりMCMCでやっている気がする。
まあ、サンプルからパラメータの信頼区間を求められるのが長所かな。
逆にきれいに従うモデルがあるとすれば、そこにこそ真実があるのかも知れませんね。
遅くなっちゃったので今日はこれまでと言うことで。
Rに慣れたらやってみます。パッケージすら、選び方がなかなかで...。
ベイズ統計学の講義を視聴しているのですが、問題は事前分布が分からないような場合に
どうするのかと言うことが、MCMC法を使う理由のようですね。
線虫とかイヌの嗅覚で、がんを見つけるときに、母集団の有病率の事前分布をさてどうやって
規定すればいいのやら、ってのことではないのでしょうか。
朝から木を切っていて疲れました、これは剛体の物理学通りに落ちてくれるのですが、
予期しない落ち方もありますね（笑）。
英語で考えると日本語の3倍ぐらい時間がかかってしまうようになってしまって、
カルテも電子カルテで情報共有と言われると、日本語ばかりになってしまうわけで
英語で考えたり、読んだりが大変です。
その上、老視になると、英文の活字の小さいこと（笑）、で苦戦しています。
メガネを二つ掛け替えないとなると、いかに学問がやりにくいか、目だけでも
若返りたい（笑）。
Rのいいところはオープンソースってことだな。
パッケージの関数のソースは
（）なしで入力すると、ソースが表示されるから内部計算の様子がわかる。
例えば
install.packages('Epi')
library(Epi)
twoby2
でtwoby2の関数としてのスクリプトが表示される。
ソースを改造して使えるので便利。
といっても
俺の実力じゃ関数の引数を増やすくらいの改造しかできないけど。
...を追加して引数としてcol='lightblue'としてplot関数に与えてグラフの色を変えるとか簡単にできる。
T.test=function(n1,n2,m1,m2,sd1,sd2){
SE12=sqrt((1/n1+1/n2)*((n1-1)*sd1^2+(n2-1)*sd2^2)/((n1-1)+(n2-1)))
T=(m1-m2)/SE12
2*pt(abs(T),n1-1+n2-1,lower.tail = FALSE)
}
# A君の彼女は女子大生、B君の彼女は女子高生。
# Y1女子大生n1=100人とY2女子高生n2=100人の胸囲を測定して
# 前者が平均82 , 標準偏差3
# 後者が平均81 , 標準偏差3
T.test(100,100,82,81,3,3)
> T.test(100,100,82,81,3,3)
[1] 0.0193982
シミュレーションデータを作って検証。
> x=82+scale(rnorm(100))*3
> y=81+scale(rnorm(100))*3
> t.test(x,y,var.equal = TRUE)$p.value
[1] 0.0193982
ラッキー！
これ、これが欲しかったんです。データの作り方！！
ありがとうございます！
自分のデータがないとまずRとの距離が遠くて、手でデータを10個ぐらい入れても何の感動もなくて
とにかく感謝。
今日も放送大学「心理統計学」を視聴しておりましたが、今日は、
2つの標本間の差の分析...全部MCMC法で差を出すので正規分布しか
出てこない。t検定はおまけで説明。
平均の差の確率分布まで出てくるのがおもしろいのですが、用語と手法に
慣れないと見ていて疲れます...。
A君の彼女は女子大生、B君の彼女は女子高生。
A君は女子大生の方が胸が大きいと主張して次のようなデータを出した。
女子大生100人と女子高生100人の胸囲を測定して
前者が平均82 , 標準偏差3
後者が平均81 , 標準偏差3
であった。
t検定でp = 0.0194と有意差があったとA君は勝ち誇っている。
さて、女子高生の彼女をもつB君は平均1cmの差では実地臨床w上、意味がない、
5cm以上の差があってこそ体感上有意と言えると主張。
問.
B君の女子高生彼女がA君の女子大生彼女より5cm以上の巨乳である確率とその95%信頼区間を述べよ。
新薬投与群100人でHbA1c7.2(sd=0.3)、従来薬100人でHbA1c7.1(sd=0.3)で統計的に有意差ありという医学ネタにすると面白くないね。
シミュレーションでの計算例は
http://egg.2ch.net/test/read.cgi/hosp/1428282054/756-757
Inference for Stan model: boobs.
4 chains, each with iter=15000; warmup=5000; thin=1;
post-warmup draws per chain=10000, total post-warmup draws=40000.
mean se_mean sd 2.5% 50% 97.5% n_eff Rhat
d 0.990 0.024 4.251 -7.352 0.974 9.308 31862 1
JD 0.175 0.002 0.380 0.000 0.000 1.000 28355 1
JK 0.078 0.002 0.268 0.000 0.000 1.000 26103 1
dは胸囲の差
分布をグラフにすると
http://i.imgur.com/huoDBIq.jpg
JDは女子大生のバストが女子高生より5cm以上大きい確率、
JKは女子高生のバストが女子大生より5cm以上大きい確率。
新薬の切り替えたときに臨床的有益性がどれくらいあるかの確率が計算できる。
今日の放送大学の講義で、pって何だったんですかって話になって、
「元の確率分布から非常に離れた値を取る確率」
という説明で、
「元の確率分布が正しい確率が1-pになるわけじゃないですよ」
と説明されていた。
有意差検定とベイズ統計学の差が出ているのかなと思いました。
MotuluskyのIntuitive Biostatisticsに
ｐ値がでたら、帰無仮説は何かを考えよ という趣旨のことが書いてあった。
リスク比RR＝１ （またはリスク差RD＝０）を帰無仮説にしてｐ値を算出するけれど
RR＝１に帰無仮説を設定する必然性はない、例えばRR＝１．５に設定してｐ値が算出できるという記載が
Rothmanの疫学(introductionの方)にあって
そのグラフｐ値関数を再現できるまでずいぶんと悩んだ（寝当直の暇つぶしになった）。
その誤解がアニメになっている。
https://www.youtube.com/watch?v=ax0tDcFkPic&;feature=youtu.be
p.value functionを検索していたら
http://sphweb.bumc.bu.edu/otlt/mph-modules/ep/ep713_randomerror/EP713_RandomError7.html
に掲載されていた。
かわいいアニメですが、日本語のアニメと同時には聞き取れませんね。今日は無理か、
ガンダム観たいし（笑）、明日にします。
後、やっぱり、有意性検定で書かれた論文が多いので、便利なベイズ統計と二足の
ワラジになりそうですね。
まだ、リスク比とハザード比の差が分からないのですが...。
リスクは一定、
ハザードは時間の経過と共に変化する。
外科治療と内科治療でのハザード比は一定というモデルは
周術期と安定期では一定でないと思う。
リスク比とハザード比をひっくるめてRate Ratioと呼んだりする。
RRはどちらの略か区別がつかないこともしばしば。
比例ハザードモデル=ハザード比一定
ならリスク比と区別がつかなくてもいいんだろうと理解している。
つまらない、ピエロみたいな話にレスしてくれてありがとうございます。
コホート研究と、一回の2x2の検定の差は分かります。
で、コホート研究の確率分布関数が指数関数という仮定に基づいて
いませんか？
それは、統計学者にとっては致命的ではないのでしょうか？
私は、それががん治療における
「最終命題」
じゃないのかと思うわけです。
「つらい」の変換で「痛い」がでないんですか？
「つらい」は日本人的には「痛い」なんですよ。
先生が英語で話したい理由は分かります。世界中に関する影響力が
違いますよね。
英語で聞き、英語で表現する、それが確率的に影響力最大なんですよね？
「日本人は苦労して、世界に届いている」
どうしてそれだけの能力があるのに、世界で認められないのか
そういう話ですよね。
確実に臨床統計は、
「日本人の生死とQOLを握っている」
わけでしょ。
日本人が複数である以上、それを否定する理論があれば、間違いですよ。
医師が努力すれば、
「医師法第一条に定められた、公衆衛生の利益が守られるわけじゃない」
という時代に、
利益最大の医師会や病院団体と、
厚労省の利益は合わないでしょ？
ごめんなさい、
他の板の関係で、数学板やら物理板の関係でこんなことを書きましたが、
学問は中立ですよね。中立ゆえの権利があるはずですね。
と思っているわけです。
数学板でモンティ・ホール問題に疑問を呈して、恣意的な確率操作に対して
意を表明していますが、
人間は、理論より納得でしょ。それを得られるかどうか、やってみているわけです。
ダメなら、呪術をmedicineと呼んでいるアフリカ諸国と同じですよ。
日本語で、「ハザード比、オッズ比、リスク比」を検索すると
こういうyahoo知恵袋が一番上に出てくるわけで、
情けない
と思うわけです。
誰が日本の臨床統計に対して責任を持っているのか、そういう学会があれば、その検索結果が
トップにでるように努力すべきなのではないですかね？
ネット時代に対応していない学会は捨てられるか、利益団体に利用されるだけかな？
東京馬鹿大で、
「医学生が医師を刺した」
という事象はどう説明するのかね？
明らかに、これは確率論・統計学的な話と言えないかな？
まともな臨床統計を目指すならコメントすべきじゃないし、
言いたいことがある人なら、コメントすべきじゃないかな。
日本語は使いにくいかな。
もっと言えば、
「日本人であること、日本国籍を持っていることは有利なのか？」
って話だと思うよ。
反論したければ、公的保険に対する期待値を示すべきだね。
AI=機械学習が人間の決定論に対して、鏡になってくれているわけかな。
EBMで、医療すら確率論的空間になってしまったが、
「人間という機械は、するかしないかの二択でしかあり得ない。」
だね。
「確率を提示するのが医師」
なのかな？ 論理学ならすべての事象を集合論で網羅して、真偽を与える
わけなんだけれど。
私はおかしげな当時の決定論に疑問を持って、大学院は拒否したわけだけれど、
多くの患者さんの犠牲の下に、私は地位を確立したかったのか、それを拒否したのか、
その感覚的判断は正しかったのか、バカみたいな論文を書き続けて今の日本の
医学的な指導者になっているのか、結局、
「屍の上に学問は成り立っているわけ」
でしかない。それをやった奴は手を血に染めているわけだ...。
その実験をするためには、それを誘導するための意志があったわけだろ。
二重の事後確率を決定するわけだよね。
だいたい、普通の臨床医は
「即断即決」
を求められているから。
EBMは嫌いなんじゃないかな、と思う、私もそうだから。
外来の決められた時間で
「決定論的結論」
を求めている患者さんには、この考察にかかる時間は
「不利益」
なんだよね。
確率論は熱力学と同じで、時間的問題を無視している。
サイコロはいつ投げられても同じ、
「コンビニの店長は、時間という価値と確率論的価値
はどう判断しているのか？」
簡単なORにおける在庫管理じゃないよね。
治療による診断はさしずめ、シュレーディンガーの猫かな？
天気予報にも降水確率つきで発表されるから、正診確率とともに診断を伝えてもいいんじゃないか？
事前確率は往々に経験則もしくは主観的設定だけど。
という問いに対して医者から「絶対これは譲りたくない」と心理的抵抗が強い業務こそ、AIを開発することによって医者減らしに貢献すると思うがどうかな？（救命救急士が行う気管内挿管のように、医者の既得権益？に踏み込む事だろうから。）
画像診断（ミクロの画像診断、病理も含む）だな。
あの話題の線虫によるがん検診の話がどのぐらいの信憑性があるのか、
知りたいなぁ。
AIの能力次第だと思うんだけれど...。
大量のデータから診断や治療法を探す検索系と、
機械学習で得られた成果を組み込んだ、画像判断ソフト
みたいな判断系と、熟練の技術者のデータを入れた
自動車組み立てロボットみたいな手技系が
できるんじゃないのかな？
土曜の午後は放送大学の無料放送で
「ベイズ統計学の復習」
の予定だったのですが、数週間できませんでした。
今日は見ます。
今日も無慈悲に
飛ばしている講師の先生。
不偏分散の話もどこかの回で無視していたのだが、
nで割るのとn-1で割るのと
たいした違いがない。分かるんだけれどね...。
http://eman-physics.net/math/figures4.html
にきれいな証明があるからご参考までに。
R言語で積み重ねられた、
統計学に必要なパッケージと
ランダムに作る、100万以上の仮想的なデータ
があれば、
統計学の先人達も、そりゃ対数表に頼っていたニュートンやら
昔の数学・物理学者も1,000円ぐらいの電卓に負けるかもね。
考慮すべき技術的な基盤技術が違う...、
事前確率分布の関数ことが人間の決められる時代なのかな。
あれ、今日もp値の評価の仕方かな。
最後に有意性検定の否定かな？
まず、帰無仮説の否定...
まあ、母集団とサンプル群の値が同じだとは言えないよな。
サンプルを取る前から偽...
そりゃあ、恣意的なのかもな。
Jargon!!!!
笑います。
ずごい！ 刑事事件になってきたぞ。
アリバイが検定に導入されている。
アリバイがないことで有罪の確率が変わるのはおかしい、
まあそういうことかな。
親子鑑定にベイズが使われたりするんだよな。
理由不十分の原則とかに陪審員が騙されるんだよね。
日々の生活での返済、お支払いでお悩みの方。
急な出費などで、今月の生活費が足りない方。
多重債務、ヤミ金、家賃滞納でお困りの方。
お金に関するお困り事や法的トラブル等HPに記載以外の事でも、お気軽にご相談下さい。
東京、神奈川、千葉、埼玉にお住まいの方は優遇です。
詳しくはHPをご覧下さい。
ｴｽﾃｨｰｴｰで検索
（１）Comparison of Hospital Mortality and Readmission Rates for Medicare Patients Treated by Male vs Female Physicians
http://scholar.harvard.edu/files/yusuketsugawa/files/tsugawa_jama_im_2016.pdf
若い医師が担当医の方が生存率が高いという論文
（２）Physician age and outcomes in elderly patients in hospital in the US:observational study
http://www.bmj.com/content/357/bmj.j1797
この二つの論文から
（３）若い女医が担当医のときが生存率が最も高い
（４）老いた男性医師が担当医のときが生存率が最も低い
という結論を導きだせるか。
申し訳ないです。
確率論におけるヒルベルト空間での議論で
はあ、有意差検定というのは、
10,000人のデータを真にしたとき
の30例のデータが優位であるかないかの話で、
10,030例の
検証に至っていないわけです。
臨床統計に至る100例未満の検証が
10,000の線形空間なのか
10,100の線形空間なのか
定義がずれているわけで、
AIやらニューロネットワーク的には、後者を選択するわけですよね？
明らかにn=10,000がn->無限と規定したいるから
おかしい話になるわけだ。
メンテしてくれている人に感謝です。
政治ネタは下げたいのでご容赦を。
安倍政権のお友達の確率を二項分布でpとしたときに
明らかに3つ出れば有意な差が出る
でしょうね。
医学部を増やす、何の意味があるのでしょうか
竹中さん？
と思いますよ、今の医学系の経営リスクを増やすんでしょうな。
さて先生のご不満はご承知の上で挑みますよ。
臨床統計における
独立したヒルベルト空間における独立したベクトルをどう設定するかでしょ？
主治医が男性か女性、あるいは患者さんにとって異性か同性なのか、
それを独立したベクトルとして採用するかどうか
が問題なんでしょうね。
臨床統計にとって、
ヒルベルト空間で何が独立した単位ベクトルなのか
もちろん、集めた母集団で主因子分析をするわけですが
「しゅいんし」とかな漢字変換に渡したら、「手淫し分析」
が一番に上がるぐらい自己満足感満載です。
ここ数日の国会中継を見ていますが、
加世学園の問題は確率論的にベイズ更新を行って
安倍総理の
ここ数年の法案提出 → 国会での可決
確率pがが落ちているのを
覚悟すべきだと思います。
既にp自体が低下しているのに泥船に乗る確率を
落とすべきですよね。
ゲーム理論で表現される、
混合戦略に入りつつあるわけです。
税務署が「無作為」抽出（実は無作為抽出でなく作為抽出）して調査した５例中、中元を受け取ったのは０であったという。
それをもって税務署は中元は１００例全例虚偽であると認定した。
これはサンプリングに伴うバラつきだと主張して全例への課税を軽減したい。
どういう計算をすればいいか？
foo <-function(SS,NN=100,N=5){
YY=c(rep(1,SS),rep(0,NN-SS))
return(sum(sample(YY,N)))
}
ss=0:100
S=0
k=10^4
SS=NULL
for(i in 1:k){
x=sapply(ss,foo)
SS=c(SS,which(x==S)-1)
}
hist(SS,freq=FALSE,col='lightblue', main='')
lines(density(SS),lwd=2,lty=3)
summary(SS)
MAP(SS)[1]
quantile(SS,c(0.025,0.50,0.975))
> summary(SS)
Min. 1st Qu. Median Mean 3rd Qu. Max.
0.00 4.00 10.00 13.56 20.00 89.00
> MAP(SS)[1]
x
1.547634
> quantile(SS,c(0.025,0.50,0.975))
2.5% 50% 97.5%
0 10 45
http://i.imgur.com/bhCzo9w.png
> print(fit, pars='p',probs=c(.025,.5,.975),digits=4)
Inference for Stan model: coin5.
4 chains, each with iter=100000; warmup=50000; thin=1;
post-warmup draws per chain=50000, total post-warmup draws=200000.
mean se_mean sd 2.5% 50% 97.5% n_eff Rhat
p 0.1429 0.0005 0.123 0.0042 0.1097 0.4569 68121 1
http://i.imgur.com/XYCecoG.png
5C0*x^0*(1-x)^(5-0)の期待値を求めればいいので
N=5
S=0
integrate(function(x) choose(N,S)*x^S*(1-x)^(N-S),0,1)$value
[1] 0.1666667
シミュレーションと少し違うな。
世田谷区でデング熱と診断された人が蚊に刺された
として、デング熱の発症確率は増えるんでしょうか？
根拠はあるのですか？ 行政的な出費をする根拠になるのですか？
AIの登場で臨床統計も変わってくると思いますよね。
AIなんてベイズ統計学そのもので検定主義の統計学とは異なるわけです。
死亡率と治療手段を独立とするベクトル空間における内積で議論するには
問題があるように思えますが。
個々の患者さんを説得するには明らかに分散が変わってくると思いますよね？
ベイズ統計で進めていくときに
説明変数が独立かどうかの設定が難しいと思う。
どうやるのか知らないからではあるが。
模擬試験の判定って ロジスティック回帰の応用だろうけど
英語の点数と国語の点数って独立じゃないだろね。
最近は、ジェネラリストのための内科診断リファレンス
をつまみ読みして生半可な知識を強化している。
明日は雨でしょうから
明日の降水確率は**%
に昇華。
知識が正確になると却って混乱することも増えた。
バセドー病でも抗TPO抗体が陽性になることもあるとか。
http://www4.nhk.or.jp/doctorg/
ありますよね。今でもNHK-Gで毎週放送しています。
新感覚！病名推理エンターテインメント番組「総合診療医ドクターG」。
病名を探り当てるまでの謎解きの面白さをスタジオで展開する！
あなたの症状も解き明かされるか！
というNHK的なクレジットがあるのですが、
患者さんの生死とかQOKがゲーム的に扱われている
のに疑問を感じます。
診断をどう扱うか、確率のヒルベルト空間では
ベイズ更新的
な発想で考えていますよね？
一つの事実で1,000-10,000ある診断ラベルのどれの
確率が変わるのか
という話です。
統計学・AI的思考の話。
研修医は診断AIに学ぶべき
だと思いませんか？
P(x)
に関して
時間tの要素があるんじゃないか
P(x,t)と思いますよね。
2000年の評価と2017年の評価は違う
としたら、
2000年に治療を受けていた患者さんと
2017年に治療を受けていた患者さんは
別だ
と言いたいわけでしょ？
それで
サイコロを2回振るのか二つのサイコロを1回振るのか
の違いが分かると思いますよ。
白鵬の土俵入りが観られる
という偶然は偶然じゃなくて
それなりに
ポテンシャルを変更している
という話が量子論的・確率論的な話だよね。
2人の横綱が対決する
ことを事後確率にして
何人の横綱が必要か
という問題を解いているわけだね。
シリツ卒ならば、医者ならば馬鹿である が、導けるか？
という論理命題の問題を臨床適用ｗするとこうなる。
甲状腺癌ならば、未分化癌なら予後不良である から
未分化癌ならば、甲状腺癌なら予後不良である が、導けるか？
Rに真理表を使って解答させるスクリプトは以下の通り。
# P->(Q->R) |- Q->(P->R)
library('gtools')
pm3=permutations(2,3,v=c(T,F),re=TRUE)
colnames(pm3)=c('P','Q','R'); pm3
imply <- function(x,y) !(x&&!y)
f <- function(P,Q,R) imply(imply(P,imply(Q,R)),imply(Q,imply(P,R)))
f1 <- function(pm) f(pm[1],pm[2],pm[3])
result=logical(8)
for(i in 1:8) result[i]=f1(pm3[i,])
cbind(pm3,result)
> cbind(pm3,result)
P Q R result
[1,] FALSE FALSE FALSE TRUE
[2,] FALSE FALSE TRUE TRUE
[3,] FALSE TRUE FALSE TRUE
[4,] FALSE TRUE TRUE TRUE
[5,] TRUE FALSE FALSE TRUE
[6,] TRUE FALSE TRUE TRUE
[7,] TRUE TRUE FALSE TRUE
[8,] TRUE TRUE TRUE TRUE
>50できる？
(3)若い女医の担当患者の成人率が、老いた男医の担当患者の生存率より高いと言えるか？
も追加。
宝くじに当選者がでたということはp<0.05のことが起こったので「くじ引きが無作為」という帰無仮説は棄却される。
正しい議論か？
# NN(100)個中当たりSS個、N(5)個サンプルしてS個当たりからSSを推測する。
foo <-function(SS,NN=100,N=5){
YY=c(rep(1,SS),rep(0,NN-SS)) #YYは当たり(1)がSS個、はずれ(0)がNN-SS個
return(sum(sample(YY,N))) # YYからN個引いたときの当たりの個数を返す
}
sss=0:100 #くじ中のあたりの候補
S=0 #引いた当たりの数
k=10^4 # 繰り返し回数
SS=NULL #容れ子初期値
for(i in 1:k){
x=sapply(sss,foo) #あたりがくじ全体でsss個だった時N個引いたときのあたりの個数
SS=c(SS,which(x==S)-1) #引いたあたりの個数がS個(0個)だったときのくじ全体のあたりの個数で配列をつくる
}
hist(SS,freq=FALSE,col='lightblue', main='')
lines(density(SS))
summary(SS)
quantile(SS,c(0.025,0.50,0.975))
## 最頻値計算
MAP <- function(x) {
dens <- density(x)
mode_i <- which.max(dens$y) # densityの頂点となるindex
mode_x <- dens$x[mode_i]
mode_y <- dens$y[mode_i]
c(x=mode_x, y=mode_y)
}
MAP(SS)[1] #最頻値
Min. 1st Qu. Median Mean 3rd Qu. Max.
0.00 4.00 10.00 13.56 20.00 85.00
> quantile(SS,c(0.025,0.50,0.975))
2.5% 50% 97.5%
0 10 45
> NN=100
> pp=0:NN #くじ全体のアタリの個数候補
> f <- function(x,NN=100,N=5) choose(NN-x,N)/choose(NN,N) #アタリがx個のときN個引いてすべてハズレの確率
> plot(pp,f(pp))
> sum(pp*f(pp)/sum(f(pp))) # f(pp)/sum(f(pp)):確率密度
[1] 13.57143
# 期待値＝26.36人 信頼区間0～101.06人
NN=600 ; N=20
pp=0:NN #くじ全体のアタリの個数候補
f <- function(x,NN=600,N=20) choose(NN-x,N)/choose(NN,N) #アタリがx個のときN個引いてすべてハズレの確率
plot(pp,f(pp))
sum(pp*f(pp)/sum(f(pp))) # f(pp)/sum(f(pp)):確率密度
binom::binom.confint(0,N)
(p=1-0.025^(1/N))
(1-p)^N ; p*NN
binom.test(0,N)$conf*NN
binom::binom.exact(0,N)
# NN個中アタリSS個、N個サンプルしてS個アタリからSSを推測する。
foo <-function(SS,NN=600,N=20){
YY=c(rep(1,SS),rep(0,NN-SS)) #YYはアタリ(1)がSS個、はずれ(0)がNN-SS個
return(sum(sample(YY,N))) # YYからN個引いたときのアタリの個数を返す
}
sss=0:NN #くじ中のアタリの候補
S=0 #引いたアタリの数
k=10^4 # 繰り返し回数
SS=NULL #容れ子初期値
for(i in 1:k){
x=sapply(sss,foo) #アタリがくじ全体でsss個だった時N個引いたときのアタリの個数
SS=c(SS,which(x==S)-1) #引いたアタリの個数がS個(0個)だったときのくじ全体のアタリの個数で配列をつくる
}
hist(SS,freq=FALSE,col='wheat', main='',xlab='正規合格者数') ; lines(density(SS))
summary(SS) ; quantile(SS,c(.025,.50,.975))
conf=binom::binom.confint(0,20)
cbind(conf['method'],round(conf['lower'],1),round(conf['upper']*NN,2))
n=600
r=20
n ｎ
Σj*(n-j)Ｃr/nＣr ÷ Σ(n-i)Ｃr/nＣr
j=0 i=0
atari <- function(.NN, .N, r, k=10^3){
f <-function(SS,NN=.NN,N=.N){
YY=c(rep(1,SS),rep(0,NN-SS)) #YYはアタリ(1)がSS個、はずれ(0)がNN-SS個
sum(sample(YY,N)) # YYからN個引いたときのアタリの個数を返す
}
sss=0:.NN # くじ中のアタリの候補
SS=NULL # 容れ子初期値
for(i in 1:k){ # k:繰り返し数
x=sapply(sss,f) # アタリがくじ全体でsss個だった時N個引いたときのアタリの個数
SS=c(SS,which(x==r)-1) #引いたアタリの個数がr個だったときのくじ全体のアタリの個数で配列をつくる
}
hist(SS,freq=FALSE,col='lightblue', main='', xlab='アタリ総数')
lines(density(SS))
print(summary(SS))
cat('\n')
print(quantile(SS,c(.025,.05,.50,.95,.975)))
invisible(SS)
}
atari(100,5,0)
atari(600,20,1)
### くじ全体のアタリの期待値
atari.e <- function(NN,N,r){ # 全体NN個のくじからN個引いてr個アタリ
pp=0:NN #くじ全体のアタリの個数候補
f <- function(x) choose(x,r)*choose(NN-x,N-r)/choose(NN,N) # 全体のアタリがx個のときN個引いてr個アタリの確率
plot(pp,f(pp))
sum(pp*f(pp)/sum(f(pp))) # Σpp：個数 * f(pp)/sum(f(pp)):確率密度
}
atari.e(100,5,0)
atari.e(600,20,1)
# Σ i*iＣr*(N-i)Ｃ(n-r)/NＣn ÷ ΣjＣr*(N-j)Ｃ(n-r)/NＣn
# i=0 j=0
# Σi*choose(i,r)*choose(N-i,n-r)/choose(N,n) ÷ Σchoose(j,r)*choose(N-j,n-r)/choose(N,n)
atari.ee <- function(N,n,r){
X=numeric() ; Y=numeric()
for(i in 1:(N+1)) X[i] = (i-1)*choose(i-1,r)*choose(N-(i-1),n-r)/choose(N,n)
for(j in 1:(N+1)) Y[j] = choose(j-1,r)*choose(N-(j-1),n-r)/choose(N,n)
sum(X)/sum(Y)
}
atari.ee(100,5,0)
atari.ee(600,20,1)
# Σ i*iＣr*(N-i)Ｃ(n-r)/NＣn ÷ ΣjＣr*(N-j)Ｃ(n-r)/NＣn
# i=0 j=0
# Σi*choose(i,r)*choose(N-i,n-r)/choose(N,n) ÷ Σchoose(j,r)*choose(N-j,n-r)/choose(N,n)
atari.ee <- function(N,n,r){
X=numeric() ; Y=numeric()
for(i in 1:(N+1)) X[i] = (i-1)*choose(i-1,r)*choose(N-(i-1),n-r)/choose(N,n)
for(j in 1:(N+1)) Y[j] = choose(j-1,r)*choose(N-(j-1),n-r)/choose(N,n)
sum(X)/sum(Y)
}
atari.ee(100,5,0)
atari.ee(600,20,1)
N=600
n=20
r=1
L <- function(x) choose(x,r)*choose(N-x,n-r)/choose(N,n) # 全体のアタリがx個のときn個引いてr個アタリの確率
L(0)
L(1)
xx=1:N
yy=sapply(xx,L)
which.max(yy)
plot(xx,yy)
plot(xx[25:35],yy[25:35])
L(29:31)
n=20
r=1
L <- function(x) choose(x,r)*choose(N-x,n-r)/choose(N,n) # 全体のアタリがx個のときn個引いてr個アタリの確率
L(0) # = 0
L(1)
xx=1:N # yy[i]=L(xx[i])になるように1から始める
yy=sapply(xx,L)
which.max(yy) # 最頻値
plot(xx,yy)
plot(xx[25:35],yy[25:35])
L(29:31)
#chooseはΓ関数で内部計算なので整数でなくても計算する
curve(L(x),0,600)
optimise(L,c(0,600),maximum=TRUE)
素数Aiを任意の数ｎ個集めて
n
Ｂ = Π Ai + 1
i=1
とすると
Ｂを割り切るAi以外の素数が存在することになり、ｎ個集めればn+1個以上の素数の存在が示せることになる。
例
2*3+1で素数7
3*5+1で素数2
3*7+１で素数2と11
# Σ i*iＣr*(N-i)Ｃ(n-r)/NＣn ÷ ΣjＣr*(N-j)Ｃ(n-r)/NＣn
# i=0 j=0
# Σi*choose(i,r)*choose(N-i,n-r)/choose(N,n) ÷ Σchoose(j,r)*choose(N-j,n-r)/choose(N,n)
atari.m <- function(N,n,r){
X=numeric() ; Y=numeric()
for(i in 1:(N+1)) X[i] = (i-1)*choose(i-1,r)*choose(N-(i-1),n-r)/choose(N,n)
for(j in 1:(N+1)) Y[j] = choose(j-1,r)*choose(N-(j-1),n-r)/choose(N,n)
c(mean=sum(X)/sum(Y),mode=which.max(Y)-1)
}
atari.m(100,5,0)
atari.m(600,20,1)
# Σ i*iＣr*(N-i)Ｃ(n-r)/NＣn ÷ ΣjＣr*(N-j)Ｃ(n-r)/NＣn
# i=0 j=0
# Σi*choose(i,r)*choose(N-i,n-r)/choose(N,n) ÷ Σchoose(j,r)*choose(N-j,n-r)/choose(N,n)
atari.mm <- function(N,n,r){
xx=0:N
c(mean = sum(xx*choose(xx,r)*choose(N-xx,n-r)/choose(N,n))/sum(choose(xx,r)*choose(N-xx,n-r)/choose(N,n)),
mode = which.max(choose(xx,r)*choose(N-xx,n-r))-1)
}
atari.mm(100,5,0)
atari.mm(600,20,1)
+ xx=0:N
+ c(mean = sum(xx*choose(xx,r)*choose(N-xx,n-r)/choose(N,n))/sum(choose(xx,r)*choose(N-xx,n-r)/choose(N,n)),
+ mode = which.max(choose(xx,r)*choose(N-xx,n-r))-1)
+ }
> atari.mm(100,5,0)
mean mode
13.57143 0.00000
> atari.mm(600,20,1)
mean mode
53.72727 30.00000
>
# Σ i*iＣr*(N-i)Ｃ(n-r)/NＣn ÷ ΣjＣr*(N-j)Ｃ(n-r)/NＣn
# i=0 j=0
# Σi*choose(i,r)*choose(N-i,n-r)/choose(N,n) ÷ Σchoose(j,r)*choose(N-j,n-r)/choose(N,n)
atari.mm <- function(N,n,r) c(mean = sum(0:N*choose(0:N,r)*choose(N-0:N,n-r)/choose(N,n))/sum(choose(0:N,r)*choose(N-0:N,n-r)/choose(N,n)),mode = which.max(choose(0:N,r)*choose(N-0:N,n-r))-1)
atari.mm(100,5,0)
atari.mm(600,20,1)
lottery <- function(.N,.r,k=10^3){
f <-function(S,N=.N){
y=c(rep(1,S),rep(0,N-S)) # yはアタリ(1)がS個、はずれ(0)がN-S個
Y=sample(y,N) # 並べ替えた配列を返す
return(Y)
}
# 初めて0以外の数が現れた位置を返す
g <- function(y){
n=length(y)
for(i in 1:n){
if(!y[i]) i=i+1
else break
}
return(i)
}
xx=0:.N # くじ中のアタリ数の候補
SS=NULL # 容れ子初期値
for(i in 1:k){
M=t(sapply(xx,f)) # アタリ0~.N個の並べ替え済サンプル行列M
# r個めが初めて当たりだったときの個数（=行番-1)
for(j in 1:.N){
if(g(M[j,])==.r) SS=c(SS,j-1) #r個めで初めてのアタリだったときのくじ全体のアタリの個数で配列をつくる
}
}
hist(SS,freq=FALSE,main='', xlab='Wins',col='skyblue')
# lines(density(SS))
print(summary(SS))
cat('\n')
print(quantile(SS,c(.025,.05,.50,.95,.975)))
invisible(SS)
}
lottery.mm <- function(.N,.r){
pmf <- function(S,N=.N,r=.r){ # .N個中S個のアタリのとき.r個めで初めてあたる確率は
choose(N-r,S-1)/choose(N,S) #.r+1以後の配列/すべての配列
}
ss=0:.N
pdf=pmf(ss)/sum(pmf(ss)) # 確率密度関数に変換
plot(ss,pdf)
c(mean=sum(ss*pdf),mode=which.max(pdf)-1)
}
lottery.mm(100,50)
pmf <- function(S,N=.N,r=.r){ # .N個中S個のアタリのとき.r個めで初めてあたる確率は
choose(N-r,S-1)/choose(N,S) #.r+1以後の配列/すべての配列
}
ss=0:.N
pdf=pmf(ss)/sum(pmf(ss)) # 確率密度関数に変換
E=sum(ss*pdf)
SSS=sample(0:.N,10^5*.N,replace=TRUE,prob=pdf) # 重みをつけて繰り返しサンプリング
UL=quantile(SSS,c(.025,.975))
c(E,UL)
}
lottery.mci(100,5)
+ pmf <- function(S,N=.N,r=.r){ #
+ choose(N-r,S-1)/choose(N,S) #
+ }
+ ss=0:.N
+ pdf=pmf(ss)/sum(pmf(ss)) #
+ E=sum(ss*pdf)
+ SSS=sample(0:.N,10^5*.N,replace=TRUE,prob=pdf) #
+ UL=quantile(SSS,c(.025,.975))
+ c(mean=E,UL)
+ }
> lottery.mci(100,1)
mean 2.5% 97.5%
67 16 99
pmf <- function(S,N=.N,r=.r){
choose(N-r,S-1)/choose(N,S)
}
ss=0:.N
pdf=pmf(ss)/sum(pmf(ss))
E=sum(ss*pdf)
SSS=sample(0:.N,10^5*.N,replace=TRUE,prob=pdf)
UL=quantile(SSS,c(.025,.975))
c(E,UL)
}
.N=100
rr=1:.N
MLU=sapply(rr, function(r) lottery.mci(.N,r))
round(t(MLU))
2.5% 97.5%
[1,] 67 16 99
[2,] 50 9 91
[3,] 40 7 80
[4,] 33 5 71
[5,] 28 4 63
[6,] 25 4 57
[7,] 22 3 51
[8,] 19 3 47
[9,] 18 2 43
[10,] 16 2 40
[11,] 15 2 37
[12,] 14 2 34
[13,] 13 2 32
[14,] 12 2 30
[15,] 11 2 28
[16,] 10 1 27
[17,] 10 1 25
[18,] 9 1 24
[19,] 9 1 23
[20,] 8 1 22
[21,] 8 1 21
[22,] 8 1 20
[23,] 7 1 19
[24,] 7 1 18
[25,] 7 1 17
[26,] 6 1 17
[27,] 6 1 16
[28,] 6 1 15
[29,] 6 1 15
[30,] 5 1 14
xx=0:N
pmf=choose(xx,r)*choose(N-xx,n-r)/choose(N,n)
pdf=pmf/sum(pmf)
SS=sample(xx,N*k,replace=TRUE,prob=pdf)
print(quantile(SS,c(0.025,0.5,0.975)))
c(mean = sum(xx*pdf),
mode = which.max(choose(xx,r)*choose(N-xx,n-r))-1)
}
atari.Q(100,10,2)
2.5% 50% 97.5%
6 23 50
mean mode
24.5 20.0
>
+ pmf <- function(S,N=.N,r=.r){
+ choose(N-r,S-1)/choose(N,S)
+ }
+ ss=0:.N
+ pdf=pmf(ss)/sum(pmf(ss))
+ c(mean=sum(ss*pdf),mode=which.max(pdf)-1)
+ }
> lottery.mm(100,5)
mean mode
28.14286 20.00000
atari.Q <- function(N,n,r,k=10^5){
xx=0:N
pmf=choose(xx,r)*choose(N-xx,n-r)/choose(N,n)
pdf=pmf/sum(pmf)
SS=sample(xx,N*k,replace=TRUE,prob=pdf)
print(c(mean = sum(xx*pdf),
mode = which.max(choose(xx,r)*choose(N-xx,n-r))-1))
cat('\n')
print(quantile(SS,c(0.025,0.5,0.975)))
invisible(SS)
}
lottery.mci <- function(N,m,k=10^5){
pmf <- function(S,.N=N,.m=m){
choose(.N-.m,S-1)/choose(.N,S)
}
ss=0:N
pdf=pmf(ss)/sum(pmf(ss))
E=sum(ss*pdf)
SSS=sample(0:N,N*k,replace=TRUE,prob=pdf)
print(c(mean=E,mod=which.max(pdf)))
cat('\n')
print(quantile(SSS,c(.025,.975)))
invisible(SSS)
}
atari.Q(N,n,r)
lottery.mci(N,m)
シリツ医大進学予備校"どていへん予備校"では５年連続不合格、
別のシリツ医大進学予備校"うらぐち予備校"では１０年めで初めて合格者がでたという実績があるとき、
どていへん予備校 と うらぐち予備校ではどちらが合格可能性が高いと言えるか？
巨乳女子大では10人に声をかけて2人が誘いに応じた。
桃尻女子大では無作為順に声をかけていったら5人めが誘いに応じた。
どちらが誘いに応じやすいといえるか？
http://i.imgur.com/DgsfuyX.png
> lottery.mci(100,5)
mean mod
28.14286 21.00000
2.5% 97.5%
4 63
> atari.Q(100,10,2)
mean mode
24.5 20.0
2.5% 50% 97.5%
6 23 50
>
atari.Q <- function(N,n,r,k=10^5){
xx=0:N
pmf=choose(xx,r)*choose(N-xx,n-r)/choose(N,n)
pdf=pmf/sum(pmf)
SS=sample(xx,N*k,replace=TRUE,prob=pdf)
print(c(mean = sum(xx*pdf),
mode = which.max(choose(xx,r)*choose(N-xx,n-r))-1))
cat('\n')
print(quantile(SS,c(0.025,0.5,0.975)))
invisible(SS)
}
lottery.mci <- function(N,m,k=10^5){
pmf <- function(S,.N=N,.m=m){
choose(.N-.m,S-1)/choose(.N,S)
}
ss=0:N
pdf=pmf(ss)/sum(pmf(ss))
E=sum(ss*pdf)
SSS=sample(0:N,N*k,replace=TRUE,prob=pdf)
print(c(mean=E,mod=which.max(pdf)-1))
cat('\n')
print(quantile(SSS,c(.025,.975)))
invisible(SSS)
atari.Q <- function(N,n,r,k=10^5){
xx=0:N
pmf=choose(xx,r)*choose(N-xx,n-r)/choose(N,n)
pdf=pmf/sum(pmf)
SS=sample(xx,N*k,replace=TRUE,prob=pdf)
# print(quantile(SS,c(0.025,0.5,0.975)))
# cat('\n')
# print(c(mean = sum(xx*pdf),
# mode = which.max(choose(xx,r)*choose(N-xx,n-r))-1))
invisible(SS)
}
lottery.mci <- function(N,m,k=10^5){
pmf <- function(S,.N=N,.r=m){
choose(.N-.r,S-1)/choose(.N,S)
}
ss=0:N
pdf=pmf(ss)/sum(pmf(ss))
E=sum(ss*pdf)
SSS=sample(0:N,N*k,replace=TRUE,prob=pdf)
UL=quantile(SSS,c(.025,.975))
# print(c(E,UL))
invisible(SSS)
}
Brown=sum(choose(0:N,r)*choose(N-0:N,n-r)/choose(N,n))
curve(choose(x,r)*choose(N-x,n-r)/choose(N,n)/Brown,0,100,col='brown',xlab='尻軽数',ylab='')
Pink=sum(choose(N-m,0:N-1)/choose(N,0:N))
curve(choose(N-m,x-1)/choose(N,x)/Pink,0,100, add=TRUE,col='pink',lwd=2)
legend('topright',bty='n',legend=c('巨乳女子','桃尻女子'),lwd=1:2,col=c('brown','pink'))
平均値と信頼区間のどちらを選択するかだな。
lottery.s <- function(m,N=100){
pmf <- function(S,.N=N,.m=m){
choose(.N-.m,S-1)/choose(.N,S)
}
bb=0:N # numbers of possible bitches
pdf=pmf(bb)/sum(pmf(bb))
SS=sample(0:N,replace=TRUE,prob=pdf) # sample as the same length
return(SS)
}
lottery.s(8)
foo <- function(y,al='l'){ # one-sided mo > ky
f <- function(x){
mo=lottery.s(5)
ky=lottery.s(x)
t.test(ky,mo,alt=al)$p.value
}
welch=replicate(10^2,f(y))
mean(welch)
}
yy=5:10
pp=sapply(yy,foo)
plot(yy,pp)
abline(h=0.05,lty=3)
f <- function(x){
mo=lottery.s(5)
ky=lottery.s(x)
fn(ky,mo,alt=al)$p.value
}
p.values=replicate(10^2,f(y))
mean(p.values)
}
yy=5:10
# どの検定でも結果は変わらず
pp=sapply(yy,function(x) foo(x,fn=t.test))
pp=sapply(yy,function(x) foo(x,fn=lawstat::brunner.munzel.test))
pp=sapply(yy,function(x) foo(x,fn=wilcox.test))
PP=sapply(yy,function(x) foo(x,fn=perm::permTS))
plot(yy,pp)
abline(h=0.05,lty=3)
+ pmf <- function(S,.N=N,.m=m){
+ choose(.N-.m,S-1)/choose(.N,S)
+ }
+ ss=0:N
+ pdf=pmf(ss)/sum(pmf(ss))
+ sum(ss*pdf)
+ }
>
> lottery.e(100,10)
[1] 16
> lottery.e(50,5)
[1] 13.85714
>
> A=100;a=10
> B=50;b=5
>
> prop.test(c(lottery.e(A,a),lottery.e(B,b)),c(A,B))
2-sample test for equality of proportions with continuity correction
data: c(lottery.e(A, a), lottery.e(B, b)) out of c(A, B)
X-squared = 2.1814, df = 1, p-value = 0.1397
alternative hypothesis: two.sided
95 percent confidence interval:
-0.27551116 0.04122545
sample estimates:
prop 1 prop 2
0.1600000 0.2771429
lottery.e <- function(N,m){
pmf <- function(S,.N=N,.m=m) choose(.N-.m,S-1)/choose(.N,S)
ss=0:N
pdf=pmf(ss)/sum(pmf(ss))
sum(ss*pdf)
}
prop.test(c(lottery.e(A,a),lottery.e(B,b)),c(A,B))
}
sillygal(5,10,50,100)
sillygal (5,7,100,100)
th=ifelse(0<r&&r<4,c('st','nd','rd')[which(r==1:3)],'th')
plot(0:N/N,dbinom(0:N,N,p=(0:N)/N),pch='+',
xlab='治癒確率',ylab='治癒確率通り治癒する確率')
yy=dbinom(0:N,N,p=(0:N)/N)
summary(yy[2:100])
hist(yy[2:100],col='tomato')
.D0=10^8 # 借入額
.ra=0.01 # 年利
.r=.ra/12 # 月利
.n=120 # 返済月数
L <- function(x,D0=.D0,r=.r,n=.n){ # x:毎月の返済額
D=numeric(n)
D[1]=D0*(1+r) - x
for(i in 1:(n-1)) D[i+1] <- D[i]*(1+r) -x
return(D[n]) # n回返済後の借入金残高を返す
}
# L(.n)=0になる毎月の返済額 x を求める。
(m=uniroot(L,c(.D0/.n,.D0*(1+.n*.r)))$root)
m*.n # 総返済額
##### 元利均等返済 毎月の返済額と総返済額
loan <- function(.D0,.ra,.n){
A0=.D0
r=.ra/12
N=.n
m=A0*r*(1+r)^N/( (1+r)^N- 1)
c(Monthly=floor(m),Total=floor(m)*N)
}
loan(23700000,0.03,60)
loan(10^8,0.01,120)
Debt <- function(n,.D0,.ra,.n){
A0=.D0
r=.ra/12
N=.n
s=1+r
A0*(1- (1-s^n)/(1-s^N))
}
Debt(1:60,23700000,0.03,60)
##
Loan <- function(.D0,.ra,.n){
L <- function(x,D0=.D0,r=.ra/12,n=.n){
D=numeric(n)
D[1]=D0*(1+r) - x
for(i in 1:(n-1)) D[i+1] <- D[i]*(1+r) -x
return(D[n])
}
m=uniroot(L,c(.D0/.n,.D0*(1+.n*.ra/12)))$root
c(Monthly=floor(m),Total=floor(m)*.n)
}
#N=7 # 元数
I=1:N
.Y=sample(I,N) ; .Y # 1,2,..,Nを.Y[1],Y.[2],..,.Y[N]に置換
tikan <- function(X,Y=.Y){ # X:置換される配列
n=length(X)
Z=rep(NA,n)
I=1:n
for(i in 1:n){
j <- which(I==X[i])
Z[i] <- Y[j]
}
return(Z) # 置換後の配列を返す
}
## 循環したらやめる
z=matrix(1:N,nrow=1)
z[1,]=tikan(I)
for(i in 1:N^2){
if(!prod(z[i,]==I)){
z=rbind(z,tikan(z[i,]))
}
else break
}
print(z)
print(rbind(I,z[1,]))
return(nrow(z))
}
N=length(.Y) # 元数
I=1:N
#.Y=sample(I,N) ; .Y # 1,2,..,Nを.Y[1],Y.[2],..,.Y[N]に置換
tikan <- function(X,Y=.Y){ # X:置換される配列
n=length(X)
Z=rep(NA,n)
I=1:n
for(i in 1:n){
j <- which(I==X[i])
Z[i] <- Y[j]
}
return(Z) # 置換後の配列を返す
}
## 循環したらやめる
z=matrix(1:N,nrow=1)
z[1,]=tikan(I)
for(i in 1:N^2){
if(!prod(z[i,]==I)){
z=rbind(z,tikan(z[i,]))
}
else break
}
# print(rbind(I,.Y))
# print(z)
return(ifelse(i!=N^2,i,ifelse(prod(z[i,]==I),i,0)))
}
library(gtools)
N=7
PM=permutations(N,N,v=1:N)
jn=numeric(N)
n=nrow(PM)
for(j in 1:n) jn[j] <- junkan(PM[j,])
table(jn)
which(jn==0)
> table(jn)
jn
1 2 3 4 5 6 7 10 12
1 231 350 840 504 1470 720 504 420
> which(jn==0)
integer(0)
開眼片足立ち左秒,16.02,7.73,18.99,8.12,18.92,9.84,18.83,9.92
開眼片足立ち右秒,18.48,8.29,21.23,8.14,19.88,9.36,19.75,9.35
左握力kg,18.72,4.22,19.67,4.03,19.83,4.63,19.73,4.68
右握力kg,20.89,4.13,21.7,3.86,21.21,4.37,20.92,4.28
FRcm,22.36,6.08,24.83,5.89,23.51,4.97,22.45,4.67
10m歩行速度秒,6.61,0.75,5.95,0.67,6.53,1.18,6.65,1.32
立位体前屈cm,6.90,10.64,12.33,6.41,9.25,4.90,9.00,5.48
左片足立ち振り回,8.40,4.76,9.93,4.24,8.96,6.28,8.36,5.85
右片足立ち振り回,9.30,5.20,11.16,5.34,9.93,7.38,9.80,7.27
nt=30
nc=30
(d=read.csv('clipboard'))
mt2=d[,'mt2']
st2=d[,'st2']
mc2=d[,'mc2']
sc2=d[,'sc2']
# t検定(生データなし,等分散不問)
Welch.test=function(n1,n2,m1,m2,sd1,sd2){
T=(m1-m2)/sqrt(sd1^2/n1+sd2^2/n2)
df=(sd1^2/n1+sd2^2/n2)^2 / (sd1^4/n1^2/(n1-1)+sd2^4/n2^2/(n2-1))
p.value=2*pt(abs(T),df,lower.tail = FALSE)
return(p.value)
}
cbind(d['test'],Welch.test(nt,nc,mt2,mc2,st2,sc2))
Dbinom <- function(s,n,p){
choose(n,s)*p^s*(1-p)^(n-s)
}
Dbinom(100,100,0.95)
Dbinom(100,100,0.99)
s=99;n=100 # 百発99中
curve(Dbinom(s,n,x),ylab='',xlab='p')
AUC=integrate(function(p) Dbinom(s,n,p),0,1)$value
integrate(function(x) x*Dbinom(s,n,x)/AUC,0,1)$value
s=100;n=100 # 百発百中
curve(Dbinom(s,n,x),ylab='',xlab='p',0.9,1)
AUC=integrate(function(p) Dbinom(s,n,p),0,1)$value
integrate(function(x) x*Dbinom(s,n,x)/AUC,0,1)$value # Expected value
curve(Dbinom(s,n,x)/AUC)
curve(Dbinom(s,n,x)/AUC,0.9,1)
integrate(function(x) Dbinom(s,n,x)/AUC, 0,1)
pdf <- function(x) Dbinom(s,n,x)/AUC
p99 <- uniroot(function(x,u0=0.99) integrate(pdf,x,1)$value - u0,c(0,1))$root ; p99
N=10^7
hits=rbinom(N,n,p99)
hist(hits)
mean(hits==100)
# PMF(x)=nCn*x^n*(1-x)^(n-n)=x^n
# AUC=integrate(PMF,0,1)=[x^(n+1)/(n+1)]1,0 = 1/(n+1)
# PDF=PMF/AUC=(n+1)x^n
# CDF(u)=integrate(pdf(x),0,u)=[x^(n+1)]0,u = u^(n+1)
# (1-CL)^(1/(n+1)) # lower.limit
# exp(log(1-CL)/(n+1))
#
# Ex=integrate(x*PDF,0,1) = integrate((n+1)*x^(n+1),0,1)
# = (n+1)/(n+2)
#
sniper <- function(n,CL=0.99){
c(Lower=(1-CL)^(1/(n+1)), Expected=(n+1)/(n+2), Upper=1)
}
sniper(100,0.99)
nn=1:100
plot(nn,sapply(nn,function(x) sniper(x,CL=0.99)[1]),
xlab='ｎ発ｎ中',ylab='99%信頼区間下限値',pch=19)
N=10^3
n=100
pn=sniper(n,0.99)[1] ; pn
hits=rbinom(N,n,pn)
hist(hits,freq=FALSE, main='')
mean(hits==n)
k=10^5
M=numeric(k)
foo <-function(){
hits=rbinom(N,n,pn)
mean(hits==n)
}
for(i in 1:k) M[i] <- foo()
summary(M)
hist(M,freq=FALSE,main='',xlab='全発命中割合')
Epi::twoby2
# logOR±1.96*sqrt(1/a+1/b+1/c+1/d)
HRCI <- function(a,b,c,d,CL=0.95){
Z=qnorm(1-(1-CL)/2)
HR=(a/(a+b)) /(c/(c+d))
se=sqrt(1/a-1/(a+b)+1/c-1/(c+d))
lwr=HR*exp(-Z*se)
upr=HR*exp( Z*se)
c(lwr,HR,upr)
}
The 95% confidence interval upper bound of 0.527 represents a 47% risk reduction, which translates into a risk increase of about 90% from not being on warfarin (1/0.527 = 1.898)
(i.e., what would be seen if the test drug had no effect). Thus, M1 (in terms of the hazard ratio favoring the control to be ruled out) is 1.898.
M2 was calculated on the log hazard scale as 1.378, so that NI would be demonstrated provided the upper bound for the 95% confidence interval for C vs. T < 1.378.
exp(0.5*log(1/0.527))=1.378
ゴルゴ14は10発10中
ゴルゴ15は1発1中
とする。
各々10000発撃ったとき各ゴルゴの命中数の期待値はいくらか？
The NI trial assesses T ? Cn , the effect of the test drug compared to active control. If the outcome for the active control is constant across studies,
then Cn = Ch, and the sum T ? Cn + Ch ? P = T ? P represents the effect of the test drug compared to placebo.
# Fixed Margin Approach
M1M2 <- function(ub){ # ub :upper border of c.i. by meta-analysis
c(M1=1/ub,M2=exp(-log(ub)/2))
}
M1M2(.527)
## Synthesis Method risk ratio
NIs <- function(rr21,se21,rr10,se10){ # 0:placebo, 1:active control 2:test drug
se=sqrt(se21^2+(se10/2)^2) # log_se=sqrt(log(1/a-1/(a+b)+1/c-1/c+d)))
z=(log(rr21)+log(rr10)/2)/se
p=pnorm(-abs(z))
c(p.value=p,z=z)
}
NIs(1.39,0.216,0.361,0.154)
## fixed margin test
NIf <-function(rr21,se21,rr10,se10){
se=se21+se10/2
z=(log(rr21)+log(rr10)/2)/se
p=pnorm(-abs(z))
c(p.value=p,z=z)
}
NIf(1.39,0.216,0.361,0.154)
f <-function(S,N=.N,n=.n){
y=c(rep(1,S),rep(0,N-S))
sum(sample(y,n))
}
xx=0:.N
SS=NULL
for(i in 1:k){
x=sapply(xx,f)
SS=c(SS,which(x==r)-1)
}
summary(SS)
}
G(10000,100,100)
pp=0:N
f <- function(x) choose(x,r)*choose(N-x,n-r)/choose(N,n)
sum(pp*f(pp)/sum(f(pp)))
}
G13(10000,100,100)
G13(10000,10,10)
G13(10000,1,1)
f <-function(S,N=.N,n=.n){
y=c(rep(1,S),rep(0,N-S))
sum(sample(y,n))
}
xx=r:.N
SS=NULL
for(i in 1:k){
x=sapply(xx,f)
SS=c(SS,which(x==r)-1+r)
}
summary(SS)
}
Go13(100,1,1)
Go13(1000,10,10)
Go13(10000,100,100)
pa=0.1 ; pb=0.01
Wa=100 ; Wb=1000
A=c(rep(1,Na*pa),rep(0,Na-Na*pa)) ; A=sample(A)
B=c(rep(1,Nb*pb),rep(0,Nb-Nb*pb)) ; B=sample(B)
n=100
Get <- function(a){
sum(sample(A,a))*Wa + sum(sample(B,n-a))*Wb
}
aa=0:n
k=10^4
MAX=replicate(k,which.max(sapply(aa,Get)))
summary(MAX)
hist(MAX,freq=FALSE)
lines(density(MAX),lwd=2)
パチンコのスレにこういう記載があった。
>バカは何故かパチンコで勝てると思い込んでいる
>バカは本来なら勝てるのに遠隔や不正で負けていると思い込んでいる
>バカは10分の1で10円が当たるクジより1万分の1で8000円が当たるクジの方が儲かると思ってる
>算数すらできないバカが必死に守って支えてきたのがパチンコ業界
これを読んでこんな問題を考えてみた。
宝くじAは1000本中100本が当たりで当たりは 100万円の賞金、
宝くじBは1000本中 10本が当たりで当たりは1000万円の賞金、
どちらも売り出し価格は同じなので100本買うことにする。
どちらを何本買うときに賞金の期待値が最大になるか、シミュレーションしてみよ。
dens <- density(x)
mode_i <- which.max(dens$y)
mode_x <- dens$x[mode_i]
mode_y <- dens$y[mode_i]
c(x=mode_x, y=mode_y)
}
Na=1000 ; Nb=1000
pa=0.1 ; pb=0.01
Wa=100 ; Wb=1000
n=100
A0=c(rep(1,Na*pa),rep(0,Na-Na*pa))
B0=c(rep(1,Nb*pb),rep(0,Nb-Nb*pb))
Get <- function(a){ #Aをa本買ったときの賞金合計
sum(sample(A0,a))*Wa + sum(sample(B0,n-a))*Wb
}
takarakuji <- function(k=10^3,Histogram=FALSE,Print=TRUE,...){
MAX=replicate(k,which.max(sapply(aa,Get))-1)
if(Histogram) {hist(MAX,freq=FALSE,...) ; lines(density(MAX),lwd=2)}
if(Print)print(round(c(mean=mean(MAX),sd=sd(MAX),mode=MAP(MAX)[1]),2))
invisible(c(mean=mean(MAX),sd=sd(MAX),mode=MAP(MAX)[1]))
}
takarakuji(10^5,Histogram = TRUE,col='lightblue')
.n=100,.Wa=100,.Wb=1000,Histogram=TRUE,Print=TRUE,...){
Na=.Na ; Nb=.Nb
pa=.pa ; pb=.pb
Wa=.Wa ; Wb=.Wb
n=.n
aa=0:n
A0=c(rep(1,Na*pa),rep(0,Na-Na*pa))
B0=c(rep(1,Nb*pb),rep(0,Nb-Nb*pb))
Get <- function(a)sum(sample(A0,a))*Wa + sum(sample(B0,n-a))*Wb
MAX=replicate(k,which.max(sapply(aa,Get))-1)
tbl_MAX=table(MAX)
MODE=tbl_MAX[which.max(tbl_MAX)]
mode=as.numeric(names(MODE))
if(Histogram) {
hist(MAX,freq=FALSE,main=paste('Na=',Na,'Nb=',Nb),...)
lines(density(MAX),lwd=1)
}
if(Print){
print(round(c(mean=mean(MAX),sd=sd(MAX),mode=mode),2))
}
invisible(c(mean=mean(MAX),sd=sd(MAX),mode=mode))
}
dev.off()
par(mfrow=c(2,2))
Takarakuji(.Na=10^3,.Nb=10^3,col='lightblue')
Takarakuji(.Na=10^5,.Nb=10^5,col='wheat')
Takarakuji(.Na=10^7,.Nb=10^7,col='maroon')
Takarakuji(.Na=10^8,.Nb=10^8,col='gray')
# クジ1本の値段は前者は2万円,後者は4万円とする.
# 購入金額100万円としてどのように買うとき賞金の期待値が最大になるか？
pa=0.1 #Aの当選率
Wa=10 #Aの賞金
ca=2 #Aのコスト
pb=1/10000
Wb=8000
cb=4
Cash=100 #購入額
# a,bは各々A,Bの購入数 2*a+4*b=100 a=(Cash-4*b)/2
award <- function(b){
a=(100-4*b)/2
sum(rbinom(a, 1, pa) * Wa) + sum(rbinom(b, 1, pb) * Wb)
}
bb=0:floor(Cash/cb)
AWD <- function(){
Award=sapply(bb,award)
c(which.max(Award)-1,max(Award))
}
k=10^6 ; res=replicate(k,AWD())
Max.B=res[1,]
hist(Max.B,freq=FALSE,breaks=20,col='lightblue')
lines(density(Max.B),lwd=1)
summary(Max.B)
Mode(Max.B)
Max.AWD=res[2,]
hist(Max.AWD,col='wheat',breaks=100)
summary(Max.AWD)
Mode(Max.AWD)
https://www.rstudio.com/wp-content/uploads/2015/02/data-wrangling-cheatsheet.pdf
のデータは
EDAWR
というパッケージにあるらしいのだが、R3.4.2だと
Warning in install.packages :
package ‘EDAWR’ is not available (for R version 3.4.2)
と警告がでた。
install.packages('devtools')
devtools::install_github("rstudio/EDAWR")
で警告を回避してインストールできた。
> cases
country 2011 2012 2013
1 FR 7000 6900 7000
2 DE 5800 6000 6200
3 US 15000 14000 13000
> tidyr::gather(cases,'year','n',2:4)
country year n
1 FR 2011 7000
2 DE 2011 5800
3 US 2011 15000
4 FR 2012 6900
5 DE 2012 6000
6 US 2012 14000
7 FR 2013 7000
8 DE 2013 6200
9 US 2013 13000
と動作してくれた。
library(EDAWR)
cases
cases %>% gather('year','n',2:4)
cases %>% gather('year','n',2:4) %>% spread(year,n) %>% arrange(country)
cases %>% arrange(country)
pollution
pollution %>% spread(size, amount)
pollution %>% spread(size, amount) %>% gather('size','amount',2:3) %>% arrange(desc(city))
pollution
library(reshape2)
cases
cases %>% melt(value.name ='cases')
pollution
pollution %>% acast(city ~ size)
http://imagizer.imageshack.com/img923/1874/4NP9BA.png
http://i.imgur.com/094oClD.png
Min. 1st Qu. Median Mean 3rd Qu. Max.
8992 9866 9933 9903 9972 10000
> which.max(table(g13))
10000
714
Wa=100 ; Wb=1000 # 賞金
n=100 # 買う総本数
k=10^3 # シミュレーション回数
# Aをi買ったときの賞金総額
a <- function(i){sum(rbinom(i, 1, pa) * Wa) + sum(rbinom(100-i, 1, pb) * Wb)}
which.max2 <- function(x){which(x==max(x))-1}
# 最大賞金総額になるAの購入数（複数可）の配列を返す
b <- function(){
b1=NULL
b1=c(b1,which.max2(sapply(0:n, a)))
return(b1)
}
b2=NULL
for(j in 1:k){
b2=c(b2,b())
}
hist(b2,freq=FALSE,breaks=20,col=sample(colors(),2),ann=FALSE)
lines(density(b2),lwd=1)
summary(b2)
which.max(table(b2))
Wa=100 ; Wb=1000 # 賞金
n=100 # 買う総本数
aa=0:n # 宝くじAを買う候補
Get <- function(a){sum(sample(A0,a))*Wa + sum(sample(B0,n-a))*Wb} #賞金総額
foo <- function(k=10^3){
which.max2 <- function(x){which(x==max(x))-1}
MAX=NULL
MAX.AWD=NULL
for(i in 1:k){
tmp=sapply(aa,Get)
indx=which.max2(tmp)
MAX=c(MAX,indx) # 最大賞金を獲得したときに買ったAの本数の配列
MAX.AWD=c(MAX.AWD,tmp[indx+1]) #最大賞金が複数回あるときは重複して数える
}
indx=which.max2(MAX.AWD)+1
plot(MAX,MAX.AWD,xlim=c(0,n),ylim=c(n*pa*Wa,8*n*pa*Wa),
xlab='A_lots',ylab='Award',col=rgb(.1,.1,.1,.5))
points(MAX[indx],MAX.AWD[indx],pch=19)
luckyA=MAX[indx]
lucky.AWD=MAX.AWD[indx]
cbind(luckyA,lucky.AWD)
}
foo()
[1] 3
> '*'(2,3)
[1] 6
> a=1:10
> '['(a,7)
[1] 7
'[' って関数なんだな。
宝くじAは1000本中300本が当たりで当たりは 100万円の賞金、
宝くじBは1000本中 10本が当たりで当たりは1000万円の賞金、
とAの期待値＝Bの期待値の3倍のとき
http://i.imgur.com/6CN1yOt.png
続きのコードが書き込めないので画像でアップ
http://imagizer.imageshack.com/img922/5007/LKoY9v.jpg
pb=0.01 # 当たる確率
Wa=100 ; Wb=1000 # 賞金
n=100 # 買う総本数
foo <- function(pa=0.1,k=10^3){
# k=10^3 # シミュレーション回数
# Aをi買ったときの賞金総額
a <- function(i){sum(rbinom(i, 1, pa) * Wa) + sum(rbinom(100-i, 1, pb) * Wb)}
which.max2 <- function(x){which(x==max(x))-1}
# 最大賞金総額になるAの購入数（複数可）の配列を返す
b <- function(){
b1=NULL
b1=c(b1,which.max2(sapply(0:n, a)))
return(b1)
}
b2=NULL
for(j in 1:k){
b2=c(b2,b())
}
hist(b2,freq=FALSE,breaks=20,col=sample(colors(),1),xlab='',ylab='',yaxt='n',
main=paste('pa =',pa))
lines(density(b2),lwd=1)
print(summary(b2))
print(c(Mode=as.numeric(names(which.max(table(b2)))))) # モード値
print(c(length=length(b2))) # 最大値となる数は複数最大値があるのでｎを超える
invisible(b2)
}
par(mfrow=c(2,2))
for(i in c(0.15,0.2,0.25,0.3)) foo(i,500)
##-- now some "magic" to do the 4 regressions in a loop:
ff <- y ~ x
mods <- setNames(as.list(1:4), paste0("lm", 1:4))
for(i in 1:4) {
ff[2:3] <- lapply(paste0(c("y","x"), i), as.name)
## or ff[[2]] <- as.name(paste0("y", i))
## ff[[3]] <- as.name(paste0("x", i))
mods[[i]] <- lmi <- lm(ff, data = anscombe)
print(anova(lmi))
}
## See how close they are (numerically!)
sapply(mods, coef)
lapply(mods, function(fm) coef(summary(fm)))
## Now, do what you should have done in the first place: PLOTS
op <- par(mfrow = c(2, 2), mar = 0.1+c(4,4,1,1), oma = c(0, 0, 2, 0))
for(i in 1:4) {
ff[2:3] <- lapply(paste0(c("y","x"), i), as.name)
plot(ff, data = anscombe, col = "red", pch = 21, bg = "orange", cex = 1.2,
xlim = c(3, 19), ylim = c(3, 13))
abline(mods[[i]], col = "blue")
}
mtext("Anscombe's 4 Regression data sets", outer = TRUE, cex = 1.5)
par(op)
(d=outer(11:19,11:19,'*'))
d[,3]
apply(d,1,'[',3)
# を，3行2列おきに平均して
# ,,1
# [,1] [,2]
# [1,] 5 17
# [2,] 8 20
# ,,2
# [,1] [,2]
# [1,] 29 41
# [2,] 32 44
#
a=3
b=2
c=1
l=6
m=4
n=2
re=NULL
for(k in 1:(n/c)){
for(j in 1:(m/b)){
for(i in 1:(l/a)){
re=append(re,mean(d[1:a+a*(i-1),1:b+b*(j-1),1:c+c*(k-1)]))
}
}
}
array(re,dim=c(m/b,l/a,n))
d=array(1:(l*m*n),dim=c(l,m,n))
re=NULL
for(k in 1:(n/c)){
for(j in 1:(m/b)){
for(i in 1:(l/a)){
re=append(re,mean(d[1:a+a*(i-1),1:b+b*(j-1),1:c+c*(k-1)]))
}}}
array(re,dim=c(m/b,l/a,n))
}
fe <- function(){ # Expertソース
A <- array(1:(l*m*n), dim=c(l,m,n))
B <- expand.grid(1:(l %/% a), 1:(m %/% b),1:(n %/% c))
f <- function(i, j, k){mean(A[(a*(i-1)+1):(a*i),(b*(j-1)+1):(b*j),(c*(k-1)+1):(c*k)])}
re=mapply(f, B[,1], B[,2],B[,3])
array(re,dim=c(m%/%b,l%/%a,n%/%c))
}
a=4
b=2
c=1
l=400
m=200
n=2
> system.time(fs())
user system elapsed
2.17 0.00 2.18
> system.time(fe())
user system elapsed
1.14 0.00 1.14
y=11:19
nx=length(x)
ny=length(y)
re=matrix(rep(NA,nx*ny),ncol=nx)
for(i in 1:nx){
for(j in 1:ny){
re[j,i]=x[i]*y[j]
}
}
re
a=expand.grid(x,y)
b=mapply('*',a[,1],a[,2])
matrix(b,nx)
outer (x,y,'*')
y=1:999
nx=length(x)
ny=length(y)
fs = function (){
re=matrix(rep(NA,nx*ny),ncol=nx)
for(i in 1:nx){
for(j in 1:ny){
re[j,i]=x[i]*y[j]
}
}
re
}
fe = function (){
a=expand.grid(x,y)
b=mapply('*',a[,1],a[,2])
matrix(b,nx)
}
fo = function (){
outer (x,y,'*')
}
system.time(fs())
system.time(fe())
system.time(fo())
m=7 ; n=17
Z=matrix(rep(NA,m*n),m,n)
colnames(Z)=paste0('n',0:(n-1))
rownames(Z)=paste0('m',0:(m-1))
f <- function(x) c(x%%m+1,x%%n+1)
for(i in 0:(n*m-1)){
idx=f(i) ; idx
Z[idx[1],idx[2]]=i
}
length(unique(Z))
Z
NZ <- function(x,y,m=7,n=17){
f <- function(x) c(x%%m+1,x%%n+1)
for(i in 0:(n*m-1)){
idx=f(i)
Z[idx[1],idx[2]]=i
}
Z[(x%%m+1),(y%%n+1)]
}
NZ(5,15)
NZ(6,0)
a=expand.grid(0:6,0:16)
res=mapply(NZ,a[,1],a[,2])
Z=matrix(res,m,n)
colnames(Z)=paste0('n',0:(n-1))
rownames(Z)=paste0('m',0:(m-1))
Z
length(unique(Z))
modm=paste0('(mod ',m,')')
modn=paste0('(mod ',n,')')
res=c(x%%m,x%%n)
names(res)=c(modm,modn)
return(res)
}
where2(100)
fij <- function(i,j){
ai=where2(i)
aj=where2(j)
aiaj=ai+aj
NZ(aiaj[1],aiaj[2]) == i+j
}
a=expand.grid(0:(m-1),0:(n-1))
mapply(fij,a[,1],a[,2])
## 積で直積
fij <- function(i,j){
ai=where2(i)
aj=where2(j)
aiaj=ai * aj
NZ(aiaj[1],aiaj[2]) == i * j
}
a=expand.grid(0:(m-1),0:(n-1))
mapply(fij,a[,1],a[,2])
[1] TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE
[18] TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE
[35] TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE
[52] TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE
[69] TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE
[86] TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE
[103] TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE
同型写像確認
lmn=l*m*n
N=0:(lmn-1)
.M=rbind(nl=N%%l,nm=N%%m,nn=N%%n)
which(apply((.M - c(x,y,z)),2,function(x) sum(x^2))==0)-1
}
l=13 ; m=15 ; n=17
ll=0:(l-1); mm=0:(m-1) ; nn=0:(n-1)
a=expand.grid(ll,mm,nn)
res=mapply(NZ,a[,1],a[,2],a[,3])
length(unique(res)) == l*m*n
summary(res)
plot(sort(res))
hist(res,breaks=l*m*n)
l*m*nNZ <- function(x,y,z, l=13,m=15,n=17){
lmn=l*m*n
N=0:(lmn-1)
.M=rbind(nl=N%%l,nm=N%%m,nn=N%%n)
which(apply((.M - c(x,y,z)),2,function(x) sum(x^2))==0)-1
}
l=13 ; m=15 ; n=17
ll=0:(l-1); mm=0:(m-1) ; nn=0:(n-1)
a=expand.grid(ll,mm,nn)
res=mapply(NZ,a[,1],a[,2],a[,3])
length(unique(res)) == l*m*n
summary(res)
plot(sort(res))
hist(res,breaks=l*m*n)
l*m*n 👀
Rock54: Caution(BBR-MD5:0be15ced7fbdb9fdb4d0ce1929c1b82f)
を参考にオイラー関数をグラフにしてみた。
http://i.imgur.com/9db3JHt.png
phi <- function(n){
nn=0:(n-1)
f=function(x,y) (x*y)%%n
names(nn)=paste0('n',nn)
z=outer(nn,nn,f)
i=which(gmp::gcd(1:(n-1),n)==1)
length(i)
}
#Fourier transform
phi.F <- function(N){
nn=1:N
sum( gmp::gcd(nn,N)*cos(2*pi*nn/N))
}
N=1000
nn=1:N
y=sapply(nn,phi)
plot(nn,y,col=sample(colours()),pch=19,ylab='',xlab='n',main='Euler\'s totient function')
y1=sapply(nn,phi.F)
points(nn,y1,pch='.',cex=1.5)
(p+1)^(p^(n-1)) ≡ p^n + 1 (mod p^(n+1))
beki <- function(x,y,p){ # (x^y)%%p
if(y==0) return(1)
if(y==1) return(x%%p)
re=numeric(y)
re[1]=x
for(i in 1:(y-1)) re[i+1] = (x*re[i])%%p
return(re[y])
}
f <- function(p,n){ # (p+1)^(p^(n-1)) ≡1 (mod p^n)
beki(p+1,p^(n-1),p^n)
}
p=(2:9)[gmp::isprime(2:9)!=0]
n=2:9
a=expand.grid(p,n)
> mapply(f,a[,1],a[,2])
> mapply(f,a[,1],a[,2])
[1] 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 👀
Rock54: Caution(BBR-MD5:0be15ced7fbdb9fdb4d0ce1929c1b82f)
p:奇素数
beki <- function(x,y,p){
if(!y) return(x^y)
re=numeric()
re[1]=x%%p
for(i in 1:y) re[i+1] = (x*re[i])%%p
return(re[y])
}
# ｎのmod p での位数を求める
isu <- function(n,p){
re=numeric()
for(i in 1:(p-1)){
re[i]=beki(n,i,p)
}
which.min(re)
}
n=length(X)
Z=rep(NA,n)
I=1:n
for(i in 1:n){
j <- which(I==X[i])
Z[i] <- Y[j]
}
return(Z)
}
e =c(1,2,3)
d =c(3,1,2)
d2=c(2,3,1)
t =c(1,3,2)
td=c(3,2,1)
td2=c(2,1,3)
(.M=rbind(e,d,d2,t,td,td2))
(names=rownames(.M))
equal <- function(x,y) sum((x-y)^2)==0
f <- function(x){ #
re=NULL
for(i in 1:nrow(.M)){
if(equal(.M[i,],x)) return(i) # i for names[i]
}
}
g <- function(x,y){
f(tikan2(x,y)) # first y, then x makes names[i]
}
names(.L)=names
.L
a=expand.grid(.L,.L)
(.a=mapply(g,a[,1],a[,2]))
(.M0=matrix(mapply(g,a[,1],a[,2]),nrow(.M)))
.M1=matrix(names[.a], nrow(.M))
rownames(.M1)=names
colnames(.M1)=names
> print(.M1, quote=FALSE)
e d d2 t td td2
e e d d2 t td td2
d d d2 e td2 t td
d2 d2 e d td td2 t
t t td td2 e d d2
td td td2 t d2 e d
td2 td2 t td d d2 e
k <- function(x,y,z) equal(tikan2(x,tikan2(y,z)), tikan2(tikan2(x,y),z))
(a=expand.grid(.L,.L,.L))
b=mapply(k,a[,1],a[,2],a[,3])
> summary(b)
Mode TRUE
logical 216
結合則
結合則の確認は手計算だと手間がかかる。
プログラムを組んで確認できて納得。
群論における「位数」とは、二つの異なる定義があり、それぞれ、
①有限群Gの位数＝有限群Gの元の個数、
②有限群Gの元aの位数＝有限群Gの元aにおいて、a^m=e となる最小の正の整数、
となります。
# D2n( e,d1,d2,d3,..,dn-1, t,td,td2,td3,...,tdn-1)
n=7
tikan <- function(X,Y=.Y){ # e.g. c(1,2,3) -> .Y=c(2,1,3)
n=length(X)
Z=rep(NA,n)
I=1:n
for(i in 1:n){
j <- which(I==X[i])
Z[i] <- Y[j]
}
return(Z)
}
e=1:n
d1=c(n,1:(n-1)) # 360°/n 回転移動
Mnd=matrix(NA,n,n)
Mnd[1,]=e
for(i in 1:(n-1)){
Mnd[i+1,]=tikan(Mnd[i,],d1)
}
rownames(Mnd)=c('e',paste0('d',1:(n-1)))
Mnd
tikan(t,d1) # D2n( e,d1,d2,d3,..,dn-1, t,td,td2,td3,...,tdn-1)
Mnt=matrix(NA,n,n)
Mnt[1,]=t
for(i in 1:(n-1)){
Mnt[i+1,]=tikan(Mnt[i,],d1)
}
rownames(Mnt)=c('t',paste0('td',1:(n-1)))
Mnt
(Mn=rbind(Mnd,Mnt))
names=rownames(Mn)
.L=list(2*n) # list(Mn[1,],Mn[2,],...Mn[,n]) list(e,d1,d2,..,dn-1,t,td1,td2,..,tdn-1)
for(i in 1:(2*n)) .L[[i]]=Mn[i,]
names(.L)=names
.L
a=expand.grid(.L,.L)
(.a=mapply(g,a[,1],a[,2]))
(.M0=matrix(mapply(g,a[,1],a[,2]),length(.L)))
.M1=matrix(names[.a], length(.L))
rownames(.M1)=names
colnames(.M1)=names
.M1
print(.M1, quote=FALSE)
e d1 d2 d3 d4 d5 d6 t td1 td2 td3 td4 td5 td6
e e d1 d2 d3 d4 d5 d6 t td1 td2 td3 td4 td5 td6
d1 d1 d2 d3 d4 d5 d6 e td6 t td1 td2 td3 td4 td5
d2 d2 d3 d4 d5 d6 e d1 td5 td6 t td1 td2 td3 td4
d3 d3 d4 d5 d6 e d1 d2 td4 td5 td6 t td1 td2 td3
d4 d4 d5 d6 e d1 d2 d3 td3 td4 td5 td6 t td1 td2
d5 d5 d6 e d1 d2 d3 d4 td2 td3 td4 td5 td6 t td1
d6 d6 e d1 d2 d3 d4 d5 td1 td2 td3 td4 td5 td6 t
t t td1 td2 td3 td4 td5 td6 e d1 d2 d3 d4 d5 d6
td1 td1 td2 td3 td4 td5 td6 t d6 e d1 d2 d3 d4 d5
td2 td2 td3 td4 td5 td6 t td1 d5 d6 e d1 d2 d3 d4
td3 td3 td4 td5 td6 t td1 td2 d4 d5 d6 e d1 d2 d3
td4 td4 td5 td6 t td1 td2 td3 d3 d4 d5 d6 e d1 d2
td5 td5 td6 t td1 td2 td3 td4 d2 d3 d4 d5 d6 e d1
td6 td6 t td1 td2 td3 td4 td5 d1 d2 d3 d4 d5 d6 e
f <- function(x){
re=NULL
for(i in 1:length(.L)){
if(equal(.L[[i]],x)) return(i) # i for names[i]
}
}
g <- function(x,y){
f(tikan2(x,y)) # first y, then x makes names[i]
}
# D2n( e,d1,d2,d3,..,dn-1, t,td,td2,td3,...,tdn-1)
n=7
tikan <- function(X,Y=.Y){ # e.g. c(1,2,3) -> .Y=c(2,1,3)
n=length(X)
Z=rep(NA,n)
I=1:n
for(i in 1:n){
j <- which(I==X[i])
Z[i] <- Y[j]
}
return(Z)
}
tikan2 <- function(X,Y){ # replace Y first then X
n=length(X)
Z=rep(NA,n)
I=1:n
for(i in 1:n){
j <- which(I==X[i])
Z[i] <- Y[j]
}
return(Z)
}
equal <- function(x,y) sum((x-y)^2)==0
re=NULL
for(i in 1:length(.L)){
if(equal(.L[[i]],x)) return(i) # i for names[i]
}
}
g <- function(x,y){
f(tikan2(x,y)) # first y, then x makes names[i]
}
e=1:n
d1=c(n,1:(n-1)) # 360°/n 回転移動
Mnd=matrix(NA,n,n)
Mnd[1,]=e
for(i in 1:(n-1)){
Mnd[i+1,]=tikan(Mnd[i,],d1)
}
rownames(Mnd)=c('e',paste0('d',1:(n-1)))
Mnd
tikan(t,d1) # D2n( e,d1,d2,d3,..,dn-1, t,td,td2,td3,...,tdn-1)
Mnt=matrix(NA,n,n)
Mnt[1,]=t
for(i in 1:(n-1)){
Mnt[i+1,]=tikan(Mnt[i,],d1)
}
rownames(Mnt)=c('t',paste0('td',1:(n-1)))
Mnt
(Mn=rbind(Mnd,Mnt))
names=rownames(Mn)
.L=list(2*n) # list(Mn[1,],Mn[2,],...Mn[,n]) list(e,d1,d2,..,dn-1,t,td1,td2,..,tdn-1)
for(i in 1:(2*n)) .L[[i]]=Mn[i,]
names(.L)=names
.L
a=expand.grid(.L,.L)
(.a=mapply(g,a[,1],a[,2]))
(.M0=matrix(mapply(g,a[,1],a[,2]),length(.L)))
.M1=matrix(names[.a], length(.L))
rownames(.M1)=names
colnames(.M1)=names
.M1
print(.M1, quote=FALSE)
e d1 d2 d3 d4 d5 d6 d7 d8 d9 t td1 td2 td3 td4 td5 td6 td7 td8 td9
e e d1 d2 d3 d4 d5 d6 d7 d8 d9 t td1 td2 td3 td4 td5 td6 td7 td8 td9
d1 d1 d2 d3 d4 d5 d6 d7 d8 d9 e td9 t td1 td2 td3 td4 td5 td6 td7 td8
d2 d2 d3 d4 d5 d6 d7 d8 d9 e d1 td8 td9 t td1 td2 td3 td4 td5 td6 td7
d3 d3 d4 d5 d6 d7 d8 d9 e d1 d2 td7 td8 td9 t td1 td2 td3 td4 td5 td6
d4 d4 d5 d6 d7 d8 d9 e d1 d2 d3 td6 td7 td8 td9 t td1 td2 td3 td4 td5
d5 d5 d6 d7 d8 d9 e d1 d2 d3 d4 td5 td6 td7 td8 td9 t td1 td2 td3 td4
d6 d6 d7 d8 d9 e d1 d2 d3 d4 d5 td4 td5 td6 td7 td8 td9 t td1 td2 td3
d7 d7 d8 d9 e d1 d2 d3 d4 d5 d6 td3 td4 td5 td6 td7 td8 td9 t td1 td2
d8 d8 d9 e d1 d2 d3 d4 d5 d6 d7 td2 td3 td4 td5 td6 td7 td8 td9 t td1
d9 d9 e d1 d2 d3 d4 d5 d6 d7 d8 td1 td2 td3 td4 td5 td6 td7 td8 td9 t
t t td1 td2 td3 td4 td5 td6 td7 td8 td9 e d1 d2 d3 d4 d5 d6 d7 d8 d9
td1 td1 td2 td3 td4 td5 td6 td7 td8 td9 t d9 e d1 d2 d3 d4 d5 d6 d7 d8
td2 td2 td3 td4 td5 td6 td7 td8 td9 t td1 d8 d9 e d1 d2 d3 d4 d5 d6 d7
td3 td3 td4 td5 td6 td7 td8 td9 t td1 td2 d7 d8 d9 e d1 d2 d3 d4 d5 d6
td4 td4 td5 td6 td7 td8 td9 t td1 td2 td3 d6 d7 d8 d9 e d1 d2 d3 d4 d5
td5 td5 td6 td7 td8 td9 t td1 td2 td3 td4 d5 d6 d7 d8 d9 e d1 d2 d3 d4
td6 td6 td7 td8 td9 t td1 td2 td3 td4 td5 d4 d5 d6 d7 d8 d9 e d1 d2 d3
td7 td7 td8 td9 t td1 td2 td3 td4 td5 td6 d3 d4 d5 d6 d7 d8 d9 e d1 d2
td8 td8 td9 t td1 td2 td3 td4 td5 td6 td7 d2 d3 d4 d5 d6 d7 d8 d9 e d1
td9 td9 t td1 td2 td3 td4 td5 td6 td7 td8 d1 d2 d3 d4 d5 d6 d7 d8 d9 e
a=t(combn(1:12,3))
RES=numeric(nrow(a))
for(ii in 1:nrow(a)){
H=list(G[[a[ii,1]]],G[[a[ii,2]]],G[[a[ii,3]]])
# names(H)=names(G[c(a[ii,1],a[ii,2],a[ii,3])])
M=matrix(NA,length(H),length(G))
for(i in 1:length(H)){
for(j in 1:length(G)){
M[i,j] = g12(G[[j]],H[[i]])
}
}
#colnames(M)=paste0(names(G),'*')
#rownames(M)=names(H)
#print(M,quote=FALSE)
re=matrix(NA,nrow(M),ncol(M))
for(i1 in 1:ncol(M)){
re[,i1]=sort(M[,i1])
}
#print(re,quote=FALSE)
#print(unique(t(re)),quote=FALSE)
RES[ii] =nrow(unique(t(re)))
}
RES
idx=which(RES==4)
(b=a[idx,])
print(matrix(names[b],ncol=3),quote=FALSE)
[,1] [,2] [,3]
[1,] 1 3 5
[2,] 2 4 6
[3,] 7 9 11
[4,] 8 10 12
> print(matrix(names[b],ncol=3),quote=FALSE)
[,1] [,2] [,3]
[1,] e d2 d4
[2,] d1 d3 d5
[3,] t td2 td4
[4,] td1 td3 td5
n=9 ; m=3
tikan <- function(X,Y=.Y){ # e.g. c(1,2,3) -> .Y=c(2,1,3)
n=length(X)
Z=rep(NA,n)
I=1:n
for(i in 1:n){
j <- which(I==X[i])
Z[i] <- Y[j]
}
return(Z)
}
tikan2 <- function(X,Y){ # replace Y first then X
n=length(X)
Z=rep(NA,n)
I=1:n
for(i in 1:n){
j <- which(I==X[i])
Z[i] <- Y[j]
}
return(Z)
}
f1 <- function(x,L){
re=NULL
for(i in 1:length(L)){
if(equal(L[[i]],x)) return(names(L)[i]) # i for names[i]
}
}
a=t(combn(1:(2*n),m))
RES=numeric(nrow(a))
for(ii in 1:nrow(a)){
H=list() # H=list(G[[a[ii,1]]],G[[a[ii,2]]],G[[a[ii,3]]])
for(jj in 1:m){
H[[jj]]=G[[a[ii,jj]]]
}
M=matrix(NA,m,2*n)
for(i in 1:m){
for(j in 1:(2*n)){
M[i,j] = g12(G[[j]],H[[i]])
}
}
re=matrix(NA,m,2*n)
for(i1 in 1:(2*n)){
re[,i1]=sort(M[,i1])
}
RES[ii] =nrow(unique(t(re)))
}
idx=which(RES==(2*n/m)) # Lagrangea's theorem
(b=a[idx,])
print(matrix(names[b],ncol=m),quote=FALSE)
[,1] [,2] [,3]
[1,] 1 4 7
[2,] 2 5 8
[3,] 3 6 9
[4,] 10 13 16
[5,] 11 14 17
[6,] 12 15 18
> print(matrix(names[b],ncol=m),quote=FALSE)
[,1] [,2] [,3]
[1,] e d3 d6
[2,] d1 d4 d7
[3,] d2 d5 d8
[4,] t td3 td6
[5,] td1 td4 td7
[6,] td2 td5 td8
# 御明算
(debugged)
a=t(combn(1:(2*n),m))
RES=numeric(nrow(a))
for(ii in 1:nrow(a)){
H=list() # H=list(G[[a[ii,1]]],G[[a[ii,2]]],G[[a[ii,3]]])
for(jj in 1:m){
H[[jj]]=G[[a[ii,jj]]]
}
M=matrix(NA,m,2*n)
for(i in 1:m){
for(j in 1:(2*n)){
M[i,j] = g12(G[[j]],H[[i]])
}
}
re=matrix(NA,m,2*n)
for(i1 in 1:(2*n)){
re[,i1]=sort(M[,i1])
}
RES[ii] =nrow(unique(t(re)))
}
idx=which(RES==(2*n/m)) # Lagrangea's theorem
b=a[idx,]
(B=b[b[,1]==1,])
print(matrix(names[B],ncol=m),quote=FALSE)
dihedral_group <- function(n=9,m=3){ # start
tikan <- function(X,Y=.Y){ # e.g. c(1,2,3) -> .Y=c(2,1,3)
n=length(X)
Z=rep(NA,n)
I=1:n
for(i in 1:n){
j <- which(I==X[i])
Z[i] <- Y[j]
}
return(Z)
}
tikan2 <- function(X,Y){ # replace Y first then X
n=length(X)
Z=rep(NA,n)
I=1:n
for(i in 1:n){
j <- which(I==X[i])
Z[i] <- Y[j]
}
return(Z)
}
f1 <- function(x,L){
re=NULL
for(i in 1:length(L)){
if(equal(L[[i]],x)) return(names(L)[i]) # i for names[i]
}
}
g12 <- function(x,y,L=G){
f1(tikan2(x,y),L)
}
equal <- function(x,y) sum((x-y)^2)==0
d1=c(n,1:(n-1)) # rotation
Mnd=matrix(NA,n,n)
Mnd[1,]=e
for(i0 in 1:(n-1)){
Mnd[i0+1,]=tikan(Mnd[i0,],d1)
}
rownames(Mnd)=c('e',paste0('d',1:(n-1)))
Mnd
t=n:1 ## mirror
tikan(t,d1) # D2n( e,d1,d2,d3,..,dn-1, t,td,td2,td3,...,tdn-1)
Mnt=matrix(NA,n,n)
Mnt[1,]=t
for(i2 in 1:(n-1)){
Mnt[i2+1,]=tikan(Mnt[i2,],d1)
}
Mnt
rownames(Mnt)=c('t',paste0('td',1:(n-1)))
Mn=rbind(Mnd,Mnt)
names=rownames(Mn)
Mn
.L=list(2*n) # list(Mn[1,],Mn[2,],...Mn[,n]) list(e,d1,d2,..,dn-1,t,td1,td2,..,tdn-1)
for(i3 in 1:(2*n)) .L[[i3]]=Mn[i3,]
names(.L)=names
G=.L
RES=numeric(nrow(a))
for(ii in 1:nrow(a)){
H=list() # H=list(G[[a[ii,1]]],G[[a[ii,2]]],G[[a[ii,3]]])
for(jj in 1:m){
H[[jj]]=G[[a[ii,jj]]]
}
M=matrix(NA,m,2*n)
for(i in 1:m){
for(j in 1:(2*n)){
M[i,j] = g12(G[[j]],H[[i]])
}
}
re=matrix(NA,m,2*n)
for(i1 in 1:(2*n)){
re[,i1]=sort(M[,i1])
}
RES[ii] =nrow(unique(t(re)))
}
RES
idx=which(RES==(2*n/m)) # Lagrangea's theorem
(b=a[idx,])
#b=as.matrix(b)
if(m==1||m==2*n){
B=1:m
}else{
B=b[b[,1]==1,]
}
matrix(names[B],ncol=m)
} # End of Function, dihedral_group
sub_group <- function(n){
N=2*n
xx=which(N%%(1:N)==0)
res=lapply(xx,function(x)dihedral_group(n,x))
names(res)=xx
.print(res)
}
$`1`
[,1]
[1,] e
$`2`
[,1] [,2]
[1,] e d3
[2,] e t
[3,] e td1
[4,] e td2
[5,] e td3
[6,] e td4
[7,] e td5
$`3`
[,1] [,2] [,3]
[1,] e d2 d4
$`4`
[,1] [,2] [,3] [,4]
[1,] e d3 t td3
[2,] e d3 td1 td4
[3,] e d3 td2 td5
$`6`
[,1] [,2] [,3] [,4] [,5] [,6]
[1,] e d1 d2 d3 d4 d5
[2,] e d2 d4 t td2 td4
[3,] e d2 d4 td1 td3 td5
$`12`
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12]
[1,] e d1 d2 d3 d4 d5 t td1 td2 td3 td4 td5
GCD <- function(x,y){
if(round(x)!=x | round(y)!=y) stop('Not integer')
if(!x&!y) return(NA)
a=max(c(abs(x),abs(y)))
b=min(c(abs(x),abs(y)))
if(!a*b) return(a)
r=integer()
r[1]=a
r[2]=b
i=1
r[i+2]=r[i]%%r[i+1]
while(r[i+2]!=0 & r[i+2]!=1){
i=i+1
r[i+2]=r[i]%%r[i+1]
}
return(ifelse(r[i+2]==0,r[i+1],1))
}
GCD(2.3,4)
GCD(0,0)
GCD(24,15)
GCD(16,15)
GCD(5,0)
GCD(24,-15)
GCD(-24,-15)
$`1`
[,1]
[1,] e
$`2`
[,1] [,2]
[1,] e t
[2,] e td1
[3,] e td2
[4,] e td3
[5,] e td4
[6,] e td5
[7,] e td6
[8,] e td7
[9,] e td8
$`3`
[,1] [,2] [,3]
[1,] e d3 d6
$`6`
[,1] [,2] [,3] [,4] [,5] [,6]
[1,] e d3 d6 t td3 td6
[2,] e d3 d6 td1 td4 td7
[3,] e d3 d6 td2 td5 td8
$`9`
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9]
[1,] e d1 d2 d3 d4 d5 d6 d7 d8
$`18`
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12] [,13] [,14] [,15]
[1,] e d1 d2 d3 d4 d5 d6 d7 d8 t td1 td2 td3 td4 td5
[,16] [,17] [,18]
[1,] td6 td7 td8
n=length(X)
Z=rep(NA,n)
I=1:n
for(i in 1:n){
j <- which(I==X[i])
Z[i] <- Y[j]
}
return(Z)
}
# Gを有限群とすると g∈G n=|G| （位数） g^n=e :単位元
n=length(G)
re=list()
for(i in 1:n){
tikan2(G[[i]],G[[i]])
for(j in 1:n) data[[j]]=G[[i]]
re[[i]]=Reduce(tikan2,data) # Reduce(function(x,y)x+y,c(1,2,3,4),accumulate = TRUE)
}
> re
[[1]]
[1] 1 2 3 4 5 6 7 8 9
[[2]]
[1] 1 2 3 4 5 6 7 8 9
......
[[17]]
[1] 1 2 3 4 5 6 7 8 9
[[18]]
[1] 1 2 3 4 5 6 7 8 9
[1] 1 3 6 10 15
> Reduce('+',c(1,2,3,4,5),accu=TRUE) ; cumsum(1:5)
[1] 1 3 6 10 15
[1] 1 3 6 10 15
> Reduce('*',c(1,2,3,4,5)) ; factorial(5)
[1] 120
[1] 120
> beki2 <- function(x,y,p,...){ #x^y%%p
+ if(y==0) return(1%%p)
+ data=rep(x,y)
+ Reduce(function(x,y) (x*y)%%p, data,...)
+ }
> beki2(2,10,10,accumulate=TRUE)
[1] 2 4 8 6 2 4 8 6 2 4
> beki2(2,100,10)
[1] 6
> beki2(2,0,10)
[1] 1
#
# a^(p-1)≡1 (mod p)
#
# Check if it works when p is lower than N.
N=100
(p100=(1:N)[!!gmp::isprime(1:N)] ) # primes < 100
m=length(p100)
cop=list()
for(i in 1:m){
p=p100[i]
cop[[i]]=(1:p)[gmp::gcd(1:p,p)==1] # disjoint,coprime to p100[i]
}
names(cop)=p100
cop
re=cop
for(i in 1:m){
p=p100[i]
for(j in 1:length(cop[[i]])){
re[[i]][j] = beki2(cop[[i]][j],p-1,p) # coprime^(p-1)%%p
}
}
re
> str(re)
List of 25
$ 2 : int 1
$ 3 : int [1:2] 1 1
...
$ 89: int [1:88] 1 1 1 1 1 1 1 1 1 1 ...
$ 97: int [1:96] 1 1 1 1 1 1 1 1 1 1 ...
フェルマーの定理
フェルマーも小定理の方ね
##
n=10
conf.level=0.95
PMF <- function(x) x^n # AUC==integrate(PMF,0,1) == 1/(n+1)
PDF <- function(x) (n+1)*x^n # PDF==PMF/AUC
Ex= (n+1)/(n+2) # integrate(x*PDF,0,1)==integrate((n+1)*x^(n+1),0,1)== (n+1)/(n+2)
CDF <- function(x) x^(n+1) # == integrate(PDF,0,x)
lwr = (1-conf.level)^(1/(n+1)) # CDF(lwr) == 1-conf.level
exp(log(1-conf.level)/(n+1))
curve(PDF)
curve(x*PDF(x))
integrate(function(x) x*PDF(x),0,1)$value
integrate(function(x) x*(n+1)*x^n,0,1)$value # integrate(function(x)(n+1)*x^(n+1),0,1)
(n+1)/(n+2)
# |((n+1)/(n+2))*x^(n+2)|[0,1]
## binomとの比較
binom::binom.confint(c(1,10,100),c(1,10,100),conf=0.95)
# n out of n
# mean=(n+1)/(n+2)
# lower=(n+1)√(1-conf.level) = 0.05^(1/(n+1))
non=function(n,conf.level=0.95){ # n hits out of n shoots
b=binom::binom.confint(n,n)[,c('method','mean','lower')]
n_1_root=function(n)(0.05)^(1/(n+1))
a=data.frame(method='root(n+1)',mean=(n+1)/(n+2),lower=(1-conf.level)^(1/(n+1)))
rbind(a,b)
}
> non(1)
method mean lower
1 root(n+1) 0.6666667 0.22360680
2 agresti-coull 1.0000000 0.16749949
3 asymptotic 1.0000000 1.00000000
4 bayes 0.7500000 0.22851981
5 cloglog 1.0000000 0.02500000
6 exact 1.0000000 0.02500000
7 logit 1.0000000 0.02500000
8 probit 1.0000000 0.02500000
9 profile 1.0000000 0.13811125
10 lrt 1.0000000 0.14650325
11 prop.test 1.0000000 0.05462076
12 wilson 1.0000000 0.20654931
method mean lower
1 root(n+1) 0.9166667 0.7615958
2 agresti-coull 1.0000000 0.6791127
3 asymptotic 1.0000000 1.0000000
4 bayes 0.9545455 0.8292269
5 cloglog 1.0000000 0.6915029
6 exact 1.0000000 0.6915029
7 logit 1.0000000 0.6915029
8 probit 1.0000000 0.6915029
9 profile 1.0000000 0.7303058
10 lrt 1.0000000 0.8252466
11 prop.test 1.0000000 0.6554628
12 wilson 1.0000000 0.7224672
> non(100)
method mean lower
1 root(n+1) 0.9901961 0.9707748
2 agresti-coull 1.0000000 0.9555879
3 asymptotic 1.0000000 1.0000000
4 bayes 0.9950495 0.9810231
5 cloglog 1.0000000 0.9637833
6 exact 1.0000000 0.9637833
7 logit 1.0000000 0.9637833
8 probit 1.0000000 0.9637833
9 profile 1.0000000 0.9670434
10 lrt 1.0000000 0.9809757
11 prop.test 1.0000000 0.9538987
12 wilson 1.0000000 0.9630065
n=10 の時のPDFと９５％CI下限値0.7615958
https://i.imgur.com/VrACoar.png
n=10 の時のPDFと９５％CI下限値0.7615958
http://i.imgur.com/VrACoar.png
Go13 <- function(.N, .n, r, k=10^3){ # k:シミュレーション回数
f <-function(S,N=.N,n=.n){
y=c(rep(1,S),rep(0,N-S))
sum(sample(y,n))
}
xx=r:.N
SS=NULL
for(i in 1:k){
x=sapply(xx,f)
SS=c(SS,which(x==r)-1+r)
}
print(summary(SS))
invisible(SS)
}
PMF <- function(x) choose(n,r)*x^r*(1-x)^(n-r)
AUC=integrate(PMF,0,1)$value
# library(hypergeo)
# f.auc <- function(x) choose(n,r)*x^(r+1)/(r+1)*hypergeo(r+1,r-n,r+2,x)
# auc=as.numeric(f.auｎc(1)-f.auc(0)) ; 1/auc
PDF <- function(x)PMF(x)/AUC
Ex=integrate(function(x)x*PDF(x),0,1)$value
mode=optimize(PDF,c(0,1),maximum = TRUE)$maximum
CDF <- function(x) integrate(PDF,0,x)$value
CDFu0 <- function(x,u0=.025) CDF(x)-u0
lwr=uniroot(CDFu0,u0=(1-cl)/2,c(0,1))$root
upr=uniroot(CDFu0,u0=1-(1-cl)/2,c(0,1))$root
print(c(lower=lwr,mode=mode,mean=Ex,upper=upr))
xx=seq(0,1,by=0.0001)
pp=sapply(xx,PDF)
yy=sample(xx,K,replace=TRUE,prob=pp)
if(Print){hist(yy,freq=FALSE,main='',xlab='Probability',
col=sample(colors(),1),breaks=30)
lines(density(yy),col='gray',lty=3)
curve(PDF,add=TRUE)}
print(quantile(yy,probs=c(.025,.05,.5,.95,.975)))
myy=mean(yy)
dens <- density(yy)
mdyy=dens$x[which.max(dens$y)]
print(c(mode=mdyy,mean=myy))
invisible(yy)
}
Dotsubo <- function(s=1,f=4,cl=0.95,K=10^6,Print=FALSE){
PMF <- function(p) choose(s+f-1,f)*(1-p)^f*p^s
AUC= (gamma(s+f)*gamma(s+1)) / (gamma(s)*gamma(f+s+2))
PDF <- function(p) (1-p)^f*p^s*gamma(f+s+2)/(gamma(f+1)*gamma(s+1))
curve(PDF)
Ex=integrate(function(x)x*PDF(x),0,1)$value
mode=optimize(PDF,c(0,1),maximum = TRUE)$maximum
CDF <- function(x) integrate(PDF,0,x)$value
CDFu0 <- function(x,u0=.025) CDF(x)-u0
lwr=uniroot(CDFu0,u0=(1-cl)/2,c(0,1))$root
upr=uniroot(CDFu0,u0=1-(1-cl)/2,c(0,1))$root
print(c(lower=lwr,mode=mode,mean=Ex,upper=upr))
xx=seq(0,1,by=0.0001)
pp=sapply(xx,PDF)
yy=sample(xx,K,replace=TRUE,prob=pp)
if(Print){hist(yy,freq=FALSE,main='',xlab='Probability',
col=sample(colors(),2),breaks=30)
lines(density(yy),col='gray',lty=3)
curve(PDF,add=TRUE)}
print(quantile(yy,probs=c(.025,.05,.5,.95,.975)))
myy=mean(yy)
dens <- density(yy)
mdyy=dens$x[which.max(dens$y)]
print(c(mode=mdyy,mean=myy))
invisible(yy)
}
ゴルゴ14は10発10中
ゴルゴ15は1発1中
とする。
各々10000発撃ったとき各ゴルゴの命中数の期待値はいくらか？
ドツボ13は100発0中
ドツボ14は10発0中
ドツボ15は1発0中
とする。
各々10000発撃ったときドツボの命中数の期待値はいくらか？
Golgo.sim <- function(N, n, r, k=10^3,Print=TRUE){ # k:シミュレーション回数
f <-function(S,.N=N,.n=n){ # 成績サンプル：命中S個、外れ(N-S)個
y=c(rep(1,S),rep(0,.N-S))
sum(sample(y,.n)) # その成績サンプルからｎ個数取り出したときの命中数
}
xx=r:N # ｒ未満ではｒ個命中することはないので除外
SS=NULL # 容れ子
for(i in 1:k){
x=sapply(xx,f) # 命中数の配列
SS=append(SS,which(x==r)-1+r) # 命中数がｒ個のときの成績サンプルの命中数Ｓの配列をつくる
}
print(summary(SS))
print(quantile(SS,probs=c(0.025,0.05,0.95,0.975)))
print(c(mode=names(which.max(table(SS)))),quote=FALSE)
if(Print) {
hist(SS,xlim=c(0,N),freq=FALSE,col=sample(colors(),1),main='',xlab='Hits')
lines(density(SS))}
invisible(SS)
}
Golgo <- function(n=3,r=1,cl=0.95,K=10^6,Print=FALSE){
PMF <- function(x) choose(n,r)*x^r*(1-x)^(n-r)
AUC=integrate(PMF,0,1)$value
# library(hypergeo)
# f.auc <- function(x) choose(n,r)*x^(r+1)/(r+1)*hypergeo(r+1,r-n,r+2,x)
# auc=as.numeric(f.auc(1)-f.auc(0))
PDF <- function(x)PMF(x)/AUC
Ex=integrate(function(x)x*PDF(x),0,1)$value
mode=optimize(PDF,c(0,1),maximum = TRUE)$maximum
CDF <- function(x) integrate(PDF,0,x)$value
CDFu0 <- function(x,u0=.025) CDF(x)-u0
lwr=uniroot(CDFu0,u0=(1-cl)/2,c(0,1))$root
upr=uniroot(CDFu0,u0=1-(1-cl)/2,c(0,1))$root
print(c(lower=lwr,mode=mode,mean=Ex,upper=upr))
xx=seq(0,1,by=0.0001)
pp=sapply(xx,PDF)
yy=sample(xx,K,replace=TRUE,prob=pp)
if(Print){hist(yy,freq=FALSE,main='',xlab='Probability',
col=sample(colors(),1),breaks=30)
lines(density(yy),col='gray',lty=3)
curve(PDF,add=TRUE)}
print(quantile(yy,probs=c(.025,.05,.5,.95,.975)))
myy=mean(yy)
dens <- density(yy)
mdyy=dens$x[which.max(dens$y)]
print(c(mode=mdyy,mean=myy))
invisible(yy)
}
int N;
int<lower=0,upper=1> Y[N];
}
parameters{
real<lower=0,upper=1> p;
}
model{
for(n in 1:N)
Y[n] ~ bernoulli(p);
}
data{// coin1.stan
int<lower=0,upper=1> Y;
}
parameters{
real<lower=0,upper=1> p;
}
model{
Y ~ bernoulli(p);
}
equal <- function(x,y) sum((x-y)^2)==0
tikan2 <- function(X,Y){ # replace Y first then X
n=length(X)
Z=rep(NA,n)
I=1:n
for(i in 1:n){
j <- which(I==X[i])
Z[i] <- Y[j]
}
return(Z)
}
f2 <- function(x,L=G){
re=NULL
for(i in 1:length(L)){
if(equal(L[[i]],x)) return(i) # i for names[i]
}
}
a =c(2,1,4,3)
b =c(3,4,1,2)
c =c(4,3,2,1)
e =c(1,2,3,4)
d =c(1,3,4,2)
t =c(1,2,4,3)
d2 =tikan2(d,d) # 1 4 2 3 # d3=tikan2(d2,d) == e
td =tikan2(t,d) # 1 3 2 4
td2=tikan2(td,d)
D3=list(e,d,d2,t,td,td2)
gr=expand.grid(V,D3)
.m=mapply(tikan2,gr[,1],gr[,2])
t.m=t(.m)
G=list()
for(i in 1:nrow(t.m)) G[[i]]=t.m[i,]
names(G)=paste0('t',1:length(G))
G # G: S(P6)
lG=length(G)
V
lV=length(V)
.M1=matrix(NA,nrow=lV,ncol=lG)
for (i in 1:lG){
for(j in 1:lV){
.M1[j,i]=f2(tikan2(G[[i]],V[[j]]))
}
}
.M2=matrix(NA,nrow=lV,ncol=lG)
for (i in 1:lG){
for(j in 1:lV){
.M2[j,i]=f2(tikan2(V[[j]],G[[i]]))
}
}
identical(apply(.M1,2,sort) ,apply(.M2,2,sort))
> identical(apply(.M1,2,sort) ,apply(.M2,2,sort))
[1] TRUE
equal <- function(x,y) sum((x-y)^2)==0 & length(x)==length(y)
tikan2 <- function(X,Y){ # replace Y first then X
n=length(X)
Z=rep(NA,n)
I=1:n
for(i in 1:n){
j <- which(I==X[i])
Z[i] <- Y[j]
}
return(Z)
}
witch <- function(x,L=G){
re=NULL
for(i in 1:length(L)){
if(equal(L[[i]],x)) return(i) # i for names[i]
}
}
tikan3 <- function(X,Y,L=G){ # replace Y first then X and return index of L
Z=tikan2(X,Y)
witch(Z,L)
}
product <- function(A,B,L=G){ # product of sets, retur index of L
la=length(A)
lb=length(B)
gr=expand.grid(1:la,1:lb)
f<-function(x,y) tikan3(A[[x]],B[[y]],L)
re=mapply(f,gr[,1],gr[,2])
return(sort(unique(re)))
}
e=1:n
d1=c(n,1:(n-1)) # rotation
Mnd=matrix(NA,n,n)
Mnd[1,]=e
for(i0 in 1:(n-1)){
Mnd[i0+1,]=tikan(Mnd[i0,],d1)
}
rownames(Mnd)=c('e',paste0('d',1:(n-1)))
Mnd
t=n:1 ## mirror
tikan(t,d1) # D2n( e,d1,d2,d3,..,dn-1, t,td,td2,td3,...,tdn-1)
Mnt=matrix(NA,n,n)
Mnt[1,]=t
for(i2 in 1:(n-1)){
Mnt[i2+1,]=tikan(Mnt[i2,],d1)
}
Mnt
rownames(Mnt)=c('t',paste0('td',1:(n-1)))
Mn=rbind(Mnd,Mnt)
names=rownames(Mn)
Mn
.L=list(2*n) # list(Mn[1,],Mn[2,],...Mn[,n]) list(e,d1,d2,..,dn-1,t,td1,td2,..,tdn-1)
for(i3 in 1:(2*n)) .L[[i3]]=Mn[i3,]
names(.L)=names
G=.L
return(G)
}
PDF=PMF/sum(PMF)
rsPDF=rev(sort(PDF))
min.density=rsPDF[min(which(cumsum(rsPDF)>=cl))]
index=which(PDF>=min.density)
data.frame(lower.idx=round(min(index)),upper.idx=round(max(index)),actual.CI=sum(PDF[index]))
}
Golgo2 <- function(n=3,r=1,cl=0.95,k=0.00001,Print=FALSE){
PMF <- function(x) choose(n,r)*x^r*(1-x)^(n-r)
xx=seq(0,1,by=k)
pmf=sapply(xx,PMF)
pdf=pmf/sum(pmf)
rspdf=rev(sort(pdf))
min.density=rspdf[min(which(cumsum(rspdf)>=cl))]
index=which(pdf>=min.density)
lower.idx=round(min(index))
upper.idx=round(max(index))
lower=xx[lower.idx]
upper=xx[upper.idx]
actual.CI=sum(pdf[index])
mpdf=sum(xx*pdf)
print(c(lower=lower,mean=mpdf,upper=upper,actual.CI=actual.CI),digits=5)
if(Print){plot(xx,pmf,lwd=1,xlab='probability of hit',
ylab=paste('probabilty of',r,'hits out of ',n,'shoots'))}
}
# ２年：進級失敗１６人、放校なし
# ３年：進級失敗３４人、うち放校９人
# ４年：進級失敗９人、うち放校２人
# ５年：進級失敗１０人、うち放校１人
# ６年：卒業失敗２６人、うち放校１人
# 一学年約120～130人前後。
#http://mao.2ch.net/test/read.cgi/doctor/1488993025/1
flunk=c(10,16,34,9,10,26)
expel=c(1,0,9,2,1,1)
n=125
total.fl=sum(flunk)
total.ex=sum(expel)
re=matrix(NA,6,1)
for(i in 1:6){
re[i,]=poisson.test(c(flunk[i],n) ,c(total.fl,n*6))$p.value
}
re
for(i in 1:6){
re[i,]=poisson.test(c(expel[i],n) ,c(total.ex,n*6))$p.value
}
re
prop.test(flunk,rep(n,6))
pairwise.prop.test(flunk,rep(n,6),'bon')
prop.test(expel,rep(n,6))
d=cbind(expel,rep(n,6)-expel) ; d
fisher.test(d)
pairwise.prop.test(expel,rep(n,6),'none')
pairwise.prop.test(expel,rep(n,6),'bon')
HDCI2 <- function(PMF,cl=0.95,k=0.0001,Print=TRUE){
xx=seq(0,1,by=k)
xx=xx[-1]
pmf=sapply(xx,PMF)
pdf=pmf/sum(pmf)
rspdf=rev(sort(pdf))
min.density=rspdf[min(which(cumsum(rspdf)>=cl))]
index=which(pdf>=min.density)
lower.idx=round(min(index))
upper.idx=round(max(index))
lower=xx[lower.idx]
upper=xx[upper.idx]
actual.CI=sum(pdf[index])
mpdf=sum(xx*pdf)
print(c(lower=lower,mean=mpdf,upper=upper,actual.CI=actual.CI),digits=4)
if(Print) plot(xx,pmf,xlab='prior',ylab='posterior')
}
HDCI2(function(x)dnbinom(5-1,1,x))
HDCI2 <- function(PMF,cl=0.95,k=0.0001,Print=FALSE){
pp=seq(0,1,by=k)
xx=pp[-1]
pmf=sapply(xx,PMF)
pdf=pmf/sum(pmf)
rspdf=rev(sort(pdf))
min.density=rspdf[min(which(cumsum(rspdf)>=cl))]
index=which(pdf>=min.density)
lower.idx=round(min(index))
upper.idx=round(max(index))
lower=xx[lower.idx]
upper=xx[upper.idx]
actual.CI=sum(pdf[index])
mpdf=sum(xx*pdf)
mode=xx[which.max(pmf)]
print(c(lower=lower,mode=mode,mean=mpdf,upper=upper,actual.CI=actual.CI),digits=4)
if(Print) plot(xx,pmf,xlab='prior',ylab='posterior')
}
Testing
Under NHST, sequential testing of data generated from the null
hypothesis will eventually lead to a false alarm. With infinite
patience, there is 100% probability of falsely rejecting the null.
This is known as “sampling to reach a foregone conclusion” (e.g.,
Anscombe, 1954). To illustrate this phenomenon, a computer
simulation generated random values from a normal distribution
with mean zero and standard deviation one, assigning each sequential
value alternately to one or the other of two groups, and at each
step conducting a two-group t test assuming the current sample
sizes were fixed in advance. Each simulated sequence began with
N1 N2 3. If at any step the t test indicated p .05, the
sequence was stopped and the total N ( N1 N2) was recorded.
Otherwise, another random value was sampled from the zero-mean
normal and included in the smaller group, and a new t test was
conducted. For purposes of illustration, each sequence was limited
to a maximum sample size of N 5,000. The simulation ran 1,000
sequences.
NHST <- function(N=5000){
x=rnorm(3)
y=rnorm(3)
while(length(x) < N & t.test(x,y,var.equal=TRUE)$p.value >= 0.05){
x=append(x,rnorm(1))
y=append(y,rnorm(1))
}
return(length(x))
}
res <- replicate(1000,NHST())
# Under NHST, sequential testing of data generated from the null
# hypothesis will eventually lead to a false alarm. With infinite
# patience, there is 100% probability of falsely rejecting the null.
# This is known as “sampling to reach a foregone conclusion” (e.g.,
# Anscombe, 1954). To illustrate this phenomenon, a computer
# a computer simulation generated random values from a normal distribution
# with mean zero and standard deviation one, assigning each sequential
# value alternately to one or the other of two groups, and at each
# step conducting a two-group t test assuming the current sample
# sizes were fixed in advance. Each simulated sequence began with
# N1=N2=3. If at any step the t test indicated p .05, the
# sequence was stopped and the total N (=N1+N2) was recorded.
NHST <- function(N){
x=rnorm(3)
y=rnorm(3)
while(length(x) < N & t.test(x,y,var.equal=TRUE)$p.value >= 0.05){
x=append(x,rnorm(1))
y=append(y,rnorm(1))
}
return(length(x))
}
FRR <- function(N,k=100){ #False Reject Rate
re <- replicate(k,NHST(N))
return(mean(re!=N)) # rate falsely rejected as significantly different
}
NN=c(10,20,40,80,160,320,640,1280,2560,5120,10240)
RjR=sapply(NN,FRR)
plot(NN,RjR,type='b')
# suffer a 100% false alarm rate in sequential testing. Instead, the
# false alarm rate asymptotes at a much lower level, depending on
# the choice of ROPE. For illustration, again a computer simulation
# generated random values from a normal distribution with mean of
# zero and standard deviation of one, assigning each sequential value
# alternately to one or the other of two groups but at each step
# conducting a Bayesian analysis and checking whether the 95%
# HDI completely excluded or was contained within a ROPE from 0.15 to 0.15
# ROPE* region of practical equivalence
librry(BEST)
BA <- function(N){
mc=BEST::BESTmcmc(rnorm(N),rnorm(N),numSavedSteps=1000, burnInSteps=500)
re=summary(mc,ROPEm=c(-0.15,15))
return(re[['muDiff','%InROPE']])
}
NN=c(10,20,40,80,160,320,640,1280,2560,5120)
inrope=sapply(NN,BA)
plot(NN,inrope,type='b',pch=19,xlab='N',ylab='% in ROPE')
http://www.sumsar.net/best_online/
トレースプロットがみられるのがうれしい。
https://www.amazon.co.jp/Intuitive-Biostatistics-Nonmathematical-Statistical-Thinking/dp/0190643560/ref=dp_ob_title_bk
ベイズ統計がどれくらい組み込まれたをみてから買うかな。
# Y1女子大生n1=100人とY2女子高生n2=100人の胸囲を測定して
# 前者が平均82 , 標準偏差3
# 後者が平均81 , 標準偏差3
# 有意差はあるか？
T.test=function(n1,n2,m1,m2,sd1,sd2){
SE12=sqrt((1/n1+1/n2)*((n1-1)*sd1^2+(n2-1)*sd2^2)/((n1-1)+(n2-1)))
T=(m1-m2)/SE12
2*pt(abs(T),n1-1+n2-1,lower.tail = FALSE)
}
T.test(100,100,82,81,3,3)
y1=82+scale(rnorm(100))*3
y2=81+scale(rnorm(100))*3
t.test(y1,y2,var.equal = TRUE)
library(BEST)
BESTout <- BESTmcmc(y1,y2)
plot(BESTout,ROPE=c(-2,2))
summary(BESTout,ROPEm=c(-2,2))
plotAll(BESTout,ROPEm=c(-2,2))
ProData <- makeData(mu1=82, sd1=3, mu2=81, sd2=3, nPerGrp=100,
pcntOut=10, sdOutMult=2.0, rnd.seed=NULL,showPlot=TRUE)
proMCMC <- BESTmcmc(proData$y1, proData$y2, numSavedSteps=2000)
N1plan <- N2plan <- 100
powerPro <- BESTpower(proMCMC, N1=N1plan, N2=N2plan,
ROPEm=c(-0.5,0.5), ROPEsd=c(-1,1), ROPEeff=c(-0.5,0.5),
maxHDIWm=5.0, maxHDIWsd=2.0, maxHDIWeff=1.0, nRep=5)
powerPro
pcntOut=10, sdOutMult=2.0, rnd.seed=NULL,showPlot=TRUE)
proMCMC <- BESTmcmc(proData$y1, proData$y2, numSavedSteps=2000)
N1plan <- N2plan <- 100
powerPro <- BESTpower(proMCMC, N1=N1plan, N2=N2plan,
ROPEm=c(-2,2), ROPEsd=c(-0,0), ROPEeff=c(-0,0),
maxHDIWm=5.0, maxHDIWsd=2.0, maxHDIWeff=1.0, nRep=1000)
powerPro
re=summary(BESTout,ROPEm=c(-x,x))
re[['muDiff','%InROPE']]
}
xx=seq(0,2.5,by=0.01)
InRope=sapply(xx,Jikkan)
plot(xx,InRope,type='l',lwd=2, xlab='Difference',ylab='% Practically Equivalent')
abline(h=95, lty=3)
(Diff=uniroot(function(x,u0=95) Jikkan(x)-u0, c(1.5,2))$root)
plot(BESTout,ROPE=c(-Diff,Diff))
http://i.imgur.com/mOlgEXG.png
library(BayesFactor)
tBF <- function(x,y){
t=t.test(x,y,var.equal = TRUE)$statistic
ttest.tstat(t,length(x),length(y),simple=TRUE)
}
NHST2 <- function(N){
x=rnorm(3)
y=rnorm(3)
while(length(x) < N & tBF(x,y) <= 1){
x=append(x,rnorm(1))
y=append(y,rnorm(1))
}
return(length(x))
}
FRR2 <- function(N,k=100){ #False Reject Rate
re <- replicate(k,NHST2(N))
return(mean(re!=N)) # rate falsely rejected as significantly different
}
> FRR2(10)
[1] 0.37
> FRR2(50)
[1] 0.46
> FRR2(100)
[1] 0.56
ベイズ因子をつかっても ｔ 検定を組み込むと
# NHST Has 100% False Alarm Rate in Sequential Testing (NHST : Null Hypothesis Significance Testing)
という結論は変わらないな。
Sequential Samplingに修正
library(BEST)
BA <- function(x,y){
mc=BEST::BESTmcmc(x,y,num=5000)
re=summary(mc,ROPEm=c(-0.1,0.1))
return(re[['muDiff','%InROPE']])
}
x=rnorm(3)
y=rnorm(3)
inROPE=numeric()
N=100
for(i in 1:(N-3)){
x=append(x,rnorm(1))
y=append(y,rnorm(1))
inROPE[i]=BA(x,y)
}
plot(3:N,inROPE,type='b',pch=19,xlab='n',ylab='% in ROPE')
n=1;r=1
f=function(p)choose(n,r)*p^r*(1-p)^(n-r)
AUC=integrate(f,0,1)$value
integrate(function(x) x*f(x)/AUC,0,1)$value
tBF2 <- function(x,y,...){
tt=t.test(x,y,var.equal = TRUE)
bf=ttest.tstat(tt$statistic,length(x),length(y),simple=TRUE,...)
p=tt$p.value
return(c(bf=1/bf,p=p))
}
N=10
BF=numeric()
p.value=numeric()
k=1000
for(i in 1:k){
x=rnorm(N) ; y=rnorm(N)
bfp=tBF2(x,y)
BF[i]=bfp[1]
p.value[i]=bfp[2]
}
.m=cbind(BF,p.value)
.m[which(p.value<0.05),]
mean(p.value<0.05)
.m[which(BF<1),]
mean(BF<1)
crooked <- function(n,r,H0=0.5,d=0.1,cl=0.95,Print=TRUE,...){
hdi=HDInterval::hdi(qbeta,cl,shape1=1+r,shape2=1+n-r)
if(Print){
ROPEl=H0*(1-d)
ROPEu=H0*(1+d)
curve(dbeta(x,1+r,1+n-r),lwd=1,xlab='p',ylab='density',...) # posterior
segments(ROPEl,0,ROPEu,lwd=5,col='navy')
segments(hdi[1],0,hdi[1],dbeta(hdi[1],1+r,1+n-r),col='blue')
segments(hdi[2],0,hdi[2],dbeta(hdi[2],1+r,1+n-r),col='blue')
legend('topleft',bty='n',legend=c('Range of Practival Equivalence',
'High Density Interval'),lwd=c(5,1),col=c('navy','blue'))
}
return(hdi)
}
> crooked(3000,490,H0=1/6,xlim=c(0.1,0.3))
lower upper
0.1503971 0.1768440
crooked <- function(n,r,H0=0.5,d=0.1,credMass=0.95,Print=TRUE,...){
hdi=HDInterval::hdi(qbeta,credMass,shape1=1+r,shape2=1+n-r)
if(Print){
ROPEl=H0*(1-d)
ROPEu=H0*(1+d)
curve(dbeta(x,1+r,1+n-r),lwd=1,xlab='p',ylab='density',...) # posterior
segments(ROPEl,0,ROPEu,lwd=5,col='navy')
segments(hdi[1],0,hdi[1],dbeta(hdi[1],1+r,1+n-r),col='blue')
segments(hdi[2],0,hdi[2],dbeta(hdi[2],1+r,1+n-r),col='blue')
legend('topleft',bty='n',legend=c('Range of Practival Equivalence',
paste0(credMass/0.01,'% High Density Interval')),lwd=c(5,1),col=c('navy','blue'))
}
return(hdi)
}
crooked(3000,490,H0=1/6,xlim=c(0.12,0.20))
int N;
int<lower=0,upper=1> Y[N];
real b; // border
}
parameters{
real<lower=0,upper=1> p;
}
transformed parameters{
real ura = step(b-p); // ifelse(b-p>0,1,0)
}
model{
for(n in 1:N)
Y[n] ~ bernoulli(p);
}
r=5
Y=c(rep(1,r),rep(0,N-r))
b=0.6
data <- list(Y=Y, N=N,b=b)
model.coin5d <- stan_model('coin5d.stan')
fit.coin5 <- sampling(model.coin5d, data=data, seed=123)
print(fit.coin5,digits=4)
Inference for Stan model: coin5d.
4 chains, each with iter=2000; warmup=1000; thin=1;
post-warmup draws per chain=1000, total post-warmup draws=4000.
mean se_mean sd 2.5% 25% 50% 75% 97.5% n_eff Rhat
p 0.4977 0.0035 0.1410 0.2286 0.3988 0.4966 0.5976 0.7744 1620 1.0036
ura 0.7552 0.0098 0.4300 0.0000 1.0000 1.0000 1.0000 1.0000 1933 1.0007
lp__ -8.8598 0.0234 0.7805 -11.0878 -9.0348 -8.5596 -8.3753 -8.3186 1116 1.0027
# NHST : Null Hypothesis Significance Testing
# Under NHST, sequential testing of data generated from the null
# hypothesis will eventually lead to a false alarm. With infinite
# patience, there is 100% probability of falsely rejecting the null.
# This is known as “sampling to reach a foregone conclusion” (e.g.,
# Anscombe, 1954). To illustrate this phenomenon,
# a computer simulation generated random values from a normal distribution
# with mean zero and standard deviation one, assigning each sequential
# value alternately to one or the other of two groups, and at each
# step conducting a two-group t test assuming the current sample
# sizes were fixed in advance. Each simulated sequence began with
# N1=N2=3. If at any step the t test indicated p < .05, the
# sequence was stopped and the total N (=N1+N2) was recorded.
FUN = perm::permTS
FUN = lawstat::brunner.munzel.test
NHST <- function(N){
x=rnorm(3)
y=rnorm(3)
while(length(x) < N & FUN(x,y)$p.value >= 0.05){
x=append(x,rnorm(1))
y=append(y,rnorm(1))
}
return(length(x))
}
NHST(100)
FRR <- function(N,k=100){ #False Reject Rate
re <- replicate(k,NHST(N))
return(mean(re!=N)) # rate falsely rejected as significantly different
}
FRR(10)
FRR(50)
FRR(100)
FRR(500)
n=10 ; mean(replicate(k,FUN(rnorm(n),rnorm(n))$p.value) < 0.05)
n=50 ; mean(replicate(k,FUN(rnorm(n),rnorm(n))$p.value) < 0.05)
n=100 ; mean(replicate(k,FUN(rnorm(n),rnorm(n))$p.value) < 0.05)
n=500 ; mean(replicate(k,FUN(rnorm(n),rnorm(n))$p.value) < 0.05)
source('https://github.com/boboppie/kruschke-doing_bayesian_data_analysis/blob/master/2e/DBDA2E-utilities.R')
a=1;b=1
N=21
z=21
pp=seq(0,1,by=0.001)
likelihood=pp^z*(1-pp)^(N-z)
prior=dbeta(pp,a,b)
posterior = BernGrid(pp,prior/sum(prior),c(rep(1,z),rep(0,N-z)), plotType="Bars" ,
showCentTend="Mean" , showHDI=TRUE , showpD=TRUE )
par(mfrow=c(2,2))
z=1 ; N=1
pp=seq(0,1,by=0.001)
prior=pmin(pp,1-pp) # a isosceles triangular distribution
plot(pp,prior,type='h',lwd=5,col='lightblue')
likelihood=pp^z*(1-pp)^(N-z)
plot(pp,likelihood,type='h',col='lightblue')
(pD=sum(prior*likelihood))
posterior=prior*likelihood/pD
plot(pp,posterior,type='h', col=' maroon')
z=21
N=21
y=c(rep(1,z),rep(0,N-z))
data=list(N=N,y=y)
modelString = "
model {
for (i in 1:N) {
y[i] ~ dbern(theta)
}
theta ~ dbeta(1,1)
}
"
writeLines( modelString , con="TEMPmodel.txt" )
jagsModel = jags.model( file="TEMPmodel.txt" , data=data , # inits=initsList ,
n.chains=3 , n.adapt=500 )
update( jagsModel , n.iter=500 )
codaSamples = coda.samples( jagsModel , variable.names=c("theta") ,
n.iter=3334 )
summary(codaSamples)
plot(codaSamples)
function( data , numSavedSteps=50000 , saveName=NULL, a=1,b=1) {
require(rjags)
y = data$y
s = as.numeric(data$s) # converts character to consecutive integer levels
# Do some checking that data make sense:
if ( any( y!=0 & y!=1 ) ) { stop("All y values must be 0 or 1.") }
Ntotal = length(y)
Nsubj = length(unique(s))
# Specify the data in a list, for later shipment to JAGS:
dataList = list(
y = y ,
s = s ,
Ntotal = Ntotal ,
Nsubj = Nsubj
)
#-----------------------------------------------------------------------------
# THE MODEL.
modelString = paste0("
model {
for ( i in 1:Ntotal ) {
y[i] ~ dbern( theta[s[i]] )
}
for ( sIdx in 1:Nsubj ) {
theta[sIdx] ~ dbeta(", a,',' , b," )
}
}
")
# close quote for modelString
writeLines( modelString , con="TEMPmodel.txt" )
# INTIALIZE THE CHAINS.
# Initial values of MCMC chains based on data:
# Option 1: Use single initial value for all chains:
# thetaInit = rep(0,Nsubj)
# for ( sIdx in 1:Nsubj ) { # for each subject
# includeRows = ( s == sIdx ) # identify rows of this subject
# yThisSubj = y[includeRows] # extract data of this subject
# thetaInit[sIdx] = sum(yThisSubj)/length(yThisSubj) # proportion
# }
# initsList = list( theta=thetaInit )
# Option 2: Use function that generates random values near MLE:
initsList = function() {
thetaInit = rep(0,Nsubj)
for ( sIdx in 1:Nsubj ) { # for each subject
includeRows = ( s == sIdx ) # identify rows of this subject
yThisSubj = y[includeRows] # extract data of this subject
resampledY = sample( yThisSubj , replace=TRUE ) # resample
thetaInit[sIdx] = sum(resampledY)/length(resampledY)
}
thetaInit = 0.001+0.998*thetaInit # keep away from 0,1
return( list( theta=thetaInit ) )
}
# RUN THE CHAINS
parameters = c( "theta") # The parameters to be monitored
adaptSteps = 500 # Number of steps to adapt the samplers
burnInSteps = 500 # Number of steps to burn-in the chains
nChains = 4 # nChains should be 2 or more for diagnostics
thinSteps = 1
nIter = ceiling( ( numSavedSteps * thinSteps ) / nChains )
# Create, initialize, and adapt the model:
jagsModel = jags.model( "TEMPmodel.txt" , data=dataList , inits=initsList ,
n.chains=nChains , n.adapt=adaptSteps )
# Burn-in:
cat( "Burning in the MCMC chain...\n" )
update( jagsModel , n.iter=burnInSteps )
# The saved MCMC chain:
cat( "Sampling final MCMC chain...\n" )
codaSamples = coda.samples( jagsModel , variable.names=parameters ,
n.iter=nIter , thin=thinSteps )
# resulting codaSamples object has these indices:
# codaSamples[[ chainIdx ]][ stepIdx , paramIdx ]
if ( !is.null(saveName) ) {
save( codaSamples , file=paste(saveName,"Mcmc.Rdata",sep="") )
}
return( codaSamples )
}
library("rstudioapi")
rstan_options(auto_write = TRUE)
options(mc.cores = parallel::detectCores())
G1314model='
data{// Golgo13.14.stan
int N13; // 100
int N14; //10
int<lower=0,upper=1> G13[N13];
int<lower=1,upper=2> G14[N14];
}
parameters{
real<lower=0,upper=1> p13;
real<lower=0,upper=1> p14;
}
model {
for(i in 1:N13) G13[i] ~ bernoulli(p13);
for(j in 1:N14) G14[j] ~ bernoulli(p14);
p13 ~ beta(1,1);
p14 ~ beta(1,1);
}
generated quantities{
real d = p13 - p14;
}
'
writeLines( G1314model , con='G1314.stan' )
N14=10
G13=rep(1,N13)
G14=rep(1,N14)
data=list(N13=N13,N14=N14,G13=G13,G14=G14)
G1314.model=stan_model('G1314.stan')
saveRDS(G1314.model,file='G1314.model.rds')
# G1314.model=readRDS('G1314.model.rds')
fitG1314 <- sampling(G1314.model, data=data, seed=1234)
fitG1314
stan_dens(fitG1314,separate_chains = TRUE)
i.imgur.com/aL2PSDM.png
mean se_mean sd 2.5% 25% 50% 75% 97.5% n_eff Rhat
p13 0.99 0.00 0.01 0.97 0.99 0.99 1.00 1.00 2500 1
p14 0.92 0.00 0.08 0.72 0.88 0.94 0.97 1.00 2834 1
d 0.07 0.00 0.08 -0.01 0.02 0.05 0.11 0.27 2837 1
lp__ -10.24 0.04 1.16 -13.44 -10.70 -9.88 -9.42 -9.09 979 1
> ms=rstan::extract(fitG1314)
> mean(ms$d<0)
[1] 0.09425
Let's MCMC with JAGS.
I set the ROPE ( Range of Practical Equivalence ) as -0.01 to 0.01
> smryMCMC( mcmcCoda2 , compVal=NULL ,ropeDiff = c(-0.01,0.01))
Mean Median Mode HDIlow HDIhigh CompVal PcntGtCompVal
Diff 0.07384483 0.05247579 0.01267166 -0.02478474 0.2345431 0 90.18
PcntLtROPE PcntInROPE PcntGtROPE
Diff 3.07 15.66 81.27
It'll be illustrated as follows.
http://i.imgur.com/JtNJnkH.png
They are about equal to the result with Stan.
> mean(d)
[1] 0.07288324
> median(d)
[1] 0.05019718
> MAP(d)[1]# mode
0.01531325
> HDInterval::hdi(d)
lower upper
-0.0242909 0.2395352
> mean(d>0) # PcntGtCompVal
[1] 0.90575
> mean(d < -0.01) # PcntLtROPE
[1] 0.03475
> mean(-0.01 < d & d < 0.01) PcntInROPE
[1] 0.15975
> mean(d>0.01) # PcntGtROPE
[1] 0.8055
http://i.imgur.com/p4G8Y4R.png
http://i.imgur.com/bQgD8xn.png
omega1=0.25
omega2=0.75
a1 = omega1*(K-2)+1
b1 = (1-omega1)*(K-2)+1
a2 = omega2*(K-2)+1
b2 = (1-omega2)*(K-2)+1
curve(dbeta(x,a1,b1))
curve(dbeta(x,a2,b2))
curve(dbeta(x,a1,b1)+dbeta(x,a2,b2))
pdf <- function(theta) (dbeta(theta,a1,b1)+dbeta(theta,a2,b2))/2
n=31
d=0.02
h=function(theta,omega){ # some omega must equal to omega1 or omega2
if(omega>=omega1-d & omega<=omega1+d){
a1 = omega*(K-2)+1
b1 = (1-omega)*(K-2)+1
return(dbeta(theta,a1,b1))
}
if(omega>=omega2-d & omega<=omega2+d){
a2 = omega*(K-2)+1
b2 = (1-omega)*(K-2)+1
return(dbeta(theta,a2,b2))
}
return(0)
}
for(i in 1:n){
for(j in 1:n){
prior[i,j]=h(theta[i],omega[j])
}
}
image(theta,omega,prior,col = heat.colors(12,0.5))
contour(theta,omega,prior,add=TRUE)
persp(theta,omega,prior,col='skyblue',theta = 30)
library(rgl)
persp3d(theta,omega,prior,col='skyblue')
s=6 ; f=3
h2=function(theta,omega) theta^s*(1-theta)^f
likelihood=outer(theta,omega,h2)
image(theta,omega,likelihood,col = terrain.colors(12,0.5))
contour(theta,omega,likelihood,add=TRUE)
persp(theta,omega,likelihood,col='wheat',theta = 30)
library(rgl)
persp3d(theta,omega,likelihood,col='wheat')
posterior=prior*likelihood
image(theta,omega,posterior,col = topo.colors(12,0.5))
contour(theta,omega,posterior,add=TRUE)
persp(theta,omega,posterior,col='maroon',theta = 30)
library(rgl)
persp3d(theta,omega,posterior,col='maroon')
高卒レベルの基礎学力テストをしたところ裏口入学は不合格率の最頻値が0.75、例外者のそれは0.25であった。
いずれの分布も形状母数和が12のベータ分布に従っていた。
ド底辺シリツ医大でテストしたところ6人が不合格、3人が合格であったとき、ド底辺シリツ医大の裏口入学者の割合を推測せよ。
omega2=0.75
K=12
modelString='
model {
f o r(ii n1 : N){
y[i] ~ dbern( theta )
}
theta ~ dbeta( omega[m]*(kappa-2)+1 , (1-omega[m])*(kappa-2)+1 )
omega[1] <-
omega1
omega[2] <- omega2
kappa <- K
m ~ dcat( mPriorProb[] )
mPriorProb[1] <- p
mPriorProb[2] <- 1 - p
p ~ dunif(0,1)
}
'
dataList=list(omega1=omega1,omega2=omega2,K=K)
writeLines( modelString , con="TEMPmodel.txt" )
jagsModel = jags.model( file="TEMPmodel.txt" , data=dataList)
update( jagsModel)
codaSamples = coda.samples( jagsModel , variable=c('omega','kappa','theta'), n.iter=10000)
summary(codaSamples)
plot(codaSamples)
y= c(1,1,1,1,1,1,0,0,0)
N=length(y)
omega1=0.25
omega2=0.75
K=12
modelString='
model {
for(i n1:N){
y[i] ~ dbern( theta )
}
theta ~ dbeta( omega[m]*(kappa-2)+1 , (1-omega[m])*(kappa-2)+1 )
omega[1] <- omega1
omega[2] <- omega2
kappa <- K
m ~ dcat(mPriorProb[] )
mPriorProb[1] <- p
mPriorProb[2] <- 1 - p
p ~ dunif(0,1)
}
'
dataList=list(y=y,N=N, omega1=omega1,omega2=omega2,K=K)
writeLines( modelString , con="TEMPmodel.txt" )
jagsModel = jags.model( file="TEMPmodel.txt" , data=dataList)
update( jagsModel)
codaSamples = coda.samples( jagsModel , variable=c('m,'theta'), n.iter=10000)
summary(codaSamples)
plot(codaSamples)
y= c(1,1,1,1,1,1,0,0,0)
N=length(y)
omega1=0.25
omega2=0.75
kappa1=12
kappa2=12
modelString='
model {
for (i in 1:N){
y[i] ~ dbern( theta )
}
theta <- equals(m,1)*theta1 + equals(m,2)*theta2
theta1 ~ dbeta( omega1*(kappa1-2)+1 , (1-omega1)*(kappa1-2)+1 )
theta2 ~ dbeta( omega2*(kappa2-2)+1 , (1-omega2)*(kappa2-2)+1 )
m ~ dcat( mPriorProb[] )
mPriorProb[1] <- p
mPriorProb[2] <- 1-p
p ~ dunif(0,1)
}
'
dataList=list(y=y,N=N, omega1=omega1,omega2=omega2, kappa1=kappa1, kappa2=kappa2)
writeLines( modelString , con="TEMPmodel.txt" )
jagsModel = jags.model( file="TEMPmodel.txt" , data=dataList)
update( jagsModel)
codaSamples = coda.samples( jagsModel , variable=c('m,'theta'), n.iter=10000)
summary(codaSamples)
plot(codaSamples)
Uraguchi: Buying the way to Do-Teihen, unfair matriculation
Wrong: Writing Wrong English
Square: fair matriculation
P(Square) = 1 - P(Uraguchi)
P(Wrong|Uraguchi) = 1
P(Wrong|Square)=0.001
P(Uraguchi) ~ dunif(0,1)
P(U|W)=1*P(U)/(1*P(U)+0.001*(1-P(U)))
modelString='
puw <- 1 * pu /(1 * pu + 0.001*(1-pu))
pu ~ dunif(0,1)
'
> js=as.matrix(codaSamples)
> boxplot(theta~m)
> tapply(theta,m,length)
1 2
8778 41222
> sum(m==2)/length(m)
[1] 0.82444
JmodelString='
model {
puw = 1 * pu /(1 * pu + 0.001*(1-pu))
pu ~ dunif(0,1)
}
'
writeLines( JmodelString , con="TEMPmodel.txt" )
jagsModel = jags.model( file="TEMPmodel.txt")
update( jagsModel)
codaSamples = coda.samples( jagsModel , variable=c('pu','puw'), n.iter=100000)
summary(codaSamples)
js=as.matrix(codaSamples)
hist(js[,'puw'],xlim=c(0.9,1),freq=FALSE,breaks=1000,col='red',
main='P(Uraguchi|Wrong_English)',xlab='Probability')
HDInterval::hdi(js[,'puw'])
modelString='
parameters{
real<lower=0,upper=1> pu;
}
transformed parameters{
real puw = 1 * pu /(1 * pu + 0.001*(1-pu));
}
model{
pu ~ uniform(0,1);
}
ura.model<-stan_model(model_code = modelString)
fit.ura <- rstan::sampling(ura.model,seed=123,iter=10000,warmup=5000)
print(fit.ura,digits=4)
ms=rstan::extract(fit.ura)
round(HDInterval::hdi(ms$puw),4)
高卒レベルの基礎学力テストをしたところ裏口入学は不合格率の最頻値が0.75、例外者のそれは0.25であった。
いずれの分布も形状母数和が12のベータ分布に従っていた。
あるド底辺シリツ医大でテストしたところ6人が不合格、3人が合格であったとき、このド底辺シリツ医大の裏口入学者の割合を推測せよ。
Suppose there are Uraguchi and non-Uraguchi(irregular) enrollees in the DoTeihen medical school,
they get the achievement test for high school students.
The failing rate of Uraguchi is known to distribute in β distributuion with its mode value ω = 0.75 and sum of shape parameters κ = 12.
The failing rate of irregulars is in β distribution with ω = 0.25 and κ = 12.
At a DoTeihen medical school, 9 alimni had the test, and 6 failed and 3 passed.
Infer the proportion of Uraguchi in this DoTeihen.
N=length(y)
omega1=0.75
omega2=0.25
kappa1=12
kappa2=12
modelString='
model {
for (i in 1:N){
y[i] ~ dbern( theta )
}
theta <- equals(m,1)*theta1 + equals(m,2)*theta2
theta1 ~ dbeta( omega1*(kappa1-2)+1 , (1-omega1)*(kappa1-2)+1 )
theta2 ~ dbeta( omega2*(kappa2-2)+1 , (1-omega2)*(kappa2-2)+1 )
m ~ dcat( mPriorProb[] )
mPriorProb[1] <- p
mPriorProb[2] <- 1-p
p ~ dunif(0,1)
}
'
dataList=list(y=y,N=N, omega1=omega1,omega2=omega2, kappa1=kappa1, kappa2=kappa2)
writeLines( modelString , con="TEMPmodel.txt" )
jagsModel = jags.model( file="TEMPmodel.txt" , data=dataList)
update( jagsModel)
codaSamples = coda.samples( jagsModel , variable=c('m','theta','theta1','theta2'), n.iter=50000)
summary(codaSamples)
js=as.matrix(codaSamples)
tapply(js[,'theta'],js[,'m'],length)
sum(js[,'m']==1)/nrow(js)
RandICDF <- function(ICDF,PDF,...){
U=runif(10000)
rand=ICDF(U,...)
hist(rand,freq=FALSE,breaks=30,
col=sample(colors(),2),main='')
curve(PDF(x,...),add=TRUE,lwd=2)
invisible(rand)
}
par(mfrow=c(2,2))
RandICDF(qnorm,dnorm)
RandICDF(qbeta,dbeta,shape1=3.5,shape2=8.5)
RandICDF(qbeta,dbeta,shape1=0.1,shape2=0.1)
RandICDF(qgamma,dgamma,shape=3,rate=1)
http://i.imgur.com/ci7kHBN.jpg
vonNeumann <- function(PDF,xmin=0,xmax=1){
N=10000
ymax=max(PDF(seq(xmin,xmax,length=N+1)))
Ux=runif(N,xmin,xmax)
Uy=runif(N,0,ymax)
Rand=Ux[which(Uy<=PDF(Ux))]
hist(Rand,xlim=c(xmin,xmax),freq=FALSE,breaks=30,col=sample(colors(),2),main='')
curve(PDF,add=TRUE,lwd=2)
invisible(Rand)
}
par(mfrow=c(2,2))
vonNeumann(function(x)dbeta(x,3.5,8.5))
vonNeumann(function(x)dgamma(x,3,1),0,10)
vonNeumann(dnorm,xmin=-3,xmax=3)
p=runif(1)
f=function(x) p*dnorm(x,-3,1)+(1-p)*dnorm(x,3,3)
vonNeumann(f,xmin=-10,xmax=10)
http://i.imgur.com/fmC24HX.jpg
N shoots with z hits
Nz <- function(N,z,...){
curve(dbeta(x,1+z,1+N-z),xlab='Probability of Hit',
ylab=paste('Probabilty of',z,'Hits out of ',N,'Shoots'),...)
hdi=HDInterval::hdi(qbeta,shape1=1+z,shape2=1+N-z)
print(hdi,digits=4)
}
'model {
z ~ dbin(0.5,N)
N ~ dpois(lambda)
p=z/N
}
'
writeLines(modelString , con="TEMPmodel.txt" )
f <- function (lambda){
dataList=list(lambda=lambda)
jagsModel = jags.model( file="TEMPmodel.txt" , data=dataList)
update( jagsModel)
codaSamples = coda.samples( jagsModel , variable=c('p'), n.iter=10000)
js=as.matrix(codaSamples)
jsp=js[,'p']
mean(jsp<=7/24)
}
xx=7:50
yy=sapply(xx,f)
plot(xx,yy)
p=binom.test(7,24,alt='less')$p.value
1-(1-p)^2 # 0.06289339
z1=7
N1=24
N2=24
plot(0:N1/N1,dbinom(0:N1,N1,0.5),type='h',lwd=5,col='skyblue',ann=FALSE,ylim=c(0,0.25))
points(z1/N1,0,pch='+',cex=2)
binom.test(z1,N1,alt='less')$p.value
0:N1/N1 < z1/N1
sum(0:N1/N1 <= z1/N1) # 8個0:7
sum(dbinom(0:z1,N1,0.5))
# A∪B == A + B - A∩B 0.06289339
sum(dbinom(0:7,N1,0.5))+sum(dbinom(0:7,N2,0.5)) -sum(outer(dbinom(0:7,N1,0.5),dbinom(0:7,N2,0.5),'*'))
z1=7
N1=24
N2=12
plot(0:N2/N2,dbinom(0:N2,N2,0.5),type='h',lwd=5,col='wheat',ann=FALSE)
lines(0:N1/N1+0.05,dbinom(0:N1,N1,0.5),type='h',lwd=5,col='skyblue',ann=FALSE,ylim=c(0,0.25))
points(z1/N1,0,pch='+',cex=2)
0:N2/N2 < z1/N1
sum(0:N2/N2 <= z1/N1) # 4個0:3
# A∪B == A + B - A∩B 0.1026226
sum(dbinom(0:7,N1,0.5))+sum(dbinom(0:3,N2,0.5)) - sum(outer(dbinom(0:z1,N1,0.5),dbinom(0:3,N2,0.5)))
pdf2hdi <- function(pdf,xMIN=0,xMAX=1,cred=0.95,Print=FALSE){
nxx=1001
xx=seq(xMIN,xMAX,length=nxx)
xx=xx[-nxx]
xx=xx[-1]
xmin=xx[1]
xmax=xx[nxx-2]
AUC=integrate(pdf,xmin,xmax)$value
cdf <- function(x) integrate(pdf,xmin,x)$value/AUC
ICDF <- function(x) uniroot(function(y) cdf(y)-x,c(xmin,xmax))$root
hdi=HDInterval::hdi(ICDF,credMass=cred)
print(c(hdi[1],hdi[2]))
if(Print){
pp=seq(0,1,length=nxx)
plot(pp,sapply(pp,ICDF),type='l',lwd=2,xlab='p',ylab='x')
legend('top',bty='n',legend=paste('HDI:',round(hdi,3)))
}
invisible(ICDF)
}
pdf2hdi(function(x)dbeta(x,0.001,0.001)*x^7*(1-x)^17)
pdf2hdi(dnorm,-10,10,cre=0.95)
nxx=1001
xx=seq(xMIN,xMAX,length=nxx)
xx=xx[-nxx]
xx=xx[-1]
xmin=xx[1]
xmax=xx[nxx-2]
AUC=integrate(pdf,xmin,xmax)$value
PDF=function(x)pdf(x)/AUC
cdf <- function(x) integrate(PDF,xmin,x)$value
ICDF <- function(x) uniroot(function(y) cdf(y)-x,c(xmin,xmax))$root
hdi=HDInterval::hdi(ICDF,credMass=cred)
print(c(hdi[1],hdi[2]),digits=4)
if(Print){
par(mfrow=c(3,1))
plot(xx,sapply(xx,PDF),main='pdf',type='l',lwd=2,xlab='x',ylab='Density')
legend('top',bty='n',legend=paste('HDI:',round(hdi,3)))
plot(xx,sapply(xx,cdf),main='cdf',type='l',lwd=2,xlab='x',ylab='Probability')
pp=seq(0,1,length=nxx)
pp=pp[-nxx]
pp=pp[-1]
plot(pp,sapply(pp,ICDF),type='l',lwd=2,xlab='p',ylab='x',main='ICDF')
par(mfrow=c(1,1))
}
invisible(ICDF)
}
nxx=1001
xx=seq(xMIN,xMAX,length=nxx)
xx=xx[-nxx]
xx=xx[-1]
xmin=xx[1]
xmax=xx[nxx-2]
AUC=integrate(pdf,xmin,xmax)$value
PDF=function(x)pdf(x)/AUC
cdf <- function(x) integrate(PDF,xmin,x)$value
ICDF <- function(x) uniroot(function(y) cdf(y)-x,c(xmin,xmax))$root
hdi=HDInterval::hdi(ICDF,credMass=cred)
print(c(hdi[1],hdi[2]),digits=5)
if(Print){
par(mfrow=c(3,1))
plot(xx,sapply(xx,PDF),main='pdf',type='h',xlab='x',ylab='Density',col='lightgreen')
legend('top',bty='n',legend=paste('HDI:',round(hdi,3)))
plot(xx,sapply(xx,cdf),main='cdf',type='h',xlab='x',ylab='Probability',col='lightblue')
pp=seq(0,1,length=nxx)
pp=pp[-nxx]
pp=pp[-1]
plot(pp,sapply(pp,ICDF),type='l',xlab='p',ylab='x',main='ICDF')
par(mfrow=c(1,1))
}
invisible(ICDF)
}
Let's assume there are 120 students in one class and the number of flunker is distributed as poisson distribution.
In what range will students are expected to flunk next year? Calculate the number with 99% confidence interval.
pdf2hdi <- function(pdf,xMIN=0,xMAX=1,cred=0.95,Print=TRUE,FUN=FALSE){
nxx=1001
xx=seq(xMIN,xMAX,length=nxx)
xx=xx[-nxx]
xx=xx[-1]
xmin=xx[1]
xmax=xx[nxx-2]
AUC=integrate(pdf,xmin,xmax)$value
PDF=function(x)pdf(x)/AUC
cdf <- function(x) integrate(PDF,xmin,x)$value
ICDF <- function(x) uniroot(function(y) cdf(y)-x,c(xmin,xmax))$root
hdi=HDInterval::hdi(ICDF,credMass=cred)
print(c(hdi[1],hdi[2]),digits=5)
if(Print){
par(mfrow=c(3,1))
plot(xx,sapply(xx,PDF),main='pdf',type='h',xlab='x',ylab='Density',col='lightgreen')
legend('top',bty='n',legend=paste('HDI:',round(hdi,3)))
plot(xx,sapply(xx,cdf),main='cdf',type='h',xlab='x',ylab='Probability',col='lightblue')
pp=seq(0,1,length=nxx)
pp=pp[-nxx]
pp=pp[-1]
plot(pp,sapply(pp,ICDF),type='l',xlab='p',ylab='x',main='ICDF')
par(mfrow=c(1,1))
}
if(FUN) invisible(ICDF)
invisible(hdi)
}
m<-a/(a+b)
v<-m*(1-m)/(a+b+1)
mv<-c(m,v)
return(mv)
}
mv2ab<-function(m,v){
a=(-m^3+m^2-m*v)/v
b=(m^3-2*m^2+m*v+m-v)/v
ab<-c(a,b)
return(ab)
}
HDCI <- function(PMF,cl=0.95){ # Highest Density Confidence Interval
PDF=PMF/sum(PMF)
rsPDF=rev(sort(PDF))
min.density=rsPDF[min(which(cumsum(rsPDF)>=cl))]
index=which(PDF>=min.density)
data.frame(lower.idx=round(min(index)),upper.idx=round(max(index)),actual.CI=sum(PDF[index]))
}
m=50;s=10
rn=rnorm(1000,m,s)
mean(rn)
sd(rn)
y=Scale(rn)*s+m
mean(y)
sd(y)
theta=0.5
NN=1000
N=1:NN
flip=numeric()
for(i in N){
flip=append(flip,rbinom(1,1,theta))
}
z=cumsum(flip)
z_N=z/N
plot(z_N,type='l',ylim=c(0,1))
pv=numeric()
for(i in N){
pv[i]=binom.test(z[i],N[i],theta)$p.value
}
plot(pv,type='l')
abline(h=0.05,col='blue',ylim=c(0,1))
bf=numeric()
for(i in N){
bf[i]=beta(z[i]+1,N[i]-z[i]+1)/beta(1,1)/(theta^z[i]*(1-theta)^(N[i]-z[i]))
}
plot(log(bf),type='l')
abline(h=log(3),lty=3)
abline(h=log(1/3),lty=3)
for(i in N){
y=flip[1:i]
s=rep(1,i)
data=data.frame(y,s)
Ntotal=i
Nsubj=1
dataList=list(y=y,s=s,Ntotal=Ntotal,Nsubj=Nsubj)
js=genMCMC2(data)
hdi=rbind(hdi,HDIofMCMC(as.matrix(js)))
}
saveRDS(hdi,'hdi_sequential')
hdi=readRDS('hdi_sequential')
plot(hdi[,1],type='l',ylim=c(0,1),main='95% HDI')
lines(hdi[,2])
abline(h=0.5,col=4)
plot(apply(hdi,1,diff),type='l',main='HDI width')
source('DBDA2E-utilities.R')
Bern <- function(x) rbinom(1,1,x)
Metro <- function(
SD=0.02,
.z=14,
.N=20,
a=1,
b=1,
k=50000,
Print=TRUE){
theta=numeric()
theta[1]=0.01
likely <- function(x,z=.z,N=.N) x^z*(1-x)^(N-z)
for(i in 1:(k-1)){
delta=rnorm(1,0,SD)
theta_p=theta[i]+delta
p=min(1,likely(theta_p)*dbeta(theta_p,a,b)/
(likely(theta[i])*dbeta(theta[i],a,b)))
theta[i+1]=theta[i]+Bern(p)*delta
}
if(Print){
# plot(theta,1:k,type='l')
plotPost(theta,cenTend = 'mean',cex.lab = 1)
plot(theta[1:100],1:100,type='l',xlim=c(0,1))
plot(theta[(k-100):k],(k-100):k,type='l',xlim=c(0,1))}
invisible(theta)
}
graphics.off()
rm(list=ls())
zi=100; Ni=100; zj=10; Nj=10
(y=c(rep(1,zi),rep(0,Ni-zi),rep(1,zj),rep(0,Nj-zj)))
(s=as.numeric(factor(c(rep('D',Ni),rep('U',Nj)))))
myData=data.frame(y=y,s=s)
Ntotal = length(y)
Nsubj = length(unique(s))
dataList = list(
y = y ,
s = s ,
Ntotal = Ntotal ,
Nsubj = Nsubj
)
a=1 ; b=1 # prior : beta(a,b)
# JAGS model
modelString = paste0("
model {
for ( i in 1:Ntotal ) {
y[i] ~ dbern( theta[s[i]] )
}
for ( sIdx in 1:Nsubj ) {
theta[sIdx] ~ dbeta(", a,',' , b," )
}
}
")
# close modelString
jagsModel = jags.model( file="TEMPmodel.txt" , data=dataList)
#jags.model(file, data, inits,n.chains = 1, n.adapt=1000, quiet=FALSE)
update( jagsModel)
codaSamples = coda.samples( jagsModel , variable="theta", n.iter=10000 )
#coda.samples(model, variable.names, n.iter, thin = 1, na.rm=TRUE, ...)
summary(codaSamples)
plot(codaSamples,col=sample(colors()))
mcmcMat=as.matrix(codaSamples)
par(mfrow=c(2,2))
hist(mcmcMat[,1],freq=FALSE,xlim=c(0,1),
col=sample(colours(),1))
hist(mcmcMat[,1]-mcmcMat[,2],freq=FALSE,xlim=c(-1,1),
col=sample(colours(),1))
plot(mcmcMat[,1],mcmcMat[,2], col=rgb(0.01,0.01,0.3,0.25))
hist(mcmcMat[,2],freq=FALSE, xlim=c(0,1),
col=sample(colours(),1))
(myData=data.frame(y,s))
mcmcCoda = genMCMC2( data=myData , numSavedSteps=10000,a=1,b=1)
# mcmcCoda = genMCMC( data=myData , numSavedSteps=10000)
# genMCMC
# Display diagnostics of chain, for specified parameter:
source('Jags-Ydich-XnomSsubj-MbernBeta.R')
diagMCMC( mcmcCoda , parName="theta[1]" )
diagMCMC( mcmcCoda , parName="theta[2]" )
# Display numerical summary statistics of chain:
smryMCMC( mcmcCoda , compVal=NULL,ropeDiff = c(-0.025,0.025))
#function( codaSamples , compVal=NULL , rope=NULL , saveName=NULL )
summary(mcmcCoda)
# Display graphical posterior information:
plotMCMC( mcmcCoda , data=myData , compVal=NULL,ropeDiff = c(-0.025,0.025))
# function( codaSamples , data , compVal=NULL , rope=NULL ,
# saveName=NULL , showCurve=FALSE , saveType="jpg" )
plot(mcmcCoda)
plotMCMC2( mcmcCoda , data=myData , compVal=NULL, showCurve=FALSE,
.credMass = 0.95,ropeDiff = c(-0.025,0.025),cenTend='mean')
(summry=smryMCMC( mcmcCoda, compVal=NULL, ropeDiff = c(-0.025,0.025)))
print(summry[3,],digits=2)
prop.test(c(zi,zj),c(Ni,Nj))$p.value
fisher.test(matrix(c(zi,Ni-zi,zj,Nj-zj),2))$p.value
1/(1 + exp(-gain*(x-threshold)))
}
b2gt <- function(b0,b1,b2){
gain=sqrt(b1^2+b2^2)
threshold=-b0/gain
return(gain=gain,threshold=threshold)
}
but with the examples depicted in the textbook I have finally got understood.
This is it.
http://i.imgur.com/FEHRi9l.png
core portion of its code :
http://egg.2ch.net/test/read.cgi/hosp/1493809494/275
# p = logistic(z) = 1/(1+e^-z)
# 1-p = (1+e^-z)/(1+e^-z) - 1/(1+e^-z) = e^-z/(1+e^-z)
# p/(1-p) = 1 /e^-z = e^z
# logit(p) = log(p/(1-p))= log(e^z) = z
# logit(logistic(z)) = z
modelString = '
model {
for ( i in 1:Ntotal ) {
y[i] ~ dt( mu , 1/sigma^2 , nu )
}
mu ~ dnorm( meanY , 1/(100*sdY)^2 )
sigma ~ dunif( sdY/1000 , sdY*1000 )
nu ~ dexp(1/30.0)
}
'
writeLines(modelString , con="TEMPmodel.txt" )
jagsModel = jags.model( file="TEMPmodel.txt" , data=dataList)
update( jagsModel)
codaSamples = coda.samples( jagsModel , variable=c('sigma','mu','nu'), n.iter=10000)
plot(codaSamples,col=sample(colours(),1))
js=as.matrix(codaSamples)
head(js)
dt_ls <- function(x, df, mu, a) 1/a * dt((x - mu)/a, df)
pt_ls <- function(x, df, mu, a) pt((x - mu)/a, df)
qt_ls <- function(prob, df, mu, a) qt(prob, df)*a + mu
rt_ls <- function(n, df, mu, a) rt(n,df)*a + mu
par(mfrow=c(1,1))
hist(y,breaks=20,col='skyblue',freq=FALSE,xlim=c(30,220),main='')
N=63 #length(y)
for(i in sample(1:nrow(js),N)){
curve(dt_ls(x,js[i,'nu'],js[i,'mu'],js[i,'sigma']),add=TRUE,
lty=1,col=rgb(.01,.01,.01,.1))
}
s=sd*sqrt((nu-2)/nu)
dt((x - mu)/s, nu)/s
}
pT <- function(x, nu, mu, sd){
s=sd*sqrt((nu-2)/nu)
pt((x - mu)/a, nu)
}
qT <- function(prob, nu, mu, sd){
s=sd*sqrt((nu-2)/nu)
qt(prob, nu)*s + mu
}
rT <- function(n, nu, mu, sd){
s=sd*sqrt((nu-2)/nu)
rt(n,nu)*s + mu
}
女性 9.0％
男女計 18.2％
https://www.jti.co.jp/investors/library/press_releases/2017/0727_01.html
P(s)=.182
P(s|f)=.090
P(s|m)=.282
P(s)=P(s|f)P(f)+P(s|m)P(m)
P(m)=1-P(f)
から
P(f)=(P(s)-P(s|m))/(P(s|f)-P(s|m))
ベイズの公式
P(f|s)=P(s|f)P(f)/(P(s|m)P(m)+P(s|f)P(f))
P(s|m)P(m)+P(s|f)P(f)=P(s)
.090*(.182-.282)/(.090-.282)/0.182=0.2575549
# 患者が煙草を忘れて行ったとする。
# 忘れて行った人物が女性である確率を以下のデータから計算せよ。
#
# 喫煙率
# 男性 28.2％
# 女性 9.0％
# 男女計 18.2％
P(s|m) = 0.282
P(s|f) = 0.090
P(s) = P(s|m)P(m)+P(s|f)P(f)
= P(s|m)(1-P(f)) + P(s|f)P(f)
= 0.182
P(f) = (P(s) - P(s|m))/(P(s|f) - P(s|m))
= (0.182 - 0.282)/(0.090 - 0.282)
= 0.5208333
P(f|s) = P(s|f)P(f)/P(s)
= 0.090*0.5208333/0.182
= 0.2575549
#
LR = P(s|f)|P(s|m)=0.090/0.282=0.3191489
prior.odds(f)=P(f)/(1-P(f))=0.5208333/(1-0.5208333)=1.086956
post.odds(f|s)= prior.odds(f)*LH=1.086956*0.3191489=0.3469008
P(f|s)=post.odds(f|s)/(1+post.odds(f|s))=0.3469008/(1+0.3469008)
= 0.2575548
http://imagizer.imageshack.com/img923/2715/RosCsf.jpg
何度読んでも馬鹿すぎる。
男女別の割合と全体での割合から男女比が計算できるとも思わないとは。
なんでこんなのが大学に入れるわけよ？
裏口入学以外に説明がつく？
中学生でも解ける一次方程式の問題だろ。
それすらできない馬鹿が自信を持って発言。
>患者の男女比が必要なのもわからないのか？
だとさ。
http://imagizer.imageshack.com/img923/9687/zNivZW.jpg
0.2575549
と答を書いてやったら
>単位も書かずに答えだとか…
ド底辺シリツ医大では確率に単位があるらしいぞｗｗｗ
何でこんな馬鹿が大学に入れるわけ？
裏口入学以外に説明がつく？
http://imagizer.imageshack.com/img923/5683/vMw9nv.jpg
http://imagizer.imageshack.com/img923/2715/RosCsf.jpg
何度読んでも馬鹿すぎる。
男女別の割合と全体での割合から男女比が計算できるとも思わないとは。
なんでこんなのが大学に入れるわけよ？
裏口入学以外に説明がつく？
中学生でも解ける一次方程式の問題だろ。
シリツ医大には二次方程式が解けないやつがいると言ってた えなりかずき もビックリだろね。
それすらできない馬鹿が自信を持って発言。
>患者の男女比が必要なのもわからないのか？
だとさ。
http://imagizer.imageshack.com/img923/9687/zNivZW.jpg
求める確率を
0.2575549
と答を書いてやったら
>単位も書かずに答えだとか…
ド底辺シリツ医大では確率に単位があるらしいぞｗｗｗ
何でこんな馬鹿が大学に入れるわけ？
裏口入学以外に説明がつく？
http://imagizer.imageshack.com/img923/5683/vMw9nv.jpg
# 新薬が登場して3人に投与したところ治癒した人はいなかった。
# この新薬を継続して使う価値があるかどうか検討せよ。
別バージョン
# 巨乳女子大で25人に声をかけたら3人が誘いにのった。
# 桃尻女子大で3人に声をかけたら誰も誘いにのらなかった。
# どちらが口説きやすいか検討せよ。
JAGSでMCMCして治癒率の確率密度関数を描くとこうなる。
http://i.imgur.com/y49H5AK.png
治癒率差の不偏推定量は
> mean(dif)
[1] -0.05136971
54％が負
> c(mean(dif<0),mean(dif>0))
[1] 0.5395 0.4605
５％幅の違いは同等扱いにすると
> c(mean(dif<ROPE[1]),mean(ROPE[1]<dif & dif<ROPE[2]), mean(dif>ROPE[2]))
[1] 0.4834 0.1236 0.3930
と計算できる。
98％HDIは
> HDInterval::hdi(dif)
lower upper
-0.4247349 0.2535357
と０を挟む。
RのパッケージBESTを改造して、治癒率の差の関数密度をかくと
http://i.imgur.com/vdIj7ES.png
ゆえに新薬は無効とはいえないだけでなく、不偏推定量から従来薬を凌駕する可能性が54％ある。
# 新薬が登場して3人に投与したところ治癒した人はいなかった。
# この新薬を継続して使う価値があるかどうか検討せよ。
別バージョン
# 巨乳女子大で25人に声をかけたら3人が誘いにのった。
# 桃尻女子大で3人に声をかけたら誰も誘いにのらなかった。
# どちらが口説きやすいか検討せよ。
JAGSでMCMCして治癒率の確率密度関数を描くとこうなる。
http://i.imgur.com/y49H5AK.png
治癒率差の不偏推定量は
> mean(dif)
[1] -0.05136971
54％が負
> c(mean(dif<0),mean(dif>0))
[1] 0.5395 0.4605
５％幅の違いは同等扱いにすると
> c(mean(dif<ROPE[1]),mean(ROPE[1]<dif & dif<ROPE[2]), mean(dif>ROPE[2]))
[1] 0.4834 0.1236 0.3930
と計算できる。
98％HDIは
> HDInterval::hdi(dif)
lower upper
-0.4247349 0.2535357
と０を挟む。
RのパッケージBESTを改造して、治癒率の差の確率密度をかくと
http://i.imgur.com/vdIj7ES.png
ゆえに新薬は無効とはいえないだけでなく、不偏推定量から従来薬を凌駕する可能性が54％ある。
# 新薬が登場して3人に投与したところ治癒した人はいなかった。
# この新薬を継続して使う価値があるかどうか検討せよ。
別バージョン
# 巨乳女子大で25人に声をかけたら3人が誘いにのった。
# 桃尻女子大で3人に声をかけたら誰も誘いにのらなかった。
# どちらが口説きやすいか検討せよ。
JAGSでMCMCして治癒率の確率密度関数を描くとこうなる。
http://i.imgur.com/y49H5AK.png
治癒率差の不偏推定量は
> mean(dif)
[1] -0.05136971
54％が負
> c(mean(dif<0),mean(dif>0))
[1] 0.5395 0.4605
５％幅の違いは同等扱いにすると
> c(mean(dif<ROPE[1]),mean(ROPE[1]<dif & dif<ROPE[2]), mean(dif>ROPE[2]))
[1] 0.4834 0.1236 0.3930
と計算できる。
95％HDIは
> HDInterval::hdi(dif)
lower upper
-0.4247349 0.2535357
と０を挟む。
RのパッケージBESTを改造して、治癒率の差の確率密度分布をかくと
http://i.imgur.com/vdIj7ES.png
ゆえに新薬は無効とはいえないだけでなく、不偏推定量から従来薬を凌駕する可能性が54％ある。
A careful analyst considers credible slopes across a variety of values for the other predictors.
Notice that this is true even though the interaction coefficient did not exclude zero from its 95% HDI.
In other words, if you include an interaction term, you cannot ignore it even if its marginal posterior distribution includes zero.
rn=rbinom(N,1,p)
count=0
for(i in 1:N){
if(rn[i] & count<n){
count=count+1
}
else{
if(count==n) {return(TRUE)}
else{
count=0
}
}
}
return(count==n)
}
mean(replicate(10^5,seqn()))
f <- function(n) mean(replicate(10^4,seqn(n)))
nn=2:20
yy=sapply(nn,f)
plot(nn,yy,pch=19,xlab='sequential heads',ylab='Proportion')
abline(h=0.05,lty=3)
f(9)
f(10)
Mv2sr <- function(M,v){
shape=(M^2 +2*v+sqrt(M^2*(M^2+4*v)))/(2*v)
rate= (M^2+ sqrt(M^2*(M^2+4*v)))/(2*M*v)
c(shape=shape,rate=rate)
}
Mv2sr(1,1)
sr2mMv <- function(shape,rate){
c(mean=shape/rate,mode=(shape-1)/rate,var=shape/(rate^2))
}
sr2mMv(2.618,1.618)
mv2sr <- function(mean,var){
rate=mean/var
shape=mean*rate
c(shape=shape,rate=rate)
}
mv2sr(1.618,1)
re=i+0:(k-1)
re=re%%n
re[which(re==0)]=n
return(re)
}
g <- function(x) (x+1)%%2
h <- function(i,b){
idx=f(i)
b[idx]=g(b[idx])
return(b)
}
i <- function(v){
tmp=a
for(w in v){
tmp=h(w,tmp)
}
return(tmp)
}
k=3
a=rep(0,7) #7枚全部裏のとき
f <- function(i){
re=i+0:(k-1)
re=re%%n
re[which(re==0)]=n
return(re)
}
g <- function(x) (x+1)%%2
h <- function(i,b){
idx=f(i)
b[idx]=g(b[idx])
return(b)
}
i <- function(v){
tmp=a
for(w in v){
tmp=h(w,tmp)
}
return(tmp)
}
sc6p=numeric(nrow(sc6))
for(j in 1:nrow(sc6)){
sc6p[j]=prod(i(sc6[j,]))
}
any(sc6p==1) #6回でも無理
sc7=t(combn(n,7))
sc7p=numeric(nrow(sc7))
for(j in 1:nrow(sc7)){
sc7p[j]=prod(i(sc7[j,]))
}
any(sc7p==1) # TRUE! 7回で全部表にできる
sc7[which(sc7p==1),]
実行してみる(0:裏 1:表)
0000000
1110000
1001000
1010100
1011010
1011101
0011110
1111111
> tapply(Y,Group,mean)
A B C D
97 99 102 104
> tapply(Y,Group,sd)
A B C D
8 1 1 8
http://i.imgur.com/B8rAPCh.png
http://i.imgur.com/eB3P8D4.png
> kruskal.test(Y~Group)
Kruskal-Wallis rank sum test
data: Y by Group
Kruskal-Wallis chi-squared = 25.325, df = 3, p-value = 0.0000132
> pairwise.t.test(Y,Group,p.adjust.method = 'holm', pool.sd = FALSE)
Pairwise comparisons using t tests with non-pooled SD
data: Y and Group
A B C
B 0.472 - -
C 0.023 0.00000000000071 -
D 0.020 0.023 0.472
P value adjustment method: holm
Pairwise comparisons using t tests with non-pooled SD
data: Y and Group
A B C
B 1.000 - -
C 0.034 0.00000000000071 -
D 0.024 0.034 1.000
P value adjustment method: bonferroni
> pairwise.t.test(Y,Group,p.adjust.method = 'fdr', pool.sd = FALSE)
Pairwise comparisons using t tests with non-pooled SD
data: Y and Group
A B C
B 0.2362 - -
C 0.0086 0.00000000000071 -
D 0.0086 0.0086 0.2362
P value adjustment method: fdr
どの補正でも有意差ありは、A-C,A-D,B-C,B-D
有意差なしは A-B,C-D
> pairwise.wilcox.test(Y,Group,p.ad='holm')
Pairwise comparisons using Wilcoxon rank sum test
data: Y and Group
A B C
B 0.231 - -
C 0.005 0.000000000073 -
D 0.019 0.062 0.533
P value adjustment method: holm
http://i.imgur.com/KcqMpsQ.png
http://i.imgur.com/9xKhTot.png
> pairwise.t.test(Y,Group,p.adjust.method = 'holm',pool.sd = TRUE)
Pairwise comparisons using t tests with pooled SD
data: Y and Group
A B C
B 0.4547 - -
C 0.0155 0.2147 -
D 0.0003 0.0155 0.4547
P value adjustment method: holm
MCMCのモデルで標準偏差をグループ共通にすると95％HDIが０を跨いでしまう。
http://i.imgur.com/YaVq7tQ.png
http://i.imgur.com/SiVUMXS.png
で HDIが０を跨がない。
http://i.imgur.com/mK7DoCz.png
固有sdモデル
http://i.imgur.com/ifOQlyC.png
どちらが現実をよりよく説明するかということだな。
pdf2hdi <- function(pdf,xMIN=0,xMAX=1,cred=0.95,Print=TRUE){
nxx=1001
xx=seq(xMIN,xMAX,length=nxx)
xx=xx[-nxx]
xx=xx[-1]
xmin=xx[1]
xmax=xx[nxx-2]
AUC=integrate(pdf,xmin,xmax)$value
PDF=function(x)pdf(x)/AUC
cdf <- function(x) integrate(PDF,xmin,x)$value
ICDF <- function(x) uniroot(function(y) cdf(y)-x,c(xmin,xmax))$root
hdi=HDInterval::hdi(ICDF,credMass=cred)
print(c(hdi[1],hdi[2]),digits=5)
if(Print){
par(mfrow=c(3,1))
plot(xx,sapply(xx,PDF),main='pdf',type='h',xlab='x',ylab='Density',col='lightgreen')
legend('top',bty='n',legend=paste('HDI:',round(hdi,3)))
plot(xx,sapply(xx,cdf),main='cdf',type='h',xlab='x',ylab='Probability',col='lightblue')
pp=seq(0,1,length=nxx)
pp=pp[-nxx]
pp=pp[-1]
plot(pp,sapply(pp,ICDF),type='l',xlab='p',ylab='x',main='ICDF')
par(mfrow=c(1,1))
}
invisible(ICDF)
}
N=100 ; r=5
pmf <- function(x) (1-x/N)^(r-1)*x/N # dnbinom(r-1,1,x/N) ; dgeom(r-1,x/N)
curve((1-x/N)^(r-1)*x/N,0,N)
AUC=integrate(pmf,0,N)$value
pdf <- function(x) pmf(x)/AUC
source('tools.R')
pdf2hdi(pdf,0,N)
female_propotion=100/(192)
kappa=10
(AB=betaABfromMeanKappa(female_propotion,kappa))
alpha=AB$a ; beta=AB$b
# alpha=1 ; beta=1
curve(dbeta(x,alpha,beta),xlab='female/male ratio')
data=list(
smoker_female=0.090,
smoker_male=0.282,
smoker=0.182,
alpha=alpha,
beta=beta
)
data{
real<lower=0,upper=1> smoker_female;
real<lower=0,upper=1> smoker_male;
real<lower=0,upper=1> smoker;
real<lower=0> alpha;
real<lower=0> beta;
}
parameters{
real<lower=0,upper=1> female;
}
model{
female ~ beta(alpha,beta);
}
generated quantities{
real<lower=0,upper=1> female_smoker;
female_smoker = smoker_female*female/smoker;
}
'
stanModel=stan_model(model_code = stanStrings)
fit=sampling(stanModel,data=data,seed=123,iter=50000,warmup=5000,chains=4)
print(fit,digits=4)
ようやく完成。
https://i.imgur.com/fzzGWoz.png
べつに分布を９０度回転させて表示させなくてもいいのだが。
stanStrings='
data{
int r; //3
int z; //3
int N; //10
int<lower=0,upper=1> y[r]; //c(0,0,1)
}
parameters{
real<lower=0,upper=1>p[2]; //p[1]:yuruyuru, p[2]:gabagaba
}
model{
y ~ bernoulli(p[1]);
z ~ binomial(N,p[2]);
}
generated quantities{
real<lower=0,upper=1> yuru;
real<lower=0,upper=1> gaba;
real diff;
yuru = (1-p[1])^(r-1)*p[1];
gaba = choose(N,z)*p[2]^z*(1-p[2])^(N-z);
diff = p[1]-p[2];
}
'
data=list(r=3,z=3,N=10,y=c(0,0,1))
stanmodel=stan_model(model_code = stanStrings)
fit=sampling(stanmodel,data=data,seed=123)
print(fit,digits=4)
声を掛けたら、ゆるゆる女子大r人めで開脚、がばがば女子大N人中ｚ人開脚、どっちが開脚が容易か？
という問題にした方が興味をひくなｗ
stanでの結果は これ
mean se_mean sd 2.5% 25% 50% 75% 97.5% n_eff Rhat
p[1] 0.399 0.001 0.200 0.066 0.241 0.386 0.542 0.802 31981 1
p[2] 0.334 0.001 0.130 0.110 0.238 0.324 0.421 0.609 32098 1
yuru 0.114 0.000 0.035 0.028 0.094 0.127 0.143 0.148 19842 1
gaba 0.195 0.000 0.071 0.029 0.150 0.218 0.255 0.267 20013 1
diff 0.065 0.001 0.239 -0.377 -0.106 0.058 0.231 0.541 32024 1
lp__ -12.079 0.008 1.063 -14.941 -12.503 -11.751 -11.313 -11.031 16102 1
p[1]:ゆるゆる女子大開脚率
p[2]:がばがば女子大開脚率
diff = p[1]-p[2];
# ゆるゆる女子大生 r 人めではじめて開脚、がばがば女子大生 N 人中 ｚ 人が開脚、どっちが開脚が容易か？
r=3
z=3
N=9
とサンプルでの比率が同じとき母集団の推定平均値に差があるだろうか？
stanの出力をグラフにしてみた。
平均値で４％ほどの差が推定された。
http://i.imgur.com/NEkpGDX.png
dnbinom(24-7,7,7/24)
N24=24
z7=7
nn=0:50
pp=dnbinom(nn,z7,z7/(nn+z7))
plot(z7/(nn+z7),pp,type='h',col='blue')
points(z7/N24,0, pch='+', cex=2,col=2)
花子と太郎に課された。
花子は５０人を調査できたら終了としてド底辺シリツ医大入学者を５０人をみつけて１８人が裏口であるという結果を得た。
帰無仮説のもとで
５０人中１８人が裏口である確率は 0.01603475
これ以下になるのは５０人中０?１８人と３２?５０人が裏口の場合なので
両側検定して
> sum(dbinom(c(0:18,32:50),50,0.5))
[1] 0.06490865
> binom.test(18,50,0.5)$p.value
[1] 0.06490865
で帰無仮説は棄却できないと結論した。
http://i.imgur.com/XDIp9rM.png
一方、本番と十八番が好きな太郎は一人ずつ調べて１８人めの裏口がみつかったところで調査を終えることにした。
１８人めがみつかったのは花子と同じく５０人めであった。
帰無仮説のもとで
１８人がみつかるのが５０人めである確率は0.005772512
これ以下になるのは２３人以下５０人以上番目で裏口１８人めがみつかった場合なので
両側検定して
pnb=dnbinom(0:999,18,0.5)
> 1 - sum(pnb[-which(pnb<=dnbinom(50-18,18,0.5))]) # < 0.05
[1] 0.02750309
http://i.imgur.com/K3T7utr.png
で帰無仮説は棄却される。
５％のばらつきはイカサマとみなさないとする。
ROPE=c(0.5,0.5*1.05)
curve(dbeta(x,1+zi,1+Ni-zi))
abline(v=ROPE[1],col='gray',lty=3) ;abline(v=ROPE[2],col='gray',lty=3)
pbeta(ROPE[2],1+zi,1+Ni-zi)-pbeta(ROPE[1],1+zi,1+Ni-zi)
HDInterval::hdi(qbeta,shape1=1+zi,shape2=1+Ni-zi)
> f=function(n) HDInterval::hdi(qbeta,shape1=n+1,shape2=1)[1]
> f(5)
lower
0.6069622
> f(10)
lower
0.7615958
> re=sapply (1:100,f)
> names (re)=NULL
> re
[1] 0.2236068 0.3684031 0.4728708 0.5492803 0.6069622 0.6518363 0.6876560
[8] 0.7168712 0.7411344 0.7615958 0.7790778 0.7941833 0.8073638 0.8189637
[15] 0.8292503 0.8384339 0.8466824 0.8541315 0.8608917 0.8670541 0.8726946
[22] 0.8778766 0.8826538 0.8870719 0.8911696 0.8949808 0.8985343 0.9018554
[29] 0.9049661 0.9078859 0.9106318 0.9132188 0.9156604 0.9179684 0.9201535
[36] 0.9222253 0.9241923 0.9260624 0.9278425 0.9295389 0.9311574 0.9327032
[43] 0.9341812 0.9355957 0.9369507 0.9382499 0.9394966 0.9406940 0.9418449
[50] 0.9429520 0.9440178 0.9450445 0.9460342 0.9469889 0.9479105 0.9488005
[57] 0.9496607 0.9504924 0.9512971 0.9520760 0.9528305 0.9535615 0.9542703
[64] 0.9549577 0.9556248 0.9562724 0.9569014 0.9575126 0.9581067 0.9586843
[71] 0.9592463 0.9597932 0.9603256 0.9608441 0.9613492 0.9618415 0.9623214
[78] 0.9627893 0.9632458 0.9636912 0.9641260 0.9645504 0.9649650 0.9653699
[85] 0.9657656 0.9661524 0.9665305 0.9669003 0.9672620 0.9676158 0.9679621
[92] 0.9683011 0.9686330 0.9689580 0.9692763 0.9695882 0.9698938 0.9701933
[99] 0.9704869 0.9707748
>
> g(5)
[1] 0.6069622
> g(10)
[1] 0.7615958
> sapply(1:100,g)
[1] 0.2236068 0.3684031 0.4728708 0.5492803 0.6069622 0.6518363 0.6876560
[8] 0.7168712 0.7411344 0.7615958 0.7790778 0.7941833 0.8073638 0.8189637
[15] 0.8292503 0.8384339 0.8466824 0.8541315 0.8608917 0.8670541 0.8726946
[22] 0.8778766 0.8826538 0.8870719 0.8911696 0.8949808 0.8985343 0.9018554
[29] 0.9049661 0.9078859 0.9106318 0.9132188 0.9156604 0.9179684 0.9201535
[36] 0.9222253 0.9241923 0.9260624 0.9278425 0.9295389 0.9311574 0.9327032
[43] 0.9341812 0.9355957 0.9369507 0.9382499 0.9394966 0.9406940 0.9418449
[50] 0.9429520 0.9440178 0.9450445 0.9460342 0.9469889 0.9479105 0.9488005
[57] 0.9496607 0.9504924 0.9512971 0.9520760 0.9528305 0.9535615 0.9542703
[64] 0.9549577 0.9556248 0.9562724 0.9569014 0.9575126 0.9581067 0.9586843
[71] 0.9592463 0.9597932 0.9603256 0.9608441 0.9613492 0.9618415 0.9623214
[78] 0.9627893 0.9632458 0.9636912 0.9641260 0.9645504 0.9649650 0.9653699
[85] 0.9657656 0.9661524 0.9665305 0.9669003 0.9672620 0.9676158 0.9679621
[92] 0.9683011 0.9686330 0.9689580 0.9692763 0.9695882 0.9698938 0.9701933
[99] 0.9704870 0.9707748
>
method x n mean lower upper
1 agresti-coull 18 50 0.3600000 0.2410278 0.4989496
2 asymptotic 18 50 0.3600000 0.2269532 0.4930468
3 bayes 18 50 0.3627451 0.2343802 0.4940800
4 cloglog 18 50 0.3600000 0.2306356 0.4908871
5 exact 18 50 0.3600000 0.2291571 0.5080686
6 logit 18 50 0.3600000 0.2399736 0.5005239
7 probit 18 50 0.3600000 0.2375867 0.4988707
8 profile 18 50 0.3600000 0.2363864 0.4976324
9 lrt 18 50 0.3600000 0.2363786 0.4976328
10 prop.test 18 50 0.3600000 0.2328502 0.5085700
11 wilson 18 50 0.3600000 0.2413875 0.4985898
> HDInterval::hdi(qbeta,shape1=19,shape2=33)
lower upper
0.2379677 0.4956588
attr(,"credMass")
[1] 0.95
>
[1] 0.0500000 0.2236068 0.3684031 0.4728708 0.5492803 0.6069622 0.6518363
[8] 0.6876560 0.7168712 0.7411344 0.7615958 0.7790778 0.7941833 0.8073638
[15] 0.8189637 0.8292503 0.8384339 0.8466824 0.8541315 0.8608917 0.8670541
[22] 0.8726946 0.8778766 0.8826538 0.8870719 0.8911696 0.8949808 0.8985343
[29] 0.9018554 0.9049661 0.9078859 0.9106318 0.9132188 0.9156604 0.9179684
[36] 0.9201535 0.9222253 0.9241923 0.9260624 0.9278425 0.9295389 0.9311574
[43] 0.9327032 0.9341812 0.9355957 0.9369507 0.9382499 0.9394966 0.9406940
[50] 0.9418449 0.9429520 0.9440178 0.9450445 0.9460342 0.9469889 0.9479105
[57] 0.9488005 0.9496607 0.9504924 0.9512971 0.9520760 0.9528305 0.9535615
[64] 0.9542703 0.9549577 0.9556248 0.9562724 0.9569014 0.9575126 0.9581067
[71] 0.9586843 0.9592463 0.9597932 0.9603256 0.9608441 0.9613492 0.9618415
[78] 0.9623214 0.9627893 0.9632458 0.9636912 0.9641260 0.9645504 0.9649650
[85] 0.9653699 0.9657656 0.9661524 0.9665305 0.9669003 0.9672620 0.9676158
[92] 0.9679621 0.9683011 0.9686330 0.9689580 0.9692763 0.9695882 0.9698938
[99] 0.9701933 0.9704870
[1] 0.2236068 0.3684031 0.4728708 0.5492803 0.6069622 0.6518363 0.6876560
[8] 0.7168712 0.7411344 0.7615958 0.7790778 0.7941833 0.8073638 0.8189637
[15] 0.8292503 0.8384339 0.8466824 0.8541315 0.8608917 0.8670541 0.8726946
[22] 0.8778766 0.8826538 0.8870719 0.8911696 0.8949808 0.8985343 0.9018554
[29] 0.9049661 0.9078859 0.9106318 0.9132188 0.9156604 0.9179684 0.9201535
[36] 0.9222253 0.9241923 0.9260624 0.9278425 0.9295389 0.9311574 0.9327032
[43] 0.9341812 0.9355957 0.9369507 0.9382499 0.9394966 0.9406940 0.9418449
[50] 0.9429520 0.9440178 0.9450445 0.9460342 0.9469889 0.9479105 0.9488005
[57] 0.9496607 0.9504924 0.9512971 0.9520760 0.9528305 0.9535615 0.9542703
[64] 0.9549577 0.9556248 0.9562724 0.9569014 0.9575126 0.9581067 0.9586843
[71] 0.9592463 0.9597932 0.9603256 0.9608441 0.9613492 0.9618415 0.9623214
[78] 0.9627893 0.9632458 0.9636912 0.9641260 0.9645504 0.9649650 0.9653699
[85] 0.9657656 0.9661524 0.9665305 0.9669003 0.9672620 0.9676158 0.9679621
[92] 0.9683011 0.9686330 0.9689580 0.9692763 0.9695882 0.9698938 0.9701933
[99] 0.9704870 0.9707748
>
ある仮想疾患の治癒率
軽症 重症
国立大学 10/10 10/90
底辺私立 70/90 0/10
自然経過 40/50 5/50
国立大学の方が軽症・重症とも成績がよいが
総数比較では底辺私立の方が成績がよい。
この疾患は自然治癒率が45%とされています。
この疾患の底辺私立での治癒率は70%です。
これに対して国立大学での治癒率はわずか20%です。
という記述も嘘ではないね
N=n
z=n
if(Print) {
bayes=binom::binom.bayes(z,N, prior.shape1=alpha,prior.shape2=beta)
show(binom::binom.bayes.densityplot(bayes))
}
hdi=HDInterval::hdi(qbeta, shape1=alpha+z, shape2=beta+N-z)
return (c(lower=hdi[1],mean=(alpha+z)/(alpha+beta+N),
mode=(alpha+z-1)/(alpha+beta+N-2), upper=hdi[2]))
}
f(10,P=TRUE)
nn=1:30
yy=sapply(nn,function(x)f(x,Print=FALSE)[1])
plot(nn,yy,pch=19,xlab='裏口バカ連続合格数',ylab='裏口確率信頼区間下限')
curve((0.05)^(1/(x+1)),add=TRUE,lty=3) # 0.05の（合格者数＋１）乗根
source('tools.R')
N=5 ; z=5
Bayes(N,z,alpha=1,beta=1,Print=TRUE) ; 0.05^(1/(N+1)) # N=z
# 事前分布が最頻値0.5で集中度(κ=α+β)のとき事後分布の関係
.mode=0.5
Kappa2Bayes <- function(kappa,.mode=0.5){
AB=betaABfromModeKappa(.mode,kappa)
Bayes(N,z,alpha=AB[[1]],beta=AB[[2]])
}
K=seq(2,1000,by=0.5)
K=K[-1]
res=sapply(K,Kappa2Bayes)
Mat=as.matrix(res)
plot(K,Mat['lower',],type='l',xlab=bquote(kappa),
ylab='Probability', ylim=c(0,1),lty=3)
lines(K,Mat['mean',],col=4,lwd=4)
lines(K,Mat['mode',],col=2,lwd=2)
lines(K,Mat['upper',],lty=3)
legend('bottomright',bty='n',legend=c('mean','mode','upr','lwr'),
col=c(4,2,1,1),lty=c(1,1,3,3),lwd=c(4,2,1,1))
seqn<-function(n=5,N=100,p=0.5){
rn=rbinom(N,1,p)
count=0
for(i in 1:N){
if(rn[i] & count<n){
count=count+1
}
else{
if(count==n) {return(TRUE)}
else{
count=0
}
}
}
return(count==n)
}
mean(replicate(10^6,seqn()))
> mean(replicate(10^6,seqn()))
[1] 0.810223
args = list(...)
n.args=length(args)
ss2=0
df=0
for(i in 1:n.args){
ss2 = ss2 + var(args[[i]])*(length(args[[i]])-1)
df = df + (length(args[[i]])-1)
}
ss2/df
}
effectsize <- function(y1,y2){
diff=mean(y1)-mean(y2)
var=(var(x1)*(length(x1)-1)+ var(x2)*(length(x2)-1))/(length(c(y1,y2))-2)
sd=sqrt(var)
diff/sd
}
library(effsize)
cohen.d()
[1] 69.33689
1 / ( 1- n√(1-confidence.level) )
confidence.level=0.95
rule3 <- function(n,confidence.level=0.95){ # n人に1人の副作用
p=1/n
q=1-p # q^n.sample < 1-confidence.level
n.sample = log(1-confidence.level)/log(q)
return(n.sample)
}
nn=seq(1,10000,by=100)
plot(nn,sapply(nn,rule3))
curve(3*x,col=2,add=TRUE)
plot(nn,sapply(nn,function(x) rule3(x,conf=0.99)))
lm( sapply(nn,function(x) rule3(x,conf=0.99)) ~ nn + 0)
curve(4.605*x,col=4,add=TRUE)
このスレの趣旨ｗに合わせてこんな問題にしてみた。
ド底辺学力学生がド底辺特殊シリツ医大を受験したとする。
試験は五者択一で三教科150問、合格ラインは６割とされる。
中学数学すらできないド底辺学力ゆえ正解できるのは偶然に頼るしかなく、
正答率は概ね1/５で、その日の運で1/4から1/6と推定されている。
これを、正答確率は最頻値1/５で1/6から1/4の間に正答する確率の95%があると設定する。
このド底辺が合格したとする。150問中90問以上正答したことになる。
これがイカサマ入試である確率を求めよ。
事前確率のβ分布のパラメータ算出がやや手間だが、あとはルーティン作業
JAGSを使ってMCMCでの結果 http://i.imgur.com/V7TaBG7.png
解析解： 0.9994608 とほぼ一致。
N=10
z=0
y=c(rep(1,z),rep(0,N-z))
ph=c(1,2/3,1/2,1/5)
pc=c(2/100,50/100,40/100,8/100)
names(ph)=c('特待生','学力合格','加点合格','ガチの裏')
names(pc)=c('特待生','学力合格','加点合格','ガチの裏')
dataList5=list(N=N,y=y,ph=ph,pc=pc)
# JAGS model
modelString5 ="
model {
for(i in 1:N){
y[i] ~ dbern(ph[coin])
}
coin ~ dcat(pc[])
}
"
writeLines(modelString5,'TEMPmodel.txt')
jagsModel5=jags.model('TEMPmodel.txt',data=dataList5)
codaSamples5=coda.samples(jagsModel5,var=c('coin'),n.iter=100000,na.rm=TRUE)
summary(codaSamples5)
js5=as.matrix(codaSamples5)
re=numeric()
for(i in 1:4) re[i]=mean(js5==i)
dat=data.frame(割合=round(re*100,3))
rownames(dat)=names(pc)
dat
立方体からなるサイコロの目のでる確率はすべて等しく1/6である、を帰無仮説とする。
そのサイコロをふって1の目がでた。2回目は2の目がでた。
その確率は1/6*1/6で1/36=0.02778 < 0.05だから帰無仮説は棄却される。
どの目の組合せでも同じく帰無仮説は棄却される。
頻度主義統計のもとではすべてのサイコロはいびつである。
n100=100
HDInterval::hdi(qbeta,shape1=n100+.a,shape2=.b)
qbeta(a005,n100+.a,.b)
a005=0.05
# p^n100 < a005
# p < a005^(1/n100)
GolgoLowerLimit <- function(a005,n100=100){ # Golgo lower limit
c(a005^(1/(n100+1)),qbeta(a005,n100+1,1))
}
GolgoLowerLimit(0.05)
AHO <- function(a00,n100=100,shoot=10000){
(a005^(1/n100)+1)/2*shoot
}
AHO(0.05)
x=seq(0.001,0.1,by=0.001)
plot(x,sapply(x,function(x) AHO(x,100,10000)),type='l',lwd=2,
las=1,ylab='「平均値」',xlab='危険率')
int Npip; // 6
real alpha[Npip]; // c(1,1,1,1,1,1)
int Ntotal; // length(y)
int y[Ntotal];
}
parameters{
simplex[Npip] pi;
}
model{
for(i in 1:Ntotal){
y[i] ~ categorical(pi);
pi ~ dirichlet(alpha)
}
}
RBI <- function(a=1,b=1,zi=1,Ni=1,zj=0,Nj=2,ROPE=NULL,Print=TRUE){
(y=c(rep(1,zi),rep(0,Ni-zi),rep(1,zj),rep(0,Nj-zj)))
(s=as.numeric(factor(c(rep('D',Ni),rep('U',Nj)))))
myData=data.frame(y=y,s=s)
Ntotal = length(y)
Nsubj = length(unique(s))
dataList = list(
y = y ,
s = s ,
Ntotal = Ntotal ,
Nsubj = Nsubj
)
# JAGS model
modelString = paste0("
model {
for ( i in 1:Ntotal ) {
y[i] ~ dbern( theta[s[i]] )
}
for ( sIdx in 1:Nsubj ) {
theta[sIdx] ~ dbeta(", a,',' , b," )
}
}
")
# close modelString
jagsModel = jags.model( file="TEMPmodel.txt" , data=dataList)
codaSamples = coda.samples( jagsModel , variable="theta", n.iter=10000 )
mcmcMat=as.matrix(codaSamples)
if(Print){
par(mfrow=c(2,1))
curve(dbeta(x,a,b),xlab=paste0('Beta(',a,',',b,')'),bty='n',yaxt='n',ylab='',
type='h', col='blue')
print(plotPost2(mcmcMat[,1]-mcmcMat[,2],compVal=0,ROPE=ROPE,
cenT='mean',xlab=bquote(Delta),cex=1,showCurve=FALSE))
}
dif=mcmcMat[,1]-mcmcMat[,2]
print(c(HDInterval::hdi(dif),mean=mean(dif)))
invisible(dif)
}
bf=gamma(a)*gamma(b)/gamma(a+b) *
gamma(a+b+n)/gamma(a+z)/gamma(b+n-z) *
p0^z*(1-p0)^(n-z)
pri=p1/(1-p1)
pos=pri*bf
post.prob=pos/(1+pos)
c(BayesFactor=bf, PostProb=post.prob)
}
BF01(5,4,0.5,1,1)
BF01(7,7,0.5,1,1)
b=1
n=5
z=5
p=0.5
dataList=list(
a=a,
b=b,
n=n,
z=z,
p=p
)
modelString,='
model{
bf=gamma(a)*gamma(b)/gamma(a+b) *
gamma(a+b+n)/gamma(a+z)/gamma(b+n-z) *
p^z*(1-p)^(n-z) # bf= (n+1)*p^n
pri=p0/(1-p0)
pos=pri*bf
post_prob=pos/(1+pos)
p0 ~ beta(1,1)
}
'
b=1
n=5
z=n
p=0.5
dataList=list(
a=a,
b=b,
n=n,
z=z,
p=p
)
modelString,='
model{
bf= (n+1)*p^n
pri=p0/(1-p0)
pos=pri*bf
post_prob=pos/(1+pos)
p0 ~ beta(1,1)
}
'
writeLines(modelString,'TEMPmodel.txt')
jagsModel=jags.model('TEMPmodel.txt', data=dataList)
codaSamples=coda.samples(jagsModel,n.iter=10000,var=c
('p0'))
js=as.matrix(codaSamples)
https://to-kei.net/hypothesis-testing/about-2/
ベイズでやってみるなら
的中率が1/2である確率は一応分布に従う（事前分布）として
５試合連続的中した後の的中率事後分布がどうなるかを考える。
n=5
k=10^4
p0=runif(k)
bf= (n+1)*p^n
pri=p0/(1-p0)
pos=pri*bf
post_prob=pos/(1+pos)
quantile(post_prob,prob=c(0.025,0.5,0.975))
a=a,
b=b,
n=n,
z=z,
p=p
)
modelString='
model{
bf = p^z*(1-p)^(n-z)*exp(loggam(a))*exp(loggam(b))/exp(loggam(a+b))*exp(loggam(a+b+n))/exp(loggam(a+z))/exp(loggam(b+n-z))
pri = p0/(1-p0)
pos = pri*bf
post_prob = pos/(1+pos)
p0 ~ dbeta(a,b)
}
'
writeLines(modelString,'TEMPmodel.txt')
jagsModel=jags.model('TEMPmodel.txt', data=dataList)
codaSamples=coda.samples(jagsModel,n.iter=20000,chains=4,var=c('post_prob'))
js=as.matrix(codaSamples)
xlim=c(0,min(1,mean(js[,'post_prob'])*6))
BEST::plotPost(js[,'post_prob'],xlim=xlim,xlab=paste(n,'guess',z,'correct'),cenTend='mean',
showCurve = FALSE,col='gray')
# prio.μ ~ N(η,τ)
# post.μ ~ N( [(n/σ2)x_ + (1/τ2)η] /[(n/σ2) + (1/τ2)],
# (σ2/n)*τ2/[(σ2/n) + τ2]
post_norm <- function(eta,tau,n,x_,sigma){
mean=(n/sigma^2*x_ + 1/tau^2*eta)/(n/sigma^2 + 1/tau^2)
sd=(sigma^2/n)*tau^2 / ((sigma^2/n) + tau^2)
return(c(mean,sd))
}
post_norm(eta=180,tau=15,n=5,x_=195,sigma=10)
X_=195
sigma=10
x=rnorm(n,X_,sigma)
X=(x-mean(x))/sd(x)*sigma + X_
mean(X);sd(X)
eta=180
tau=15
dataList=list(n=n,sigma=sigma,X=X,eta=eta,tau=tau)
modelString='
model{
for(i in 1:n){
X[i] ~ dnorm(mu,1/sigma^2)
}
mu ~ dnorm(eta,1/tau^2)
}
'
writeLines(modelString,'TEMPmodel.txt')
jagsModel=jags.model('TEMPmodel.txt',data=dataList)
codaSamples=coda.samples(jagsModel,n.iter = 100000,var=c('mu'))
js=as.matrix(codaSamples)
hist(js)
mean(js)
var(js)
post_norm(eta=180,tau=15,n=5,x_=195,sigma=10)
ある監獄にA、B、Cという3人の囚人がいます
3人のうちランダムに選ばれた1人に恩赦が出ます
誰が恩赦になるかは看守は答えない
囚人Aに看守が「Bは死刑になる」と教えてくれます
この時、看守は嘘は言いません
囚人Aに恩赦が与えられる確率は何％でしょうか？
恩赦(onsha)を受けるをo,死刑執行されると告(tsuge)げられるをtで表す。
Aが恩赦を受ける確率P(A=o)=1/3
Bが恩赦を受ける確率P(B=o)=1/3
Cが恩赦を受ける確率P(C=o)=1/3
求めたいのは、Bが死刑執行されると告げられた後のAが恩赦を受ける確率P(A=o|B=t)である。
ベイズの公式により
P(A=o|B=t) = P(B=t|A=o)*P(A=o) / P(B=t)
P(B=t) = P(B=t|A=o)*P(A=o) + P(B=t|B=o)*P(B=o) + P(B=t|C=o)*P(C=o)
P(B=t|B=o)=0 Bが恩赦を受けるときBが死刑執行されると告げられる確率=0
P(B=t|C=o)=1 CBが恩赦を受けるときBが死刑執行されると告げられる確率=1
問題は P(B=t|A=o)
恩赦を受けるのがAであるときに看守がCではなくBが死刑執行されると告げる確率は示されていない。
この確率をｐとすると
P(A=o|B=t)は p/(p+1)となる。
もちろんp=0.5であれば、P(A=o|B=t)=1/3と看守に告げられる前と同じである。
ここでｐが一様分布からさまざなβ分布に従うとするとどうなるか、グラフにしてみた。
http://i.imgur.com/vIzIabU.png
左の緑が看守がBとCが死刑執行予定であるときにBを選んで答える確率分布。
右の青が看守がBと告げたときのAが恩赦を受ける確率の分布。
死刑囚A,B,CでAが看守に尋ねてBは死刑執行されると告げられたと設定。
恩赦(onsha)を受けるをo,死刑執行されると告(tsuge)げられるをtで表す。
Aが恩赦を受ける確率P(A=o)=1/3
Bが恩赦を受ける確率P(B=o)=1/3
Cが恩赦を受ける確率P(C=o)=1/3
求めたいのは、Bが死刑執行されると告げられた後のAが恩赦を受ける確率P(A=o|B=t)である。
ベイズの公式により
P(A=o|B=t) = P(B=t|A=o)*P(A=o) / P(B=t)
P(B=t) = P(B=t|A=o)*P(A=o) + P(B=t|B=o)*P(B=o) + P(B=t|C=o)*P(C=o)
P(B=t|B=o)=0 Bが恩赦を受けるときBが死刑執行されると告げられる確率=0
P(B=t|C=o)=1 Cが恩赦を受けるときBが死刑執行されると告げられる確率=1
問題は P(B=t|A=o)
恩赦を受けるのがAであるときに看守がCではなくBが死刑執行されると告げる確率は示されていない。
この確率をｐとすると
P(A=o|B=t)は p/(p+1)となる。
もちろんp=0.5であれば、P(A=o|B=t)=1/3と看守に告げられる前と同じである。
ここでｐが一様分布からさまざなβ分布に従うとするとどうなるか、グラフにしてみた。
http://i.imgur.com/vIzIabU.png
左の緑が看守がBとCが死刑執行予定であるときにBを選んで答える確率分布。
右の青が看守がBと告げたときのAが恩赦を受ける確率の分布。
Aが恩赦を受ける確率の期待値（平均値）は
> 1-log(2)
[1] 0.3068528
となる。
p/(p+1)を [0,1]で定積分すれば求まる。
無情報分布として一様分布を考えると
Aが恩赦を受ける確率の期待値（平均値）は
> 1-log(2)
[1] 0.3068528
となる。
Cが恩赦を受ける確率の期待値（平均値）は
> log(2)
[1] 0.6931472
当然、Bが恩赦を受ける確率は０ 👀
Rock54: Caution(BBR-MD5:0be15ced7fbdb9fdb4d0ce1929c1b82f)
P(B=t) = P(B=t|A=o)*P(A=o) + P(B=t|B=o)*P(B=o) + P(B=t|C=o)*P(C=o) = (p + q+ 1-q)*1/3 = (p + 1)*1/3
P(B=t|A=o)*P(A=o) = p*1/3
P(B=t|B=o)*P(B=o) = q*1/3
P(B=t|C=o)*P(C=o) = (1-q)*1/3
P(A=o|B=t) = p / (p +1)
function(PDF,xmin=0,xmax=1,N=10000,Print=TRUE,...){
xx=seq(xmin,xmax,length=N+1)
ymax=max(PDF(xx))
Ux=runif(N,xmin,xmax)
Uy=runif(N,0,ymax)
Rand=Ux[which(Uy<=PDF(Ux))]
if(Print){
hist(Rand,xlim=c(xmin,xmax),freq=FALSE,col=sample(colors(),1),main='',...)
AUC=integrate(PDF,xmin,xmax)$value
lines(xx,sapply(xx,function(x)PDF(x)/AUC))
}
hdi=HDInterval::hdi(Rand)
print(c(hdi[1],hdi[2]),digits=4)
invisible(Rand)
}
stanString2='
functions{
real jisaku_lpdf(real y, real a, real b){
real temp;
temp = a*y + b;
return log(temp);
}
}
data{
real a;
real b;
}
parameters{
real<lower=0,upper=1> p;
}
transformed parameters{
real q;
q = p/(p+1);
}
model{
target += jisaku_lpdf( p | a, b);
}
'
f=function(ab,k=10^4,ma=1/3){
a=ab[1]
b=ab[2]
rn=rbeta(k,a,b)
(mean(amnesty(rn)) - ma)^2
}
optim (c(1,1),f, method='Nelder')
optim (c(2,2),f, method='Nelder')
ある監獄にA、B、Cという3人の囚人がいます
3人のうちランダムに選ばれた1人に恩赦が出ます
誰が死刑になるかは看守は本人には答えない
囚人Aに看守が「Bは死刑になる」と教えた
この時、看守は一定の確率で嘘をつく。
BとCが死刑になるときは50%の確率でBと答える。
囚人Aに恩赦が与えられる確率は何％でしょうか？
ある監獄にA、B、Cという3人の囚人がいます。
3人のうちランダムに選ばれた1人に恩赦が出ます。
誰が死刑になるかは看守は決して本人には教えない。
囚人AがB、Cの少なくともどちらかは死刑になるのだから教えてくれと看守に尋ねた。看守が本人に教えるのではないので「Bは死刑になる」とAに教えた。
この時、看守は1/3の確率で嘘をつく。
BとCが死刑になるときは50%の確率でBと答える。
囚人A、B、Cに恩赦が与えられる確率はそれぞれ何％でしょう？
p : P(B=t|A=o)Aが恩赦（BとCが死刑執行される）とき看守がBと答える確率
q : 看守が嘘をつく確率
P(B=t|B=o) Bが恩赦を受けるときBが死刑執行されると告げられる確率 = q
P(B=t|C=o) Cが恩赦を受けるときBが死刑執行されると告げられる確率 = 1-q
P(A=o|B=t) = P(B=t|A=o)*P(A=o) / P(B=t)
P(B=t) = P(B=t|A=o)*P(A=o) + P(B=t|B=o)*P(B=o) + P(B=t|C=o)*P(C=o)
= p * P(A=o) + q * P(B=o) + (1-q) * P(C=o)
P(A=o|B=t) = p*P(A=o) / ( p*P(A=o) + q * P(B=o) + (1-q) * P(C=o) )
P(A=o)= P(B=o)= P(C=o) = 1/3ならば
P(A=o|B=t) = p /(p+1)
P(B=o|B=t) = q/(p+1)
P(C=o|B=t) = (1-q)/(p+1)
Aがアタリ(atari)の確率をP(A=a)
司会者がBを開ける(open)確率をP(B=o)と表すことにする。
残った箱Cがアタリである確率P(C=a|B=o)は
ベイズの公式から
P(C=a|B=o) = (P(B=o|C=a)P(C=a)) / P(B=o)
P(B=o) = P(B=o|A=a)P(A=a) + P(B=o|B=a)P(B=a) + P(B=o|C=a)P(C=a)
= P(B=o|A=a)*1/3 + 0*1/3 + 1*1/3 ここで P(B=o|A=a)=pとおくと
= p*1/3 + 1/3
ゆえに
P(C=a|B=o) = (P(B=o|C=a)P(c=a)) / P(B=o) = (1*1/3) / (p*1/3 + 1/3) = 1/(p+1)
P(A=a|B=o) = P(B=o|A=a)P(A=a)/P(B=o)
P(B=o) = P(B=o|A=a)P(A=a) + P(B=o|B=a)P(B=a) + P(B=o|C=a)P(C=a)
P(B=o|A=a)はAがアタリであるときにBがハズレとして開けられる確率pは問題で示されていない。
不十分理由の原則に準じてpを０．５とするか一様分布に従うとするのが一般的だと思う。
P(B=o|A=a)=pとおくと
P(B=o) = P(B=o|A=a)P(A=a) + P(B=o|B=a)P(B=a) + P(B=o|C=a)P(C=a)
= p*1/3 + 0*1/3 + 1*1/3
= p*1/3 +1/3
ゆえに
P(A=a|B=o) = (p*1/3) / ( p*1/3 + 1/3 ) = p/(p+1)となる。
p=0.5ならBがハズレというデータはAがあたりの確率に影響を与えず1/3である。
P(A=a|B=o) = p/(p+1) Bが開けられた後、Aがアタリの確率 (1)
P(C=a|B=o) = 1/(p+1) Bが開けられた後、Cがアタリの確率 (2)
(1)/(2) = p なので (2)は(1)以上である。(∵0<= p <=1)
ゆえに
残った箱Cの方がアタリの確率は高い。
とする。
各々10000発撃ったときゴルゴ15の命中数の期待値はいくらか？
確率密度とかベータ分布とかを使わずに説明するなら、重み付き平均という考え方で説明するしかないかな？
命中率が0.5なら2回に1回は1発1中（確率0.5)
命中率が0.8なら10回に8回は1発1中（確率0.8)
となる。
体重100ｋｇの牛が100頭
体重99kgの牛が99頭
体重98kgの牛が98頭
・・・
体重2kgの牛が2頭
体重1kgの牛が1頭
牛の平均体重の計算と同じ
n=100
x=seq(0,1,length=n+1)
sum(x*x/sum(x))
sum(x^2)/sum(x)
2/3
(sum_x=n*(n+1)/2/n) # (n+1)/2
(sum_x2=n*(n+1)*(2*n+1)/6/(n^2)) # (n+1)*(2*n+1)/n/6
sum_x2/sum_x # (2*n+1)/n/3 = 2/3+1/3/n
n→∞
で2/3に集束する。 命中数の期待値は10000*2/3=6667
リリースされているデータだと効き目はこんなもん
group とすれば，survdiff(Surv(time,event)~group) とすればよい。この例の場合なら，下枠内の通り。
なお，一般化ウィルコクソン検定をするには survdiff(Surv(time,event)~group,rho=1) とすればよい。
it13-4-2006.R
require(survival)
time <- c(4,6,8,9,5,7,12,14)
event <- c(1,1,1,1,1,1,1,1)
group <- c(1,1,1,1,2,2,2,2)
survdiff(Surv(time,event)~group)
１０％までの歪みは許容する。
hdi=HDInterval::hdi(qbeta,credMass,shape1=1+r,shape2=1+n-r)
return(hdi)
}
crooked(3000,490,H0=1/6,xlim=c(0.12,0.20))
binom::binom.confint(490,3000)
1/6*c(0.9,1.1)
グラフ化するとHDI ⊂ ROPEになっている。
http://i.imgur.com/bmQJTUe.png
test\disease present absent
pos TP(a) FN(b)
neg FP(c) TN(d)
a+c=33
b+d=15
a+b=33
a/(a+c)=0.697
d/(b+d)=0.333
a/33=0.697
a=23
d/15=0.333
d=5
c=10
b=10
test\disease present absent
pos 23 TP(a) 10 FN(b)
neg 10 FP(c) 5 TN(d)
# http://statpages.info/ctab2x2.html
角がある という所見は髄膜炎の診断に特異度１００％である。
俺の経験上、こういう話をシリツ医大卒に振っても興味を示す奴はいないね。
nLR=.01/.99
preo=0.001/(1-0.001)
preo=0.1/(1-0.1)
poso=preo*pLR
poso/(1+poso)
mWald <- function(S,n,cl=0.95){
z=qnorm(1-(1-cl)/2)
n_tilde=n+z^2
p_tilde=(S+z^2/2)/n_tilde
W=z*sqrt(p_tilde*(1-p_tilde)/n_tilde)
CI=c(mean=S/n,lower=p_tilde-W,upper=p_tilde+W)
return(CI)
}
binom::binom.agresti.coull(S,n)
sdCI=function(x,conf.level=0.95){
n=length(x)
df=n-1
sd=sd(x)
lwr=qchisq((1-conf.level)/2,df)
upr=qchisq((1-conf.level)/2,df,lower.tail=FALSE)
CI=data.frame(lower=sqrt((n-1)/upr)*sd,sd=sd,upper=sqrt((n-1)/lwr)*sd )
return(CI)
}
##差の信頼区間(生データなし)
DifCI=function(n1,n2,m1,m2,sd1,sd2){
pooledV=((n1-1)*sd1^2+(n2-1)*sd2^2)/(n1-1+n2-1)
SE12=sqrt((1/n1+1/n2)*pooledV)
w=qt(.975,n1-1+n2-1)*SE12
ci=c(m1-m2-w,m1-m2+w)
names(ci)=c("lower","upper")
return(ci)
}
# t検定(生データなし)
T.test=function(n1,n2,m1,m2,sd1,sd2){
SE12=sqrt((1/n1+1/n2)*((n1-1)*sd1^2+(n2-1)*sd2^2)/((n1-1)+(n2-1)))
T=(m1-m2)/SE12
pt(abs(T),n1-1+n2-1,lower.tail = FALSE)
}
non=c(0.52,0.25,0.027,88)
rec=c(0.38,0.32,0.034,89)
eli=c(0.40,0.26,0.048,28)
# 生データなしで分散分析
lh=rbind(non,rec,eli)
colnames(lh)=c("m","sd","SEM","n") ; lh
mean.G=sum(lh[,"m"]*lh[,"n"])/sum(lh[,"n"])
SS.bit=sum((lh[,"m"]-mean.G)^2*lh[,"n"])
SS.wit=sum(lh[,"sd"]^2*(lh[,"n"]-1))
df.bit=nrow(lh)-1
df.wit=sum(lh[,"n"]-1)
MS.bit=SS.bit/df.bit
MS.wit=SS.wit/df.wit
F.ratio=MS.bit/MS.wit
pf(F.ratio,df.bit,df.wit,lower.tail=FALSE) # 0.003720507
(η2=(SS.bit)/(SS.bit+SS.wit)) # 0.05387927
prop=function(S,n)prop.test(S,n)$conf.int[1:2]
#binom.test(S,n)$conf.int # S:success, n:number of trial
binom=function(S,n) binom.test(S,n)$conf.int[1:2]
## S:success, n:number of trial
binomCI=function(S,n,conf.level=0.95){
upper=uniroot(f=function(x)pbinom(S,n,x)-(1-conf.level)/2,c(0,1))$root
lower=uniroot(f=function(x)pbinom(S,n,x,lower.tail=FALSE)-(1-conf.level)/2,c(0,1))$root
CI=data.frame(lower=lower, upper=upper)
return(round(CI,3))}
##
wCI=function(S,n,cl=0.95){ #modified Wald CI for Proportion
z=qnorm(1-(1-cl)/2)
p.=(S+0.5*z^2)/(n+z^2)
W=z*sqrt((p.*(1-p.))/(n+z^2))
C.I.=data.frame(lower=p.-W,upper=p.+W)
return(C.I.)
}
##
bCI<-function(r,n,cl=0.95){
p<-r/n
q<-1-p
sd<-sqrt (n*p*q)
SE<-sd/sqrt(n)
Z<-qnorm(1-(1-cl)/2)
ci<-data.frame(lower=p-Z*SE/sqrt(n),upper=p+Z*SE/sqrt(n))
return(ci)
}
biological and statistical signif?cance (6). Individuals with
signif?cosis fail to realize that just because something is
unlikely to have occurred by chance doesn’t mean it’s
important (17). See also Borderline Probability Disorder.
Borderline Probability Disorder. Afflicted individuals
may dismiss the potential importance of results with P=0.06
while unquestioningly accepting the importance of results with P=0.05
http://journals.asm.org/misc/DiseasedScience_MicrobeMag.pdf
n1=5936 ; n2=3403
a=r1
b=n1-r1
c=r2
d=n2-r2
Fragile <- function(a,b,c,d){
mat=matrix(c(a,b,c,d),2,2,byrow=TRUE,dimnames=list(c("Treated","Control"),c("Event","No Event")))
print(mat)
p=fisher.test(mat)$p.value
cat(paste('p-value =',round(p,5)))
i=0
while(p < 0.05 ){
p=fisher.test(matrix(c(a+i,b-i,c,d),2,2,byrow=TRUE))$p.value
i=i+1
}
cat('\n','\n')
cat(paste('Fragile Index = ',i,'\n','\n'))
print(matrix(c(a+i,b-i,c,d),2,2,byrow=TRUE,dimnames=list(c("Treated","Control"),c("Event","No Event"))))
cat(paste('p-value =',round(p,5)))
invisible(i)
}
# Event a b x
# No Event c d y
sqrt(1.37*4.09)
x+y=43407
x=1280
y=43407-1280
HR=x/(x+y) ; HR
HR1= 2.37*HR ; HR1
a/(a+c)=HR1
c=(1-HR1)*a/HR1
V(logRR)=1/a-1/x+1/c-1/y
SE(logRR)=sqrt(1/a-1/x+1/c-1/y)
HR1*exp(1.96*SE(logRR))=4.09
hazardratio <-function (a, b, PT1, PT0, conf.level = 0.95) {
.M <- a + b
.T <- PT1 + PT0
.MAT <- matrix(c(a, b, .M, PT1, PT0, .T), 3, 2)
colnames(.MAT) <- c("Cases", "Person-time")
rownames(.MAT) <- c("Exposed", "Unexposed", "Total")
class(.MAT) <- "table"
# print(.MAT)
ESTIMATE <- (a/PT1)/(b/PT0)
norm.pp <- qnorm(1 - (1 - conf.level)/2)
.CHI <- (a - (PT1/.T) * .M)/sqrt(.M * (PT1/.T) * (PT0/.T))
p.v <- 2 * (1 - pnorm(abs(.CHI)))
RRL <- ESTIMATE * exp(-norm.pp * sqrt(1/a + 1/b))
RRU <- ESTIMATE * exp(norm.pp * sqrt(1/a + 1/b))
CINT <- c(RRL, RRU)
attr(CINT, "conf.level") <- conf.level
RVAL <- list(p.value = p.v, conf.int = CINT, estimate = ESTIMATE,
method = "Incidence rate ratio estimate and its significance probability",
data.name = paste(deparse(substitute(a)), deparse(substitute(b)),
deparse(substitute(PT1)), deparse(substitute(PT0))))
class(RVAL) <- "htest"
return(RVAL)
}
f <- function(a,u0=1.37) hazardratio(a, x, a/HR1, x+y)$conf[1] - u0
uniroot(f,c(1,1000))$root
a=13
(1-HR1)*a/HR1
c=173
https://rdrr.io/snippets/
X=rnorm(N,0,1)
Y=rnorm(N,1,1)
n=17
f <- function(){
x=sample(X,n)
y=sample(Y,n)
x-y
}
d=replicate (10^5, f())
hist(d)
g <- function(){
x=sample(X,n)
y=sample(Y,n)
t.test(x,y)$p.value
}
p=replicate (10^4, g())
hist(p)
mean(p<0.05)
X=rnorm(N,0,1)
Y=rnorm(N,1,1)
n=16
f <- function(){
x=sample(X,n)
y=sample(Y,n)
x-y
}
d=replicate (10^5, f())
hist(d)
g <- function(){
x=sample(X,n)
y=sample(Y,n)
t.test(x,y)$p.value
}
p=replicate (10^4, g())
hist(p)
hist(-log10(p))
mean(log10(p)<log10(0.05))
X=rnorm(N,0,1)
Y=rnorm(N,1,1)
n=16
f <- function(){
x=sample(X,n)
y=sample(Y,n)
mean(x)-mean(y)
}
d=replicate (10^5, f())
hist(d)
sd(d)
g <- function(){
x=sample(X,n)
y=sample(Y,n)
t.test(x,y)$p.value
}
p=replicate (10^5, g())
hist(p)
hist(-log10(p))
mean(log10(p)<log10(0.05))
> X=rnorm(N,0,1)
> Y=rnorm(N,1,1)
> n=16
> f <- function(){
+ x=sample(X,n)
+ y=sample(Y,n)
+ mean(x)-mean(y)
+ }
> d=replicate (10^5, f())
> hist(d)
> sd(d)
[1] 0.3574393
>
> g <- function(){
+ x=sample(X,n)
+ y=sample(Y,n)
+ t.test(x,y)$p.value
+ }
> p=replicate (10^5, g())
> hist(p)
> hist(-log10(p))
> mean(log10(p)<log10(0.05))
[1] 0.79713
>
>
Two-sample t test power calculation
n = 16
delta = 1
sd = 1
sig.level = 0.05
power = 0.7813965
alternative = two.sided
NOTE: n is number in *each* group
X=rnorm(N,0,1)
n=16
f <- function(){
x=sample(X,n)
y=sample(X,n)
mean(x)-mean(y)
}
d=replicate (10^5, f())
hist(d)
sd(d)
g <- function(){
x=sample(X,n)
y=sample(X,n)
t.test(x,y)$p.value
}
p=replicate (10^4, g())
hist(p)
hist(-log10(p))
mean(log10(p)<log10(0.05))
理論上、
mean(p<0.05)は
power.t.test(n=16,delta=1)$powerに一致。
# sdiff=sqrt(sigma^2/nsamp + sigma^2/nsamp)
ns1=nsamp
ns2=nsamp
# CALC sdiff = sd of difference between means
sdiff=sqrt(sigma^2/ns1 + sigma^2/ns2)
df=ns1+ns2-2
# Note FPR doesn't need calculation of power for p-equals case
#
#under H0, use central t distribution
tcrit=qt((1-pval/2),df,ncp=0)
x0=tcrit
y0=dt(x0,df,0)
#
# under H1 use non-central t distribution
ncp1=delta1/sdiff #non-centrality paramater
x1=x0 #tcrit
y1=dt(x1,df,ncp=ncp1)
# check solution
# pcheck=pt(y1,df,ncp=ncp1)
# pcheck
# Calc false positive risk
p0=2*y0
p1=y1
FPR=((1-prior)*p0)/(((1-prior)*p0) + prior*p1)
FPR
output=c(FPR,x0,y0,x1,y1)
return(output)
}
# end of function calc.FPR
#
calc.FPR0 = function(nsamp,pval,sigma,prior,delta1){
myp=power.t.test(n=nsamp,sd=sigma,delta=delta1,sig.level=pval,type="two.sample",alternative="two.sided",power=NULL)
power = myp$power
PH1=prior
PH0=1-PH1
FPR0=(pval*PH0/(pval*PH0 + PH1*power))
output=c(FPR0,power)
return(output)
}
#
FPRP <- function(n, p.value, prior, effect.size=1){
power=power.t.test(n=n,delta=effect.size,sig.level=p.value)$power
FP=(1-prior)*p.value
TP=prior*power
return(FP/(TP+FP))
}
FPRP(16,p.value=0.045,prior=0.10)
# サンプルサイズが違うとき
FPRP2 <- function(n1,n2, p.value, prior, effect.size=1,...){
power=pwr::pwr.t2n.test(n1, n2, d=effect.size, sig.leve=p.value, ...)$power
FP=(1-prior)*p.value # p-less-than case
TP=prior*power
return(FP/(TP+FP))
}
FPRP2(10,6,p.value=0.05,prior=0.05)
FPRP <- function(n, p.value, prior, effect.size=1){
power=power.t.test(n=n,delta=effect.size,sig.level=p.value)$power
FP=(1-prior)*p.value
TP=prior*power
return(FP/(TP+FP))
}
FPRP(16,p.value=0.045,prior=0.10)
# サンプルサイズが違うとき
FPRP2 <- function(n1,n2, p.value, prior, effect.size=1,...){
power=pwr::pwr.t2n.test(n1, n2, d=effect.size, sig.leve=p.value, ...)$power
FP=(1-prior)*p.value # p-less-than case
TP=prior*power
return(FP/(TP+FP))
}
FPRP2(10,6,p.value=0.05,prior=0.05)
http://rsos.royalsocietypublishing.org/content/4/12/171085
を読んでたらRのスクリプトが公開されていた。
https://figshare.com/articles/files-paper-2_zip_from_The_reproducibility_of_research_and_the_misinterpretation_of_i_p_i_-values/5624929
= alpha*(1-prior) / [ alpha*(1-prior) + power*prior ] (1)
= p.value*(1-prior) / [ p.value*(1-prior) + power*prior ] (2)
> length(CONTROLS) ; length(HYPERTENSION)
[1] 17
[1] 18
> mean(CONTROLS) ; mean(HYPERTENSION)
[1] 263
[1] 257
> sd(CONTROLS) ; sd(HYPERTENSION)
[1] 87
[1] 59
で条件に合致。
> t.test(CONTROLS,HYPERTENSION,var=TRUE)
Two Sample t-test
data: CONTROLS and HYPERTENSION
t = 0.24003, df = 33, p-value = 0.8118
alternative hypothesis: true difference in means is not equal to 0
95 percent confidence interval:
-44.85718 56.85718
JAGSを使ってMCMCしてみた(パッケージBESTを改造して使用）。
http://i.imgur.com/Xq7jRDp.png
理論値より信頼区間幅が広くなるが、まあ、シミュレーションなのでこんなもんだろう。
> HDIofMCMC(muDiff)
[1] -48.86974 61.99241
自分で計算してグラフ化しながら読み進むのは楽しい。
args(pwr.t2n.test)
n1=17;n2=18;m1=263;m2=257;sd1=87;sd2=59
sp_sq = ((n1-1)*sd1^2 + (n2-1)*sd2^2)/(n1-1+n2-1) # pooled variance
sp=sqrt(sp_sq) ; sp # pooled sd
sep=sqrt(1/n1+1/n2)*sp # se for pooled sd
f20.1 <- function(x) pwr.t2n.test(n1=17,n2=18, d=x, sig.level = 0.05)$power
xx=0:150
plot(xx,sapply(xx/sp,f20.1),type='l',ylab='power',xlab='mean difference')
f20.1(0)
f20.1(1)
#
z1=383;z2=373;n1=7685;n2=7596
p1=z1/n1
p2=z2/n2
p1/p2
ES.h(p1,p2)
g20.1 <- function(x){
pwr.2p2n.test(h=ES.h(p1,x*p1),n1=n1,n2=n2,sig.level=0.05)$power
}
g20.1(1)
g20.1(0.7)
rr=seq(0,1,by=0.01)
plot(rr,sapply(rr,g20.1),type='l',xlab='relative risk ratio',ylab='power')
FPRPP <- function(r1,r2,n1,n2, prior){
p1=r1/n1
p2=r2/n2
p.value=prop.test(c(r1,r2),c(n-1,n2))$p.value
pwr::pwr.2p2n.test(h=ES.h(p1,x*p1),n1=n1,n2=n2,sig.level=p.value)$power
FP=(1-prior)*p.value # p-less-than case
TP=prior*power
return(FP/(TP+FP))
}
r1=10 ; r2=16
n1=5936 ; n2=3403
FPRPP(10,16,5936,3403,0.5)
FPRPP <- function(r1,r2,n1,n2, prior){
p.value=prop.test(c(r1,r2),c(n1,n2))$p.value
p1=r1/n1
p2=r2/n2
h=pwr::ES.h(p1,p2)
power=pwr::pwr.2p2n.test(h=h,n1=n1,n2=n2,sig.level=p.value)$power
FP=(1-prior)*p.value # p-less-than case
TP=prior*power
return(FP/(TP+FP))
}
r1=10 ; r2=16
n1=5936 ; n2=3403
FPRPP(r1,r2,n1,n2, prior=0.5)
FragileIndex<- function(r1,r2,n1,n2){
if(r1/n1 < r2/n2){
a=r1
b=n1-r1
c=r2
d=n2-r2
}else{
a=r2
b=n2-r2
c=r1
d=n1-r1
}
mat=matrix(c(a,b,c,d),2,2,byrow=TRUE,dimnames=list(c("low","high"),c("Event","No Event")))
print(mat)
p=fisher.test(mat)$p.value
cat(paste('p-value =',round(p,5)))
i=0
while(p < 0.05 ){
p=fisher.test(matrix(c(a+i,b-i,c,d),2,2,byrow=TRUE))$p.value
i=i+1
}
cat('\n','\n')
cat(paste('Fragile Index = ',i,'\n','\n'))
print(matrix(c(a+i,b-i,c,d),2,2,byrow=TRUE,dimnames=list(c("low+FI","high-FI"),c("Event","No Event"))))
cat(paste('p-value =',round(p,5)))
invisible(i)
}
# Fragile Index
FragileIndex<- function(r1,r2,n1,n2,Fisher=TRUE){
if(r1/n1 < r2/n2){
a=r1
b=n1-r1
c=r2
d=n2-r2
}else{
a=r2
b=n2-r2
c=r1
d=n1-r1
}
mat=matrix(c(a,b,c,d),2,2,byrow=TRUE,dimnames=list(c("low","high"),c("Event","No Event")))
print(mat)
FUN=ifelse(Fisher,fisher.test,chisq.test)
p=FUN(mat)$p.value
cat(paste('p-value =',round(p,5)))
i=0
while(p < 0.05 ){
p=fisher.test(matrix(c(a+i,b-i,c,d),2,2,byrow=TRUE))$p.value
i=i+1
}
cat('\n','\n')
cat(paste('Fragile Index = ',i,'\n','\n'))
print(matrix(c(a+i,b-i,c,d),2,2,byrow=TRUE,dimnames=list(c("low+FI","high-FI"),c("Event","No Event"))))
cat(paste('p-value =',round(p,5)))
invisible(i)
}
graphics.off()
source('https://raw.githubusercontent.com/boboppie/kruschke-doing_bayesian_data_analysis/master/2e/DBDA2E-utilities.R')
BMV_vs_ETI <- function(zi=44 , Ni=1018 , zj=43 , Nj=1022, ROPE=c(-0.005,0.005),COLOR='skyblue'){
y=c(rep(1,zi),rep(0,Ni-zi),rep(1,zj),rep(0,Nj-zj))
s=rep(1:2,c(Ni,Nj))
shape1=1 ; shape2=1 # JAGS prior : beta(shape1,shape2)
myData=data.frame(y=y,s=s)
Ntotal = length(y)
Nsubj = length(unique(s))
dataList = list(
y = y ,
s = s ,
Ntotal = Ntotal ,
Nsubj = Nsubj
)
# JAGS model
modelString = paste0("
model {
for ( i in 1:Ntotal ) {
y[i] ~ dbern( theta[s[i]] )
}
for ( sIdx in 1:Nsubj ) {
theta[sIdx] ~ dbeta(", shape1,',' , shape2," )
}
}
")
# end of modelString
jagsModel = jags.model( file="TEMPmodel.txt" , data=dataList)
update( jagsModel)
codaSamples = coda.samples( jagsModel , variable="theta", n.iter=10000 )
mcmcMat=as.matrix(codaSamples)
dif=mcmcMat[,1]-mcmcMat[,2]
plotPost(dif,ROPE=ROPE,compVal=0,xlab=quote(Delta),breaks=30,cenT='mean',col=COLOR)
invisible(dif)
}
# favorable functional survival at day 28
BMV_vs_ETI(zi=44 , Ni=1018 , zj=43, Nj=1022, ROPE=c(-0.01,0))
# Survival to hospital admission 294/1018 vs 333/1022
BMV_vs_ETI(294,1018,333,1022,ROPE=c(-0.01,0.01))
# global survival at day 28 55/1018 vs 54/1022
BMV_vs_ETI(55,1018,54,1022,ROPE=c(-0.01,0.01))
Brand=rlnorm(20,4.3,0.1)
while(!Equiv(Generic,Brand)){
Generic=rlnorm(10,4.5,0.2)
Brand=rlnorm(20,4.3,0.1)
}
Generic
Brand
t.test(Generic,Brand)$p.value
tt=t.test(Generic,conf.level = 0.90) ; tt
lo=tt$conf[1]
hi=tt$conf[2]
m=mean(Brand)
0.80*m < lo
hi < 1.25*m
r1=44; n1=1018;r2=43;n2=1022
BMV_vs_ETI(r1,n1,r2,n2)
risk.difference(r1,r2,n1,n2)
f <- function(x,margin=0.01){
rd=fmsb::riskdifference(x*r1,x*r2,x*n1,x*n2)
lo=rd$conf[1]
hi=rd$conf[2]
- margin - lo
}
m=uniroot(f,c(0.001,5))$root ; m
BMV_vs_ETI(round(m*r1),round(m*n1),round(m*r2),round(m*n2),COLOR = 'pink')
X=matrix(rnorm(50*100),ncol=100) # X[50 variables,100 samples]
Y=rnorm(100)
ans=lm(Y~ X[1,]+X[2,]+X[3,]+X[4,]+X[5,]+X[6,]+X[7,]+X[8,]+X[9,]+X[10,]+X[11,]+X[12,]+X[13,]+X[14,]+X[15,]+X[16,]+X[17,]+X[18,]+X[19,]+X[20,]+
X[21,]+X[22,]+X[23,]+X[24,]+X[25,]+X[26,]+X[27,]+X[28,]+X[29,]+X[30,]+X[31,]+X[32,]+X[33,]+X[34,]+X[35,]+X[36,]+X[37,]+X[38,]+X[39,]+X[40,]+
X[41,]+X[42,]+X[43,]+X[44,]+X[45,]+X[46,]+X[47,]+X[48,]+X[49,]+X[50,])
anova.ans=anova(ans)
p.value=anova.ans$`Pr(>F)`[1] # p.value of regression
smry=summary(ans)
r.squared=smry$r.squared
pv.coef=smry$coef[-1,4]
pv.coef025=sum(pv.coef<0.25) # p.value of coefficient
pv.coef005=sum(pv.coef<0.05)
data.frame(p.value, r.squared,pv.coef025,pv.coef005)
}
Freedman50()
res50=replicate(10^3,Freedman50()$p.value)
BEST::plotPost(res50,compVal = 0.05)
f(5/10)
power.t.test(delta=0.5,power=0.80)$n
dd=seq(0.01,0.99,by=0.01)
g<- function(x) f(x,.50)/f(x,.80)
sapply(dd,g)
(2*(abs(1.96+abs(qnorm(1-0.80))))^2)/(2*(abs(1.96+abs(qnorm(1-0.50))))^2)
(1.96+0.84)^2/(1.96+0)^2
f(5/10)
power.t.test(delta=0.5,power=0.80)$n
dd=seq(0.01,0.99,by=0.01)
g<- function(x) f(x,.50)/f(x,.80)
sapply(dd,g)
(2*(abs(1.96+abs(qnorm(1-0.80))))^2)/(2*(abs(1.96+abs(qnorm(1-0.50))))^2)
(1.96+0.84)^2/(1.96+0)^2
dd=seq(0.01,0.99,by=0.01)
h<-function (x){
power.t.test(d=x, power=0.80)$n/power.t.test(d=x, power=0.5)$n
}
res=sapply (dd,h)
plot(dd,res)
summary (res)
p.value=fisher.test(matrix(c(r1,n1-r1,r2,n2-r2),2))$p.value
p1=r1/n1
p2=r2/n2
power=statmod::power.fisher.test(p1,p2,n1,n2,alpha=p.value)
FP=(1-prior)*p.value
TP=prior*power
c(p.value=p.value,'false positive rate' = FP/(TP+FP))
}
r1=10;n1=19;r2=11;n2=12
FPRPP.F(r1,r2,n1,n2,0.5)
f247 <- function(n,conf.level=0.95){
df=n-1
lwr=qchisq((1-conf.level)/2,df)
upr=qchisq((1-conf.level)/2,df,lower.tail=FALSE)
c('Lower limit'=sqrt((n-1)/upr),'Upper limit'=sqrt((n-1)/lwr))
}
sd.ci=sapply(c(2,3,4,5,10,25,50,100,500,1000),f247)
colnames(sd.ci)=paste('n =',c(2,3,4,5,10,25,50,100,500,1000))
t(round(sd.ci,2))
π=P(H0=TRUE)=P(association)は
π=P(HA=TRUE)=P(association)の間違いじゃないだろうか？
xy=rnorm(N)
index=1:N
f254 <- function(r1=5,K=75,PRINT=TRUE){
x0=sample(index,r1) ; y0=sample(index,r1)
PV=numeric()
PV[1]=t.test(xy[x0] , xy[y0])$p.value
x.index=x0 ; y.index=y0
for(i in 2:(K-r1+1)){
add.x=sample(index[-x.index],1)
x.index=append(x.index,add.x)
add.y=sample(index[-y.index],1)
y.index=append(y.index,add.y)
PV[i]=t.test(xy[x.index],xy[y.index])$p.value
i=i+1
}
if(PRINT){
plot(r1:K,PV,type='l',lwd=2, log='y', ylim=c(0.001,1),
xlab='n',ylab='p-value')
abline(h=0.05,lty=3)
}
FPR=mean(PV<0.05)
return(FPR)
}
x11() ; par(mfrow=c(1,1)) ;f254()
x11() ;par(mfrow=c(3,3)) ; replicate(9,f254())
and the resulting P value is plotted at the left of the graph.Then the t test was repeated with one more value added to each group.
Then one more value was added to each group(n=7),and the P value was computed again. This was continued up to n=75.
こういうのを読むと自分でシミュレーションせずにはいられなくなる。
http://i.imgur.com/Y8Tm8Xp.jpg
Rのコードはこれ。
https://egg.5ch.net/test/read.cgi/hosp/1493809494/410
Truth of alternative hypothesis
Significance of test
Significant Not significant Total
True association (1 ) [True positive] [False negative]
No association -
(1 ) [False positive] (1 -
) (1 ) [True negative] 1
Total (1 )-
(1 ) (1 -
) (1 ) 1
440 COMMENTARY Journal of the National Cancer Institute, Vol. 96, No. 6, March 17, 2004
f(5/10)
power.t.test(delta=0.5,power=0.80)$n
# power 50%->80%
dd=seq(0.01,0.99,by=0.01)
g<- function(x) f(x,.50)/f(x,.80)
plot(dd,sapply(dd,g))
(2*(abs(1.96+abs(qnorm(1-0.80))))^2)/(2*(abs(1.96+abs(qnorm(1-0.50))))^2)
(1.96+0.84)^2/(1.96+0)^2
dd=seq(0.01,0.99,by=0.01)
h<-function (x,pow1=0.80,pow2=0.50){
power.t.test(d=x, power=pow1)$n/power.t.test(d=x, power=pow2)$n
}
res=sapply (dd,h)
plot(dd,res)
summary (res)
D=rbeta(N,2,1)
K=rbeta(N,1,2)
par (mfrow=c(2,2))
hist(D)
hist(D-K)
hist (K)
hist(log(D/K))
quantile (D-K, probs=c(0.025,0.5,0.975))
quantile (D/K, probs=c(0.025,0.5,0.975))
summary (D-K)
summary (D/K)
exp(mean (log(D/K)))
median (D/K)
BEST::plotPost (D-K)
BEST::plotPost (D/K)
BEST::plotPost(log(D/K))
D=rbeta(N,2,1)
K=rbeta(N,1,2)
par (mfrow=c(2,2))
hist(D)
hist(D-K)
hist (K)
hist(log(D/K))
quantile (D-K, probs=c(0.025,0.5,0.975))
quantile (D/K, probs=c(0.025,0.5,0.975))
summary (D-K)
summary (D/K)
exp(mean (log(D/K)))
median (D/K)
NNT=1/(D-K)
BEST::plotPost (D-K)
BEST:: plotPost (NNT)
BEST::plotPost (D/K)
BEST::plotPost(log(D/K))
pnorm(-qnorm(.975)-sqrt(n)*delta)+pnorm(qnorm(.975)-sqrt(n)*delta,lower=FALSE)
}
f3.6(0.6,9)
curve (f3.6(x,25),-2,2,xlab=quote(Delta), ylab='power')
curve (f3.6(x,16),add=TRUE)
curve (f3.6(x, 9),add=TRUE)
curve(dchisq(x,9),0,30)
conf.level=0.95
n=10
f <- function(x,df=n-1,conf.level=0.95){
d <- function(d) pchisq(x+d,df) - pchisq(x,df) - conf.level
uniroot(d,c(0,df*3))$root
}
qchisq(1-conf.level,n-1)
low=seq(0,floor(qchisq(1-conf.level,n-1)),by=0.01)
plot(low,sapply(low,f),type='l',lwd=2)
opt=optimise(f,c(0,floor(qchisq(1-conf.level,n-1)))) ; opt
opt[[1]] ; opt[[1]]+opt[[2]]
pchisq(opt[[1]]+opt[[2]],n-1) - pchisq(opt[[1]],n-1)
qchisq(0.025,n-1) ; qchisq(0.975,n-1)
pchisq(qchisq(0.975,n-1),n-1)-pchisq(qchisq(0.025,n-1),n-1)
# 不偏分散の期待値が母分散と一致するからです。
# 定理：E[u2]=σ2
N=1000
n=10
X=rpois(N3)
hist(X)
var(X)
k=10^4
mean(replicate(k,var(sample(X,n))))
VAR <- function(x){
n.x=length(x)
var(x)*(n.x-1)/n.x
}
mean(replicate(k,VAR(sample(X,n))))
sum(dbinom(240:400,400,0.6))
binom.test(240,400,0.6, alt='greater')$p.value
# 6割未満正解 0.478
sum(dbinom(0:239,400,0.6))
binom.test(239,400,0.6,alt='less')$p.value
n=5
# 禁忌枝3個以上選択0.317
binom.test(3,n,1-0.6,alt='g')
sum(dbinom(3:n,n,1-0.6))
0.522*(1-0.317)
# 一般問題を1問1点、臨床実地問題を1問3点とし、
#（1）?（3）のすべての合格基準を満たした者を合格とする。
#（1）必修問題 160点以上/200点
#（2）一般問題及び臨床実地問題 208点以上/299点
#（3）禁忌肢問題選択数 3問以下
p=0.6
binom.test(160,200,p,alt='greater')$p.value
binom.test(200,290,p,alt='greater')$p.value
n=5
一般問題を1問1点、臨床実地問題を1問3点とし、
（1）～（3）のすべての合格基準を満たした者を合格とする。
（1）必修問題 160点以上/200点
（2）一般問題及び臨床実地問題 208点以上/299点
（3）禁忌肢問題選択数 3問以下
来年から400問に減るらしい。
合格基準の正解率は同じ、即ち、(160+208)/499*400=295以上正解を要し、かつ、禁忌肢選択も３問以下とする。
正解率80%の受験生集団の合格率が50%であったとき
禁忌肢問題は何問出題されたか答えよ。
f<-function (n,p){
(a=binom.test(295,400,p,alt='greater')$p.value)
(b=binom.test(n-3,n,p,alt='greater')$p.value)
a*b
}
nn=3:40
p=0.80
plot (nn,sapply(nn, function (n)f(n,p)))
fp.100 <- function(){
N=10^4
phi=sample(1:100,1)
rF=rf(N,phi,Inf)
hist(rF,breaks=25,freq=FALSE,col=sample(colours(),1),main=paste('Φ1 = ',phi1,', Φ2 = Inf'),
xlab=' F ')
curve(df(x,phi,Inf),add=TRUE)
hist(phi*rF,breaks=25,freq=FALSE,col=sample(colours(),1),main=paste('Φ1 = ',phi1,', Φ2 = Inf'),
xlab=' Φ*F ')
curve(dchisq(x,phi),add=TRUE,lwd=2)
}
x11() ; par(mfrow=c(3,3)) ; for(i in 1:9) fp.100()
f <- function (v){
sh=v[1]
sc=v[2]
xof=rgamma(n,sh,sc) # sh: shape, sc: scale
(median(xof)-med)^2+ (qgamma(0.025, sh,sc) - lwr)^2 + (qgamma(0.975,sh,sc) - upr)^2
}
opt=optim (c(shape,scale), f, method='N')$par
print (opt)
curve(dgamma(x,opt [1],opt[2]),0,100)
sim=rgamma (n,opt [1],opt[2])
print(quantile (sim, probs=c(0.025,0.5,0.975)))
invisible (opt)
}
XOF(400,7)
f <- function (v){
sh=v[1]
sc=v[2]
N=10^4
xof=rgamma(N,sh,sc) # sh: shape, sc: scale
(median(xof)-med)^2+ (qgamma(0.025, sh,sc) - lwr)^2 + (qgamma(0.975,sh,sc) - upr)^2
}
opt=optim (c(shape,scale), f, method='N')$par
print (opt)
curve(dgamma(x,opt [1],opt[2]),0,100)
sim=rgamma (n,opt [1],opt[2])
print(quantile (sim, probs=c(0.025,0.5,0.975)))
invisible (opt)
}
xof=XOF(400,7,375,53.5,48.0,58.5)
tam=XOF(400,7,377,53.8,50.2,56.4)
X=rgamma (375,xof[1],xof[2])
T=rgamma (377,tam[1],tam[2])
wilcox.test (X,T)
t.test(X,T)
bss=10^3
f1 <- function (){
XO=sample (X,bss, replace=TRUE)
TA=sample (T,bss, replace=TRUE)
mean(XO-TA)
}
dif=replicate (10^3,f1())
quantile (dif,probs=c(.024,.5,.975))
http://imagizer.imageshack.com/img924/7173/aQ153k.jpg
f <- function (v){
sh=v[1]
sc=v[2]
N=10^4
xof=rgamma(N,sh,sc) # sh: shape, sc: scale
(median(xof)-med)^2+ (qgamma(0.025, sh,sc) - lwr)^2 + (qgamma(0.975,sh,sc) - upr)^2
}
opt=optim (c(shape,scale), f, method='L-BFGS-B')
opt_par=opt$par
print (opt_par)
if(opt$convergence!=0) print(opt)
x11()
curve(dgamma(x,opt_par[1],opt_par[2]),40,70,xlab='time (h)',ylab='',bty='l')
sim=rgamma (n,opt_par[1],opt_par[2])
print(quantile(sim, probs=c(.025,.5,.975)),digits=3)
invisible (opt_par)
}
xof=XOF(400,7,375,53.5,48.0,58.5) ; tam=XOF(1000,20,377,53.8,50.2,56.4)
X=rgamma (375,xof[1],xof[2]) ; T=rgamma (377,tam[1],tam[2])
wilcox.test (X,T)
t.test(X,T)
bss=10^3
f1 <- function (){
XO=sample (X,bss, replace=TRUE)
TA=sample (T,bss, replace=TRUE)
mean(XO-TA)
}
dif=replicate (10^3,f1())
print(quantile (dif,probs=c(.024,.5,.975)),digits=3)
ta=data.frame(n=377,med=53.8,l=50.2,u=56.4)
(xo$l+xo$u)/2 ; (ta$l+ta$u)/2
sqrt(xo$l*xo$u) ; sqrt(ta$l*ta$u)
ci2sd.t <- function(n,L,U){
(U-L)/2/qt(.975,n-1)*sqrt(n)
}
ci2sd.n <- function(n,L,U){
(U-L)/2/qnorm(.975)*sqrt(n)
}
(sd.xo=ci2sd.n(xo$n,xo$l,xo$u)) ; ci2sd.t(xo$n,xo$l,xo$u)
(sd.ta=ci2sd.n(ta$n,ta$l,ta$u)) ; ci2sd.t(ta$n,ta$l,ta$u)
s1=sd.xo ; s2=sd.ta
n1=xo$n ; n2=ta$n
sd=sqrt(((n1-1)*s1^2 + (n2-1)*s2)/(n1 + n2 -2))
sd
# 両側検定
f7.11n <- function(n,delta,alpha=0.05){ # n1 = n2
df=n+n-2
ncp=delta/sqrt(1/n + 1/n) # ⊿= (μ1-μ0)/σ
pt(qt(alpha/2,df),df,ncp)+
pt(-qt(alpha/2,df),df,ncp,lower=FALSE)
}
f7.17n <- function(power,delta,alpha=0.05){
uniroot(function(n)f7.11n(n,delta,alpha)-power,c(3,10^6))$root
}
f7.17n(0.8,0.3/sd)
xo=data.frame(n=375,med=53.5,l=48.0,u=58.5)
ta=data.frame(n=377,med=53.8,l=50.2,u=56.4)
(xo$l+xo$u)/2 ; (ta$l+ta$u)/2
sqrt(xo$l*xo$u) ; sqrt(ta$l*ta$u)
ci2sd.t <- function(n,L,U){
(U-L)/2/qt(.975,n-1)*sqrt(n)
}
ci2sd.n <- function(n,L,U){
(U-L)/2/qnorm(.975)*sqrt(n)
}
(sd.xo=ci2sd.t(xo$n,xo$l,xo$u)) ; ci2sd.n(xo$n,xo$l,xo$u)
(sd.ta=ci2sd.t(ta$n,ta$l,ta$u)) ; ci2sd.n(ta$n,ta$l,ta$u)
s1=sd.xo ; s2=sd.ta
n1=xo$n ; n2=ta$n
sd=sqrt(((n1-1)*s1^2 + (n2-1)*s2)/(n1 + n2 -2))
sd
f7.11n <- function(n,delta,alpha=0.05){ # n1 = n2
df=n+n-2
ncp=delta/sqrt(1/n + 1/n) # ⊿= (μ1-μ0)/σ
pt(qt(alpha/2,df),df,ncp)+
pt(-qt(alpha/2,df),df,ncp,lower=FALSE)
}
f7.17n <- function(power,delta,alpha=0.05){
uniroot(function(n)f7.11n(n,delta,alpha)-power,c(3,10^6))$root
}
f7.17n(0.8,0.3/sd)
# 片側検定 H1: mean(xo) < mean(ta)
f7.16n <- function(n,delta,alpha=0.05){ # n1=n2
df=n+n-2
ncp=delta/sqrt(1/n+1/n) # ⊿= (μ1-μ0)/σ
pt(qt(alpha,df),df,ncp)
}
f7.19n <- function(power,delta,alpha=0.05){
uniroot(function(n)f7.16n(n,delta,alpha)-power,c(3,10^6))$root
}
f7.19n(0.80,-0.3/sd)
pl=c(230,med=80.2,72.6,87.1)
n1=xo[1] ;n2=pl[1]
ci2sd.t <- function(n,L,U){
(U-L)/2/qt(.975,n-1)*sqrt(n)
}
ci2sd.n <- function(n,L,U){
(U-L)/2/qnorm(.975)*sqrt(n)
}
pooled.sd <- function(sd1,sd2,n1,n2){
sqrt((sd1^2*(n1-1)+sd2^2*(n2-1))/(n1+n2-2))
}
sd1=ci2sd.t(n1,xo[3],xo[4]) ; sd1
sd2=ci2sd.t(n2,pl[3],pl[4]) ; sd2
sd.p=pooled.sd(sd1,sd2,n1,n2) ; sd.p
pwr::pwr.t2n.test(n1,n2,d=-26.5/sd.p,alt='less')
pwr::pwr.t2n.test(n1=NULL,n2=n2,d=-26.5/sd.p,power=0.80,alt='less')
# t検定(生データなし,等分散不問,両側検定)
Welch.test=function(n1,n2,m1,m2,sd1,sd2){
T=(m1-m2)/sqrt(sd1^2/n1+sd2^2/n2)
df=(sd1^2/n1+sd2^2/n2)^2 / (sd1^4/n1^2/(n1-1)+sd2^4/n2^2/(n2-1))
p.value=2*pt(abs(T),df,lower.tail = FALSE)
return(p.value)
}
m1=(xo[3]+xo[4])/2 ; m2=(pl[3]+pl[4])/2
Welch.test(n1,n2,m1,m2,sd1,sd2)
T=(m1-m2)/sqrt(sd1^2/n1+sd2^2/n2)
df=(sd1^2/n1+sd2^2/n2)^2 / (sd1^4/n1^2/(n1-1)+sd2^4/n2^2/(n2-1))
pt(T,df)
FPRPP <- function(r1,r2,n1,n2, prior=0.5){
p.value=prop.test(c(r1,r2),c(n1,n2))$p.value
p1=r1/n1
p2=r2/n2
h=pwr::ES.h(p1,p2)
power=pwr::pwr.2p2n.test(h=h,n1=n1,n2=n2,sig.level=p.value)$power
FP=(1-prior)*p.value # p-less-than case
TP=prior*power
c(p.value=p.value,'false positive rate' = FP/(TP+FP))
}
p.value=fisher.test(matrix(c(r1,n1-r1,r2,n2-r2),2))$p.value
p1=r1/n1
p2=r2/n2
power=statmod::power.fisher.test(p1,p2,n1,n2,alpha=p.value)
FP=(1-prior)*p.value
TP=prior*power
c(p.value=p.value,'false positive rate' = FP/(TP+FP))
}
r1=18;n1=18;r2=6;n2=18
FPRPP.F(r1,r2,n1,n2,0.5)
p.value false positive rate
2.966259e-05 8.016273e-05
f9.22 <- function(k){
mui=runif(k)
X2.dash=0
f <- function(){
for(i in 1:k){
X2.dash=X2.dash+rnorm(1,mui[i])^2
}
return(X2.dash)
}
chisq.dash=replicate(10^3,f())
hist(chisq.dash,freq=FALSE,col=sample(colours(),1),xlab=quote(chi),main='')
ncp=sum(mui^2)
curve(dchisq(x,k,ncp),add=TRUE,lwd=2)
}
graphics.off()
x11() ; par(mfrow=c(3,3)) ; for(i in 1:9) f9.22(sample(3:10,1))
fp.142c <- function(n){
mui=rnorm(n)
sigma=runif(1)
mu=mean(mui)
xi=numeric(n)
f <- function(){
for(i in 1:n) xi[i]=rnorm(1,mui[i],sigma)
S=var(xi)*(n-1)
S/sigma^2
}
chisq.dash=replicate(10^3,f())
hist(chisq.dash,freq=FALSE,col=sample(colours(),1),xlab=quote(chi),main='')
ncp=sum((mui-mu)^2/sigma^2)
curve(dchisq(x,n,ncp),add=TRUE,lwd=2)
}
graphics.off()
fp.142c(7)
x11() ; par(mfrow=c(3,3)) ; for(i in 1:9) fp.142c(sample(3:10,1))
graphics.off()
graphics.off()
x11()
par(mfrow=c(2,1))
hist(FUN(n),col='skyblue',freq=FALSE)
dat=replicate(k,FUN(n))
hist(apply(dat,1,sum),col=sample(colours(),1),freq=FALSE)
}
clt(FUN=function(x) rbeta(x,0.5,0.5))
clt(FUN=function(x) rexp(x))
clt(FUN=function(x) rgamma(x,1,1))
Black=c(6.3772, 29, 1.4262)
Other=c(12.0832, 37, 3.7964)
# Totalc(3.6351 313 3.9770)
dat=rbind(White,Black,Other)
colnames(dat)=c("Mean","N","SD")
mean.G=sum(dat[,"Mean"]*dat[,"N"])/sum(dat[,"N"])
SS.bit=sum((dat[,"Mean"]-mean.G)^2*dat[,"N"])
SS.wit=sum(dat[,"SD"]^2*(dat[,"N"]-1))
df.bit=nrow(dat)-1
df.wit=sum(dat[,"N"]-1)
MS.bit=SS.bit/df.bit
MS.wit=SS.wit/df.wit
F.ratio=MS.bit/MS.wit
pf(F.ratio,df.bit,df.wit,lower.tail=FALSE)
(η2=(SS.bit)/(SS.bit+SS.wit))
Mean=dat[,'Mean'] ; N=dat[,'N'] ; SD=dat[,'SD']
sqrt(sum((N-1)*SD^2 + N*(Mean-sum(Mean*N)/sum(N))^2)/(sum(N)-1))
total.SD <- function(Mean,N,SD) sqrt(sum((N-1)*SD^2 + N*(Mean-sum(Mean*N)/sum(N))^2)/(sum(N)-1))
(uniroot(function(x) total.Mean(c(60,65,x),c(20,5,95)) - 45,c(0,100))$root)
total.Mean(c(60,65,40.79),c(20,5,95))
(uniroot(function(x) total.SD(c(60,65,40.79),c(20,5,95),c(3,2,x)) - 10 , c(0,100))$root)
total.SD(c(60,65,40.79),c(20,5,95),c(3,2,6.13))
辞退者=c(60,20,3)
特待生=c(65, 5, 2)
裏口バカ=c(40.79, 95, 6.13)
# Totalc(45 120 10)
dat=rbind(辞退者,特待生,裏口バカ)
colnames(dat)=c("Mean","N","SD")
mean.G=sum(dat[,"Mean"]*dat[,"N"])/sum(dat[,"N"])
SS.bit=sum((dat[,"Mean"]-mean.G)^2*dat[,"N"])
SS.wit=sum(dat[,"SD"]^2*(dat[,"N"]-1))
df.bit=nrow(dat)-1
df.wit=sum(dat[,"N"]-1)
MS.bit=SS.bit/df.bit
MS.wit=SS.wit/df.wit
(F.ratio=MS.bit/MS.wit)
pf(F.ratio,df.bit,df.wit,lower.tail=FALSE)
(η2=(SS.bit)/(SS.bit+SS.wit)) # eta^2
> pf(F.ratio,df.bit,df.wit,lower.tail=FALSE)
[1] 2.789672e-30
> (η2=(SS.bit)/(SS.bit+SS.wit)) # eta^2
[1] 0.687539
>
特待=scale(rnorm(5))*2+65
裏口=scale(rnorm(95))*6.1+40.79
score=c(辞退,特待,裏口)
group=c(rep('辞退',20),rep('特待',5),rep('裏口',95))
boxplot(score~group)
data=data.frame(score,group)
res=aov(score~group)
re=summary(res) ; re
str(re)
re2=re[[1]] ; re2
F.ratio=(re2$`Sum Sq`[1]/re2$`Df`[1])/(re2$`Sum Sq`[2]/re2$`Df`[2]) ; F.ratio
pf(F.ratio,re2$Df[1],re2$Df[2],lower.tail = FALSE)
Jonckheere<-function(L){
f<-function(A,B){
a<-length(A)
b<-length(B)
det<-0
for(i in 1:a){
for(j in 1:b){
det<- det+ifelse(A[i]==B[j],0.5,A[i]>B[j])
}
}
return(det)
}
g<-function(L){ #L=list(A1,,,,Aa),A1 > A2 > A3,..,> Aa : vector
a<-length(L)
comb<-combn(1:a,2)
con<-ncol(comb)
J=0
for(i in 1:con){
J<-J+f(L[[comb[1,i]]],L[[comb[2,i]]])
}
return(J)
}
a<-length(L)
n=double(a)
for(i in 1:a){
n[i]<-length(L[[i]])
}
N<-sum(n)
EJ <- (N^2-sum(n^2))/4
VJ <- (N^2*(2*N+3)-sum(n^2*(2*n+3)))/72
Z <- abs(J-EJ)/sqrt(VJ)
p.value<-pnorm(Z,lower.tail=FALSE)
return(p.value)
}
辞退=scale(rnorm(20))*3+60
裏口=scale(rnorm(95))*6.1+40.79
score=c(特待,辞退,裏口)
group=as.factor(c(rep(1,5),rep(2,20),rep(3,95)))
levels(group) <- c('特待','辞退','裏口')
boxplot(score~group)
data=data.frame(score,group)
res=aov(score~group)
re=summary(res) ; re
str(re)
re2=re[[1]] ; re2
F.ratio=(re2$`Sum Sq`[1]/re2$`Df`[1])/(re2$`Sum Sq`[2]/re2$`Df`[2]) ; F.ratio
pf(F.ratio,re2$Df[1],re2$Df[2],lower.tail = FALSE)
oneway.test(score~group)
kruskal.test(score~group,data=data)
Tk=TukeyHSD(aov(score~group,data=data)) ; Tk[[1]]
pairwise.t.test(score,group)
pairwise.t.test(score,group,p.adj='none')
pairwise.t.test(score,group,p.adj='bon')
pairwise.t.test(score,group,p.adj='bon',pool.sd = FALSE)
pairwise.wilcox.test(score,group)
#
library(PMCMR)
jonckheere.test(data$score,data$group,alternative = 'dec')
＝ BF*PO/(BF*PO+1) BF = Pr(ｙ｜H0)/Pr(y | H1) : Bayes factor PO = π0/(1-π0) the prior odds of no association(true null hypothesis)
Pr(H0|y) < (Cβ/Cα)/(1+(Cβ/Cα))
A Bayesian Measure of the Probability of False Discovery
in Genetic Epidemiology Studies
Pr(H0|y) < (Cβ/Cα)/(1+(Cβ/Cα))
が成立するとのこと。
A Bayesian Measure of the Probability of False Discovery
in Genetic Epidemiology Studies
P.hat=x/n
if((!Ignore)&(n*P.hat<5 | n*(1-P.hat)<5 | n*P0<5 | n*(1-P0)<5)){
warning('unfit for asymptotics')
return(NA)
}
u0= (P.hat-P0)/(sqrt(P0*(1-P0)/n))
p.value=pnorm(-abs(u0))
data.frame(u0,p.value)
}
> f.nxP0(x=3,n=100,P0=0.10)
[1] NA
Warning message:
In f.nxP0(x = 3, n = 100, P0 = 0.1) : unfit for asymptotics
> f.nxP0(3,100,0.10,Ignore=TRUE)
u0 p.value
1 -2.333333 0.009815329
x = 2 # of white balls drawn (<=m)
m = 6 # of white balls in urn
n = 4 # of black balls in urn
k = 5 # drawn
sum(dhyper(0:k,m,n,k)[dhyper(0:k,m,n,k)<=dhyper(x,m,n,k)])
fisher.test(matrix(c(x,k-x,m-x,n-k+x),ncol=2,byrow=TRUE))$p.value
?dhyper
x=2
wd=x # white drawn : x < td (= k)
wu=6 # white in urn : m
bu=4 # blac in urn : n
td=5 # total drawn : k
wd2p <- function(wd) dhyper(wd,wu,bu,td) #white drawn to probability
(probs=sapply(0:td,wd2p))
plot(0:td,probs,type='h')
sum(probs[probs<=wd2p(x)])
fisher.test(matrix(c(wd,td-wd,wu-wd,bu-(td-wd)),ncol=2,byrow=TRUE))$p.value
td=4
(probs=sapply(0:td,wd2p))
plot(0:td,probs,type='h')
wd=1
sum(probs[probs<=wd2p(wd)])
fisher.test(matrix(c(wd,td-wd,wu-wd,bu-(td-wd)),ncol=2,byrow=TRUE))$p.value
fisher.test(ex1)
exact2x2::fisher.exact(ex1)
exposure a b
no exposure c d
OR=(a/c)/(b/d) = ad/bc ; ad=bc*OR
RR=a/(a+b) ÷ c/(c+d)=a(c+d)÷c(a+b)=(ac+ad)/(ac+bc)
=(ac+bc*OR)/(ac+bc)
=(b*OR+a)/(a+b)
=OR*b/(a+b)+a/(a+b)
=OR*( 1-a/(a+b) ) + a/(a+b)
=OR*(1-P1) + P1 # P1:暴露群でのイベント発生率=a/(a+b)
exposure a b
no exposure c d
OR=(a/c)/(b/d) = ad/bc ; bc=ad/OR
RR=a/(a+b) ÷ c/(c+d)=a(c+d)÷c(a+b)=(ac+ad)/(ac+bc)
=(ac+ad)/(ac+ad/OR)
=(c+d) /(c + d/OR) # (c+d) で割る
=1 / {c/(c+d) + d/[(c+d)/OR]}
=OR/{OR*c/(c+d) + d/(c+d)} # ORを掛ける
=OR/{OR*c/(c+d) + (c+d)/(c+d)-c/(c+d)}
=OR/(OR*P0 + 1-P0) # P0:非暴露群でのイベント発生率=c/(c+d)
####
RR=OR*(1-P1) + P1
OR=(RR-P1)/(1-P1) # P1:暴露群でのイベント発生率=a/(a+b)
RR=OR/(OR*P0 + 1-P0)
OR=(1-P0)*RR/(1-P0*RR) # P0:非暴露群でのイベント発生率=c/(c+d)
####
OR2RRp0=function(OR,p0) OR/(OR*p0+1-p0) #p0:非暴露群でのイベント発生率
OR2RRp1=function(OR,p1) OR*(1-p1)+p1 #P1:暴露群でのイベント発生率
RR=OR*(1-P1) + P1
OR=(RR-P1)/(1-P1) # P1:暴露群でのイベント発生率=a/(a+b)
P1=(OR-RR)/(OR-1)
RR=OR/(OR*P0 + 1-P0)
OR=(1-P0)*RR/(1-P0*RR) # P0:非暴露群でのイベント発生率=c/(c+d)
P0=(OR-RR)/(OR-1)/RR
RR2ORp1 <- function(RR,P1) (RR-P1)/(1-P1) # P1:暴露群でのイベント発生率=a/(a+b)
RR2ORp0 <- function(RR,P0) (1-P0)*RR/(1-P0*RR) # P0:非暴露群でのイベント発生率=c/(c+d)
R2p1 <- function(RR,OR) (OR-RR)/(OR-1)
R2p0 <- function(RR,OR) (OR-RR)/(OR-1)/RR
# 身長は170cmか，150cmのどちらかである。
# 身長170cmの人の胸囲は90cm, 身長150cmの人の胸囲は75cm．
# そして，胸囲90cmの人は確率0.9でクラス1へ，確率0.1でクラス2に振り分けられる.
# 一方で，胸囲75cmの人は確率0.8でクラス2へ，確率0.2でクラス1に振り分けられる.
# そして，胸囲が90cmと75cmの人はそれぞれ30,70人である。
# クラス1とクラス2の胸囲調整済み平均身長を求めよ。
# Class1
(170*30*0.9 + 150*70*0.2)/(30*0.9 + 70*0.2) # 27+14人
mean(c(rep(170,30*0.9),rep(150,70*0.2)))
# Class2
(170*30*0.1 + 150*70*0.8)/(30*0.1 + 70*0.8) # 3+56人
mean(c(rep(170,30*0.1),rep(150,70*0.8)))
# average
mean(c(rep(170,30),rep(150,70)))
# Inverse Probability Weighting(IPW)
# Class 1 adjusted
(170*1/0.9*27 + 150*1/0.2*14)/sum(1/0.9*27+1/0.2*14)
weighted.mean(c(rep(170,30*0.9),rep(150,70*0.2)),c(rep(1/0.9,30*0.9),rep(1/0.2,70*0.2)))
# Class 2 adjusted
(170*1/0.1*3 + 150*1/0.8*56)/sum(1/0.1*3+1/0.8*56)
weighted.mean(c(rep(170,30*0.1),rep(150,70*0.8)),c(rep(1/0.1,30*0.1),rep(1/0.8,70*0.8)))
IPW8 <- function(Y,Tr,ps) weighted.mean(Y,Tr/ps) # Y:dead or alive, Tr:treated or control, ps:propensity score
IPW8(Y,Tr,ps) - IPW8(Y,1-Tr,1-ps)
library(MatchLinReg)
data("lindner")
head(lindner)
formula.stent=stent ~ abcix + height + female + diabetic + acutemi + ejecfrac + ves1proc-1
re.glm=glm(stent ~ abcix + height + female + diabetic + acutemi +ejecfrac + ves1proc-1,family=binomial,data=lindner)
summary(re.glm)
Epi::ROC(form=stent~.-1,data=lindner)$AUC
rms::lrm( stent ~ abcix + height + female + diabetic + acutemi +
ejecfrac + ves1proc, data=lindner)$stat['C']
ps=re.glm$fitted.values
Y=lindner$lifepres
Tr=lindner$stent
weighted.mean(Y,Tr/ps) - weighted.mean(Y,(1-Tr)/(1-ps))
m.out=Match(Y,Tr,ps)
summary(m.out)
## (Doubly Robust: DR)
n <- nrow(lindner)
y <- lindner['lifepres']
z <- lindner['stent']
lindner1 <- lindner[lindner['stent']==1,]
lindner0 <- lindner[lindner['stent']==0,]
model1=lm(formula=lifepres ~ abcix + height + female + diabetic
+ acutemi +ejecfrac + ves1proc, data=lindner1)
model0=lm(formula=lifepres ~ abcix + height + female + diabetic
+ acutemi +ejecfrac + ves1proc, data=lindner0)
fitted1 <- predict(model1, lindner)
fitted0 <- predict(model0, lindner)
dre1 <- (1/n)*sum(y+((z-ps)/ps)*(y-fitted1))
dre0 <- (1/n)*sum(((1-z)*y)/(1-ps)+(1-(1-z)/(1-ps))*fitted0)
c(treated=dre1,control=dre0,ATE=dre1-dre0)
#
interval = seq(0,1,by=caliper)
n=length(interval)
res = numeric(n)
for(i in 1:(n-1)){
temp0 = Y[ (Tr==0) & (interval[i]<X) & (X<interval[i+1]) ]
temp1 = Y[ (Tr==1) & (interval[i]<X) & (X<interval[i+1]) ]
res[i] = mean(temp1) - mean(temp0)
}
mean(res,na.rm=TRUE)
}
match0(Y=lindner$lifepres,Tr=lindner$stent,X=ps)
summary(Match(Y=lindner$lifepres,Tr=lindner$stent,X=ps, caliper=0.05))
MatchBalance(formula.stent,data=lindner)
臨床統計のRスクリプトを公開するスレ。
上記の相対リスク＝1.82を論文記載の対照群のリスク（36人/10万人）等を基に有意なエビデンスとして検出するには約19万人を対象とする臨床試験が必要です。
WHOにより検証された世界の質の高い臨床試験の総人数が7万3697人）であることを考えると，現時点で因果関係を高い質で問うのは困難であるとわかります
https://www.igaku-shoin.co.jp/paperDetail.do?id=PA03259_04
とあるが、
俺の計算では（Rのpackage、Epiで計算）
各群約46000人で
p=0.05
Relative Risk: 1.8200 1 3.3125
> Epi::twoby2(mat)
2 by 2 table analysis:
------------------------------------------------------
Outcome : Col 1
Comparing : Row 1 vs. Row 2
Col 1 Col 2 P(Col 1) 95% conf. interval
Row 1 30.1927 46051.50 7e-04 5e-04 9e-04
Row 2 16.5894 46065.11 4e-04 2e-04 6e-04
95% conf. interval
Relative Risk: 1.8200 1 3.3125
Sample Odds Ratio: 1.8205 1 3.3144
Probability difference: 0.0003 0 0.0006
Asymptotic P-value: 0.05
------------------------------------------------------
>
# 相対リスク＝1.82を論文記載の対照群のリスク（36人/10万人）
# 1.82（95％信頼区間0.79-4.20）
rr=1.82
r0=36/10^5
r1=rr*r0
nn=seq(10^4,10^5,by=100)
rr2p.e <- function(n){
Epi::twoby2(matrix(c(n*r1,n*r0,n-n*r1,n-n*r0),ncol=2),print=FALSE)$p.value
}
plot(nn,sapply(nn,rr2p.e),type='l') ; abline(h=0.05, lty=3)
n=uniroot(function(n) rr2p.e(n)-0.05, c(10^4,10^5))$root
mat=matrix(c(n*r1,n*r0,n-n*r1,n-n*r0),ncol=2)
Epi::twoby2(mat)
time=c(2,6,12,54,56,68,89,96,96,125,128,131,140,141,143,145,146,148,162,168,173,181)
y=c(21/22,20/21,19/20,18/19,1,16/17,15/16,14/15,13/14,1,1,1,1,1,7/8,1,5/6,1,1,2/3,1,1)
survival=cumprod(y)
plot(time,survival,type='S',ylim=c(0,1))
censored=c(0,0,0,0,1,0,0,0,0,1,1,1,1,1,0,1,0,1,1,0,1,1)
event=1-censored
library(survival)
Surv(time,event)
plot(survfit(Surv(time,event)~1))
打ち切りポイントも描画できるように変更。
time=c(2,6,12,54,56,68,89,96,96,125,128,131,140,141,143,145,146,148,162,168,173,181)
y=c(21/22,20/21,19/20,18/19,1,16/17,15/16,14/15,13/14,1,1,1,1,1,7/8,1,5/6,1,1,2/3,1,1)
survival=cumprod(y)
censored=c(0,0,0,0,1,0,0,0,0,1,1,1,1,1,0,1,0,1,1,0,1,1)
plot(time,survival,type='s',ylim=c(0,1))
for(i in 1:22) if(censored[i]) points(time[i],survival [i],pch='+')
# サンプルサイズと分散が同等な正規分布する集団からの無作為抽出で標本平均±標準誤差区間が重ならないときは母平均の有意差有無の判断はできない。
N=1000
f <- function(mx){
set.seed(123)
x1=rnorm(N,0 ,1)
x2=rnorm(N,mx,1)
t.test(x1,x2,var.equal = TRUE)$p.value
}
xx=seq(0,0.5,length=1000)
plot(xx,sapply(xx,f))
abline(h=0.05,lty=3)
uniroot(function(x) f(x)-0.05,c(0,1))$root
mx=0.0615 # 0.615以上で有意
g <- function(mx){
set.seed(123)
x1=rnorm(N,0 ,1)
x2=rnorm(N,mx,1)
n1=length(x1) ; n2=length(x2)
m1=mean(x1) ; m2=mean(x2)
s1=sd(x1) ; s2=sd(x2)
se1=s1/sqrt(n1) ; se2=s2/sqrt(n1)
(m1+se1) > (m2-se2) # overlap?
}
xx=seq(0,0.5,length=1000)
plot(xx,sapply(xx,g))
abline(h=0,lty=3)
uniroot(g,c(0,1))$root # non-overlap には0.0369以上
f(0.07) # 有意差あり
g(0.07) # overlapなし
f(0.05) # 有意差なし
g(0.05) # overlapなし
# サンプルサイズと分散が同等な正規分布する集団からの無作為抽出で
# 標本平均±標準誤差区間が重なるときは母平均に有意差はない。
##
# サンプルサイズと分散が同等な正規分布する集団からの無作為抽出で
# 標本平均±標準誤差区間が重なるときは母平均に有意差はない(p>0.05)。
#
x1=rnorm(n,m1,s)
x2=rnorm(n,m2,s) # m1 < m2
t.stat=(m1-m2)/(sqrt(2/n)*s) # < 0
=(m1-m2)*sqrt(n)/(sqrt(2)*s)
m1 + se > m2 -se # overlap
m1 - m2 > -2*se = -2*s/sqrt(n)
m1 - m2 = t.stat*(sqrt(2)*s)/sqrt(n) > -2*s/sqrt(n)
t.stat > -2/sqrt(2)=-sqrt(2)
df=198 # 例
curve(pt(x,df),-5,0) # x < 0で増加関数
pt(t.stat,df) > pt(-sqrt(2),df)
pt(-sqrt(2),df)
# dfを変化させる
curve(pt(-sqrt(2),x),200,ylim=c(0,0.5),xlab='df',ylab='p.value',lwd=2)
abline(h=0.05,lty=3)
pt(-sqrt(2),Inf) ; pnorm(-sqrt(2))
text(0,0.05,'0.05')
set.seed(123)
x1=rnorm(100,0 ,1)
x2=rnorm(100,0.3 , 1)
t.test(x1,x2,var.equal = TRUE)$p.value # > 0.05
t.test(x1)$conf[2] > t.test(x2)$conf[1] # overlap TRUE
plot(NULL,NULL,ylim=c(0,0.05),xlim=c(-0.75,0.75),yaxt='n',ann=FALSE,bty='l')
segments(t.test(x1)$conf[1],0,t.test(x1)$conf[2],0,lwd=5,col=1)
segments(t.test(x2)$conf[1],0.01,t.test(x2)$conf[2],0.01,lwd=5,col=2)
set.seed(123)
x1=rnorm(100,0 ,1)
x2=rnorm(100,0.5 ,1)
t.test(x1,x2,var.equal = TRUE)$p.value # < 0.05
t.test(x1)$conf[2] > t.test(x2)$conf[1] # overlap TRUE
plot(NULL,NULL,ylim=c(0,0.05),xlim=c(-0.75,0.75),yaxt='n',ann=FALSE,bty='l')
segments(t.test(x1)$conf[1],0,t.test(x1)$conf[2],0,lwd=5,col=1)
segments(t.test(x2)$conf[1],0.01,t.test(x2)$conf[2],0.01,lwd=5,col=2)
SE12=sqrt((1/n+1/n)*((n-1)*var1+(n-1)*var2)/((n-1)+(n-1)))
T=dm/SE12
2*pt(abs(T),n-1+n-1,lower.tail = FALSE)
}
m1-m2=dm
n1=n2=n
T.test3=function(n,dm,var1,var2){
SE12=sqrt((2/n)*(var1+var2)/2))
T=dm/SE12
2*pt(abs(T),n-1+n-1,lower.tail = FALSE)
}
T.test4=function(x,n=1000,dm=1,var1=1){
SE=sqrt((2/n)*(var1+x)/2)
T=dm/SE
2*pt(abs(T),n-1+n-1,lower.tail = FALSE)
}
curve(T.test4(x),0,100,xlab='variance=x against variance=1',ylab='p.value')
Welch.test=function(n1,n2,m1,m2,var1,var2){
T=(m1-m2)/sqrt(var1/n1+var2/n2)
df=(var1/n1+var2/n2)^2 / (var1^2/n1^2/(n1-1)+var2^2/n2^2/(n2-1))
p.value=2*pt(abs(T),df,lower.tail = FALSE)
return(p.value)
}
n1=n2=n
m1-m2=dm
var2=x
Welch.test2=function(x,n=1000,dm=1,var1=1){
T=dm/sqrt(var1/n+x/n)
df=(var1/n+x/n)^2 / (var1^2/n^2/(n-1)+x^2/n^2/(n-1))
p.value=2*pt(abs(T),df,lower.tail = FALSE)
return(p.value)
}
curve(Welch.test2(x),0,100,xlab='variance=x against variance=1',ylab='p.value')
n1=40
n2=60
SDR=10
set.seed(1234)
A=scale(rnorm(N))
B=scale(rnorm(N))*SDR
f2.b <- function(){
a=sample(A,n1)
b=sample(B,n2)
t.test(a,b, var=TRUE)$p.value
}
p.t=replicate (10^4,f2.b())
hist (p.t)
f2.bW <- function(){
a=sample(A,n1)
b=sample(B,n2)
t.test(a,b, var=FALSE)$p.value
}
p.W=replicate (10^4,f2.bW())
hist (p.W)
n1=40
n2=60
SDR=1
set.seed(1234)
A=scale(rnorm(N))
B=scale(rnorm(N))*SDR
f2.b <- function(){
a=sample(A,n1)
b=sample(B,n2)
t.test(a,b, var=TRUE)$p.value
}
p.t=replicate (10^4,f2.b())
hist (p.t)
f2.bW <- function(){
a=sample(A,n1)
b=sample(B,n2)
t.test(a,b, var=FALSE)$p.value
}
p.W=replicate (10^4,f2.bW())
hist (p.W)
n1=40
n2=60
SDR=1
dm=0.1
set.seed(1234)
A=scale(rnorm(N))
B=scale(rnorm(N))*SDR+dm
f2.b <- function(){
a=sample(A,n1)
b=sample(B,n2)
t.test(a,b, var=TRUE)$p.value
}
p.t=replicate (10^4,f2.b())
hist (p.t)
f2.bW <- function(){
a=sample(A,n1)
b=sample(B,n2)
t.test(a,b, var=FALSE)$p.value
}
p.W=replicate (10^4,f2.bW())
hist (p.W)
SE12=sqrt((1/n1+1/n2)*((n1-1)*var1+(n2-1)*var2)/((n1-1)+(n2-1)))
T=dm/SE12
2*pt(abs(T),n1-1+n2-1,lower.tail = FALSE)
}
curve(T.test4(x,40,160,0.1),0,100,xlab='variance=x against variance=1',ylab='p.value')
# Why Psychologists Should by Default Use Welch’s t-test
# Instead of Student’s t-test
par(mfrow=c(2,1))
N=1000
n1=10
n2=90
SDR=10
dm=1
k=10^4
set.seed(1234)
A=scale(rnorm(N))
B=scale(rnorm(N))*SDR+dm
f2.b <- function(){
a=sample(A,n1)
b=sample(B,n2)
t.test(a,b, var=TRUE)$p.value
}
p.t=replicate (k,f2.b())
hist (p.t,main='Student\'s t.test',col=sample(colours(),1))
mean(p.t < 0.05) # power(when dm!=0) or Type I error(when dm=0)
f2.bW <- function(){
a=sample(A,n1)
b=sample(B,n2)
t.test(a,b, var=FALSE)$p.value
}
p.W=replicate (k,f2.bW())
hist (p.W,main='Welch\'s t.test',col=sample(colours(),1))
mean(p.W < 0.05) # power(when dm!=0) or Type I error(when dm=0)
https://www.rips-irsp.com/articles/10.5334/irsp.82/
に触発されてシミュレーションの条件（サンプルサイズや分散比）を変えて追試してみた。
結果にびっくり
http://i.imgur.com/f9CMZ6I.jpg
あたかもド底辺シリツ医大卒を最高学府を履修したと呼ぶほどの差異に等しい。
Welchのrobustnessに再度感銘した。
N=1000
n1=50
n2=25
SDR=5
dm=0 # null hypothesis is true when dm==0
k=10^4
set.seed(123)
A=scale(rnorm(N))
B=scale(rnorm(N))*SDR+dm
f2.b <- function(){
a=sample(A,n1)
b=sample(B,n2)
t.test(a,b, var=TRUE)$p.value
}
p.t=replicate (k,f2.b())
hist (p.t,main='Student\'s t.test',col=sample(colours(),1),
xlab=paste('n1 = ',n1,', sd1 = 1 ; n2 = ',n2,' , sd2 = ',SDR))
mean(p.t < 0.05) # power(when dm!=0) or Type I error(when dm=0)
f2.bW <- function(){
a=sample(A,n1)
b=sample(B,n2)
t.test(a,b, var=FALSE)$p.value
}
p.W=replicate (k,f2.bW())
hist (p.W,main='Welch\'s t.test',col=sample(colours(),1),
xlab=paste('n1 = ',n1,', sd1 = 1 ; n2 = ',n2,' , sd2 = ',SDR))
mean(p.W < 0.05) # power(when dm!=0) or Type I error(when dm=0)
y=relax=c(2.6,10.5,15.8,21.1,36.8,57.9,73.7,89.5,94.7,100.0,100.0)
(re.nls=nls(y ~ Top/(1+10^((LogEC50-x)*HillSlope)),
start=c(Top=100,LogEC50=-5,HillSlope=1),algo='port'))
nls2R2(re.nls,y)
plot(x,y,bty='l',pch=19)
lines(x,predict(re.nls))
#
R2 <- function(dat){
n = nrow(dat)
sm = summary(
nls(dat$y ~ Top/(1+10^((LogEC50-dat$x)*HillSlope)),
start=c(Top=100,LogEC50=-5,HillSlope=0.5),algorithm = 'port')
)
SSalt = sum(sm$residuals^2)
SSnull = var(dat$y)*(n-1)
Rsq=1-SSalt/SSnull
Rsq
# k=sm$df[1]
# AdjRsq=1-(1-Rsq)*(n-1)/(n-k-1)
# data.frame(Rsq,AdjRsq)
}
xy=data.frame(x,y)
R2(xy)
library(boot)
re=boot(xy,function(data,indices) R2(data[indices,]),R=1000)
re$t0
BEST::plotPost(re$t) ; HDInterval::hdi(re$t)
quantile(re$t,c(.025,.975))
nls2R2(re.nls,y)
min( pf(summary(lm)$fstatistic[1],
summary(lm)$fstatistic[2],summary(lm)$fstatistic[2],lower=FALSE),
pf(summary(lm)$fstatistic[1],
summary(lm)$fstatistic[2],summary(lm)$fstatistic[2] )
lm2p <- function(lm){ # p_value=anova(lm)$Pr[1]
f=summary(lm)$fstatistic
min(
pf(f[1],f[2l,f[3],lower=FALSE),
pf(f[1],f[2l,f[3])
)
}
ｎｏｉｓｅ２ｓｉｇ ＜－ ｆｕｎｃｔｉｏｎ（ｓｅｅｄ，ｓｅｑｕｅｎｔｉａｌ＝ＦＡＬＳＥ）｛
ｓｅｔ．ｓｅｅｄ（ｓｅｅｄ）
Ｎｏｉｓｅ＝ｍａｔｒｉｘ（ｒｎｏｒｍ（１００＊５１），ｎｃｏｌ＝５１，ｎｒｏｗ＝１００）
＃ ｆｉｒｓｔ ｐａｓｓ
ｌｍ１＝ｌｍ（Ｎｏｉｓｅ［，５１］ ～ Ｎｏｉｓｅ［，－５１］） ＃ Ｎｏｉｓｅ［，５１］ ： 目的変数Ｙ
ｃａｔ（＇\ｎＲ２ （１ｓｔ） ＝ ＇，ｓｕｍｍａｒｙ（ｌｍ１）＄ｒ．ｓｑｕａｒｅｄ）
ｃａｔ（＇\ｎｐ．ｖａｌｕｅ （１ｓｔ） ＝ ＇，ａｎｏｖａ（ｌｍ１）＄Ｐｒ［１］）
ｃｏｅｆｓ１＝ｓｕｍｍａｒｙ（ｌｍ１）＄ｃｏｅｆ［，＇Ｐｒ（＞｜ｔ｜）＇］
ｌｅｎｇｔｈ（ｃｏｅｆｓ１）
ｃｏｅｆｓ１［１］
ｃｏｅｆｆｓ１＝ｃｏｅｆｓ１［－１］
ｃａｔ（＇\ｎｃｏｅｆ ＜ ０．２５ ＝＇，ｓｕｍ（ｃｏｅｆｆｓ１＜０．２５））
ｃａｔ（＇\ｎｃｏｅｆ ＜ ０．０５ ＝＇，ｓｕｍ（ｃｏｅｆｆｓ１＜０．０５））
ｉｎｄｘ２５＝ｗｈｉｃｈ（ｃｏｅｆｆｓ１＜０．２５）
ｌｍ２＝ｌｍ（Ｎｏｉｓｅ［，５１］ ～ Ｎｏｉｓｅ［，ｉｎｄｘ２５］）
ｃａｔ（＇\ｎ\ｎＲ２ （２ｎｄ） ＝ ＇，ｓｕｍｍａｒｙ（ｌｍ２）＄ｒ．ｓｑｕａｒｅｄ）
ｃａｔ（＇\ｎｐ．ｖａｌｕｅ（２ｎｄ） ＝ ＇，ａｎｏｖａ（ｌｍ２）＄Ｐｒ［１］）
ｃｏｅｆｓ２＝ｓｕｍｍａｒｙ（ｌｍ２）＄ｃｏｅｆ［，＇Ｐｒ（＞｜ｔ｜）＇］
ｌｅｎｇｔｈ（ｃｏｅｆｓ２）
ｃｏｅｆｓ２［１］
ｃｏｅｆｆｓ２＝ｃｏｅｆｓ２［－１］
ｃａｔ（＇\ｎｃｏｅｆ ＜ ０．２５ （２ｎｄ） ＝＇，ｓｕｍ（ｃｏｅｆｆｓ２＜０．２５））
ｃａｔ（＇\ｎｃｏｅｆ ＜ ０．０５ （２ｎｄ） ＝＇，ｓｕｍ（ｃｏｅｆｆｓ２＜０．０５））
ｃａｔ（＇\ｎ\ｎ＇）
ｉｆ（ｓｅｑｕｅｎｔｉａｌ）｛
ｃａｔ（＇Ｈｉｔ Ｒｅｔｕｒｎ Ｋｅｙ ｉｎ ｃｏｎｓｏｌｅ ｗｉｎｄｏｗ＇）
ｎｏ＿ｓａｖｅ ＜－ ｓｃａｎ（ｎ＝１， ｗｈａｔ＝ｃｈａｒａｃｔｅｒ（）， ｑｕｉｅｔ＝ＴＲＵＥ）
｝
｝
ｎｏｉｓｅ２ｓｉｇ（１）
ｆｏｒ（ｉ ｉｎ ２：５） ｎｏｉｓｅ２ｓｉｇ（ｉ，ｓｅｑ＝ＴＲＵＥ）
pv=numeric(10)
for(j in 1:10){
L=list()
tmp=UG[-j,]
for(i in 1:6) L=append(L,list(tmp[,i]))
pv[j]=jonckheere(L,cat=FALSE,alternative = alt)
}
return(pv)
}
which(UG.Purge('two') < 0.05)
which(UG.Purge('increasing') < 0.05)
＃＃ ｆｉｔｔｅｄ ｉｓ ａ ｓｅｑｕｅｎｃｅ ｏｆ ｍｅａｎｓ
＃＃ ｎｉｓ ｉｓ ａ ｃｏｒｒｅｓｐｏｎｄｉｎｇ ｓｅｑｕｅｎｃｅ ｏｆ ｓａｍｐｌｅ ｓｉｚｅｓ ｆｏｒ ｅａｃｈ ｍｅａｎ
＃＃ ｄｆ ｉｓ ｔｈｅ ｒｅｓｉｄｕａｌ ｄｆ ｆｒｏｍ ｔｈｅ ＡＮＯＶＡ ｔａｂｌｅ
＃＃ ＭＳＥ ＝ ｍｅａｎ ｓｑｕａｒｅｄ ｅｒｒｏｒ ｆｒｏｍ ｔｈｅ ＡＮＯＶＡ ｔａｂｌｅ
＃＃ ｃｏｎｆ．ｌｅｖｅｌ ｉｓ ｔｈｅ ｆａｍｉｌｙ－ｗｉｓｅ ｃｏｎｆｉｄｅｎｃｅ ｌｅｖｅｌ， ｄｅｆａｕｌｔｓ ｔｏ ．９５
ｐａｉｒｗｉｓｅ．ｓｃｈｅｆｆｅ．ｔｅｓｔ ＜－ ｆｕｎｃｔｉｏｎ（ｒｅ．ａｏｖ， ｃｏｎｆ．ｌｅｖｅｌ ＝ ０．９５）｛
ｍｏｄｅｌ ＝ ｒｅ．ａｏｖ＄ｍｏｄｅｌ
ｃｏｌｎａｍｅｓ（ｍｏｄｅｌ） ＝ ｃ（＇ｓｃｏｒｅ＇，＇ｇｒｏｕｐ＇）
ｆｉｔｔｅｄ ＝ ｗｉｔｈ（ｍｏｄｅｌ，ｔａｐｐｌｙ（ｓｃｏｒｅ，ｇｒｏｕｐ，ｍｅａｎ））
ｎｉｓ ＝ ｗｉｔｈ（ｍｏｄｅｌ，ｔａｐｐｌｙ（ｓｃｏｒｅ，ｇｒｏｕｐ，ｌｅｎｇｔｈ））
ｄｆ ＝ ｒｅ．ａｏｖ＄ｄｆ．ｒｅｓｉｄｕａｌ
ＭＳＥ ＝ ｓｕｍｍａｒｙ（ｒｅ．ａｏｖ）［［１］］［＇Ｒｅｓｉｄｕａｌｓ＇，＇Ｍｅａｎ Ｓｑ＇］
ｒ ＝ ｌｅｎｇｔｈ（ｆｉｔｔｅｄ）
ｐａｉｒｓ ＝ ｃｏｍｂｎ（１：ｒ，２）
ｄｉｆｆｓ ＝ ｆｉｔｔｅｄ［ｐａｉｒｓ［１，］］ － ｆｉｔｔｅｄ［ｐａｉｒｓ［２，］］
ｈｗｉｄｔｈｓ ＝ Ｔ＊ｓｑｒｔ（ＭＳＥ＊（１／ｎｉｓ［ｐａｉｒｓ［１，］］ ＋ １／ｎｉｓ［ｐａｉｒｓ［２，］］））
ｆｖｓ ＝ （ｄｉｆｆｓ＾２）／（ＭＳＥ＊（１／ｎｉｓ［ｐａｉｒｓ［１，］］ ＋ １／ｎｉｓ［ｐａｉｒｓ［２，］］））／（ｒ－１）
ｐｖｓ ＝ １－ｐｆ（ｆｖｓ， ｒ－１， ｄｆ）
ｖａｌ ＝ ｃｂｉｎｄ（ｄｉｆｆｓ － ｈｗｉｄｔｈｓ， ｄｉｆｆｓ， ｄｉｆｆｓ ＋ ｈｗｉｄｔｈｓ， ｆｖｓ， ｒ－１， ｄｆ， ｐｖｓ）
ｄｉｍｎａｍｅｓ（ｖａｌ） ＝ ｌｉｓｔ（ｐａｓｔｅ（＂ｓｕｂｊｅｃｔ＂，ｐａｉｒｓ［１，］，＂ － ｓｕｂｊｅｃｔ＂， ｐａｉｒｓ［２，］，
ｓｅｐ ＝ ＂＂）， ｃ（＂Ｌｏｗｅｒ＂， ＂Ｄｉｆｆ＂，＂Ｕｐｐｅｒ＂， ＂Ｆ Ｖａｌｕｅ＂， ＂ｎｍｄｆ＂， ＂ｄｎｄｆ＂， ＂Ｐｒ（＞Ｆ）＂））
Ｓｃ ＝ ａｓ．ｍａｔｒｉｘ（ｖａｌ）
ｐ．Ｓｃ ＝ Ｓｃ［，＇Ｐｒ（＞Ｆ）＇］
ｎ ＝ ｒｅ．ａｏｖ＄ｒａｎｋ － １
ｍａｔ．Ｓｃ ＝ ｍａｔｒｉｘ（ｒｅｐ（ＮＡ，ｎ＊ｎ），ｎ）
ｆｏｒ（ｋ ｉｎ １：ｎ） ｍａｔ．Ｓｃ［，ｋ］ ＝ ｃ（ｒｅｐ（ＮＡ，ｋ－１）， ｐ．Ｓｃ［（（ｋ－１）＊（ｎ＋１－ｋ／２）＋１）：（（ｋ－１）＊（ｎ＋１－ｋ／２）＋１＋ｎ－ｋ）］）
ｃｏｌｎａｍｅｓ（ｍａｔ．Ｓｃ） ＝ ｍｏｄｅｌ［［２］］［１：ｎ］
ｒｏｗｎａｍｅｓ（ｍａｔ．Ｓｃ） ＝ ｍｏｄｅｌ［［２］］［２：（ｎ＋１）］
ｄ ＝ ｒｏｕｎｄ（ｍａｔ．Ｓｃ，５）
ｄ［ｉｓ．ｎａ（ｄ）］ ＝ ＇－＇
ｐｒｉｎｔ（ｄ，ｑｕｏｔｅ ＝ ＦＡＬＳＥ）
ｉｎｖｉｓｉｂｌｅ（ｖａｌ）
｝
# positive test TP(A) FP(B)
# negative test FN(C) TN(D)
PV <- function(prevalence=c(10^-4,1),sn=0.80,sp=0.95,...){
plot(NULL,NULL,xlim=prevalence,ylim=c(0,1),xlab='Prevalence',
ylab='Predicative Value(Test Credibility)',type='n',bty='l',
main=paste0('感度 = ',sn, ' 特異度 = ',sp), ...)
legend('center',bty='n',lwd=2,lty=1:3,legend=c('陽性適中率','陰性適中率','偽陽性率'),
col=c('red','darkgreen','brown'))
ppv<-function(prevalence,sensitivity=sn,specificity=sp){
PPV=prevalence*sensitivity/
(prevalence*sensitivity+(1-prevalence)*(1-specificity))
return(PPV)
}
curve(ppv(x),lty=1,lwd=2,col='red', add=TRUE)
npv<-function(prevalence,sensitivity=sn,specificity=sp){
NPV=(1-prevalence)*specificity/
( (1-prevalence)*specificity + prevalence*(1-sensitivity) )
return(NPV)
}
curve(npv(x),lty=2,lwd=2,col='darkgreen',add=TRUE)
false_negative_rate <- function(prevalence,sensitivity=sn,specificity=sp){
FNR <- prevalence*(1-sensitivity)/
( (1-prevalence)*specificity + prevalence*(1-sensitivity) )
return(FNR)
}
curve(false_negative_rate(x), lty=3,lwd=2,col='brown',add=TRUE)
}
N=c(856301,888348,917553,844635,937615,903009,897503,893332,846813,850128,918512,921196)
X=c(1433,1476,1496,1343,1553,1497,1350,1522,1277,1297,1534,1445)
iP=which(zodiac=='Pisces')
p.Pisces=prop.test(c(X[iP],sum(X[-iP])),c(N[iP],sum(N[-iP])))$p.value
p0=sum(X)/sum(N)
set.seed(16062006)
p.max=numeric()
for(i in 1:10^4){
xi=rbinom(length(N),N,p0)
I=which.max(xi/N)
re=prop.test(c(xi[I],sum(xi[-I])),c(N[I],sum(N[-I])))
p.max[i]=re$p.value
}
mean(p.max <= p.Pisces)
cat("P-value for Pisces and CHF: ", p.max, file="Pisces.txt",fill=TRUE, append=TRUE)
set.seed(seed)
A0=rnorm(10,50,10)
A1=A0+rnorm(10,0,5)+5
B0=rnorm(10,45,10)
B1=B0+rnorm(10,0,5)+5
A0=round(A0)
B0=round(B0)
A1=round(A1)
B1=round(B1)
a=t.test(A0,A1,paired=TRUE)$p. # 外部有意差なし
b=t.test(B0,B1,paired=TRUE)$p. # 内部有意差あり
ab=t.test(A1-A0,B1-B0)$p. # 加点差有意差なし
a0b0=t.test(A0,B0)$p.# base差なし
a1b1=t.test(A1,B1)$p.# final差
list(p=c(外部=a,内部=b,差異=ab,base差=a0b0,final差=a1b1),A0=A0,B0=B0,A1=A1,B1=B1)
}
TRAP9p()$p
rep=replicate(1000,TRAP9p()$p)
mean(rep['外部',]>0.05 & rep['内部',]<0.05 & rep['差異',]>0.05
& re['base差',] > 0.05 & re['final差',]<0.05)
seeds=c(4799, 10638, 12173, 12908, 13671, 17145, 18955)
re=sapply(seeds,function(x) TRAP9p(x)$p) # wait several ten seconds
idx=which(re['外部',]>0.05 & re['内部',]<0.05 & re['差異',]>0.05
& re['base差',] > 0.05 & re['final差',]<0.05)
idx ; re[,idx]
Tx=as.data.frame(TRAP9p(4799)[2:5]) # 4799 10638 12173 12908 13671 17145 18955
U=with(Tx,data.frame(外部.無=A0,外部.有=A1,内部.無=B0,内部.有=B1))
rep=replicate(1000,TRAP9p()$p)
mean(rep['外部',]>0.05 & rep['内部',]<0.05 & rep['差異',]>0.05
& re['base差',] > 0.05 & re['final差',]<0.05)
seeds=c(4799, 10638, 12173, 12908, 13671, 17145, 18955)
re=sapply(seeds,function(x) TRAP9p(x)$p) # wait several ten seconds
idx=which(re['外部',]>0.05 & re['内部',]<0.05 & re['差異',]>0.05
& re['base差',] > 0.05 & re['final差',]<0.05)
idx ; re[,idx]
Tx=as.data.frame(TRAP9p(4799)[2:5]) # 4799 10638 12173 12908 13671 17145 18955
U=with(Tx,data.frame(外部.無=A0,外部.有=A1,内部.無=B0,内部.有=B1))
U
.plot = function(){
plot (NULL,xlim=c(0,5),ylim=c(30,80),bty='l',type='n',
xaxt='n',ylab='score',xlab='',main='「任意」の寄付金効果')
axis(side=1, at=c(1.5,3.5), labels=c('外部入学','内部進学'))
points(rep(1,10),U[,1])
points(rep(2,10),U[,2])
segments(rep(1,10),U[,1],rep(2,10),U[,2])
points(rep(3,10),U[,3],pch=19)
points(rep(4,10),U[,4],pch=19)
segments(rep(3,10),U[,3],rep(4,10),U[,4])
} ; .plot()
with(U,t.test(外部.無,外部.有,paired=TRUE))$p.value # 外部での効果
with(U,t.test(内部.無,内部.有,paired=TRUE))$p.value # 内部での効果
with(U,t.test(外部.有-外部.無,内部.有-内部.無)$p.value) # 内外部効果比較
with(U,t.test(log(外部.有/外部.無),log(内部.有/内部.無))$p.value)
power=0.80 # Pr(significant|H1)
N=100
prior=0.10
disease=prior*N
TP=disease*power
FP=N*(1-prior)*alpha
(FPRP=FP/(TP+FP))
alpha.L=0.045
alpha.U=0.055
specificity=1-0.05
alpha=1-specificity. # Pr(reject|H0)
n=1000
prior=0.1
prop.p<- function (){
a=rbinom(1,n, prior)
b=rbinom(1,n, prior)
prop.test(c(a,b),c(n,n))$p.value
}
k=1000
re=replicate (k,prop.p()1)
hist(re)
mean(re<0.05)
mean (0.045<re & re<0.050)
TP=sensitivfity*prior
do qFP=(1-prior)*(1-sensitivity)
FPRP=FP/(TP+FP)
or not they are also ‘rare’ when there is a true difference.
pLR=TP/FP=sensitivity/(1-specificity)=1/BayesFactor
nLR=FN/TN=(1-sensitivity)/specificity
p.val=prop.test(c(r1,r2),c(n1,n2))$p.value
k=2
df=k-1
Pi=c(r1/n1,r2/n2)
n=mean(n1,n2)
theta.i=asin(sqrt(Pi))
delta=4*var(theta.i)*(k-1)
ncp=n*delta
power=pchisq(qchisq(1-alpha,df),df,ncp,lower=FALSE)
qcrit=qchisq(max(p.val,1-p.val),df,ncp=0)
curve(dchisq(x,df),0,15,ann=FALSE,bty='n') # H0
curve(dchisq(x,df,ncp),add=TRUE, lty=2) # H1
abline(v=qcrit,lty=3)
x0=qcrit
y0=dt(x0,df,0)
x1=x0
y1=dchisq(x1,df,ncp=ncp)
FPR=y0/(y0+y1)
print(c(p.value=p.val,FPR=FPR),digits=3)
}
calc.FPR.p(85,95,100,100)
m=length(r)
n=rep(mean(r),m)
p.val=chisq.test(rbind(r,n))$p.value
df=m-1
P0=n/sum(n)
P1=(r/n)/sum(r/n)
N=sum(r) # == sum(n)
ncp1=0
for(i in 1:m) ncp1=ncp1+N*(P1[i]-P0[i])^2/P0[i]
qcrit=qchisq(1-alpha,df,ncp=0)
curve(dchisq(x,df),0,20,xlab=quote(chi),ylab='Density',bty='n') # H0
curve(dchisq(x,df,ncp1),add=TRUE,lty=2,col=2) # H1
abline(v=qcrit,col='gray') ; text(qcrit,0,round(qcrit,2))
legend('topright',bty='n',legend=c('H0:Central','H1:Noncentral'),col=1:2,lty=1:2)
power=pchisq(qcrit,df,ncp1,lower=FALSE)
y0=dchisq(qcrit,df,0)
y1=dchisq(qcrit,df,ncp=ncp1)
FPR=y0/(y0+y1)
print(c(power=power,p.value=p.val,FPR=FPR),digits=3)
}
calc.FPR.chisq(c(10,16,34,9,10,26))
calc.FPR.chisq(c(1,0,9,2,1,1))
パーッケージpwrのpwr.2p2n.testの.コードを参考にした。
calc.FPR.p2 <- function(r1,r2,n1,n2,alpha=0.05){
p.val=prop.test(c(r1,r2),c(n1,n2))$p.value
k=length(c(r1,r2))
df=k-1
p1=r1/n1 ; p2=r2/n2
Pi=c(r1/n1,r2/n2)
theta.i=asin(sqrt(Pi))
delta=4*var(theta.i)*(k-1)
N=2/(1/n1+1/n2)
ncp1=N*delta
power.chi=pchisq(qchisq(1-alpha,df),df,ncp1,lower=FALSE)
qcrit=qchisq(max(p.val,1-p.val),df,ncp=0)
curve(dchisq(x,df),0,20,xlab='ChiSquare',ylab='Density',bty='n') # H0
curve(dchisq(x,df,ncp1),add=TRUE,lty=2,col=2) # H1
abline(v=qcrit,col='gray')
legend('top',bty='n',legend=c('H0','H1'),col=1:2,lty=1:2)
y0=dchisq(qcrit,df,0)
y1=dchisq(qcrit,df,ncp=ncp1)
FPR=y0/(y0+y1)
VAL=c(power=power.chi,p.value=p.val,FPR=FPR)
print(VAL,digits=3)
invisible(VAL)
}
p.val=prop.test(c(r1,r2),c(n1,n2))$p.value
k=length(c(r1,r2))
df=k-1
p1=r1/n1 ; p2=r2/n2
Pi=c(r1/n1,r2/n2)
theta.i=asin(sqrt(Pi))
delta=4*var(theta.i)*(k-1)
N=2/(1/n1+1/n2)
ncp1=N*delta
power.chi=pchisq(qchisq(1-alpha,df),df,ncp1,lower=FALSE)
qcrit=qchisq(max(p.val,1-p.val),df,ncp=0)
curve(dchisq(x,df),0,ncp1*3,xlab=quote(chi),ylab='Density',bty='n') # H0
curve(dchisq(x,df,ncp1),add=TRUE,lty=2,col=2) # H1
abline(v=qcrit,col='gray')
legend('top',bty='n',legend=c('H0','H1'),col=1:2,lty=1:2)
y0=dchisq(qcrit,df,0)
y1=dchisq(qcrit,df,ncp=ncp1)
FPR.equal=y0/(y0+y1)
FPR.less=p.val/(p.val+power.chi)
VAL=c(power=power.chi,p.value=p.val,FPR.equal=FPR.equal,FPR.less=FPR.less)
print(VAL,digits=3)
invisible(VAL)
}
calc.FPR.p2(95,85,100,110)
p.val=prop.test(c(r1,r2),c(n1,n2))$p.value
k=length(c(r1,r2))
df=k-1
p1=r1/n1 ; p2=r2/n2
Pi=c(p1,p2)
theta.i=asin(sqrt(Pi)) # arcsine conversion
delta=4*var(theta.i)*(k-1) # sum of squares
N=2/(1/n1+1/n2) # harmonic mean, subcontrary mean
ncp1=N*delta # non-central parameter
power.chi=pchisq(qchisq(1-alpha,df),df,ncp1,lower=FALSE)
# qchisq(1-0.05,1): 3.841
qcrit=qchisq(max(p.val,1-p.val),df,ncp=0)
# qcrit = prop.test(c(r1,r2),c(n1,n2))$statistic
curve(dchisq(x,df),0,2*qcrit,xlab=quote(chi),ylab='Density',bty='n') # H0
curve(dchisq(x,df,ncp1),add=TRUE,lty=2,col=2) # H1
# power.chi=AUC of right half of the H1 curve
abline(v=qcrit,col='gray')
legend('top',bty='n',legend=c('H0','H1'),col=1:2,lty=1:2)
text(qcrit,0,round(qcrit,2))
y0=dchisq(qcrit,df,0)
y1=dchisq(qcrit,df,ncp=ncp1)
FPR.equal=y0/(y0+y1) # length ratio
FPR.less=p.val/(p.val+power.chi) # area ratio
FPR.alpha=alpha/(alpha+power.chi) # FPR before analysis
VAL=c(power=power.chi,p.value=p.val,FPR.equal=FPR.equal,
FPR.less=FPR.less,FPR.alpha=FPR.alpha)
print(VAL,digits=3)
invisible(VAL)
}
calc.FPR.p2(85,95,100,100, alpha=0.05)
calc.FPR.p2(85,95,100,100, alpha=0.01)
p.val=prop.test(c(r1,r2),c(n1,n2))$p.value
k=length(c(r1,r2))
df=k-1
p1=r1/n1 ; p2=r2/n2
Pi=c(p1,p2)
theta.i=asin(sqrt(Pi)) # arcsine conversion
delta=4*var(theta.i)*(k-1) # sum of squares
N=2/(1/n1+1/n2) # harmonic mean, subcontrary mean
ncp1=N*delta # non-central parameter
power.chi=pchisq(qchisq(1-alpha,df),df,ncp1,lower=FALSE)
q.alpha=qchisq(1-alpha,df) # 3.841
qcrit=qchisq(max(p.val,1-p.val),df,ncp=0)
# qcrit = prop.test(c(r1,r2),c(n1,n2))$statistic
curve(dchisq(x,df),0,2*qcrit,xlab=quote(chi),ylab='Density',bty='n',lwd=2) # H0
curve(dchisq(x,df,ncp1),add=TRUE,lty=2,col=2,lwd.2) # H1
# power.chi=AUC of right half of the H1 curve
abline(v=qcrit)
abline(v=q.alpha,col='gray',lty=3)
legend('topright',bty='n',legend=c('H0','H1','chisq@p.value','chisq@alpha'),col=c(1,2,1,'gray'),lty=c(1,2,1,3),lwd=c(2,2,1,1))
text(qcrit,0,round(qcrit,2))
y0=dchisq(qcrit,df,0)
y1=dchisq(qcrit,df,ncp=ncp1)
FPR.equal=y0/(y0+y1) # length ratio
FPR.less=p.val/(p.val+power.chi) # area ratio
FPR.alpha=alpha/(alpha+power.chi) # FPR before analysis
VAL=c(power=power.chi,p.value=p.val,FPR.equal=FPR.equal,
FPR.less=FPR.less,FPR.alpha=FPR.alpha)
print(VAL,digits=3)
invisible(VAL)
}
(1-specificity)*PPV/((1-specificity)*PPV)+(1-PPV)*sensitivity))
}
FPP2prior <- function(power,FPR=0.05,pval=0.05){
pval*(1-FPR)/(pval*(1-FPR)+FPR*power)
}
(1-specificity)*PPV/((1-specificity)*PPV+(1-PPV)*sensitivity)
}
PPV2prevalence(0.75,0.99,0.9)
FPP2prior <- function(power,FPR=0.05,pval=0.05){
pval*(1-FPR)/(pval*(1-FPR)+FPR*power)
}
# as an example to illustrate the use of his t test,
# in the paper in which the test was introduced.
A=c(0.7,-1.6,-0.2,-1.2,-0.1,3.4,3.7,0.8,0.0,2.0)
B=c(1.9,0.8,1.1,0.1,-0.1,4.4,5.5,1.6,4.6,3.4)
t.test(A,B,var.equal = TRUE)
mean(A) ; mean(B)
sd(A) ; sd(B)
(E=mean(B)-mean(A))
nA=length(A) ; nB=length(B)
# The pooled estimate of the error within groups
SEpooled=sqrt(weighted.mean(c(var(A),var(B)),c(nA-1,nB-1)))
# Standard deviation of effect size
SE=sqrt(SEpooled^2/nA+SEpooled^2/nB)
(t.statistic=E/SE)
2*pt(t.statistic,nA+nB-2,lower=FALSE) # two-sided
r1=14
n1=840
r2=73 # placebo
n2=829
calc.FPR.p2(r1,r2,n1,n2)
calc.FPR0.p2(r1,r2,n1,n2)
prop.test(c(r1,r2),c(n1,n2))
prior.needed <- function(r1,r2,n1,n2,FPR=0.05){
pval=prop.test(c(r1,r2),c(n1,n2))$p.value
ES=pwr::ES.h(r1/n1,r2/n2)
power=pwr::pwr.2p2n.test(ES,n1,n2,sig.level=pval)$power
prior=pval*(1-FPR)/(pval*(1-FPR)+FPR*power)
return(prior)
}
prior.needed(r1,r2,n1,n2,FPR=0.05)
# p.508
# When p is a p-value with n1 samples, 95% ci of p-value of next experiment with n2 samples
# is supposed to be estimated by p2ci-function below.
p2ci <- function(p,n1=100,n2=100,sig.level=0.95){
lwr=pnorm(qnorm(p)*sqrt(n2/n1)-qnorm(1-(1-sig.level)/2)*sqrt(1+n2/n1))
# pnorm(qnorm(p1)-2.771808) # when n1=n2, 1.96 *s qrt(2) = 2.77
upr=pnorm(qnorm(p)*sqrt(n2/n1)+qnorm(1-(1-sig.level)/2)*sqrt(1+n2/n1))
# pnorm(qnorm(p1)+2.771808)
c(lwr,upr)
}
p2ci(0.05)
p2ci(0.001)
graphics.off()
pp=seq(0,1,length=1001)
plot(pp,sapply(pp,function(p)p2ci(p)[1]),type='l',bty='n',
xlab='initial p-value',ylab='C.I. of next p-value')
lines(pp,sapply(pp,function(p)p2ci(p)[2]))
###
(opt=optimise(function(p)p2ci(p)[1],c(0,1)))
p2ci(opt$minimum)
f <- function(n1=10,n2=10)c(t.test(rnorm(n1))$p.value,t.test(rnorm(n1))$p.value)
re=replicate(10^4,f())
points(re[1,],re[2,],col=rgb(0.01,0.01,0.01,0.01))
スクリプトを変更。
# https://www.physiology.org/doi/pdf/10.1152/advan.00042.2016
# Explorations in statistics: statistical facets of reproducibility Douglas Curran-Everett
p2p2w <- function(p.value,n1=10,n2=10,sd1=1,sd2=1,alpha=0.05){
p=p.value/2 # two.sided comparison
# Z-test
z=qnorm(p)
d.z=z*sqrt(sd1^2/n1+sd2^2/n2) # estimated difference of means by z.test
p2.z=pnorm(-qnorm(alpha/2)+z,lower=FALSE)
# Student
df=n1-1+n2-1
t=qt(p,df)
d.t=t*sqrt((1/n1+1/n2)*((n1-1)*sd1^2+(n2-1)*sd2^2)/((n1-1)+(n2-1)))
p2.t=pt(-qt(alpha/2,df)+t,df,lower=FALSE)
# Welch
var1=sd1^2 ; var2=sd2^2
dfw=(var1/n1+var2/n2)^2 / (var1^2/n1^2/(n1-1)+var2^2/n2^2/(n2-1))
t.w=qt(p,dfw)
d.w=t.w*sqrt(var1/n1+var2/n2)
p2.w=pt(-qt(alpha/2,dfw)+t.w,dfw,lower=FALSE)
data.frame(p2.w, p2.t, p2.z)
}
library(rstan)
options(mc.cores = parallel::detectCores())
rstan_options(auto_write = TRUE)
stanString='
data{
int<lower=0> r1;
int<lower=0> r2;
int<lower=0> n1;
int<lower=0> n2;
}
parameters{
real<lower=0> lambda1;
real<lower=0> lambda2;
}
model{
r1 ~ poisson(lambda1) T[0,n1];
r2 ~ poisson(lambda2) T[0,n2];
}
'
# execute only on first occation
# stanModel=stan_model(model_code = stanString)
# saveRDS(stanModel,'2x2p.rds')
data <- list(r1=r1,r2=r2,n1=n1,n2=n2)
stanModel=readRDS('2x2p.rds')
fit=sampling(stanModel,data=data,chain=1,iter=10000)
print(fit)
ms=rstan::extract(fit)
k=length(ms$lambda1)
p.sim=numeric(k)
for(i in 1:k){
p.sim[i]=prop.test(c(ms$lambda1[i],ms$lambda2[i]),c(n1,n2))$p.value
}
BEST::plotPost(p.sim)
mean(p.sim<alpha)
cat('Pr(p.value < ',alpha,') = ', mean(p.sim<alpha),'\n')
cat('Original p.value = ',prop.test(c(r1,r2),c(n1,n2))$p.value,'\n')
}
f<- function(x) (1-x)^(r-1)*x
curve (f(x))
auc=integrate (f,0,1)$value
pdf <- function (x) f(x)/auc
integrate(pdf, 0.5,1)$value
integrate (function (x)x*pdf(x),0,1)$value
2/(r+2)
z=3;N=9
f <- function (x) choose(N,z)*x^z*(1-x)^(N-z)
curve (f(x))
auc=integrate (f,0,1)$value
pdf <- function (x) f(x)/auc
integrate(pdf, 0.5,1)$value
integrate (function (x)x*pdf(x),0,1)$value
(z+1)/(N+2)
z <- function(x) integrate(f,0,x)$value
z(0.1)
z(0.5)
curve(f(x))
xx=seq(0,1,0.01)
plot(xx,sapply(xx,z))
z <- function(x) integrate(f,0,x)$value/pi
z(0.1)
z(0.5)
curve(f(x))
x=seq(.001,.999,by=.001)
plot(x,sapply(x,z))
abline(a=0,b=1)
zz <- function(x) integrate(f,0,x)$value
x=seq(.001,.999,by=.001)
plot(x,sapply(x,zz))
abline(a=0,b=1)
m.FE <- function(r1,n1,r2,n2,shape1=1,shape2=1){
choose(n1,r1)*choose(n2,r2)*beta(r1+r2+shape1,n1-r1+n2-r2+shape2)/beta(shape1,shape2)
}
# marginal likelihoo of Random Effect Model θ1~B(a1,ba),θ2~B(a2,b2)
m.REJ <- function(r1,n1,r2,n2,a1=1,b1=1,a2=1,b2=1){
2*choose(n1,r1)*choose(n2,r2)*integrate(
function(x){
dbeta(x,r1+a1,n1-r1+b1)*beta(r1+a1,n1-r1+b1)/beta(a1,b1)*
pbeta(x,r2+a2,n2-r2+b2,lower=FALSE)*beta(r2+a2,n2-r2+b2)/beta(a2,b2)
}
,0,1)$value
}
curve(Haldane(x),0,1)
f <- function(x) integrate(Haldane,0.5,x)$value
x=seq(0.001,0.999,by=0.001)
plot(x,sapply(x,f),col=3)
curve(log(x/(1-x)),add=T)
∫
p(D | θ,M1)p(θ |M1)dθ
= p(D |M1)=
∫
p(D | θ,M1)p(θ |M1)dθ
p(D |Mx)= p(ξ1)p(D | ξ1)+p(ξ2)p(D | ξ2)+p(ξ3)p(D | ξ3)
=0.6×0.001+0.3×0.002+0.1×0.003
=0.0015.
The marginal likelihood is computed
data{
int<lower=0> N1;
int<lower=0> N2;
real Y1[N1];
real Y2[N2];
}
parameters{
real mu;
real<lower=0> sigma;
real alpha;
}
transformed parameters{
real mu1;
real mu2;
real delta;
real<lower=0> precision;
delta = alpha/sigma;
mu1 = mu + alpha/2;
mu2 = mu - alpha/2;
precision = 1/(sigma^2);
}
model{
Y1 ~ normal(mu1,sigma);
Y2 ~ normal(mu2,sigma);
mu ~ uniform(-9999,9999);
precision ~ gamma(0.5,0.5);
delta ~ cauchy(0,1);
}
'
U=scale(rnorm(n1))*sd1+m1 ; E=scale(rnorm(n2))*sd2+m2
Y1=as.vector(U) ; Y2=as.vector(E)
data=list(N1=N1,N2=N2,Y1=Y1,Y2=Y2)
# execute only on first occation
# JZS.model=stan_model(model_code = stanStringJ)
# JZS.model=stan_model('JZS.stan')
# saveRDS(JZS.model,'JZS.rds')
JZS.model=readRDS('JZS.rds')
fitJ=sampling(JZS.model,data=data, iter=20000)
print(fitJ,probs = c(.025,.5,.975))
ms=rstan::extract(fitJ)
dES=density(ms$delta)
plot(dES,lwd=2, xlab='Effect Size (δ)',main='The Savage?Dickey method',bty='l')
curve(dcauchy(x),lty=3, add=TRUE)
abline(v=0,col=8)
(d1=dES$y[which.min(dES$x^2)]) # posterior density at ES=0
(d0=dcauchy(0)) # prior density at ES=0
points(0,d0,cex=2)
points(0,d1,pch=19,cex=2)
legend('topleft',bty='n',legend=c('prior','posterior'),lty=c(3,1),lwd=c(1,2))
(BF10=d1/d0)
text(0,0,paste('BF10=',round(BF10,2)))
library(BayesFactor)
1/exp(ttestBF(Y1,Y2,rscale = 1)@bayesFactor[['bf']])
x=rbeta(N,0.5,0.5)
y=rbeta(N,0.5,0.5)
z=x-y
hist(z,freq=F)
dz=density(z)
dz$y[which.min(dz$x^2)]
z=x/y
hist(log10(z),freq=F)
dz=density(z)
min=1
dz$y[which.min((dz$x-min)^2)]
int r1;
int r2;
int n1;
int n2;
real shape1;
real shape2;
}
parameters{
real <lower=0, upper=1> theta1;
real <lower=0, upper=1> theta2;
real <lower=0, upper=1> th1;
real <lower=0, upper=1> th2;
}
transformed parameters{
real rd;
real rr;
real rd0;
real rr0;
rd = theta1 - theta2;
rd0 = th1 - th2;
rr = theta1/theta2;
rr0 = th1/th2
}
model{
r1 ~ binomial(n1,theta1);
r2 ~ binomial(n2,theta2);
theta1 ~ beta(shape1,shape2);
theta2 ~ beta(shape1,shape2);
th1 ~ beta(shape1,shape2);
th2 ~ beta(shape1,shape2);
}
花子は５０人を調査できたら終了として入学者を５０人をみつけて１８人が女子であるという結果を得た。
帰無仮説のもとで
５０人中１８人が女子である確率は 0.01603475
これ以下になるのは５０人中０～１８人と３２～５０人が女子の場合なので
両側検定して
> sum(dbinom(c(0:18,32:50),50,0.5))
[1] 0.06490865
> binom.test(18,50,0.5)$p.value
[1] 0.06490865
で帰無仮説は棄却できないと結論した。
http://i.imgur.com/XDIp9rM.png
１８人めがみつかったのは花子と同じく５０人めであった。
帰無仮説のもとで
１８人がみつかるのが５０人めである確率は0.005772512
これ以下になるのは２３人以下５０人以上番めで女子１８人めがみつかった場合なので
両側検定して
pnb=dnbinom(0:999,18,0.5)
> 1 - sum(pnb[-which(pnb<=dnbinom(50-18,18,0.5))]) # < 0.05
[1] 0.02750309
http://i.imgur.com/K3T7utr.png
で帰無仮説は棄却される。
どちらの検定が正しいか、どちらも正しくないか？
検定する意図によってｐ値が変わるのは頻度主義統計の欠陥といえるか？
花子の横軸は女子数、太郎の横軸はサンプル数なので
サンプルでの女子の割合を横軸にして９５％信頼区間を示す。
花子の検定での信頼区間は0.36～0.72で18/50を含む、p=0.06491
http://i.imgur.com/SeTLk8K.jpg
太郎の検定での信頼区間は0.375～0.72で18/50を含まない、p= 0.0275
http://i.imgur.com/tNzlfxe.jpg
主観である、検定の中止の基準の差でｐ値や信頼区間が変化するのは変だという批判である。
49C17 * 0.5^17 * 0.5^32 * 0.5 の違いでしょう
18人目を見つけた人数を調べるというデザインがおかしいよね
これ事前確率0.5で50人調査して女が18人っていうのを
ベイズ更新していったらどうなる？
酷いのになるとp<0.05になったらやめるとかいうのもあるな。
p-hackingと呼ばれる
N=20
a=0.5
b=0.5
p=a/(a+b+r+(1:N))
q=cumsum(p)
q
plot(1:N,p,ann=F)
plot(1:N,q,ann=F)
​
z=40
FP=0.01
shape1=1
shape2=1
data = list(N=N,z=z,FP=FP,shape1=shape1,shape2=shape2)
stanString=paste0('
data{
int N;
int z;
real FP;
real shape1;
real shape2;
}
parameters{
real<lower=0,upper=1> TP;
}
transformed parameters{
real<lower=0,upper=1> theta;
theta=((z*1.0)/(N*1.0)-FP)/(TP-FP);
}
model{
z ~ binomial(N,theta);
TP ~ beta(shape1,shape2);
}
')
z=40
FP=0.01
shape1=1
shape2=1
data = list(N=N,z=z,FP=FP,shape1=shape1,shape2=shape2)
stanString=paste0('
data{
int N;
int z;
real FP;
real shape1;
real shape2;
}
parameters{
real<lower=0,upper=1> TP;
}
transformed parameters{
real<lower=0,upper=1> theta;
theta=((z*1.0)/(N*1.0)-FP)/(TP-FP);
}
model{
z ~ binomial(N,theta);
TP ~ beta(shape1,shape2) T[0.5,];
}
')
model=stan_model(model_code = stanString)
fit=sampling(model,data=data,control=list(adapt_delta=0.99),iter=10000)
print(fit,digits=3,probs=c(.025,.50,.975))
pdf2hdi <- function(pdf,xMIN=0,xMAX=1,cred=0.95,Print=TRUE){
nxx=1001
xx=seq(xMIN,xMAX,length=nxx)
xx=xx[-nxx]
xx=xx[-1]
xmin=xx[1]
xmax=xx[nxx-2]
AUC=integrate(pdf,xmin,xmax)$value
PDF=function(x)pdf(x)/AUC
cdf <- function(x) integrate(PDF,xmin,x)$value
ICDF <- function(x) uniroot(function(y) cdf(y)-x,c(xmin,xmax))$root
hdi=HDInterval::hdi(ICDF,credMass=cred)
print(c(hdi[1],hdi[2]),digits=5)
if(Print){
par(mfrow=c(3,1))
plot(xx,sapply(xx,PDF),main='pdf',type='h',xlab='x',ylab='Density',col='lightgreen')
legend('top',bty='n',legend=paste('HDI:',round(hdi,3)))
plot(xx,sapply(xx,cdf),main='cdf',type='h',xlab='x',ylab='Probability',col='lightblue')
pp=seq(0,1,length=nxx)
pp=pp[-nxx]
pp=pp[-1]
plot(pp,sapply(pp,ICDF),type='l',xlab='p',ylab='x',main='ICDF')
par(mfrow=c(1,1))
}
invisible(ICDF)
}
.r=40
b=0.01
f = function(x,a,b,n,r){ # x:prevalence, a:TP, b:FP=0.01
p=x*a+(1-x)*b
choose(n,r)*p^r*(1-p)^(n-r)
}
f2 = function(x,n=.n,r=.r){
cubature::adaptIntegrate(function(ab)f(x,ab[1],b,n,r),
c(0,0),c(1,1))$integral
}
vf2=Vectorize(function(x)f2(x,n=.n,r=.r))
curve(vf2(x),ylab='',yaxs='i',axes=FALSE,lwd=2,xlab='prevalence') ; axis(1)
# points(0:10/10,vf2(0:10/10),pch=19)
optimise(function(x) vf2(x),c(0,1),maximum = TRUE)
auc=integrate(function(x)vf2(x),0,1)$value
pdf<-function(x)vf2(x)/auc
vpdf=Vectorize(pdf)
integrate(function(x)x*pdf(x),0,1)$value # mean
cdf=function(x)integrate(pdf,0,x)$value
vcdf=Vectorize(cdf)
# time consuming processes
# curve(vcdf(x),bty='l',n=64)
inv_cdf <- function(u){
uniroot(function(x,u0=u)vcdf(x)-u0,c(0,1),tol = 1e-18)$root
}
vinv_cdf=Vectorize(inv_cdf)
# curve(vinv_cdf(x),lwd=2,n=64)
hdi=HDInterval::hdi(vinv_cdf) ; hdi
# lower upper
# 0.7456652 1.0000000
vonNeumann2 <- function(PDF,xmin=0,xmax=1,N=10000,Print=TRUE,...){
xx=seq(xmin,xmax,length=N+1)
xx=xx[-(N+1)]
xx=xx[-1]
ymax=max(PDF(xx))
Ux=runif(N,xmin,xmax)
Uy=runif(N,0,ymax)
Rand=Ux[which(Uy<=PDF(Ux))]
if(Print){
hist(Rand,xlim=c(xmin,xmax),freq=FALSE,col=sample(colors(),1),main='',...)
AUC=integrate(PDF,xmin,xmax)$value
lines(xx,sapply(xx,function(x)PDF(x)/AUC))
}
hdi=HDInterval::hdi(Rand)
print(c(hdi[1],hdi[2]),digits=5)
invisible(Rand)
}
ここでもうりゅう先輩が迷惑掛けてんのか？
ウリュウなあ
こいつはなあ、生まれついてのビッグマウスであちこちに自分を売り込むが、
卒業しても国試浪人で医師免許ない50過ぎでは相手にされない
国試対策塾で非常識講師で細々と食つなぐが学生に馬鹿にされる
自分の医師コンプを隠すために医学生たちを「底辺」などという
実は自分が凄まじい底辺なのだが気づいていない
こんな嘘つきデブがのさばっているスレだな
ご苦労なこったよ、うりゅうのおっさん
わからねえとでも思ってんだろどーせ
N=50
z=40
FP=0.01
shape1=1
shape2=1
dataList=list(N=N,z=z,FP=FP,shape1=shape1,shape2=shape2)
modelstring <- paste0("
model{
theta=TP*x+FP*(1-x)
z ~ dbinom(theta,N)
TP ~ dbeta(shape1,shape2)
x ~ dbeta(shape1,shape2)
}"
)
writeLines( modelstring , con="TEMPmodel.txt" )
jagsModel = jags.model( file="TEMPmodel.txt" , data=dataList, quiet=TRUE)
update(jagsModel)
codaSamples = coda.samples( jagsModel ,
variable=c("TP","x","theta"), n.iter=100000 )
js=as.matrix(codaSamples)
head(js)
BEST::plotPost(js[,'TP'],xlab='sensitivity')
BEST::plotPost(js[,'x'],xlab='prevalence')
BEST::plotPost(js[,'theta'],xlab='positive result',showMode = TRUE)
勤務実態もないのに、グループ病院内から管理手当て（10万円）をもらうな！！！
意図的な給与操作、どうにかしろ！
a=numeric(N)
for(i in 1:K) a[i]=2^(i-1)
for(i in K:(N-1)){
a[i+1]=0
for(j in 0:(K-1)){
a[i+1]=a[i+1]+a[i-j] # recursion formula
}
}
P0=numeric(N)
for(i in 1:N) P0[i]=a[i]/2^i # P0(n)=a(n)/2^n
P0
MP=matrix(rep(NA,N*K),ncol=K)
colnames(MP)=paste0('P',0:(K-1))
MP[,1]=P0
head(MP);tail(MP)
MP[1,2]=1/2
for(i in (K-2):K) MP[1,i]=0
for(k in 2:K){
for(i in 1:(N-1)) MP[i+1,k]=1/2*MP[i,k-1]
} # Pk(n+1)=1/2*P(k-1)(n)
ret=1-apply(MP,1,sum)
ret[N]
}
seqN(100,5)
seqN(1000,10)
seqNp <- function(N=100,K=5,p=0.5){
q=1-p
a=numeric(N) # a(n)=P0(n)/p^n , P0(n)=a(n)*p^n
for(i in 1:K) a[i]=q/p^i # P0(i)=q
for(i in K:(N-1)){ # recursive formula
a[i+1]=0
for(j in 0:(K-1)){
a[i+1]=(a[i+1]+a[i-j])
}
a[i+1]=q/p*a[i+1]
}
P0=numeric(N)
for(i in 1:N) P0[i]=a[i]*p^i # P0(n)=a(n)*p^n
P0
MP=matrix(rep(NA,N*K),ncol=K)
colnames(MP)=paste0('P',0:(K-1))
MP[,'P0']=P0
head(MP);tail(MP)
MP[1,'P1']=p
for(i in (K-2):K) MP[1,i]=0
for(k in 2:K){
for(i in 1:(N-1)) MP[i+1,k]=p*MP[i,k-1]
} # Pk(n+1)=p*P(k-1)(n)
ret=1-apply(MP,1,sum)
ret[N]
}
q=1-p
# Pk(n) (k=0,1,2,3,4)を途中、5連続して表が出ていなくて
# 最後のk回は連続して表が出ている確率とする。
#
P0(1)=q
P1(1)=p
P2(1)=P3(1)=P4(1)=0
P(k+1)(n+1)=p*Pk(n)
P0(n+1)=q*{P0(n)+P1(n)+P2(n)+P3(n)+P4(n)}
=q*{P0(n)+p*P0(n-1)+p^2*P0(n-2)+p^3*P0(n-3)+p^4*P0(n-4)}
P0(n)=a(n)*p^n
# a(n+1)p^(n+1)=q*p^n{a(n)+a(n-1)+a(n-2)+a(n-3)+a(n-4)}
# a(n+1)=q/p1*(a(n)+a(n-1)+a(n-2)+a(n-3)+a(n-4))
a(n)=P0(n)/p^n
統計くらいできるのが国立卒の普通の臨床医。
おい、ド底辺
統計処理からはおまえは
都外のド底辺シリツ医大卒と推測されたが、あってるか？
seqNp <- function(N=100,K=5,p=0.5){
q=1-p
a=numeric(N) # a(n)=P0(n)/p^n , P0(n)=a(n)*p^n
for(i in 1:K) a[i]=q/p^i # P0(i)=q
for(i in K:(N-1)){ # recursive formula
a[i+1]=0
for(j in 0:(K-1)){
a[i+1]=(a[i+1]+a[i-j])
}
a[i+1]=q/p*a[i+1]
}
P0=numeric(N)
for(i in 1:N) P0[i]=a[i]*p^i # P0(n)=a(n)*p^n
MP=matrix(rep(NA,N*K),ncol=K)
colnames(MP)=paste0('P',0:(K-1))
MP[,'P0']=P0
head(MP);tail(MP)
MP[1,'P1']=p
for(i in (K-2):K) MP[1,i]=0
for(k in 2:K){
for(i in 1:(N-1)) MP[i+1,k]=p*MP[i,k-1]
} # Pk(n+1)=p*P(k-1)(n)
ret=1-apply(MP,1,sum)
ret[N]
}
pdf2hdi <- function(pdf,xMIN=0,xMAX=1,cred=0.95,Print=TRUE){
nxx=1001
xx=seq(xMIN,xMAX,length=nxx)
xx=xx[-nxx]
xx=xx[-1]
xmin=xx[1]
xmax=xx[nxx-2]
AUC=integrate(pdf,xmin,xmax)$value
PDF=function(x)pdf(x)/AUC
cdf <- function(x) integrate(PDF,xmin,x)$value
ICDF <- function(x) uniroot(function(y) cdf(y)-x,c(xmin,xmax))$root
hdi=HDInterval::hdi(ICDF,credMass=cred)
print(c(hdi[1],hdi[2]),digits=5)
if(Print){
par(mfrow=c(3,1))
plot(xx,sapply(xx,PDF),main='pdf',type='h',xlab='x',ylab='Density',col='lightgreen')
legend('top',bty='n',legend=paste('HDI:',round(hdi,3)))
plot(xx,sapply(xx,cdf),main='cdf',type='h',xlab='x',ylab='Probability',col='lightblue')
pp=seq(0,1,length=nxx)
pp=pp[-nxx]
pp=pp[-1]
plot(pp,sapply(pp,ICDF),type='l',xlab='p',ylab='x',main='ICDF')
par(mfrow=c(1,1))
}
invisible(ICDF)
}
modelstring <- paste0("
model{
theta=TP*x+FP*(1-x)
z ~ dbinom(theta,N)
TP ~ dbeta(shape1,shape2)
x ~ dbeta(shape1,shape2)
}"
)
writeLines( modelstring , con="TEMPmodel.txt" )
N=100 ; FP=0.01 ; shape1=1 ; shape2=1
guess.TP <- function(z){
dataList=list(N=N,z=z,FP=FP,shape1=shape1,shape2=shape2)
jagsModel = jags.model( file="TEMPmodel.txt" , data=dataList, quiet=TRUE)
update(jagsModel)
codaSamples = coda.samples(jagsModel,variable=c("TP","x"), n.iter=10000)
js=as.matrix(codaSamples)
m.TP=mean(js[,'TP'])
ci.TP=HPDinterval(as.mcmc(js[,'TP']))
m.x=mean(js[,'x'])
ci.x=HPDinterval(as.mcmc(js[,'x']))
c(m.TP=m.TP,ci.TP=ci.TP,m.x=m.x,ci.x=ci.x)
}
zz=1:20*5
re=sapply(zz,guess.TP)
head(re[,1:4])
re=as.matrix(re)
plot(zz,re['m.TP',],bty='l',ylim=c(0,1),type='n',las=1,
xlab='n : positives out of 100',ylab='sensitivity')
segments(zz,re[2,],zz,re[3,],col=8,lwd=3)
points(zz,re['m.TP',],pch=16)
dataList=list(N=N,z=z,FP=FP,shape1=shape1,shape2=shape2)
jagsModel = jags.model( file="TEMPmodel.txt" , data=dataList, quiet=TRUE)
update(jagsModel)
codaSamples = coda.samples(jagsModel,variable=c("TP"), n.iter=10000,thin=5)
js=as.matrix(codaSamples)
mean(js[,'TP'])
}
vG=Vectorize(guess.TP2)
n=1:20*5
FP=seq(0,0.25,length=20)
TP=outer(n,FP,vG) # wait several minutes
contour(n,FP,TP, col='navy',
xlab='n : positives out of 100',ylab='FP : 1-specificity',bty='l',nlevels=64)
points(50,0.10,pch='+',col='red',cex=1.5)
nn=1:(n-1)
tasu <- function(x,y) (x+y)%%n
hiku <- function(x,y) (x-y)%%n # row - col
kake <- function(x,y) (x*y)%%n
g=function(x) nn[which(x==1)]
.M=outer(nn,nn,kake)
G=apply(.M,2,g)
gyaku <- function(x) nn[which(G==(x%%n))]
waru <- function(x,y) (x*gyaku(y))%%n # row / col
waru(3,2)
xx=yy=c(0,nn)
names(xx)=paste0('x',c(0,nn))
names(yy)=paste0('y',c(0,nn))
outer(xx,yy,tasu) # x + y
outer(xx,yy,hiku) # x - y
outer(xx,yy,kake) # x * y
X=Y=nn
outer(X,Y,waru) # WRONG!!
outer(X,Y,Vectorize(waru))
a=expand.grid(X,Y)
b=matrix(mapply(waru,a[,1],a[,2]),ncol=length(X))
rownames(b)=paste0('x',nn)
colnames(b)=paste0('y',nn)
b # x / y
p=1/n
q=1-p # q^n.sample > 1-confidence.level
n.sample = log(1-confidence.level)/log(q)
return(n.sample)
}
n.sample=log(0.05)/log(0.999)
n=length(Cards)
n1=ceiling(n/2)
n2=n-n1
C1=Cards[1:n1]
C2=Cards[(n1+1):n]
ret=NULL
for(i in 1:n1){
ret=c(ret,C1[i],C2[i])
}
ret[is.na(ret)==F]
}
x=as.character(c('A',2:10,'J','Q','K'))
cat(x,'\n') ; cat(shuffle(x))
Shuffles <- function(x){
tmp=shuffle(x)
i=1
while(!identical(x,tmp)){
tmp=shuffle(tmp)
i=i+1
}
return(i)
}
f =function(x)Shuffles(1:x)
nn=1:53
y=sapply(nn,f)
plot(nn,y,pch=16,bty='l',xlab='cards',ylab='shuffles')
cbind(nn,y)
inversion <- function(x){ # 転倒数
n=length(x)
ret=numeric(n)
for(i in 1:(n-1)){
ret[i] = sum(x[i] > x[(i+1):n])
}
sum(ret)
}
x=c(4, 3, 5, 2, 1)
inversion(x)
is.even= function(x) !inversion(x)%%2
is.even(x)
prisoner99 <- function(n=100){
indx=sample(1:n,1) # defective number
X=sample((1:n)[-indx]) ; is.even(X)
Y=numeric(n-1)
for (i in 1:(n-1)){
x1=X[-i]
x2=(1:n)[!(1:n) %in% x1] # 囚人iが見えない番号
tmp=X
tmp[i]=x2[1] ; tmp[n]=x2[2]
Y[i]=ifelse(is.even(tmp), x2[1],x2[2]) # 偶順列になるように選択
}
all(X==Y)
}
mean(replicate(1e3,prisoner99()))
inversion <- function(x){
n=length(x)
ret=numeric(n)
for(i in 1:(n-1)){
ret[i] = sum(x[i] > x[(i+1):n])
}
sum(ret) # inversion number
}
is.even= function(x) !inversion(x)%%2 # is inverion number even?
prisoner99 <- function(n=100){
indx=sample(1:n,1) # defective number
X=sample((1:n)[-indx])
Y=numeric(n-1)
for (i in 1:(n-1)){ # select as even permutation
x1=X[-i]
x2=(1:n)[!(1:n) %in% x1] # two numbers unseen for i-th prisoner
tmp=X
tmp[i]=x2[1] ; tmp[n]=x2[2]
Y[i]=ifelse(is.even(tmp), x2[1],x2[2])
}
all(X==Y)
}
mean(replicate(1e3,prisoner99()))
n=length(x)
ret=numeric(n)
for(i in 1:(n-1)){
ret[i] = sum(x[i] > x[(i+1):n])
}
sum(ret)
}
is.even <- function(x) !inversion(x)%%2 # even inversion?
even.perm <- function(n=100){
indx=sample(1:n,1) # defective number
X=sample((1:n)[-indx]) # row of 99 prisoner numbers
is.even(X)
}
mean(replicate(1e3,even.perm())) # probability of even permutation
#無作為に２人を抽出して調べたところ
#二人とも女子学生である確率は１／２であった。
#この大学の女子学生数と男子学生数は何人か？
girlsboys <- function(g,b) g*(g-1)/(g+b)/(g+b-1)==1/2
gr=expand.grid(1:1000,1:1000)
(re=gr[which(mapply(girlsboys,gr[,1],gr[,2])),])
girlsboys(re[nrow(re),1],re[nrow(re),2])
# 無作為に２人を抽出して調べたところ
# 二人とも女子学生である確率は１／２であった。
# この大学の女子学生数と男子学生数は何人か？
girlsboys <- function(g,b) g*(g-1)/(g+b)/(g+b-1)==1/2
gr=expand.grid(1:1000,1:1000)
(re=gr[which(mapply(girlsboys,gr[,1],gr[,2])),])
# 検証
Vectorize(girlsboys)(re[,1],re[,2])
r=10
D=c(rep(1,r),rep(0,N-r))
hiseiki <- function(m){
found=0
for(i in 1:(N-r+m)){
found=found+sample(D,1)
if(found==m) break
}
return(i)
}
re=replicate(1e4,hiseiki(3))
mean(re)
sd(re)
BEST::plotPost(re,breaks=30)
coupons=NULL
while(!all((1:n) %in% coupons)){
coupons=append(sample(1:n,1),coupons)
}
return(length(coupons))
}
re=replicate(100,mean(replicate(1e3,cereals(5))))
> mean(re)
[1] 11.43503
cereals <- function(p){
n=length(p)
coupons=NULL
while(!all((1:n) %in% coupons)){
coupons=append(sample(1:n,1,p=p),coupons)
}
return(length(coupons))
}
mean(replicate(1e3,cereals(p)))
re=replicate(100,mean(replicate(1e3,cereals(p))))
mean(re)
n=length(p)
ABO=NULL
enough <- function(x){
pool=numeric(n)
for(i in 1:n) pool[i]=sum(ABO==i)
all(pool >= need)
}
while(!enough(ABO)){
ABO=append(sample(1:n,1,p=p),ABO)
}
return(length(ABO))
}
p=4:1
need=c(10,10,5,2)
re=replicate(1e4,blood.type(p,need))
BEST::plotPost(re)
a=4
b=3
c=2
d=1
s =a+b+c+d
a=a/s
b=b/s
c=c/s
d=d/s
BT(a,b,c,d)
idx=combn(1:(a+b),a)
n=ncol(idx)
mat=matrix(0,nrow=n,ncol=a+b)
for(i in 1:n) mat[i,idx[,i]]=1
tally <- function (x) any(cumsum(x)==cumsum(1-x))
mean(apply (mat,1,tally))
}
even.tally()
even.tally(5,10)
v=c(rep(1,a),rep(0,b))
f <- function(v){
x=sample(v)
any(cumsum(x)==cumsum(1-x))
}
mean(replicate(1e5,f(v)))
p=c(97/400,rep(1,365))
same.birth <- function(n,lwr=2,upr=1e6){
x=sample(date,n,replace=TRUE,prob=p)
di=max(table(x)
lwr<=di & di<=upr
}
birth <- function(n,lwr=2,upr=1e6,k=1e4){
mean(replicate(k,same.birth(n,lwr,upr)))
}
#
birth(100, 3)
vrb=Vectorize(birth)
x=1:50
y=vrb(x)
plot(x,y,pch=19)
abline(h=0.5,lty=3,col=4)
min(x[whic(y > 0.5)])
p=c(97/400,rep(1,365))
same.birth <- function(n,lwr=2,upr=1e6){
x=sample(date,n,replace=TRUE,prob=p)
di=max(table(x))
lwr<=di & di<=upr
}
birth <- function(n,lwr=2,upr=1e6,k=1e4){
mean(replicate(k,same.birth(n,lwr,upr)))
}
#
birth(100, 3)
vrb=Vectorize(birth)
x=1:50
y=vrb(x)
plot(x,y,pch=19)
abline(h=0.5,lty=3,col=4)
min(x[whic(y > 0.5)])
p=c(97/400,rep(1,365))
same.birth <- function(n,lwr=2,upr=1e6){
x=sample(date,n,replace=TRUE,prob=p)
di=max(table(x)
lwr<=di & di<=upr
}
birth <- function(n,lwr=2,upr=1e6,k=1e4){
mean(replicate(k,same.birth(n,lwr,upr)))
}
#
birth(100, 3)
vrb=Vectorize(birth)
x=1:50
y=vrb(x)
plot(x,y,pch=19)
abline(h=0.5,lty=3,col=4)
min(x[whic(y > 0.5)])
ある診断キットが開発されたとする。
このキットは特異度は９９％と良好であったが、
感度については確かな情報がない。
事前確率分布として一様分布を仮定する。
５０人を無作為抽出してこの診断キットで診断したところ４０人が陽性であった。
この母集団の有病率の期待値と９５％信用区間はいくらか？
またこの診断キットの感度の期待値と９５％信用区間はいくらか
暇つぶしにこれをMCMCを使わずに解く方法を考えていた。
偽陽性率FP=0.01として
陽性確率p=TP*x+(1-x)*FP
尤度が50C40*p^40*(1-p)^10
TPは一様分布なので積分消去して
確率密度関数に比例する関数を作ってarea under the curveで割って確率密度関数化したのち積分して累積密度関数をつくる。この累積密度関数の逆関数を作って95%区間が最短になる区間を計算すれば信頼区間が算出できる。
この結果がstanでのシミュレーションの結果と一致すればよし。
same.birthday <- function(n) 1-choose(365+97/400,n)*factorial(n)/(365+97/400)^n
plot(x,y,bty='l',xlab='subjects',ylab='probability')
curve(same.birthday(x),add = TRUE)
abline(h=0.5,col=8)
same.birthday(22:23)
N=50
z=40
FP=0.01
shape1=1
shape2=1
dataList=list(N=N,z=z,FP=FP,shape1=shape1,shape2=shape2)
modelstring <- paste0("
model{
theta=TP*x+FP*(1-x)
z ~ dbinom(theta,N)
TP ~ dbeta(shape1,shape2)
x ~ dbeta(shape1,shape2)
}"
)
writeLines( modelstring , con="TEMPmodel.txt" )
jagsModel = jags.model( file="TEMPmodel.txt" , data=dataList, quiet=TRUE)
update(jagsModel)
codaSamples = coda.samples( jagsModel ,
variable=c("TP","x","theta"), n.iter=100000 )
js=as.matrix(codaSamples)
head(js)
BEST::plotPost(js[,'TP'],xlab='sensitivity')
BEST::plotPost(js[,'x'],xlab='prevalence')
BEST::plotPost(js[,'theta'],xlab='positive result',showMode = TRUE)
z=40
FP=0.01
shape1=1
shape2=1
data = list(N=N,z=z,FP=FP,shape1=shape1,shape2=shape2)
stanString=paste0('
data{
int N;
int z;
real FP;
real shape1;
real shape2;
}
parameters{
real<lower=0,upper=1> TP;
real<lower=0,upper=1> x; //prevalence
}
transformed parameters{
real<lower=0,upper=1> theta;
theta=TP*x+FP*(1-x);
}
model{
z ~ binomial(N,theta);
TP ~ beta(shape1,shape2); // T[0.5,];
x ~ beta(shape1,shape2);
}
')
# saveRDS(model,'quick_kit.rds')
model=readRDS('quick_kit.rds')
fit=sampling(model,data=data,iter=10000)
print(fit,digits=3,probs=c(.025,.50,.975))
stan_trace(fit)
# stan_diag(fit)
stan_ac(fit)
stan_dens(fit,separate_chains = TRUE)
stan_hist(fit,fill='skyblue',bins=15,pars=c('x','TP'))
ms=rstan::extract(fit)
BEST::plotPost(ms$TP,showMode = TRUE,xlab='TP')
BEST::plotPost(ms$x,showMode = FALSE,xlab='prevalence',col=sample(colours(),1))
pos=1
while(pos<k){
if(pos==0) return(FALSE)
pos=pos+sample(c(1,-1),1,prob=c(p,1-p))
}
return(TRUE)
}
mean(replicate(1e2,escape.cliff()))
while(pos<k){
if(pos==0) return(FALSE)
pos=pos+sample(c(1,-1),1,prob=c(p,1-p))
}
return(TRUE)
}
mean(replicate(1e3,escape.cliff(10,0.5,100)))
#
totter <- function(p=2/3,pos=1,pos0=NULL,k=1e3){
if(is.null(pos0)) pos0=pos
for(i in 1:k) {
if(pos==0) return(FALSE)
pos=pos+sample(c(1,-1),1,prob=c(p,1-p))
}
return(pos>pos0)
}
mean(replicate(1e3,totter(0.5,10,5 )))
while(hit<k){
money=money-1
if(money==0) return(FALSE)
shoot=sample(c(1,0),1,prob=c(p,1-p))
if(shoot){
money=money+1
hit=hit +1
}
}
return(TRUE)
}
mean(replicate(1e5, exam()))
while(grade<6){
test=rbinom(1,1,p)
if(test) grade=grade+1
else ryu=ryu+1
if(ryu==2){
money=money-5
ryu=ryu-1
}
if(money<=0) return(FALSE)
}
return(grade==6)
}
mean(replicate(1e5,ryunen()))
while(pos<k){
if(pos==0) return(FALSE)
pos=pos+sample(c(1,-1),1,prob=c(p,1-p))
}
return(TRUE)
}
mean(replicate(1e5,escape.cliff(1,2/3,3)))
4/7
while(0<money & money <40){
money=money+sample(c(1,-1),1,p=c(p,1-p))
}
return(money==40)
}
mean(replicate(1e3, gmbl()))
mean(replicate(1e5,which(sample(x)==1)[1]))
y=numeric(48)
for(i in 1:48) y[i]=i*choose(48,i-1)*factorial(i-1)*4*factorial(52-i)/factorial(52)
sum(y)
Guess how many locomotives the company has.
(b) You have looked at 5 locomotives and the largest number observed is 60.
Again guess how many locomotives the company has.
m=60
N=n:100
loco <- function(x){
max(sample(1:x,n))
}
vloco=Vectorize(loco)
loco.sim <- function() N[which(vloco(N)==m)]
locomotives=unlist(replicate(1e4,loco.sim()))
BEST::plotPost(locomotives,breaks=30)
HDInterval::hdi(locomotives)
library(gtools)
y=permutations(n,n,1:n)
f=function(x) sum(x==1:n)
sum(apply(y,1,f))/length(y)
1/n
sum(sample(1:n)==1:n)/n
}
g=function(n)mean(replicate(1e4,f(n)))
vg=Vectorize(g)
x=1:100
plot(x,vg(x))
curve(1/x,add=T)
u=10^(2:0)
f=function(a,b,c,x=1776) sum(c(a,b,c)*u+c(b,c,a)*u+c(c,a,b)*u)-x
# when A>B>C
idx=which(mapply(f,gr[,1],gr[,2],gr[,3])==0 & gr[,1]>gr[,2] & gr[,2]>gr[,3])
gr[idx,]
# otherwise
idx2=which(mapply(f,gr[,1],gr[,2],gr[,3])==0)
length (idx2)
gr[idx2,]
m=60
N=n:100
loco <- function(x){
max(sample(1:x,n))
}
vloco=Vectorize(loco)
loco.sim <- function() N[which(vloco(N)==m)]
locomotives=unlist(replicate(1e4,loco.sim()))
BEST::plotPost(locomotives,breaks=30)
HDInterval::hdi(locomotives)
n=60:100
pmf=choose(59,4)/choose(n,5) #Pr(max=60|n)
pdf=pmf/sum (pmf)
sum( n*pdf) #E(n)
lines(n,pdf)
mean(replicate(1e5,sum(sample(1:n)-1:n==0)))
}
own(100)
n=length(x)
y=numeric(n)
y[1]=x[n]
for(i in 1:(n-1)){
y[i+1]=x[i]
}
return(y)
}
rn <- function(x){ # every rotation
n=length(x)
mat=matrix(rep(NA,n^2),ncol=n)
mat[,1]=x
for(i in 1:(n-1)){
mat[,i+1]=r1(mat[,i])
}
return(t(mat))
}
same <- function(x,y){
if(sum(x)!=sum(y)) return(FALSE)
f=function(a,b=y){ # is equal to y
all(a==b)
}
mat=rbind(rn(x),rn(rev(x))) # with symmetric conversion
any(apply(mat,1,f))
}
if(num <= 0 && digit <= 0){
return(NULL)
}else{
return(append(Recall(num%/%2,digit-1), num%%2))
}
}
vd2b=Vectorize(dec2bin)
#
bracelett <- function(n){
mat=t(vd2b(0:(2^n-1),n)) # make all permutation of beads
# head(mat)
ret=list() # list of the same bracelett
for(i in 1:2^n){
ret[[i]]=which(apply(mat,1,function(z)same(z,mat[i,])))
}
# head(ret) ; table(unlist(ret))
del=NULL
for(i in 1:2^n) del=append(del,ret[[i]][-1])
2^n - length(unique(del))
}
> swap <- function(n){
+ perm=permutations(n,n,1:n)
+ mean(apply(perm,1,function(x)sum(x==1:n)))
+ }
> swap(9)
[1] 1
> swap.sim <- function(n,k=1e5){
+ mean(replicate(k,sum(sample(1:n)==1:n)))
+ }
> swap.sim(9)
[1] 1.0004
re=numeric(n)
for(i in 0:n){
p=1/n
re[i]=i*choose(n,i)*p^i*(1-p)^(n-i)
}
sum(re)
}
swap2(7)
#
swap3 <- function(n){
re=numeric(n)
for(i in 0:n){
p=1/n
re[i]=i*dbinom(i,n,p)
}
sum(re)
}
swap3(7)
args=list()
length(args)=n-1
args[[1]]=args[[n-1]]=1:2
for(i in 2:(n-2)){
args[[i]]=0:2
}
gr=do.call(expand.grid,args)
gr=as.matrix(gr)
ret=numeric()
for(i in 1:nrow(gr)){
ret[i]=all(diff(gr[i,])!=0)
}
sum(ret)
}
#include<stdio.h> /* SEND+MORE=MONEY */
int compare_int(const void *a, const void *b)
{return *(int*)a - *(int*)b;}
int i,j;
int unique(int num[8]){
qsort(num,8,sizeof(int),compare_int);
for(i=0;i<8;i++){
for(j=0;j<i;j++){
if(num[j]==num[j+1]){
return 0;
}}}
return 1;
}
main(){
int S,E,N,D,M,O,R,Y;
for(S = 1; S < 10; S++){
for(E = 0; E < 10; E++){
for(N = 0; N < 10; N++){
for(D = 0; D < 10; D++){
for(M = 1; M < 10; M++){
for(O = 0; O < 10; O++){
for(R = 0; R < 10; R++){
for(Y = 0; Y < 10; Y++){
if(S*1000+E*100+N*10+D+M*1000+O*100+R*10+E==M*10000+O*1000+N*100+E*10+Y){
int num[]={S,E,N,D,M,O,R,Y};
if(unique(num)==1){
printf("%d%d%d%d+%d%d%d%d=%d%d%d%d%d\n", S,E,N,D,M,O,R,E,M,O,N,E,Y);
}}}}}}}}}}}
C:\MinGW>gcc sendmore.c -o money
C:\MinGW>money
9567+1085=10652
int compare_int(const void *a, const void *b){
return *(int*)a - *(int*)b;}
int unique(int num[]){
int i,j,n=10;
qsort(num,n,sizeof(int),compare_int);
for(i=0;i<n;i++){
for(j=0;j<i;j++){
if(num[j]==num[j+1]){
return 0;
}}}
return 1;}
main(){ /* ド底辺＋私立医＝裏口馬鹿 */
int n=1,A,B,C,D,E,F,G,H,I,J;
for(A = 1; A < 10; A++){
for(B = 0; B < 10; B++){
for(C = 0; C < 10; C++){
for(D = 1; D < 10; D++){
for(E = 0; E < 10; E++){
for(F = 0; F < 10; F++){
for(G = 1; G < 10; G++){
for(H = 0; H < 10; H++){
for(I = 0; I < 10; I++){
for(J = 0; J < 10; J++){
if(A*100+B*10+C +D*100+E*10+F==G*1000+H*100+I*10+J){
int num[]={A,B,C,D,E,F,G,H,I,J};
if(unique(num)==1){
printf("%2d: %d%d%d + %d%d%d = %d%d%d%d\n", n,A,B,C,D,E,F,G,H,I,J);
n++;
}}}}} }}} }}} }}
# それらをたしてできた数は、
# 十の位と一の位の数字が等しい２けたの整数になり、
# それらをかけてできた数は、
# 百の位、十の位、一の位が等しい３けたの整数になりました。
# このような２つの整数の組をあるだけ答えなさい。
gr=expand.grid(1:99,1:99)
f <- function(x,y){ all(x>=y,c((x+y)%%10==(x+y)%/%10,(x*y)%/%100==((x*y)%/%10)%%10,(x*y)%/%100==(x*y)%%10))}
gr[which(mapply(f,gr[,1],gr[,2])==TRUE),]
# Consider a function which, for a given whole number n,
# returns the number of ones required when writing out all numbers between 0 and n.
# For example, f(13)=6. Notice that f(1)=1.
# What is the next largest number n such that f(n)=n.
ｆ０ ＜－ ｆｕｎｃｔｉｏｎ（ｎ）｛
ｙ＝ａｓ．ｃｈａｒａｃｔｅｒ（ｎ）
ｎｃ＝ｎｃｈａｒ（ｙ）
ｚ＝ＮＵＬＬ
ｆｏｒ（ｉ ｉｎ １：ｎｃ） ｚ［ｉ］ ＜－ ｓｕｂｓｔｒ（ｙ，ｉ，ｉ）＝＝１
ｒｅｔｕｒｎ（ｓｕｍ（ｚ））
｝
ｆ ＜－ ｆｕｎｃｔｉｏｎ（ｎ）｛
ｒｅ＝ｎｕｍｅｒｉｃ（）
ｒｅ［１］＝１
ｆｏｒ（ｉ ｉｎ ２：ｎ）｛
ｒｅ［ｉ］＝ｒｅ［ｉ－１］＋ｆ０（ｉ）
｝
ｒｅｔｕｒｎ（ｒｅ［ｎ］）
｝
ｇ ＜－ ｆｕｎｃｔｉｏｎ（ｎ） ｎ － ｆ（ｎ）
ｉ＝１９９９７９
ｗｈｉｌｅ（ｇ（ｉ）！＝０）｛
ｉ＜－ｉ＋１
｝
ｉ
=5*5!+(4+1)*4!
=5*5!+4*4!+4!
=5*5!+4*4!+(3+1)*3!
=5*5!+4*4!+3*3!+3!
=5*5!+4*4!+3*3!+(2+1)*2!
=5*5!+4*4!+3*3!+2*2!+2!
=5*5!+4*4!+3*3!+2*2!+1*1!+1
factorial(n+1)= sum(factoral(n:1)*(n:1))+1
６！＊Ｂ＋５！＊Ｃ＋４！＊Ｄ＋３！＊Ｅ＋２！＊Ｆ＋１！＊Ｇ＝５５５５
が成立するときＢ＋Ｃ＋Ｄ＋Ｅ＋Ｆ＋Ｇの最小となるＢ～Ｇの組み合わせを求めよ。
n=5555
f <- function(B,C,D,E,F,G) sum(factorial(6:1)*c(B,C,D,E,F,G))-n
max=n%/%factorial(6)
gr=expand.grid(0:max,0:6,0:5,0:4,0:3,0:2)
ret=mapply(f, gr[,1],gr[,2],gr[,3],gr[,4],gr[,5],gr[,6])
bg=apply(gr[which(ret==0),],1,sum)
(min.sum=bg[which.min(bg)])
gr[names(min.sum),]
n%/%factorial(6)
n%%factorial(6)%/%factorial(5)
n%%factorial(6)%%factorial(5)%/%factorial(4)
n%%factorial(6)%%factorial(5)%%factorial(4)%/%factorial(3)
n%%factorial(6)%%factorial(5)%%factorial(4)%%factorial(3)%/%factorial(2)
n%%factorial(6)%%factorial(5)%%factorial(4)%%factorial(3)%%factorial(2)%/%factorial(1)
#include<string.h>
int compare_int(const void *a, const void *b){
return *(int*)a - *(int*)b;
}
main( int argc, char *argv[] ){
char N = '0'+ atoi(argv[1]);
int a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t;
for(a = 0; a < 10; a++){
for(b = 0; b < 10; b++){
for(c = 0; c < 10; c++){
for(d = 0; d < 10; d++){
for(e = 0; e < 10; e++){
for(f = 0; f < 10; f++){
for(g = 0; g < 10; g++){
for(h = 0; h < 10; h++){
for(i = 0; i < 10; i++){
for(j = 0; j < 10; j++){
for(k = 0; k < 10; k++){
for(l = 0; l < 10; l++){
for(n = 0; n < 10; n++){
for(o = 0; o < 10; o++){
for(p = 0; p < 10; p++){
for(q = 0; q < 10; q++){
for(r = 0; r < 10; r++){
for(s = 0; s < 10; s++){
for(t = 0; t < 10; t++){
int num[]={a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t};
qsort(num,20,sizeof(int),compare_int);
char NUM[20];
int i;
for(i=0;i<20;i++){
NUM[i]='0'+ num[i];
}
char N4[4]={N,N,N,N};
char N5[5]={N,N,N,N,N};
if(strstr(NUM,N4)!=NULL & strstr(NUM,N5)==NULL &
(100*a+10*b+c)*f == 100*g+10*h+i &
(100*a+10*b+c)*e == 100*j+10*k+l &
(100*a+10*b+c)*d == 100*m+10*n+o &
(100*m+10*n+o)*100 + (100*j+10*k+l)*10 + 100*g+10*h+i == p*10000+q*1000+r*100+s*10+t
){
printf("abc def ghi jkl mno pqrst = %d%d%d %d%d%d %d%d%d %d%d%d %d%d%d %d%d%d%d%d\n",
a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t);
}
}}}}} }}}}} }}}}} }}}}}
}
fibon <- function(N){
f=numeric(N)
f[1]=1
f[2]=1
if(N>2){for(i in 3:N){
f[i]=f[i-2]+f[i-1]
}}
return(f[N])
}
Vectorize(fibon)(1:15)
fibon(50)
fibon(100)# wrong!
c([X|L1],L2,[X|L3]) :- c(L1,L2,L3).
L = [1,2,3,4,5,6,7,8,9],
X = [4,5,6,7,8,9],
Y = [4,5,6] ;
No
last([_|Rest],Last) :- last(Rest,Last).
% last([1,2,3,4,5],Last).
それぞれの血液型の人を最低でも各々４、３、２、１人集めるためには必要な人数の期待値はいくらか？
blood.type <- function(p,need){
n=length(p)
ABO=NULL
enough <- function(x){
pool=numeric(n)
for(i in 1:n) pool[i]=sum(ABO==i)
all(pool >= need)
}
while(!enough(ABO)){
ABO=append(sample(1:n,1,p=p),ABO)
}
return(length(ABO))
}
p=4:1
need=c(4,3,2,1)
re=replicate(1e5,blood.type(p,need))
mean(re)
mean(replicate(k,blood.type(p,need)))
}
blood.samples()
blood.samples(need=4:1,k=1e4)
ｓｕｂｓｅｔ（［Ｆｉｒｓｔ｜Ｒｅｓｔ］，［Ｆｉｒｓｔ｜Ｓｕｂ１］） ：－ ｓｕｂｓｅｔ（Ｒｅｓｔ，Ｓｕｂ１）．
ｓｕｂｓｅｔ（［＿｜Ｒｅｓｔ］，Ｓｕｂ２） ：－ ｓｕｂｓｅｔ（Ｒｅｓｔ，Ｓｕｂ２）．
？－ ｓｕｂｓｅｔ（［ド底辺，特殊，シリツ医大，イカサマ入試，裏口，馬鹿］，＿恥）， ｗｒｉｔｅｌｎ（＿恥），ｆａｉｌ．
N=5
library(gtools)
perm=permutations(n=2,r=N,v=c(1,5), repeats.allowed = TRUE)
move=t(apply(perm,1,cumsum))
p0=0
P=(p0+move)%%6
q0=2
Q=(q0+move)%%6
is.fe <- function(x,y){ # is first encounter after N sec?
all(x[-N]!=y[-N]) & x[N]==y[N]
}
re=NULL
for(i in 1:nrow(P)){
for(j in 1:nrow(Q)){
re=append(re,is.fe(P[i,],Q[j,]))
}
}
(Ans=mean(re)) ; 3^(N-1)/(2^N)^2
cat(Ans*(2^N)^2,'/',(2^N)^2)
sum(x==y) >= M
}
M=2
re=NULL
for(i in 1:nrow(P)){
for(j in 1:nrow(Q)){
re=append(re,is.pe(P[i,],Q[j,],M))
}
}
(Ans=mean(re))
cat(Ans*(2^N)^2,'/',(2^N)^2)
if(n >= 1){
Recall(n-1,from,to,via)
cat('move',n,'from',from,' to ',to,'\n')
Recall(n-1,via,from,to)
}
}
hanoi(4)
VAT <- function(n,m=1.08){
if(n==0) 0
else Recall(n-1) + m
}
VAT(250)
sup <- function(v){
if (length(v)==0) 0
else v[1] + Recall(v[-1])
}
sup(1:10)
> A <- function(m,n){
+ if(m==0) return(n+1)
+ if(n==0) return(Recall(m-1,1))
+ else return(Recall(m-1,Recall(m,n-1)))
+ }
>
> A(2,4)
[1] 11
> A(3,4)
[1] 125
> A(4,1)
Error: evaluation nested too deeply: infinite recursion / options(expressions=)?
>
# cumsum with for-loop
cumsumL <- function(v){
n=length(v)
re=numeric(n)
re[1]=v[1]
for(i in 1:(n-1)) re[i+1]=re[i]+v[i+1]
re
}
# cumsum with recursive call
cumsumR <- function(v,res=NULL,i=1){
res[1]=v[1]
if(i==length(v)) return(res)
else{
res[i+1] = res[i] + v[i+1]
Recall(v,res,i+1)
}
}
}
dec2n <- function(num, N = 2, digit = 0){ # decimal to 0,1,..,n-1 vector
if(num==0 & digit==0) return(0)
if(num <= 0 & digit <= 0) return()
else{
return(append(Recall(num%/%N, N ,digit-1), num%%N))
}
}
> dec2n(0)
[1] 0
> dec2n(11,digit=5)
[1] 0 0 1 0 1 1
> dec2n(9,N=5,digit=3)
[1] 0 0 1 4
> dec2n(1000,N=16)
[1] 3 14 8
dec2n <- function(num, N = 2, digit = 1){ # decimal to 0,1,..,n-1 vector
if(num <= 0 & digit <= 0) return()
else{
return(append(Recall(num%/%N, N ,digit-1), num%%N))
}
}
dec2n(0)
dec2n(11,digit=5)
dec2n(9,N=5,digit=3)
dec2n(1000,N=16)
#
dec2hex <- function(x){ # decimal to hexa
hex=c(0:9,letters[1:6])
n=length(x)
re=numeric(n)
for(i in 1:n){
if(x[i]==0) re[i]='0'
else re[i]=hex[x[i]+1]
}
cat(re,'\n')
}
dec2hex(c(1,0,15))
dec2hex(dec2n(1000,16))
dec2sexa <- function(x) dec2hex(dec2n(x,16))
X <- function(n,red=10,white=90){
rw=red+white
total=martix(0,nrow=n,ncol=2^n)
p=martix(0,nrow=n,ncol=2^n)
total[1,1:2]=c(rw-1,rw+1)
p[1,1:2]=c(white/rw,red/rw)
if(n > 1){
for(i in 1:n){
li=2^i
total[i+1,1:(2*li)]=c(total[i,1:li]-1, total[i,1:li]+1)
p[i+1,1:2*li)]=c(p[i,1:li]*(total[i,1:li]-red)/total[i,1:li], p[i,1:li]*(red)/total[i,1:li])
}
}
return(sum(p[n,]*total[n,]))
}
X = function(n,r=10,w=90){ #n:試行数 r: 赤玉数 w:白玉数
rw=r+w # 試行前総玉数
J=rw+n # 総玉数の上限
# s[i,j] i回試行後に総数がj個である確率の行列
s=matrix(0,nrow=n,ncol=J)
s[1,rw-1]=w/rw ; s[1,rw+1]=r/rw # 1回試行後
if(n > 1){
for(i in 2:n){
for(j in r:J){ # jはr未満にはならない
# if(j==1) s[i,j] = s[i-1,j+1]*(j+1-r)/(j+1)
if(j==J) s[i,j] = s[i-1,j-1] * r/(j-1)
else s[i,j] = s[i-1,j-1] * r/(j-1) + s[i-1,j+1]*(j+1-r)/(j+1)
}
}
}
total=sum((r:J)*s[n,r:J])# n回試行後総数の期待値
white=total-r
return(c(total=total,white=white))
}
> vX=Vectorize(X)
> vX(1000:1010)
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11]
total 20.5 20.5 20.5 20.5 20.5 20.5 20.5 20.5 20.5 20.5 20.5
white 10.5 10.5 10.5 10.5 10.5 10.5 10.5 10.5 10.5 10.5 10.5
# http://i.imgur.com/uBTnujq.png
H=(sqrt(5+2*sqrt(5)))/2
A=0.5+0i
B=A+r
shiomaneki <- function(x,y){
xy=x+y*1i
(abs(xy-A)+abs(xy-B)+x)*2 + 1
}
x=seq(0,Re(B),length=100)
y=seq(0,H,length=100)
z=outer(x,y,shiomaneki)
contour(x,y,z,nlevels=20,lwd=2,bty='l')
x11() ;persp(x,y,z, theta=35, lty=3,col="lightblue",xlab='x',ylab='y',zlab='z',
ticktype='detailed',shade=0.75,phi=30,ltheta=-10,border=TRUE)
rgl::persp3d(x,y,z,col='blue')
sio <- function(xy) shiomaneki(xy[1],xy[2])
optim(c(0.4,0.4),sio,method='Nelder-Mead')
# https://i.imgur.com/VhC8cug.png
H=(sqrt(5+2*sqrt(5)))/2
A=0.5+0i
B=A+r
C=0+H*1i
abs(C-B)
kabutogani <- function(y1,y2){
K=0+y1*1i
G=0.5+y2*1i
abs(K-C) + 2*abs(K-G) + 2*abs(G-A) +2*abs(G-B)
}
y1=seq(0,H,length=100)
y2=seq(0,H,length=100)
z=outer(y1,y2,kabutogani)
contour(y1,y2,z,nlevel=100,lwd=2,xlim=c(0.5,1.5),ylim=c(0,1.2),bty='l')
kab <- function(y1y2) kabutogani(y1y2[1],y1y2[2])
optim(c(1,0.5),kab, method = 'Nelder-Mead')
q=2*pi/n
r=cos(q)+1i*sin(q)
p=numeric(n+1)
for(i in 1:(n+1)) p[i]=r^(i-1)
D=NULL
if(n>3){
for(j in 3:(2+ceiling(n-3)/2)){
D= append(D,abs(p[1]-p[j]))
}
}
if(print){
plot(p,type='l',bty='l',axes=FALSE,ann=FALSE,lwd=2)
for(i in 3:(n-1)) segments(1,0,Re(p[i]),Im(p[i]),col='gray')
}
return(D)
}
DOP(17,p=T)
q=2*pi/n
r=cos(q)+1i*sin(q)
p=numeric(n+1)
for(i in 1:(n+1)) p[i]=r^(i-1)
D=NULL
if(n>3){
for(j in 3:(2+ceiling(n-3)/2)){
D= append(D,abs(p[1]-p[j])/abs(p[1]-p[2]))
}
}
if(print){
plot(p,type='l',bty='l',axes=FALSE,ann=FALSE,lwd=2)
for(i in 3:(n-1)) segments(1,0,Re(p[i]),Im(p[i]),col='gray')
}
return(D)
}
DOP(17,p=T)
[1] 2.190643
graphics.off()
ngon <- function(n,digit=TRUE,axis=FALSE,cex=1){
r=exp(2*pi/n*1i)
p=complex(n)
for(i in 1:(n+1)) p[i]= (1-r^i)/(1-r)
plot(p,bty='l',type='l',axes=axis, ann=FALSE,lwd=1,asp=1)
points(1/(1-r),pch='.')
if(digit) text(Re(p),Im(p),1:n,cex=cex)
if(axis){axis(1) ; axis(2)}
invisible(p)
}
r=exp(2*pi/n*1i)
p=complex(n)
for(i in 1:(n+1)) p[i]= (1-r^i)/(1-r)
plot(p,bty='l',type='l',axes=axis, ann=FALSE,asp=1,...)
points(1/(1-r),pch='.')
if(digit) text(Re(p),Im(p),paste('p',1:n),cex=cex)
if(axis){axis(1) ; axis(2)}
invisible(p)
}
seg <- function(a,b,...) segments(Re(a),Im(a),Re(b),Im(b),col=2,lwd=2,...)
pt <- function(x,y,...) text(Re(x),Im(x), y,...)
kabutogani3 <- function(xl,yl,xc,yc,xr,yr){
L=xl+yl*1i
C=xc+yc*1i
R=xr+yr*1i
abs(p[3]-C)+abs(C-R)+abs(C-L)+abs(R-p[2])+abs(L-p[4])+abs(R-p[1])+abs(L-p[5])
}
kabu3 <- function(par){
kabutogani3(par[1],par[2],par[3],par[4],par[5],par[6])
}
p=ngon(5,axis=T,col='lightblue',lwd=2)
opt=optim(runif(6),kabu3,method='Nelder-Mead')
kabu3(opt$par)
(par=opt$par)
L=par[1]+par[2]*1i
C=par[3]+par[4]*1i
R=par[5]+par[6]*1i
pt(C,'C') ; pt(L,'L') ; pt(R,'R')
seg(p[1],R);seg(p[2],R);seg(p[3],C);seg(p[4],L);seg(p[5],L);seg(L,C);seg(R,C)
r=exp(2*pi/n*1i)
p=complex(n)
for(i in 1:(n+1)) p[i]= (1-r^i)/(1-r)
plot(p,bty='l',type='l',axes=axis, ann=FALSE,asp=1,...)
points(1/(1-r),pch='.')
if(digit) text(Re(p),Im(p),paste('p',1:n),cex=cex)
if(axis){axis(1) ; axis(2)}
invisible(p)
}
seg <- function(a,b,...) segments(Re(a),Im(a),Re(b),Im(b),col=2,lwd=2,...)
pt <- function(x,y,...) text(Re(x),Im(x), y,...)
kabutogani3 <- function(xl,yl,xc,yc,xr,yr){
L=xl+yl*1i
C=xc+yc*1i
R=xr+yr*1i
abs(p[3]-C)+abs(C-R)+abs(C-L)+abs(R-p[2])+abs(L-p[4])+abs(R-p[1])+abs(L-p[5])
}
kabu3 <- function(par){
kabutogani3(par[1],par[2],par[3],par[4],par[5],par[6])
}
p=ngon(5,axis=T,col='lightblue',lwd=2)
opt=optim(runif(6),kabu3,method='CG')
kabu3(opt$par)
(par=opt$par)
L=par[1]+par[2]*1i
C=par[3]+par[4]*1i
R=par[5]+par[6]*1i
pt(C,'C') ; pt(L,'L') ; pt(R,'R')
seg(p[1],R);seg(p[2],R);seg(p[3],C);seg(p[4],L);seg(p[5],L);seg(L,C);seg(R,C)
# allocated to 1 room (4 vacant)
a1=choose(5,1)*1^6 ; a1
# allocated to 2 rooms (3 vacant)
a2=choose(5,2)*(2^6-2) ; a2
# allocated to 3 rooms (2 vacant)
a3=choose(5,3)*( 3^6-choose(3,2)*(2^6-2)-3 ) ; a3
# allocated to 4 rooms (1 vacant)
a4=choose(5,4)*( 4^6 - choose(4,3)*(3^6-choose(3,2)*(2^6-2)-3) - choose(4,2)*(2^6-2)-4 ) ; a4
5^6 - a1 - a2 - a3 - a4
if(num <= 0 & digit <= 0) return()
else{
return(append(dec2n(num%/%N, N ,digit-1), num%%N))
}
}
room.allocation <- function(n,r){ # allocate n people to r rooms without vacancy
max=r^n
counter=0
x=0
while(x < max){
if(length(unique(dec2n(x,r,n))) == r) counter = counter+1
x= x + 1
}
return(counter)
}
r = (b^2 + h^2)/(2*h)
V = (2/3*r^3 - r^2*(r-h) + (r-h)^3/3)*pi
return(c(radius=r,Volume=V))
}
r = (b^2 + h^2)/(2*h)
if(b > h) V = (2/3*r^3 - r^2*(r-h) + (r-h)^3/3)*pi
else V = (r^2*(h-r) - 1/3*(h-r)^3 + 2*r^3/3)*pi
return(c(radius=r,Volume=V))
}
# how many ways of allocating 6 rooms to n people without vacancy?
# allocated to 1 room
a1=choose(6,1)*1^n
# allocated to 2 rooms
a2=choose(6,2)*(2^n-2)
# allocated to 3 rooms
a3=choose(6,3)*( 3^n-choose(3,2)*(2^n-2)-3 )
# allocated to 4 rooms
a4=choose(6,4)*( 4^n - choose(4,3)*(3^n-choose(3,2)*(2^n-2)-3) - choose(4,2)*(2^n-2)-4 )
# allocated to 5 rooms
a5=choose(6,5)*( 5^n - choose(5,4)*(4^n-choose(4,3)*(3^n-
choose(3,2)*(2^n-2)-3) - choose(4,2)*(2^n-2)-4)-choose (5,3)*(3^n-choose(3,2)*(2^n-2)-3) - choose (5,2)*(2^n -2) -5
6^n - a1 - a2 - a3 - a4 - a5
library(Rmpfr)
six_rooms <- function(x){
if(x[1]<10) n=x else n=mpfr(x,100)
# allocated to 1 room
a1=choose(6,1)*1^n
# allocated to 2 rooms
a2=choose(6,2)*(2^n-2)
# allocated to 3 rooms
a3=choose(6,3)*( 3^n-choose(3,2)*(2^n-2)-3 )
# allocated to 4 rooms
a4=choose(6,4)*( 4^n - choose(4,3)*(3^n-choose(3,2)*(2^n-2)-3) - choose(4,2)*(2^n-2)-4 )
# allocated to 5 rooms
a5=choose(6,5)*(5^n-choose(5,4)*(4^n-choose(4,3)*(3^n-choose(3,2)*(2^n-2)-3)
-choose(4,2)*(2^n-2)-4)-choose(5,3)*(3^n-choose(3,2)*(2^n-2)-3)-choose(5,2)*(2^n -2) -5)
6^n - a1 - a2 - a3 - a4 - a5
}
if(m==n) return(factorial(m))
else if(m==1) return(1)
else m*Recall(m,n-1) + m*Recall(m-1,n-1)
}
#include<stdio.h>
long factorial(long n) {
long re = 1;
long k;
for(k=1;k <=n;k++) {re *= k;}
return re;
}
long rooms(int m, int n){
if(m==n) { return factorial(m);}
else if(m==1){ return 1;}
else{
return m * rooms(m,n-1) + m * rooms(m-1,n-1);
}
}
void main( int argc, char *argv[] ){
int m,n;
long ways;
m=atoi(argv[1]);
n=atoi(argv[2]);
ways=rooms(m,n);
printf("%d\n",ways);
}
高さ h のロケットおっぱいの体積
RocketPi <= function(a,b,c,h) 2/3*pi*a*b*c - 1/3*pi*b*c*(3*a^2-(a-h)^2)*(a-h)/a
RocketPi <= function(a,β,γ,h) # a:楕円体の長軸長, β,γ:ロケットおっぱいの楕円底面の軸長,ｈ：ロケットおっぱいの高さ
b=(a-h)*β/sqrt(a^2-(a-h)^2)
c=(a-h)*γ/sqrt(a^2-(a-h)^2)
2/3*pi*a*b*c - 1/3*pi*b*c*(3*a^2-(a-h)^2)*(a-h)/a
}
(1+sqrt(5))/2
f <- function(a=10,b=10,c=10){
xy2z <- function(x,y) c*sqrt(a^2*b^2-a^2*y^2-b^2*x^2)/(a*b)
x=seq(-a,a,le=50)
y=seq(-r*a,r*a,le=50)
z=outer(x,y,xy2z)
contour(x,y,z)
persp(x,y,z,
theta=35, lty=3,col="pink",xlab='x',ylab='y',zlab='z',ylim=c(-2*a,2*a),
ticktype='detailed',shade=0.75,phi=30,ltheta=-10,border=TRUE)
rgl::persp3d(x,y,z,col='pink')
}
f()
f(10,20,25)
segments(Re(a),Im(a),Re(b),Im(b),...)}
pt <- function(x,y=NULL,...){
text(Re(x),Im(x), ifelse(is.null(y),'+',y), ...)}
# solve α^2/a^2 + (b+β)^2/b^2=1 for a
α=3
β=-1
b=1
# α^2*b^2/(-β*(2*b+β))
(a = α*b/sqrt(-β*(2*b+β)))
(q=b+β)
f= function(x,y) x^2/a^2 + (y-q)^2/b^2 # = 1
x=seq(-5,5,length=100)
y=seq(-5,5,length=100)
z=outer(x,y,f)
contour(x,y,z,level=1,bty='l',xlim=c(-10,10),ylim=c(-2,10),
drawlabels=FALSE,col=sample(colours(),1),axes=FALSE,lwd=2)
pt(α,'●') ; pt(-α,'●') ; pt(β*1i,'●')
seg(-10,10,lty=3) ; seg(-4i,10i,lty=3)
pt(0+q*1i,'.')
eclipse <- function(b) {
# α^2*b^2/(-β*(2*b+β))
(a = α*b/sqrt(-β*(2*b+β)))
(q=b+β)
f= function(x,y) x^2/a^2 + (y-q)^2/b^2 # = 1
x=seq(-10,10,length=100)
y=seq(-10,10,length=100)
z=outer(x,y,f)
contour(x,y,z,level=1,drawlabels=FALSE,add=TRUE,col=sample(colours(),1),lwd=2)
pt(0+q*1i,'.')
}
for(i in 2:10) eclipse(i)
D=1
H=0
n=3
cards=c(rep(D,13),rep(H,39))
n.DH=length(cards)
n.D=sum(cards)
sim <- function(){
index_of_inbox=sample(1:n.DH,1)
inbox=cards[index_of_inbox]
outbox=cards[-index_of_inbox] # cards out of box
drawn=sample(outbox,n) # 2 cards drawn from outbox
c(inbox=inbox,drawn=drawn)
}
rate_sim <- function(k){
re=replicate(k,sim())
sum(apply(re,2,function(x) sum(x))==(n+1))/sum(apply(re,2,function(x) sum(x[-1]))==n)
}
re=replicate(100,rate_sim(1000))
summary(re)
#
f <- function(n,D=13,H=52-13){
T=D+H
(D/T * choose(D-1,n)/choose(T-1,n)) /((D/T * choose(D-1,n)/choose(T-1,n)) + H/T * choose(D,n)/choose(T-1,n))
}
n=0:12
f(n)
plot(n,f(n),pch=19,bty='l')
n=5
ngon <- function(n,digit=TRUE,axis=FALSE,cex=1,...){ # draw n-polygon
r=exp(2*pi/n*1i)
p=complex(n)
for(i in 1:(n+1)) p[i]= (1-r^i)/(1-r)
plot(p,bty='l',type='l',axes=axis, ann=FALSE,asp=1,...)
points(1/(1-r),pch='.')
if(digit) text(Re(p),Im(p),paste('p',1:n),cex=cex)
if(axis){axis(1) ; axis(2)}
invisible(p) # return vertex complex}
seg <- function(a,b,...){# draw segment of complex a to complex b
segments(Re(a),Im(a),Re(b),Im(b),col=2,...)}
pt <- function(x,y=NULL,...){ # draw text y at complex x
text(Re(x),Im(x), ifelse(is.null(y),'+',y), ...)}
poly_demo2 <- function(x=runif(n),y=runif(n)){ #各頂点から最短の分岐点を選ぶ x:Re(z), y:Im(z)
p=ngon(n,axis=T,col='skyblue')
Q=complex(n)
re1=re2=0
for(i in 1:n){ # plot Q
Q[i]=x[i]+y[i]*1i
pt(Q[i],paste('q',i))}
for(i in 1:n){ # draw shortest seg for each vertex
j=which.min(abs(p[i]-Q)) # Q[j]=nearest node (j: smallest index)
seg(p[i],Q[j])
re1=re1+abs(p[i]-Q[j]) # total length of p-Q}
for(i in 1:(n-1)){
seg(Q[i],Q[i+1])
re2=re2+abs(Q[i]-Q[i+1]) # total length of Q}
return(sum(re1)+sum(re2))}
poly2 <- function(par){ # par=c(Re(z),Im(z))
x=par[1:n]
y=par[(n+1):(2*n)]
Q=complex(n)
re1=re2=0
for(i in 1:n){ # par to complex number
Q[i]=x[i]+y[i]*1i
# pt(Q[i],paste('q',i)) }
for(i in 1:n){
j=which.min(abs(p[i]-Q)) # Q[j]=nearest node (j: smallest index)
# seg(p[i],Q[j])
re1=re1+abs(p[i]-Q[j]) # total length of p-Q}
for(i in 1:(n-1)){
# seg(Q[i],Q[i+1])
re2=re2+abs(Q[i]-Q[i+1]) # total length of Q}
return(sum(re1)+sum(re2))}
par(mfrow=c(2,2))
f <- function(){
(opt=optim(runif(2*n),poly2,method = 'BFGS'))
par=opt$par
poly_demo2(par[1:n],par[(n+1):(2*n)])
}
replicate(4,f())
n=5
m=1
poly_demo3 <- function(x=runif(m),y=runif(m)){ # x:Re(z), y:Im(z)
p=ngon(n,axis=T,col='skyblue')
Q=complex(m)
re1=re2=0
for(i in 1:m){ # plot Q
Q[i]=x[i]+y[i]*1i
pt(Q[i],paste('q',i))
}
for(i in 1:n){ # draw shortest seg for each vertex
j=which.min(abs(p[i]-Q)) # Q[j]=nearest node (j: smallest index)
seg(p[i],Q[j])
re1=re1+abs(p[i]-Q[j]) # total length of p-Q
}
if(m>1){
for(i in 1:(m-1)){
seg(Q[i],Q[i+1])
re2=re2+abs(Q[i]-Q[i+1]) # total length of Q
}}
return(sum(re1)+sum(re2))
}
poly_demo3()
poly3 <- function(par){ # par=c(Re(z),Im(z))
x=par[1:m]
y=par[(m+1):(2*m)]
Q=complex(m)
re1=re2=0
for(i in 1:m){ # par to complex number
Q[i]=x[i]+y[i]*1i
}
for(i in 1:n){
j=which.min(abs(p[i]-Q)) # Q[j]=nearest node (j: smallest index)
re1=re1+abs(p[i]-Q[j]) # total length of p-Q
}
if(m >1){
for(i in 1:(m-1)){
re2=re2+abs(Q[i]-Q[i+1]) # total length of Q
}}
return(sum(re1)+sum(re2))
}
poly3(runif(6))
par(mfrow=c(2,2))
f <- function(){
(opt=optim(rnorm(2*m),poly3,method = 'CG'))
par=opt$par
poly_demo3(par[1:m],par[(m+1):(2*m)])
}
replicate(4,f())
List of 2
$ :List of 2
..$ value: num 4.02
..$ par : num [1:6] 0.9432 0.6545 0.2652 0.0782 0.4755 ...
$ :List of 2
..$ value: num 3.89
..$ par : num [1:6] 0.8549 0.2805 0.0456 0.3258 0.3861 ...
> re[[which.min( unlist( lapply(re,'[',1) ) )]]
$`value`
[1] 3.891156871891314
$par
[1] 0.85487391200975060 0.28046877582694385 0.04560929326716642
[4] 0.32577844877585493 0.38608966889657914 0.91371285778407096
> heart=0
> n=98
> cards=c(rep(dia,99),rep(heart,1))
> n.DH=length(cards)
> n.D=length(dia)
> sim <- function(){
+ index_of_inbox=sample(1:n.DH,1)
+ inbox=cards[index_of_inbox]
+ outbox=cards[-index_of_inbox] # cards out of box
+ drawn=sample(outbox,n) # n cards drawn from outbox
+ c(inbox=inbox,drawn=drawn)
+ }
> rate_sim <- function(k){
+ re=replicate(k,sim()) # inbox=D&drawn=D / drawn=D
+ all_dia=sum(apply(re,2,function(x) sum(x))==(n+1))
+ drawn_dia=sum(apply(re,2,function(x) sum(x[-1]))==n)
+ c(all_dia/drawn_dia, drawn_dia/k)
+ }
> re=replicate(100,rate_sim(10000))
> summary(re[1,])
Min. 1st Qu. Median Mean 3rd Qu. Max.
0.4235 0.4816 0.5012 0.5001 0.5230 0.5833
> summary(re[2,])
Min. 1st Qu. Median Mean 3rd Qu. Max.
0.0170 0.0190 0.0199 0.0199 0.0207 0.0237
r = a%%b # a=bq+r -> a%%b=b%%r
while(r){
a = b
b = r
r = a%%b
}
return(b)
}
reduce_fraction <- function(x,y){
a=x
b=y
r = a%%b # a=bq+r -> a%%b=b%%r
while(r){
a = b
b = r
r = a%%b
}
gcd=b
cat(x/gcd,'/',y/gcd,'\n')
invisible(c(x/gcd,y/gcd))
}
# 2860 / 1082900
reduce_fraction(2860,1082900)
a=355
b=113
c=a/b # 3.141592920353983 > pi
d=a/b-pi # 2.667641894049666e-07 > 0
f <- function(i){
j=0 ; x=c ; y=d
while(x < c){
if(y < d) return(j)
x=(a+j)/(b+i)
y=abs(x-pi)
j=j+1
}
return(NULL)
}
i=1
while(is.null(f(i))){
if( !is.null(f(i)) ) return(c(i,f(i)))
i=i+1
}
a=355
b=113
(U=a/b) # 3.141592 92
(L=2*pi-a/b) # 3.141592 39
f <- function(n){
m=1
x=m/n
while(x<U){
if(L<x) return(m-1)
x=m/n
m=m+1
}
return(NULL)
}
n=1
while(is.null(f(n))){
if( !is.null(f(n)) ) break
n=n+1
}
cat(f(n),'/',n)
f <- function(n){
m=0
x=m/n
while(x<U){
if(L<x) return(m-1)
x=m/n
m=m+1
}
return(NULL)
}
n=1
while(is.null(f(n))){
if( !is.null(f(n)) ) break
n=n+1
}
cat(f(n),'/',n,'\n')
f(n)/n
}
dec2fra <- function(digit,precision=0.01){
L=digit*(1-precision)
U=digit*(1+precision)
LU2fra(L,U)
}
(1) 1234=5678 : 0000 0000 9abc
(2) 9ab=000 : 0000 0000 000c c cannot be regular.
(3) c<0 : 0000 0000 000c light
(3) c>0 : 0000 0000 000c heavy
(2) 9ab<000 : 0000 0000 9ab0
(3) 9=a : 0000 0000 00b0 light
(3) 9<a : 0000 0000 9000 light
(3) 9>a : 0000 0000 0a00 light
(2) 9ab>000 : 0000 0000 9ab0
(3) 9=a : 0000 0000 00b0 heavy
(3) 9<a : 0000 0000 0a00 heavy
(3) 9>a : 0000 0000 9000 heavy
(1) 1234<5678 : 1234 5678 0000
Take two light coins and one heavy coin on each dish of the balance
(2) 125=346 : 0000 0078 0000
(3) 7=0 : 0000 0008 0000 heavy
(3) 7>0 : 0000 0070 0000 heavy 7 cannot be in light group
(2) 125<346 : 1200 0600 0000 3,4,and 5 cannot be in both light and heavy group
Balance two coins in light group in (1) and (2),i.e. coin 1 and coin 2
(3) 1=2 : 0000 0600 0000 heavy
(3) 1<2 : 1000 0000 0000 light
(3) 1>2 : 0200 0000 0000 light
(2) 125>346 : 0034 5000 0000 1,2,and 6 cannot ben in both light and heavy group
(3) 3=4 : 0000 5000 0000 heavy
(3) 3<4 : 0030 0000 0000 light
(3) 3>4 : 0004 0000 0000 lihgt
Take two heavy coins and one light coin on each dish of the balance
(2) 125=346 : 0000 0078 0000
(3) 7=0 : 0000 0008 0000 light
(3) 7>0 : 0000 0070 0000 light 7 cannot be in heavy group
(2) 125>346 : 1200 0600 0000 3,4,and 5 cannot be in both heavy and light group
Balance two coins in heavy group in (1) and (2),i.e. coin 1 and coin 2
(3) 1=2 : 0000 0600 0000 light
(3) 1<2 : 1000 0000 0000 heavy
(3) 1>2 : 0200 0000 0000 heavy
(2) 125<346 : 0034 5000 0000 1,2,and 6 cannot ben in both heavy and light group
Balance two coins in heavy group in (1) and (2),i.e. coin 3 and coin 4
(3) 3=4 : 0000 5000 0000 light
(3) 3<4 : 0030 0000 0000 heavy
(3) 3>4 : 0004 0000 0000 lihgt
6789<abcd
same as the case with12 coins
(1)6789=abcd 12345 iregular
(2)12=30 45 irregular
(3)4=0 5 irregular
(3)4<0 4 light
(3)4>0 4 heavy
(2)12<30
(3)1=2 3 heavy
(3)1<2 1 light
(3)1>2 2 light
(2)12>30
(3)1=2 3 light
(3)1<2 2 heavy
(3)1>2 1heavy
ae=abs(x*precision)
#accepted error
d=Inf
k=1
while(d>ae){
y=(ifelse(abs(floor(k*x)/k-x) < abs(floor(k*x+1)/k-x),floor(k*x),floor(k*x+1)))
z=y/k
d=abs(x-z)
k=k+1
}
cat(y,'/',k-1,' ',z,'\n')
invisible(c(y,k-1,z))
}
> deci2frac(0.333,precision = 0.01)
1 / 3 0.3333333333333333>
> deci2frac(pi,precision = 10^-7)
355 / 113 3.141592920353983>
> deci2frac(sqrt(2),p=1e-10)
114243 / 80782 1.414213562427273>
> deci2frac(exp(1),1e-8)
20504 / 7543 2.718281850722524>
> exp(1)
[1] 2.718281828459045
>
void hanoi(int n,char *a,char *b,char *c){
if(n>=1){
hanoi(n-1,a,c,b);
printf("%s から %s へ移す\n",a,c);
/* printf("%d を %s から %s へ移す\n",n,a,c); */
hanoi(n-1,b,a,c);
}
}
void main(int argc,char *argv[]){
int i;
i=atoi(argv[1]);
hanoi(i,argv[2],argv[3],argv[4]);
}
if(n > 0){
Recall(n-1,a,c,b)
cat('move',n,'from',a,' to ',c,'\n')
Recall(n-1,b,a,c)
}
}
options(digits=16)
(2^64-1)/365.2425/24/60/60
library(Rmpfr)
mpfr((2^64-1)/365.2425/24/60/60,1024)
mpfr((2^100-1)/365.2425/24/60/60,1024)
r=a%%b
if(!r) return(b)
gcd(b,r)
}
gcd(18,48)
let rec rms(m,n) = if m=n then fact(m) else if m=1 then 1 else m*rms(m,n-1)+ m*rms(m-1,n-1);;
let rec rms(m,n) = if m=n then fact(m) else if m=1 then 1 else m*rms(m,n-1)+ m*rms(m-1,n-1);;
let ways = rms(int_of_string Sys.argv.(1),int_of_string Sys.argv.(2));;
print_int ways;;
let rec nCr(n,r) = if r=0 then 1 else nCr(n,r-1)*(n-r+1)/r;;
(* nCr = n-1Cr-1 + n-1Cr *)
let rec nCr(n,r) = if(n=r || r=0) then 1 else if (n=0 || r> n) then 0 else nCr(n-1,r-1)+ nCr(n-1,r);;
else begin
hanoi(n-1,a,c,b);
print_string("move "^string_of_int(n)^" from "^a^" to "^c^"\n");
hanoi(n-1,b,a,c);
end;;
let() = hanoi(int_of_string Sys.argv.(1),Sys.argv.(2),Sys.argv.(3),Sys.argv.(4));;
(* Note ; not ;; between begin and end, begin and end can be ( and ).
to compile
ocamlc.opt -o hanoi.exe hanoi.ml
to execute
hanoi 5 A B C
*)
let fact m = facti(m,1);;
fact 10;;
let fact n = let rec facti (n, a) = if n = 0 then a else facti (n - 1, a * n) in facti(n,1);;
fact 10;;
let fibonacci m = fibo(m,1,0);;
fibonacci 10;;
let fibonacci n = let rec fibo (n, a1, a2) = if n = 0 then a1 else fibo (n - 1, a1 + a2, a1) in fibo (n, 1, 0) ;;
fibonacci 10;;
N=P+Q
re=numeric(Q+1)
for(i in 1:(Q+1)) re[i]=i*choose(Q,i-1)/choose(N,i-1)*P/(N-i+1)
return(sum(re))
# Σ[1,Q+1] i * Q!/Q-i+1! * N-i+1!/N! * P/N-i+1!
}
ent <- function(N,p){
P=p*N
Q=(1-p)*N
Ent(P,Q)
}
x=c(rep(1,N*p),rep(0,N*(1-p))) # q:price perlot, hit: hits required to win
win=0
try=0
while(win<hit){
n=length(x)
j=sample(n,1)
win = win + as.numeric(x[j]==1)
x=x[-j]
try=try+1
}
return(try*q)
}
i=5
0011 Q/N*Q-1/N-1*P/N-2*P-1/N-3 ＊ P-2/N-4
0101 Q/N*P/N-1*Q-1/N-2*P-1/N-3
0110
1001
1010
1100
N(N-1)(N-2)(N-3)(N-4)=choose(N,i)*factorial(i)
nPr=function(n,r) choose(n,r)*factorial(r)
i*choose(i-1,hit-1)*nPr(Q,i-hit)*nPr(P,hit)/nPr(N,i)
# P:atari Q:hazure hit:atari needed to win
Ent2 <- function(P,Q,hit=1){
N=P+Q
nPr=function(n,r) choose(n,r)*factorial(r)
re=numeric(hit+Q)
for(i in hit:(hit+Q)) {
re[i]=i*choose(i-1,hit-1)*nPr(Q,i-hit)*nPr(P,hit)/nPr(N,i)
}
return(sum(re))
}
x=c(rep(1,N*p),rep(0,N*(1-p))) # q:price perlot, hit: hits required to win
win=0
try=0
while(win<hit){
n=length(x)
j=sample(n,1)
win = win + as.numeric(x[j]==1)
x=x[-j]
try=try+1
}
return(try*q)
}
lottery_sim(100,0.3,q=1,hit=3)
k=1e5
re3=replicate(k,lottery_sim(N=100,p=0.3,q=1000,hit=1))
summary(re3) ; hist(re3,col='lightblue',main='',freq=FALSE)
k=1e5
re6=replicate(k,lottery_sim(N=50,p=0.6,q=2000,hit=1))
summary(re6) ; hist(re6,col='pink', main='',freq=FALSE)
√(1+x) = a + bx + cx2 + dx3 + ....
x = 0 , a=1
√(1+x) = (1 + bx + cx2 + dx3 + ....)(1 + bx + cx2 + dx3 + ....)
1 + x = 1 + 2bx + (b2+2c)x2 + (2d+2bc)x3 + ...
b=1/2
b2+2c=0, c=-1/8
2d+2bc=0,d=1/16
√(1+x) = 1+ x/2 -x2/8+ x3/16 + ....
Tetra <- function(O=c(1/2,sqrt(3)/6,sqrt(2/3)),A=c(0,0,0),B=c(1,0,0),C=c(cos(pi/3),sin(pi/3),0)){
fn <- function(x,O,A,B,C){
AO=A-O
BO=B-O
CO=C-O
HO=x[1]*AO+x[2]*BO+(1-x[1]-x[2])*CO
AB=B-A
AC=C-A
c(HO%*%AB,HO%*%AC)
}
fn1 <- function(x) fn(x,O,A,B,C)
x=nleqslv::nleqslv(c(1/3,1/3),fn1)$'x'
AO=A-O
BO=B-O
CO=C-O
HO=x[1]*AO+x[2]*BO+(1-x[1]-x[2])*CO
h=sqrt(sum(HO^2))
a=sqrt(sum((B-C)^2))
b=sqrt(sum((C-A)^2))
c=sqrt(sum((A-B)^2))
s=(a+b+c)/2
base=sqrt(s*(s-a)*(s-b)*(s-c))
V=1/3*base*h
return(V)
}
Tetra()
sqrt(2)/12
gcd( 349163 ,7599867)
#define N 5
int b[N];
void truth_table(int k){
int i;
if(k < N){
b[k] = 1;
truth_table(k+1);
b[k] = 0;
truth_table(k+1);
}
else{
for(i = 0;i < N; i++){
printf("%s ", b[i] ? "T " : "F ");
}
printf("\n");
}
}
int main(){
truth_table(0);
return 0;
}
r=num%%N
q=num%/%N
while(q > 0 | digit > 1){
r=append(q%%N,r)
q=q%/%N
digit=digit-1
}
return(r)
}
woman=200
total=man+woman
pass=100
i=0:100
rr=1.2
sum((choose(man,i)*choose(woman,pass-i)/choose(total,pass))*(i/man > rr*(pass-i)/woman))
+choose(5,2)*(choose(2,0)*2^5 - choose(2,1)*1^5 + choose(2,2)*0^5)*(choose(3,0)*3^5 - choose(3,1)*2^5 + choose(3,2)*1^5 - choose(3,3)*0^5))*2
5部屋 男5 女5 定員4 空室可 混合不可
m4 m1 f(3,5) choose(5,4)*choose(5,2)*2* f(3,5)
m3 m2 f(3,5) choose(5,3)*choose(5,2)*2* f(3,5)
m3 m1 m1 f(2,5) choose(5,3)*5*4*3* f(2,5)
m2 m2 m1 f(2,5) choose(5,2)*choose(3,2)*5*4*3*f(2,5)
f(3,5)
f4 f1 f0 3!*choose(5,4)
f3 f2 f0 3!*choose(5,3)
f3 f1 f1 3!choose(5,3)
f2 f2 f1 3!*choose(5,2)*choose(3,2)
f(2,5)
f4 f1 choose(5,4)*2
f3 f2 choose(5,3)*2
# [117000,] 5 5 5 5 4 3 3 3 3 2
# m4 m1 3^5-3 5P2*5
# m3 m2 3^5-3 5P2*5C2
# m3 m1 m1 2^5-2 5C3*3*5!/3!
# m2 m2 m1 2^5-2 5C3*3*5!/2!/2!
5*4*5 *240
5*4*10 *240
10*3*5*4 *30
10*3*120/2/2 *30
5*4*5*240+5*4*10*240+10*3*5*4*30+10*3*120/2/2*30
n=5 # rooms
m=5 # men
w=5 # women
cap=4 # capacity
perm=permutations(n=5,r=m+w,rep=T)
nomixcap2 <- function(x,vacancy=FALSE){
men = x[1:m]
women= x[(m+1):(m+w)]
if(any(men %in% women)) return(FALSE)
if(max(tabulate(x)) > cap) return(FALSE)
if(vacancy) return(TRUE)
if(!all(1:n %in% x)) return(FALSE) # if not(all room used)
return(TRUE)
}
revac=perm[,which(apply(perm,1,function(x)nomixcap2(x,vac=T)))]
n=5 # rooms
m=5 # men
w=5 # women
perm=gtools::permutations(n,r=m+w,rep=T)
mix <- function(x){
men = x[1:m]
women= x[(m+1):(m+w)]
if(!all(men %in% women)) return(FALSE)
else all(women %in% men))
}
revac=perm[,which(apply(perm,1,mix)))]
n=5 # rooms
m=5 # men
w=5 # women
perm=gtools::permutations(n,r=m+w,rep=T)
mix <- function(x){
men = x[1:m]
women= x[(m+1):(m+w)]
if(!all(men %in% women)) return(FALSE)
all(women %in% men)
}
(x=perm[sample(1:5^10,1),])
mix(x)
re=perm[which(apply(perm,1,mix)),]
head(re)
tail(re)
pair=NULL
for(i in 1:k){
a=sort(rpois(2,7))
b=sort(rpois(2,7))
c=sum(a>b)
print(c(a=a,b=b,pair=c))
pair[i]=c
}
c(pair=pair)
hist(pair)
pair=NULL
for(i in 1:k){
a=sort(rpois(2,7))
b=sort(rpois(2,7))
c=sum(a>b)
print(c(a=a,b=b,pair=c))
pair[i]=c
}
hist(pair)
pair=NULL
for(i in 1:k){
a=sort(rpois(2,7))
b=sort(rpois(2,7))
c=sum(a>b)
print(c(a=a,b=b,pair=c))
pair[i]=c
}
k=10000
pair=NULL
for(i in 1:k){
a=sort(jitter(rpois(2,7)))
b=sort(jitter(rpois(2,7)))
c=sum(a>b)
pair[i]=c
}
hist(pair,col='skyblue')
# reverse' (x:xs) = reverse'(xs) ++ [x]
#
# main = do
# print $ reverse' [1..10]
reverse <- function(x){
if(!length(x)) return(NULL)
c(Recall(x[-1]),x[1])
}
cat(reverse(LETTERS[1:26]))
rot13ch <- function(ch){
if('A' <= ch & ch <= 'M' ) LETTERS[which(x==LETTERS)+13]
if('a' <= ch & ch <= 'm' ) LETTERS[which(x==letters)+13]
if('N' <= ch & ch <= 'Z' ) LETTERS[which(x==LETTERS)-13]
if('n' <= ch & ch <= 'z' ) LETTERS[which(x==letters)-13]
else ch
}
rot13 <- function(x){
x=strsplit(x,NULL)
re=NULL
while(!length(x)){
re=append(re,rot13ch(x[1]))
x=x[-1]}
return(re)
}
(hello13 = rot13 ("Uraguchi!"))
print(rot13( hello13))
rot13ch<- function(x){
if('A' <= x & x <= 'M' ) re=LETTERS[which(x==LETTERS)+13]
if('a' <= x & x <= 'm' ) re=letters[which(x==letters)+13]
if('N' <= x & x <= 'Z' ) re=LETTERS[which(x==LETTERS)-13]
if('n' <= x & x <= 'z' ) re=letters[which(x==letters)-13]
else re=x
return(re)
}
rot13ch('j')
rot13 <- function(x){
x=strsplit(x,NULL)
re=NULL
while(!length(x)){
re=append(re,rot13x(x[1]))
x=x[-1]}
return(re)
}
rot13ch<- function(x){
if('A' <= x & x <= 'M' ) re=LETTERS[which(x==LETTERS)+13]
else
if('a' <= x & x <= 'm' ) re=letters[which(x==letters)+13]
else
if('N' <= x & x <= 'Z' ) re=LETTERS[which(x==LETTERS)-13]
else
if('n' <= x & x <= 'z' ) re=letters[which(x==letters)-13]
else re=x
return(re)
}
rot13 <- function(str){
x=unlist(strsplit(str,NULL))
re=NULL
while(!length(x)){
re=append(re,rot13ch(x[1]))
x=x[-1]}
return(re)
}
str="Uraguchi!"
rot13(str)
p=p/sum(p)
sum.rev <- function(x){ # i,j,k -> 1/(p[i]+p[j]+p[k])
n=length(x)
s=numeric(n)
for(i in 1:n) s[i]=p[x[i]]
1/sum(s)
}
n=length(p)
re=numeric(n)
for(i in 1:n) re[i]=(-1)^(i-1)*sum(apply(combn(n,i),2,sum.rev))
sum(re)
}
Gacha(1:4/10)
Gacha(c(1/10,rep(9/50,5)))
#
sim <- function(p){
p=p/sum(p)
n=length(p)
y=NULL
while(!all(1:n %in% y)){
y=append(y,sample(1:n,1,prob=p))
}
return(length(y))
}
mean(replicate(1e4,sim(1:4)))
Gacha(1:4)
mean(replicate(1e5,sim(c(9,9,9,9,9,5))))
Gacha(c(9,9,9,9,9,5))
> mean(replicate(1e4,sim(1:10)))
[1] 68.7788
理論値
> Gacha(1:10)
[1] 68.98458
n=length(p)
par=letters[1:n]
fm <- function(v){
nv=length(v)
re=character(nv)
for(j in 1:nv) re[j]=par[v[j]]
s=paste(re,collapse='+')
if(nv==1) paste0('1/',s)
else paste0('1/(',s,')')
}
fm1 <- function(mat){
paste(apply(mat,2,fm),collapse='+')
}
re=list()
for(i in 1:n) re[[i]]=fm1(combn(n,i))
re1=re[[1]]
re1
for(i in 2:(n-1)){
re1=c(re1,ifelse(i%%2,' + ',' - '),'(',re[[i]],')')
}
output=c(paste(re1,collapse=""),ifelse(n%%2,'+','-'), re[[n]])
cat(output,'\n')
if(write) write(output,'output.txt')
invisible(output)
}
Gacha.fm(c(1/10,2/10,3/10,4/10))
Gacha.fm(c(9/50,9/50,9/50,9/50,9/50,5/10))
n=length(p)
par=letters[1:n]
fm <- function(v){
nv=length(v)
re=character(nv)
for(j in 1:nv) re[j]=par[v[j]]
s=paste(re,collapse='+')
if(nv==1) paste0('1/',s)
else paste0('1/(',s,')')
}
fm1 <- function(mat){
paste(apply(mat,2,fm),collapse='+')
}
re=list()
for(i in 1:n) re[[i]]=fm1(combn(n,i))
re1=re[[1]]
re1
for(i in 2:(n-1)){
re1=c(re1,ifelse(i%%2,' + ',' - '),'(',re[[i]],')')
}
output=c(paste(re1,collapse=""),ifelse(n%%2,'+','-'), re[[n]])
cat(output,'\n')
if(write) write(output,'output.txt')
invisible(output)
}
Gacha.fm(c(1/10,2/10,3/10,4/10))
Gacha.fm(c(9/50,9/50,9/50,9/50,9/50,5/10))
insert <- function(x,yys){
if(!length(yys)) return x
else {
y=yy[1]
ys=yys[-1]
if(x<y) return c(x,y,ys)
else c(y, Recall(x,ys))
}
}
isort <- function(xxs){
if(!length(xxs)) return NULL
else{
x=xxs[1]
xs=xxs[-1]
insert(x,Recall(xs))
}
isort(c(4, 6, 9, 8, 3, 5, 1, 7, 2))
if(!length(y)) return(x)
if(x<y[1]) return(c(x,y))
return(c(y[1], Recall(x,y[-1])))
}
isort <- function(x){
if(!length(x)) return(NULL)
insert(x[1],Recall(x[-1]))
}
isort(c(4, 6, 9, 8, 3, 5, 1, 7, 2))
if(!length(x)) return(NULL)
if(length(x)==1) return(x)
else{
y=bsort(x[-1])
ifelse(x[1]<y[1],c(x[1],y),c(y[1],bsort(c(x[1],y[-1])
}
}
bsort(c(3,1,4,1,5,9,2,6,5)
n=length(p) # number of items
if(sum(p)>=1){ # no blank and/or rate of probabilities
prob=p/sum(p) # scaling for sum(prob)=1
lot=1:n # no blank lot
}else{
prob=c(p,1-sum(p)) # blank with probability of 1-sum(p)
lot=1:(n+1) # lot[n+1] blank lot
}
y=NULL
count=0
while(length(y)<n){
z=sample(lot,1,prob=prob)
count=count+1
if(!any(z==y)) y=append(y,z) # append new item only
}
return(count)
}
n=length(p)
seg=cumsum(p)
p
seg
x=runif(1)
x
x > seg
k=numeric(n)
k | (x > seg)
n=length(p)
seg=cumsum(p)
count=0
k=numeric(n)
while(k<2^n-1){
x=runif(1)
k | (x > seg)
k=k | (x > seg)
count=count+1
}
count
n=length(p)
sep=cumsum(p)
y=NULL
count=0
while(length(y) < n){
z=sample(1:n,1,prob=p)
if(!any(z==y)) y=append(y,z) # append new item only
count=count+1
}
return(count)
}
sim3 <- function(p){
n=length(p)
sep=cumsum(p)
y=NULL
count=0
while(length(y) < n){
z=sum(runif(1) < sep)
if(!any(z==y)) y=append(y,z) # append new item only
count=count+1
}
return(count)
}
p=c(9,9,9,9,9,5)/50
system.time(mean(replicate(1e4, sim1(p))))
system.time(mean(replicate(1e4, sim3(p))))
qsort (n:xs) = qsort lt ++ [n] ++ qsort gteq
where
lt = [x | x <- xs, x < n]
gteq = [x | x <- xs, x >= n]
main = do print $ qsort [4, 6, 9, 8, 3, 5, 1, 7, 2]
gr=expand.grid(1:a,1:b)
c2=(1:c)^2
f = function(x,y) (x<y) & (x^2+y^2) %in% c2
i=which(mapply(f,gr[,1],gr[,2]))
ab=as.matrix(gr[i,])
cbind(ab,sqrt(ab[,1]^2+ab[,2]^2))
}
foo(20,20,20)
a=20;b=20;c=20
gr=expand.grid(1:a,1:b,1:c)
f = function(a,b,c) a<b & a^2+b^2==c^2
i=which(mapply(f,gr[,1],gr[,2],gr[,3]))
gr[i,]
gr=expand.grid(1:a,1:b)
c2=(1:c)^2
f = function(x,y) (x<y) & (x^2+y^2) %in% c2
i=which(mapply(f,gr[,1],gr[,2]))
ab=as.matrix(gr[i,])
cbind(ab,sqrt(ab[,1]^2+ab[,2]^2))
}
foo(20,20,20)
foo(100,100,100)
a=20;b=20;c=20
fooo <- function(a,b,c){
gr=expand.grid(1:a,1:b,1:c)
f = function(a,b,c) a<b & a^2+b^2==c^2
i=which(mapply(f,gr[,1],gr[,2],gr[,3]))
gr[i,]
}
fooo(20,20,20)
fooo(100,100,100)
#include<stdlib.h>
int pit(int A,int B, int C){
int a,b,c; int pit=0;
for(a=1;a<=A;a++){
for(b=a;b<=B;b++){
for(c=b;c<=C;c++){
if((a<b) && (a*a+b*b==c*c)) {
++pit;
printf("%d : %d * %d + %d * %d = %d * %d\n",pit,a,a,b,b,c,c);
}
}
}
}
return 0;
}
int main( int argc, char *argv[] ){
int a,b,c;
a = atoi(argv[1]);
b = atoi(argv[2]);
c = atoi(argv[3]);
pit(a,b,c);
return 0;
}
ある日、午後4時に退社した。
天気が良かったので、迎えのクルマに出会うまで散歩した。
出会ったところで、クルマはUターンして自宅に戻った。
するといつもより10分早く帰宅した。
何時何分にクルマに出会ったか？
https://cybozushiki.cybozu.co.jp/articles/m000434.html
尚、迎えの車は５時に会社に到着するように自宅を出発し行きも帰りも等速走行を仮定する。
病院から救急車が診療所に向かっており１０時到着予定と連絡が入った。
患者が９時に急変したため診療所の普通車で病院に向かって救急車と出会ったら救急車に患者を移して搬送し病院到着を早めることになった。当然、救急車の方が速く走れる。
９時５０分に救急車に乗り移ることができた。
病院到着は予定より何分早まるか述べよ。
乗り換えに要する時間は０とする。
一般化してみた。
歩行時間:t
歩行距離:l
迎えの車速:rv
同乗の車速:v
出発時刻差:s
到着時刻差:X
通常走行時間:d/rv+d/v
早退時走行時間:(d-l)/rv+(d-l)/v
d/rv+d/v - ((d-l)/rv+(d-l)/v)= X
l (r + 1)/rv=X
l/v=X*r/(r+1)
s0+s+d/v - {s0+t+(d-l)/v}= X
s-t+l/v=X
X=(r + 1) (s - t)
t = s - X / (r+1)
# include <stdlib.h>
# define N 10
int a[N + 1], key;
int search(int a[],int key,int i);
int main(int argc, char *argv[])
{
int a[]= {0,1,2,3,4,5,6,7,8,9};
key = atoi(argv[1]);
a[N]=key;
if (search(a, key ,0) < N) {
printf("Found!\n");
}
else{
printf("Not Found!\n");
}
}
int search(int a[], int key, int i)
{
if(a[i]==key){
return i;
}
return search(a,key,++i);
}
# 歩行速度:w
# 迎えの車速:v0
# 同乗の車速:v1
# 出発時刻差:s
# 到着時刻差:X
# l=wt
# 通常走行時間:d/v0+d/v1
# 早退時走行時間:(d-wt)/v0+(d-wt)/v1
# d/v0+d/v1 - ((d-wt)/v0+(d-wt)/v1)= X
# wt(1/v0+1/v1) = X
#
# s0+s+d/v1 - {s0+t+(d-wt)/v1}= X
# s - t(1-w/v1) = X
#
s = t + wt/v0
t = sv0/(v0+w)
X = tw(1/v0+1/v1) = sv0/(v0+w)*w(1/v0+1/v1)
# when the patient leave clinic s hours earlier than planned
# and encounter the ambulance t hours later,
# ambulance runs with the velocity of v0 without patient, and v1 with patient
# clinic car runs with the velocity of w
Earlier <- # s hour earlier departure, X hour earlier arrival
function(s=NULL,X=NULL,t=NULL,v0=60,v1=45,w=30){
if(is.null(s)) re=c(s=X/(v0/(v0+w)*w*(1/v0+1/v1)),t=X/w/(1/v0+1/v1))
if(is.null(X)) re=c(X=s*v0/(v0+w)*w*(1/v0+1/v1),t=s*v0/(v0+w))
if(!is.null(t)) re=c(s=t + t*w/v0, X = t*w*(1/v0+1/v1))
return(re)
}
Earlier(X=10/60)*60
Earlier(s=30/60)*60
Earlier(t=30/60)*60
診療所から病院に患者を救急搬送する。
病院から医師搭乗の救急車が診療所に向かっており１０時到着予定と連絡が入った。
患者の病態が悪化したら、診療所の普通車で病院に向かい救急車と出会ったら
救急車に患者を移して搬送し病院到着を急ぐという計画を立てた。
普通車から救急車への患者の乗り換えで１０分余分に時間がかかる。
道路事情から病院から診療所への道は
平均時速６０ｋｍで、逆方向は平均時速４５ｋｍで定速走行する。診療所の普通車は信号待ちもあり平均時速３０kmで定速走行する。
何時以降の病態悪化は診療所の車を使わずに救急車の到着を待つ方が病院に早く着くか？
診療所から病院に患者を救急搬送する。
病院から医師搭乗の救急車が診療所に向かっており１０時到着予定と連絡が入った。
患者の病態が悪化したら、診療所の普通車で病院に向かい救急車と出会ったら
救急車に患者を移して搬送し病院到着を急ぐという計画を立てた。
普通車から救急車への患者の乗り換えで１０分余分に時間がかかる。
道路事情から救急車は病院から診療所への道は
平均時速６０ｋｍで、逆方向は平均時速４５ｋｍで定速走行する。診療所の普通車は信号待ちもあり平均時速３０kmで定速走行する。
何時以降の病態悪化は診療所の車を使わずに救急車の到着を待つ方が病院に早く着くか？
病院から救急車が診療所に向かっており１０時到着予定と連絡が入った。
患者が９時に急変したため診療所の普通車で病院に向かって救急車と出会ったら救急車に患者を移して搬送し病院到着を早めることになった。救急車の方が速く走れる。
９時５０分に救急車に乗り移ることができた。
病院到着は予定より何分早まるか述べよ。
車は定速走行とし、乗り換えに要する時間は考慮しない。
dec2n <- function(num, N, digit = 3){ # decimal to 0,1,..,n-1 vector
if(num <= 0 & digit <= 0) return(NULL)
else{
append(dec2n(num%/%N, N ,digit-1), num%%N)
}
}
dec2n(42,5,4) # 0 1 3 2
N=5
num=42 ; digit=4
num%%N # 2 last=2
num%/%N # 8 (digit=3)
num%/%N%%N # 2nd last= 3
num%/%N%/%N # 1 (digit=2)
num%/%N%/%N%%N # 3rd last =1
num%/%N%/%N%/%N # 0 (digit=1)
num%/%N%/%N%/%N%%N # 4th last = 0
num%/%N%/%N%/%N%/%N # 0 (digit=0)
system.time(for(i in 0:10^5) dec2n(i,7))
system.time(for(i in 0:10^5) dec2nw(i,7))
dec2nw <- function(num, N, digit = 4){
r=num%%N
q=num%/%N
while(q > 0 | digit > 1){
r=append(q%%N,r)
q=q%/%N
digit=digit-1
}
return(r)
}
http://tpcg.io/QCYcf4
#define N 5
int b[N];
//char * u[] = {"0","1","2","3","4"};
char * u[] = {"志学","而立","不惑","知命","耳順","従心"};
void fill(int k){
int i,j;
if(k < N){
for(i=0;i<N;i++){
for(j=0; j < k && b[j]!=i; j++);
;
if(j==k){
b[k] = i;
fill(k+1);
}
}
}
else{
for(i = 0;i < N; i++){
printf("%s ", u[b[i]] );
}
printf("\n");
}
}
int main(){
printf("all around\n");
fill(0);
return 0;
}
is.sorted <- function(x){
if(length(x)==1) return(TRUE){
else{
if(x[1]<=x[2]) is.sort(x[-1]){
else return(FALSE)
}
}
}
if(length(x)==1){ return(TRUE)
}else{
if(x[1]<=x[2]) is.sorted(x[-1])
else return(FALSE)
}
}
https://plaza.rakuten.co.jp/denkyupikaso/diary/201809180000/
ニューロン=人工知能のモデルとなっている神経細胞のやりとりするところ
この細胞の伝達する場所に大麻受容体があります この受容体を通って治療効果を得る大麻を医療大麻と呼びます
人間に大麻受容体があったなんて不思議ですよね
くるくるぱーの裏口バカに
なっちゃってるのらぁあぁぁ
Ｆラン事務員の濃ゆぅぅい生ガキ汁
ド底辺の臭いが落ちないよぉ
んほおぉぉぉおぉぉ
>711って再帰呼び出ししているけど何をするスクリプトかわかる？
#include<stdlib.h>
#define N 8
#define W 2*N-1
int b[N],row[N],up[W],down[W],count=0;
void fill(int k){
int i,j;
if(k < N){
for(i=0;i<N;i++){
if(!row[i] && !up[i+k] && !down[i-k+N-1]){
b[k] = i;
row[i]=up[i+k]=down[i-k+N-1]=1;
fill(k+1);
row[i]=up[i+k]=down[i-k+N-1]=0;
}
}
}
else{
printf("# %2d\n",++count);
for(i =0; i < N; i++){
for(j = 0; j < N; j++){
if(b[i] == j) printf(" Ｑ ");
else printf(" ・ ");
}
printf("\n");
}
}
}
int main(){
fill(0);
return 0; }
int arr[] ={1,2,3,4,5};
int total = (sizeof(arr) / sizeof(arr[0]));
void heapify(int arr[], int i)
{
int lft = i * 2;
int rgt = lft + 1;
int grt = i;
if (lft <= total && arr[lft] > arr[grt]) grt = lft;
if (rgt <= total && arr[rgt] > arr[grt]) grt = rgt;
if (grt != i) {
int tmp=arr[grt];
arr[grt]=arr[i];
arr[i]=tmp;
heapify(arr, grt);
}
}
int main(){
heapify(arr,0);
for (int i = 0; i < total; i++) printf("%d ", arr[i]);
printf("\n");
}
k=3
perm=unique(permutations(3*k,3*k,rep(1:3,k),set=F,rep=F))
is3 <- function(x){
n=length(x)
y=c(x,x[1])
re=NULL
for(i in 1:(n-1)) re[i]=all((1:3) %in% y[i:(i+2)])
any(re)
}
i=(!apply(perm, 1, is3))
perm1=perm[i,]
r1 <- function(x){ # rotate by one bead
n=length(x)
y=numeric(n)
y[1]=x[n]
for(i in 1:(n-1)){
y[i+1]=x[i]
}
return(y)
}
rn <- function(x){ # every rotation
n=length(x)
mat=matrix(rep(NA,n^2),ncol=n)
mat[,1]=x
for(i in 1:(n-1)){
mat[,i+1]=r1(mat[,i])
}
return(t(mat))
}
f=function(a,b=base){ # is equal to base
all(a==b)
}
mat=rbind(rn(x),rn(rev(x))) # rotation and/or symmetric conversion
any(apply(mat,1,f))
}
mat=perm1
tail(perm1)
exvar <- function(row,mat=perm1){
var=rn(mat[row,])
n.var=nrow(var)
idx=NULL
for(i in 1:n.var){
idx=c(idx,which(apply(mat,1,function(x) same(x,var[i,]))))
}
min(idx)
}
index=sapply(1:nrow(perm1),exvar) # several minutes for k=3
re=perm1[unique(index),]
re
print(matrix(c("赤","白","青")[re],ncol=3*k),quote=F)
f=function(a,b=base){ # is equal to base
all(a==b)
}
mat=rbind(rn(x),rn(rev(x))) # rotation and/or symmetric conversion
any(apply(mat,1,f))
}
mat=perm1
core=NULL # 基本解を集める行列
while(nrow(mat)){
var=rn(mat[1,]) # matの先頭行のバリアント
n.var=nrow(var)
idx=NULL # 先頭行とそのバリアントのindex
for(i in 1:n.var){ # 先頭行およびバリアント行のindexを返す
idx=c(idx,which(apply(mat,1,function(x) same(x,var[i,]))))
}
i=sort(unique(idx))
core=rbind(core,mat[i[1],])
mat=mat[-i,] # 一度、検討した行と同一相当行を除いたmatで再評価に回す
}
core
print(matrix(c("赤","白","青")[core],ncol=3*k),quote=F)
cuniq=cmpfun(unique)
jperm <- function(n,r,v) {
if (r == 1)
matrix(v, n, 1)
else if (n == 1)
matrix(v, 1, r)
else {
X <- NULL
for (i in 1:n) X <- rbind(X, cbind(v[i], jperm(n - 1, r - 1, v[-i])))
cuniq(X)
}
}
cjperm=cmpfun(jperm)
v=rep(1:3,4)
n=r=length(v)
perm4=cjperm(n,r,v)
#define N 6
int b[N];
char * u[] = {"P","E","P","P","E","R"};
void p_table(int k){
int i;
if(k < N){
for(i=0;i<N;i++){
b[k] = i;
p_table(k+1);
}
}
else{
for(i = 0;i < N; i++){
printf("%s ", u[b[i]] );
}
printf("\n");
}
}
int main(){
p_table(0);
return 0;
}
// Program to print all permutations of a string in sorted order.
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <stdbool.h>
/* Following function is needed for library function qsort(). */
int compare(const void *a, const void * b)
{
return ( *(char *)a - *(char *)b );
}
// A utility function two swap two characters a and b
void swap(char* a, char* b)
{
char t = *a;
*a = *b;
*b = t;
}
// which is greater than 'first' and is present in str[l..h]
int findCeil(char str[], char first, int l, int h)
{
// initialize index of ceiling element
int ceilIndex = l;
// Now iterate through rest of the elements and find
// the smallest character greater than 'first'
for (int i = l+1; i <= h; i++)
if (str[i] > first && str[i] < str[ceilIndex])
ceilIndex = i;
return ceilIndex;
}
void sortedPermutations(char str[])
{
// Get size of string
int size = strlen(str);
// Sort the string in increasing order
qsort(str, size, sizeof( str[0] ), compare);
// Print permutations one by one
bool isFinished = false;
while (!isFinished)
{
// print this permutation
static int x = 1;
printf("%d %s \n", x++, str);
// Find the rightmost character which is smaller than its next
// character. Let us call it 'first char'
int i;
for (i = size - 2; i >= 0; --i)
if (str[i] < str[i+1])
break;
// means we just printed the last permutation and we are done.
if (i == -1)
isFinished = true;
else
{
// Find the ceil of 'first char' in right of first character.
// Ceil of a character is the smallest character greater than it
int ceilIndex = findCeil(str, str[i], i + 1, size - 1);
// Swap first and second characters
swap(&str[i], &str[ceilIndex]);
// Sort the string on right of 'first char'
qsort(str + i + 1, size - i - 1, sizeof(str[0]), compare);
}
}
}
// Driver program to test above function
int main()
{
char str[] = "";
sortedPermutations( str );
return 0;
}
w=1
bwb=function(x){
n=length(x)
if(n<3) return(F)
else x[n-2]==b & x[n-1]==w & x[n]==b
}
f = function(){
x=NULL
while(!bwb(x)){
x=c(x,sample(c(b,w),1,prob=c(0.2,0.8)))
}
c(W=sum(x==w),B=sum(x==b))
}
re=replicate(1e4,f())
mean(re[1,])
mean(re[2,])
f <- function(NN,prec=1000){
for(k in 1:NN){
for(m in k:NN){
for(n in m:NN){
K=mpfr(factorial(k),prec)
M=mpfr(factorial(m),prec)
N=mpfr(factorial(n),prec)
if(K+M==N) cat(k,'! + ',m,'! = ',n,'!\n')
}
}
}
}
try(f(100))
print $ foldr (-) 0 ( 1:(2:(3:[])) )
print $ 1-(2-(3-0))
elem_r 39 [3.6..]
elem_l y ys = foldl(\acc x -> if x==y then True else acc) False ys
{- ERROR!!
elem_l 39 [3,6..]
elem_r y ys = foldr (\x acc -> if x==y then True else acc) False ys
elem_l y ys = foldl(\acc x -> if x==y then True else acc) False ys
main = do
print $ zipWith (\x y -> (x*30+3)/y) [5,4,3,2,1] [1..5]
print $ map (\(a, b) -> a+b) [(1,2),(3,5),(6,3),(2,6),(2,5)]
print $ zipWith (flip (++)) ["love you","is an angel"] ["I ","Mei "]
print $ map (flip subtract 20) [1..5]
print $ foldl (\a b -> a+b) 0 [3,5,2,1]
print $ foldl (-) 0 [1,2,3]
print $ ((0-1)-2)-3
print $ foldr max 0 [1,2,3]
print $ 1 `max` (2 `max`(3 `max` 0))
print $ foldr (-) 0 [1,2,3]
print $ foldr (-) 0 ( 1:(2:(3:[])) )
print $ 1-(2-(3-0))
print $ foldr (\a b -> a-b) 0 ( 1:(2:(3:[])) )
divisor n = find (\m -> n `mod` m ==0 )[2..floor.sqrt.fromIntegral $ n]
main = do
print $ divisor $ (10^19-1) `div` 9
divisor n = find (\m -> n `mod` m ==0 )[2..floor.sqrt.fromIntegral $ n]
divisors n = filter (\m -> n `mod` m ==0 )[2..n-1]
main = do
print $ divisor $ (10^19-1) `div` 9
図のように、まず１つの○に色をぬり、
次にその●から時計回りに１０８個進んで止まり、そこにある○をぬります。
さらにその●から
時計回りに１０８個進んで止まり、
そこにある○をぬり、以下同じ作業を くり返していきます。
すでに色がぬられた●に止まったときに終了とするとき、
何個の○をぬることができますか？
foo jump spot = length $ takeWhile (\x -> x*jump `mod` spot /=0) [1..]
1 + foo 108 1000000
図のように、まず１つの○に色をぬり、
次にその●から時計回りにｎ個進んで止まり、そこにある○をぬります。
さらにその●から
時計回りにｎ個進んで止まり、
そこにある○をぬり、以下同じ作業を くり返していきます。
すでに色がぬられた●に止まったときに終了とするとき、
何個の○をぬることができますか？
ｍ / gcd(m.n)
m,nが互いに素なら全部塗れる。
| a `mod` b == 0 = b
| otherwise = gcd b $ a `mod` b
同一者の別名として国試浪人、統計野郎、自称医科歯科、がある
自称医科歯科卒、実際は九州の駅弁国立出身で、卒業後は実家の東京に帰り国試浪人となり23年間経過、家庭教師バイトなどを経て現在は事務員、とされている
本人は、勤務医でたまに開業医の手伝いと内視鏡バイト、専門医なし、と主張しているが、連日連夜の異常な書き込み数の多さからは、勤務医とは考え難い
彼の職業がたとえ何であったとしても、人としてド底辺なことは間違いがない
自ら事務員であると告白したこともある
https://egg.5ch.net/test/read.cgi/hosp/1531459372/108-109
自作自演も頻繁に行なっている、内視鏡バイトの後はステーキハウスに行く妄想話がよく出てくる、実際には食べたこともないんだろうな
病名を挙げて架空の診療報告を行うこともあるが、今どきヒヨッコ研修医でもそんなことやらねーぞW
事務仕事の際に手にした他人の給与明細や同窓会費振込票を盗撮し、自分のものとしてアップロードしたこともある、犯罪なんじゃねーの？
統計絶対主義でマウントを取ろうとするが、大学卒業後の人生の大部分においてそれが何の役に立つのかはなはだ疑問である
統計に基づいた重病の治療成績を患者に説明しても、患者の希望する治療は患者の事情によって異なることは一定年数以上の臨床経験があるものなら誰でも知っていることだ
それが理解できない彼は、彼自身が素性を明らかにしているようなものである
コンプ薬屋同様に、私立医への執拗な誹謗中傷を数年余にわたって続けている
裏口批判をしているが、実際にそれが可能な資産家の子弟がいるであろう右派スレには近寄らない、一度書き込んだ形跡があったが指摘したら別人だと言って逃げた
弱いものが多そうなスレしか狙わないのもコンプ薬屋と共通する異常者の特徴である
劣等コンプレックスの塊なんだろうな
自分の主張に対して都合の悪い突込みが入ると、相手を私立医と決めつけて、さてはシリツだな、裏口バカ、というセリフでワンパターンに返すことが多い
国試問題を挙げて簡単だとほざいてますが、本番で通らなければお話になりません
いくらネットでわめいていても、医師国試の本番で通らなければお話になりません
大事なことなので２回言いました
興味がある人はどうぞ
みんながんばろうねぇ『羽山のサユレイザ』で
K5K
定員100で男子800人女子200人が受験して合格率の男女比が
1.2であったときに統計的には有意差があると言えるか？
woman=100
pass=100
total=man+woman
p=pass/total
i=0:100
#
sum((choose(woman,i)*choose(man,pass-i)/choose(total,pass))*(i/woman > (pass-i)/man))
sum((choose(woman,i)*choose(man,pass-i)/choose(total,pass))*(i/woman == (pass-i)/man))
sum((choose(man,i)*choose(woman,pass-i)/choose(total,pass))*(i/man > (pass-i)/woman))
sum((choose(man,i)*choose(woman,pass-i)/choose(total,pass))*(i/man > 1.2*(pass-i)/woman))
[1] 0.4160339
> sum((choose(woman,i)*choose(man,pass-i)/choose(total,pass))*(i/woman == (pass-i)/man))
[1] 0.1389853
> sum((choose(man,i)*choose(woman,pass-i)/choose(total,pass))*(i/man > (pass-i)/woman))
[1] 0.4449808
> sum((choose(man,i)*choose(woman,pass-i)/choose(total,pass))*(i/man > 1.2*(pass-i)/woman))
[1] 0.3090334
定員100で男子800人女子200人が受験して合格率の男女比が
1.2であったときに統計的には有意差があると言えるか？
f <- function(ratio=1.2,man=800,woman=200,pass=100){
total=man+woman
i=0:pass
sum((choose(man,i)*choose(woman,pass-i)/choose(total,pass))*(i/man > ratio*(pass-i)/woman))
}
f()
{-ある医大で合格率の男女比が1.2で男子有意という結果だったという。
定員100で男子800人女子200人が受験して合格率の男女比が
1.2であったときに統計的には有意差があると言えるか？
-}
choose n r = [1..n] `div` [1..n-r] `div` [1..r]
ratio=1.2
pass=100
man=800
woman=200
total=man+woman
ii=[0..pass]
male_fem i =
| choose(man,i)*choose(woman,pass-i)/choose(total,pass) <ratio 0
| otherwise choose(man,i)*choose(woman,pass-i)/choose(total,pass
sum $ map male_fem ii
ド底辺シリツ医大卒って医療従事者にマウントするのは不可能だから事務員や国試浪人認定するしかないんだなぁ。
こういうのにサクッと答えてド底辺シリツ医大卒でも高卒の基礎学力くらいあるのを示せばいいのに。
ある医大で合格率の男女比が1.2で男子優位という結果だったという。
定員100で男子800人女子200人が受験して合格率の男女比が
1.2であったときに統計的には有意差があると言えるか？
Rで数えると
f <- function(ratio=1.2,man=800,woman=200,pass=100){
total=man+woman
i=0:pass
sum((choose(man,i)*choose(woman,pass-i)/choose(total,pass))*(i/man > ratio*(pass-i)/woman))
}
f()
Haskellで数えると
ratio=1.2
pass=100
man=800
woman=200
total=man+woman
ii=[0..pass]
male_fem i= if r < ratio then 0 else p
where a = (choose man i)*(choose woman (pass-i))
b = choose total pass
m=fromIntegral i/ fromIntegral man
w=fromIntegral (pass-i)/fromIntegral woman
r = m/w
p = (fromIntegral a) / (fromIntegral b)
main = do
print $ sum ( map male_fem ii)
woman=total*wm
man=total-woman
i=0:pass
sum((choose(man,i)*choose(woman,pass-i)/choose(total,pass))*(i/man > ratio*(pass-i)/woman))
}
f()
r=seq(1,3,length=1000)
p=sapply(r,f)
plot(r,p,pch=19,type='n',bty='l',xlab='M/F ratio',ylab='probability')
abline(h=0.01,lty=3)
g <- function(wm) lines(r,sapply(r,function(r)f(r,wm)),col=10*wm,lwd=10*wm)
for(i in 1:5/10) g(i)
legend('center',bty='n',lwd=1:5,col=1:5,
legend=c('10%','20%','30%','40%','50%'))
pass=100
wm=0.2
curve( (x/(1-wm))/((pass-x)/wm),0,pass)
uniroot(function(x,u0=1.2) x*wm/(1-wm)/(pass-x)-u0, c(0,pass))
(83/800)/(17/200)
prop.test(c(83,17),c(800,200))
wm=0.2
curve( (x/(1-wm))/((pass-x)/wm),0,pass)
uniroot(function(x,u0=1.2) x*wm/(1-wm)/(pass-x)-u0, c(0,pass))
(83/800)/(17/200)
prop.test(c(83,17),c(800,200))
m_suc = function(rate) (pass* rate * (wm - 1))/(rate* (wm - 1) - wm)
m_suc(1.2)
curve(m_suc(x),1,5)
total=1000
wm=0.5
h <- function(mf){
M=ceiling(m_suc(mf))
F=pass-M
prop.test(c(M,F),c(total*(1-wm),total*wm))$p.value
}
r=seq(1,3,length=1000)
plot(r,sapply(r,h),type='l')
abline(h=0.05,lty=3)
uniroot(function(x)h(x)-0.05,c(1,2))$root
m_suc(1.43)
59/41
prop.test(c(59,41),c(500,500),correct=F)
prop.test(c(60,40),c(500,500),correct=F)
/ ヽ ヽ ヽ
/ / | {. ハ ハ ヽ
/ :! │ j 八 | | )
,′ i | ｛. i | {＼ ﾊ | i| ﾘ )､ / 国試浪人事務員は薄汚いジジイ
ｉ i | 八 ｉ Vx炒¨＾jﾉ}八/ ( ヽ / 敗者は敗者らしく
| ｉ 从 { { ＼八{ //// ｲ )ヾﾉ ( この世界のなるべく闇いところで
Viﾊ ＼|x炒＾j ( (ｲ / 謝りながら生きていくといいのよ
＼＼_V//く _ ) ) ヾ ゝ,
`ｰ小. _-ｧ ( ( ヾ
|i∧ く:::_ノ ) i 丶､ﾞゝ
|ｉ| {丶、 ´ ( | iヾﾞ
ﾉ八{ { {＞ . ／) ｉ ヾ
〃{｛ `ｰ=ミ ｀T爪八 i , ヾ 八
ヾ人＼ ｀ヽ j{__j ｼ｀ヾﾐﾐﾙ'ﾊヽ.ト＜7＼＿＿＿___
／⌒￢=-ミ#ヾ/ ＼ ＼/####/ ｀ヽ
/ ヽ##｀ヽ､ノ⌒ヽ V⌒ゝ､#;;| '.
{ ﾞi####ヽ 八 |'⌒´##ヾ |
| |#####＼/:i ＼'ー‐'i"######ﾞ) |
│ |########| :| ( ⌒ )#######| |
# AEIBFJ…の順で縦に宝を探していく方法をとるP君と、
# ABCDEFGH…の順で横に宝を探していく方法をとるQ君が、同時に地点Aから探索を開始した。
# どっちの方が有利？
#
# ABCD
# EFGH
# IJKL
y=LETTERS[1:12]
z=matrix(y,ncol=4,byrow=T)
as.vector(z) # P
as.vector(t(z)) # Q(=y)
x=c(1,1,rep(0,10))
is.P1st <- function(){
Q=sample(x)
z=matrix(Q,ncol=4,byrow=T)
P=as.vector(z)
which.max(P) < which.max(Q)
}
k=1e3
re=replicate(k,mean(replicate(k,is.P1st())))
summary(re)
> PQ <- function(){
+ Q=sample(x)
+ z=matrix(Q,ncol=4,byrow=T)
+ P=as.vector(z)
+ c( even=which.max(P) == which.max(Q),
+ p1st=which.max(P) < which.max(Q),
+ q1st=which.max(P) > which.max(Q))
+
+ }
> k=1e6
> re=replicate(k,PQ())
> mean(re['even',]) ; 13/(26+27+13)
[1] 0.197025
[1] 0.1969697
> mean(re['p1st',]) ; 26/(26+27+13)
[1] 0.393803
[1] 0.3939394
> mean(re['q1st',]) ; 27/(26+27+13)
[1] 0.409172
[1] 0.4090909
一般解
treasure <- function(m=3,n=4,k=2){
y=1:(m*n)
(z=matrix(y,ncol=n,byrow=T))
(P=as.vector(z))
(Q=as.vector(t(z)))
PQ <- function(x){
p=q=numeric(k)
for(i in 1:k){
p[i]=which(P==x[i])
q[i]=which(Q==x[i])
}
min(p)-min(q)
}
tre=combn(m*n,k)
re=apply(tre,2,PQ)
c(P1st=sum(re<0),Q1st=sum(re>0),even=sum(re==0))
}
treasure(3,4,2)
treasure(5,10,3)
| 国 | .:.:.:.:.:.:.:.:..:.:.:.:.:.:.:.:.:.｀.
| 試 |.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:＼
| 浪 |:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:ヽ
| 人 |.:.:./:.:.:.:.:.:.:.:.:.:.:ヽ:.:.:.:.:.:.:..:..:.:ﾊ
| ！？ |.:.:.|:.:.:.:.:.:.::.:.:.:.:.:.|:.:.:.:.:.:.:.:.:.:.:.:.}
|＿＿＿＿＿＿|:.:.:l.:.:l:.:.:.:.:l.:.:.:.:.:ｌ:.:.:.:.:.:ｌ:.:.:.:.:.:j
l:.:.:.:.i:.:.:.:ヽl∧ﾊ＼:.:.l:.:/∨ハ:.:/l:.:.:.:ｌ:.:.ｌ
|:.:.:.:.l:.:.:.:l斗―ミ､ ヽ!/ ,. -―ﾐ､ !:.:./:.:.:ｌ
iﾄ､:.:.|:.:.:.|（ ・）` '´（・ ）` l:.ノ:.:.:.:.:l
ﾉ:.:ﾊ:.:.:l ` 一' , ｰ一'´ﾉ:.:.:.:.|.:.:人
／:.:.:.У:人ι ﾑｲ:.:.:l:.:.:.:./ヽ
(/i:.:{::.ｲ:.:.:ﾊ.丶 -―- ／:.:l:.:.:.:l.:.:.:八
. ﾚ'´}:.:.:./:.:.}ﾘ}＞ ＿_ .イ人:.:ﾊ:.:.:|:.:ﾘ}
__)ノ ﾄソ／ ＼_ _／ ＼ ﾘ 乂へ
イ /##｛ ＿/∨＼＿ }### i ＼
/ /###レイ. ヽ人／ ヽ/###.ｌ ヽ
. ｌ /####l / ヽ /####ｉ }
https://egg.5ch.net/test/read.cgi/hosp/1537867846/29
こんなスレが出てきました
自称医科歯科卒が専門医をねたむスレ [転載禁止]©2ch.net
https://egg.5ch.net/test/read.cgi/hosp/1419213994/l50
このスレを辿ってみたら白黒コピーの医師免許の一部が
大部分を隠してアップされてましたが
https://egg.5ch.net/test/read.cgi/hosp/1419213994/437
これって病院で事務用に保管しているコピーですよね
朝鮮殺戮殺人学会が警察にテロ工作員を送り込み、
なんと
警察から犯罪ライセンスを与えられ、
監禁罪、薬物大量投与テロ、
などやり、
テロ工作拠点だとバレた
福山友愛病院については？
福山友愛病院 事件 でググれば？
http://sp.nicovideo.jp/watch/sm7997483?ss_id=09863826-7a23-4d06-8791-91e89aac58b7&;ss_pos=19
スクリプトの最適化とか示せばいいのに
どれでもいいから掲載してあるRのコードをCで高速化してみ。
専門医スレで誰も正解出せなかった、
これを解くコードを書いて仮想国試浪人程度の頭脳があることを示してくれ。
door to balloon timeが短縮するのに必要な計算。
診療所から病院に患者を救急搬送する。
病院から医師搭乗の救急車が診療所に向かっており１０時到着予定と連絡が入った。
患者の病態が悪化したら、診療所の普通車で病院に向かい救急車と出会ったら
救急車に患者を移して搬送し病院到着を急ぐという計画を立てた。
普通車から救急車への患者の乗り換えで１０分余分に時間がかかる。
道路事情から救急車は病院から診療所への道は
平均時速６０ｋｍで、逆方向は平均時速４５ｋｍで定速走行する。診療所の普通車は信号待ちもあり平均時速３０kmで定速走行する。
何時以降の病態悪化は診療所の車を使わずに救急車の到着を待つ方が病院に早く着くか？
インフルエンザの迅速キットは特異度は高いが感度は検査時期によって左右される。
ある診断キットが開発されたとする。
このキットは特異度は９９％と良好であったが、
感度については確かな情報がない。
事前確率分布として一様分布を仮定する。
５０人を無作為抽出してこの診断キットで診断したところ４０人が陽性であった。
この母集団の有病率の期待値と９５％ＣＩはいくらか？
またこの診断キットの感度の期待値と９５％ＣＩはいくらか
n=ceiling(log10(x))
ifelse(10^n==x,n+1,n)
}
n2a <- function(num){ # nmu to array 122 -> c(1,2,2)
N=10
r=num%%N
q=num%/%N
while(q>0){
r=append(q%%N,r)
q=q%/%N
}
return(r)
}
one2n <- function(x){ # 121 -> 13
a=n2a(x)
k=digi(x)
p=2^((k-1):0)
sum(a*p)
}
x=1212121212
one2n(x)
見物人たちがそれを見てフルボッコにするスレである
事務員 とは？
同一者の別名として、薄汚いジジイ、国試浪人、統計野郎、自称医科歯科、がある
自称医科歯科卒、実際は九州の駅弁国立出身で、卒業後は実家の東京に帰り国試浪人となり23年間経過、家庭教師バイトなどを経て現在は事務員、とされている
本人は、勤務医でたまに開業医の手伝いと内視鏡バイト、専門医なし、と主張しているが、連日連夜の異常な書き込み数の多さからは、勤務医とは考え難く、彼の職業がたとえ何であったとしても、人としてド底辺なことは間違いがない
自ら事務員であると告白したこともある
https://egg.5ch.net/test/read.cgi/hosp/1531459372/108-109
自作自演も頻繁に行なっている
事務仕事の際に手にした他人の給与明細や同窓会費振込票を盗撮し、自分のものとしてアップロードしたこともある、犯罪なんじゃねーの？
統計絶対主義でマウントを取ろうとするが、大学卒業後の人生の大部分においてそれが何の役に立つのかはなはだ疑問である
統計に基づいた重病の治療成績を患者に説明しても、患者の希望する治療は患者の事情によって異なることは一定年数以上の臨床経験があるものなら誰でも知っていることだ
それが理解できない彼は、彼自身が素性を明らかにしているようなものである
コンプ薬屋同様に、私立医への執拗な誹謗中傷を数年余にわたって続けている
裏口批判をしているが、実際にそれが可能な資産家の子弟がいるであろう右派スレには近寄らない、一度書き込んだ形跡があったが指摘したら別人だと言って逃げた
弱いものが多そうなスレしか狙わないのもコンプ薬屋と共通する異常者の特徴である
劣等コンプレックスの塊なんだろうな
自分の主張に対して都合の悪い突込みが入ると、相手を私立医と決めつけて、さてはシリツだな、裏口バカ、というセリフでワンパターンに返すことが多い
国試問題を挙げて簡単だとほざいてますが、本番で通らなければお話になりません
いくらネットでわめいていても、医師国試の本番で通らなければお話になりません
大事なことなので２回言いました
main = do
putStr $ "Type number: "
str <- getLine
let xs = concat $ iterate (\x->[1:n| n<-x] ++ [2:n|n<-x]) [[1],[2]]
n = read str
putStrLn $ concat $ map show (xs !! (n-1))
コンパイルして実行したけど、１億めはメモリ不足に陥った。
https://www.wolframalpha.com/input/?i=IntegerDigits+%5B10%5E8,+2%5D
> digit12(10^8) # 1億め
12222212122221111211111112
> digit12(10^12) # 1兆め
221211122121211212112121112111111111112
Rのコードはここ
http://tpcg.io/D2sseW
婚活にも失敗してる素人童貞で
くるくるぱーの裏口バカに
なっちゃってるのらぁあぁぁ
Ｆラン事務員の濃ゆぅぅい生ガキ汁
ド底辺の臭いが落ちないよぉ
んほおぉぉぉおぉぉ
１０の６８乗を無量大数というらしい
無量大数＋１を２進数表示できるかやってみた。
Prelude> :main
Input integer : 100000000000000000000000000000000000000000000000000000000000000000001
1110110101100011101000100011000111010100110001001111101100100111010011001010011110101010101010000110001111101110010010111101110101001000010101101100010111000100000000000000000000000000000000000000000000000000000000000000000001
さすが不定長整数を扱えるHaskell。
んで、あんた、どこ卒？
さては国試浪人の事務員だな
俺、医科歯科卒。二期校時代に入学。
国立卒なのでこういう問題にも答が出せる。
インフルエンザの迅速キットは特異度は高いが感度は検査時期によって左右される。
ある診断キットが開発されたとする。
このキットは特異度は９９％と良好であったが、
感度については確かな情報がない。
事前確率分布として一様分布を仮定する。
５０人を無作為抽出してこの診断キットで診断したところ４０人が陽性であった。
この母集団の有病率の期待値と９５％信用区間はいくらか？
またこの診断キットの感度の期待値と９５％信用区間はいくらか
婚活にも失敗してる素人童貞で
くるくるぱーの裏口バカに
なっちゃってるのらぁあぁぁ
Ｆラン事務員の濃ゆぅぅい生ガキ汁
ド底辺の臭いが落ちないよぉ
んほおぉぉぉおぉぉ
http://sp.nicovideo.jp/watch/sm34064890?cp_in=watch_watchRelatedContents
>国立卒なのでこういう問題にも答が出せる。
を受けて正解を投稿すれば、
ド底辺シリツ医大卒でも国立卒レベルの数学ができることを示す機会なのに
馬鹿を晒す機会にするとはド底辺シリツ医大卒の裏口ガイジらしいぜｗ
無職のナマポでさえ避けたがるのがド底辺シリツ医大卒
ナマポの症例報告です。
実例↓
517 卵の名無しさん 2018/02/25(日) 11:36:00.56 ID:gq76tAvs
福岡のあの歯科大かな？
歯科口腔外科で抜歯依頼したら爺ちゃんが〇〇歯科大卒の先生は避けて下さいねがあった
けど。
この爺ちゃん、聖マリ卒の先生もよけて下さいと初診時に言ってた札付き爺さん。
生保受給者のくせにね。
http://www.courts.go.jp/saiyo/vcms_lf/3all-h30s4-di.pdf
男880 1次通過者224 合格者43
女736 1次通過者159 合格者87
調整の出来ない1次試験の通過率 男25.5% 女21.6％
調整し放題の面接と称する試験合格率 男19.2% 女54.7%
f <- function(ratio=1.2,man=800,woman=200,pass=100){
total=man+woman
i=0:pass
sum((choose(man,i)*choose(woman,pass-i)/choose(total,pass))*(i/man > ratio*(pass-i)/woman))
}
f((87/736)/(43/880),736,880,43+87)
f((87/159)/(43/224),159,224,43+87)
prop.test(c(43,87),c(880,736))
prop.test(c(224,159),c(880,736))
prop.test(c(43,87),c(224,159))
http://cdn-ak.f.st-hatena.com/images/fotolife/h/hanbunningen/20110905/20110905095207.jpg
男880 1次通過者224 合格者43
女736 1次通過者159 合格者87
x=c(880,736)
y=c(224,159)
z=c(43,87)
fisher.test(cbind(x-y,y))
fisher.test(cbind(y-z,z))
fisher.test(cbind(x-z,z))
prop.test(y,x)
prop.test(z,y)
prop.test(z,x)
>初診時に言ってた
シリツ医大卒＝裏口バカと認識しているわけだな。
>>
東京医大、本来合格者入学許可へ 今年の受験生５０人
2018年10月25日 02時06分
東京医科大＝８月、東京都新宿区
東京医科大が今年の入試で本来合格ラインを上回っていたのに、不正の影響で不合格となった受験生５０人に対し、来年４月の入学を認める方針を固めたことが２４日、関係者への取材で分かった。
昨年の本来合格者１９人については、難しいとの意見が出ているもようだ。東京医大は５０人のうち入学希望が多数に上った場合は、来年の一般入試の募集人員減も検討。
<<
https://www.nishinippon.co.jp/sp/nnp/national/article/460101/
入学者数って100人程度のだよな？
半分が裏口ってこと？
y=1:(m*n)
(z=matrix(y,ncol=n,byrow=T))
(P=as.vector(z))
(Q=as.vector(t(z)))
PQ <- function(x){
p=q=numeric(k)
for(i in 1:k){
p[i]=which(P==x[i])
q[i]=which(Q==x[i])
}
min(p)-min(q)
}
tre=combn(m*n,k)
re=apply(tre,2,PQ)
print(c(P1st=sum(re<0),Q1st=sum(re>0),even=sum(re==0)))
invisible(list(P1st=tre[,which(re<0)],Q1st=tre[,which(re>0)],even=tre[,which(re==0)]))
}
t342=treasure(3,4,2)
print(matrix(LETTERS[t342$P1st],nrow=2),quote=F)
print(matrix(LETTERS[t342$Q1st],nrow=2),quote=F)
print(matrix(LETTERS[t342$even],nrow=2),quote=F)
t452=treasure(4,5,2)
print(matrix(LETTERS[t452$P1st],nrow=2),quote=F)
print(matrix(LETTERS[t452$Q1st],nrow=2),quote=F)
print(matrix(LETTERS[t452$even],nrow=2),quote=F)
縦1列を探し終えたらすぐ右の1列に移って宝を探していく方法をとるP君と、横1行を探し終えたらすぐ下の1行に移って宝を探していく方法をとるQ君が、同時に左上の地点から探索を開始した。
例えば、n=3の時はP君はAEIBFJCGKDHLの順で探す。Q君はABCDEFGHIJKの順で探すことになる。
ABCD
EFGH
I JK L
1つの地点を捜索するのにかかる時間は同じで、相手が1度探し終えた地点を重複して調べることも当然ある。
相手より先に宝を見つけた方を勝者とする。同時の場合は引き分けとする。
どちらの方が有利になるだろうか？
> t(sapply(1:20,treasure1))
P1st Q1st even
[1,] 0 0 1
[2,] 4 5 6
[3,] 26 27 13
[4,] 84 83 23
[5,] 203 197 35
[6,] 413 398 50
[7,] 751 722 67
[8,] 1259 1210 87
[9,] 1986 1910 109
[10,] 2986 2875 134
[11,] 4320 4165 161
[12,] 6054 5845 191
[13,] 8261 7987 223
[14,] 11019 10668 258
[15,] 14413 13972 295
[16,] 18533 17988 335
[17,] 23476 22812 377
[18,] 29344 28545 422
[19,] 36246 35295 469
[20,] 44296 43175 519
http://seiga.nicovideo.jp/seiga/im6350659
4以上だと短軸探索が有利になるようにみえるな。
n=2
ABC
DEF
の場合
短軸方向探索Pが先に宝を発見する埋め方：４通り
> print(matrix(LETTERS[t232$P1st],nrow=2),quote=F)
[,1] [,2] [,3] [,4]
[1,] C D D E
[2,] D E F F
長軸方向探索Qが先に宝を発見する埋め方：５通り
> print(matrix(LETTERS[t232$Q1st],nrow=2),quote=F)
[,1] [,2] [,3] [,4] [,5]
[1,] B B B C C
[2,] C E F E F
同時に宝を発見する埋め方：６通り
> print(matrix(LETTERS[t232$even],nrow=2),quote=F)
[,1] [,2] [,3] [,4] [,5] [,6]
[1,] A A A A A B
[2,] B C D E F D
http://sp.seiga.nicovideo.jp/seiga/#!/im8552821
http://sp.seiga.nicovideo.jp/seiga/#!/im8632142
数学板で２つの宝を先に発見した方を勝者にしたらどうなるかというレスがあったのでプログラムを改変してみた。
treasure2 <- function(m=3,n=4,k=2){
y=1:(m*n)
(z=matrix(y,ncol=n,byrow=T))
(P=as.vector(z))
(Q=as.vector(t(z)))
PQ <- function(x){
p=q=numeric(k)
for(i in 1:k){
p[i]=which(P==x[i])
q[i]=which(Q==x[i])
}
max(p)-max(q)
}
tre=combn(m*n,k)
re=apply(tre,2,PQ)
print(c(P1st=sum(re<0),Q1st=sum(re>0),even=sum(re==0)))
invisible(list(P1st=tre[,which(re<0)],Q1st=tre[,which(re>0)],even=tre[,which(re==0)]))
}
t342=treasure2(3,4,2)
#短軸方向探索Pが先に２つの宝を発見する埋め方
print(matrix(LETTERS[t342$P1st],nrow=2),quote=F)
#長軸方向探索Qが先に２つの宝を発見する埋め方
print(matrix(LETTERS[t342$Q1st],nrow=2),quote=F)
#同時に２つめの宝を発見する埋め方
print(matrix(LETTERS[t342$even],nrow=2),quote=F)
P1st Q1st even
27 26 13
> #短軸方向探索Pが先に２つの宝を発見する埋め方
> print(matrix(LETTERS[t342$P1st],nrow=2),quote=F)
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12] [,13] [,14] [,15] [,16] [,17] [,18] [,19]
[1,] A A A A A B B B B B C C C D E E E E F
[2,] E F I J K E F I J K I J K K F I J K I
[,20] [,21] [,22] [,23] [,24] [,25] [,26] [,27]
[1,] F F G G G I I J
[2,] J K I J K J K K
> #長軸方向探索Qが先に２つの宝を発見する埋め方
> print(matrix(LETTERS[t342$Q1st],nrow=2),quote=F)
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12] [,13] [,14] [,15] [,16] [,17] [,18] [,19]
[1,] A A A A A B B B B C C C C C D D D D D
[2,] B C D G H C D G H D E F G H E F G H I
[,20] [,21] [,22] [,23] [,24] [,25] [,26]
[1,] E E F F G H H
[2,] G H G H H I J
> #同時に２つめの宝を発見する埋め方
> print(matrix(LETTERS[t342$even],nrow=2),quote=F)
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12] [,13]
[1,] A B C D D E F G H H I J K
[2,] L L L J L L L L K L L L L
やはり、直観と違ってイーブンにはならないな。
全部の宝を発見した方が勝者とすると、縦方向探索Pと横方向探索Qとして
勝者となる埋め方の場合の数は
> treasure2(5,10,3)
P1st Q1st even
9142 8832 1626
と算出できた。
部屋割りカウントできない底辺頭脳でもこれくらいは数えられるかな？
http://seiga.nicovideo.jp/seiga/im8552821
中卒国試浪人の事務員には解けないだろうな
熱傷診療ガイドライン(www.jsbi-burn.org/members/guideline/pdf/guideline2.pdf)に引用された論文としてこんなのが商用パンフに掲載されていた。
http://imagizer.imageshack.com/img923/3955/cIV6t9.jpg
早期群: n1=17 m1=36.2 sd1=21.5
後期群: n2=12 m2=56.1 sd2=30.1
で早期群の方が上皮化期間が有意(t検定でp<0.05)に短いと主張している。
生データがないので標本数・平均・標準偏差から検定してみる。
ttest2 = function(n1,m1,s1, n2,m2,s2){ # ni:標本数 mi:平均 si:標準偏差
n=n1+n2-2
u=((n1-1)*s1^2+(n2-1)*s2^2)/n
t=(m1-m2)/sqrt(u/n1+u/n2)
pe=2*pt(-abs(t),n)
t=(m1-m2)/sqrt(s1^2/n1 + s2^2/n2)
n=(s1^2/n1+s2^2/n2)^2 / ( (s1^2/n1)^2/(n1-1) + (s2^2/n2)^2/(n2-1))
pu=2*pt(-abs(t),n)
p.values=c(T.test=pe,Welch.test=pu)
return(p.values)
}
> ttest2(n1,m1,sd1, n2,m2,sd2)
T.test Welch.test
0.04701090 0.06461679
等分散を仮定したｔ検定でやっと0.05未満になるが、等分散を仮定しないWelchの方法だと有意差がでない。
のグラフをみると後期群の最大値は外れ値に見える。
後期群が n2=12 m2=56.1 sd2=30.1
を満たすようなシミュレーションデータを作成して
そのデータの最大値を除いた標本群を修正後期群として
早期群と検定（等分散を仮定するｔ検定と仮定しないWelchの検定）してｐ値を出す。
これを1万回繰り返してｐ値がどんな値になるかやってみた。
その結果は、
等分散ｔ検定でｐ値は平均 0.105(95%CI 0.0916 0.116)で有意とは言えない。
Welochの検定でｐ値は平均 0.126(95%CI 0.114 0.129)で有意とは言えない。
シミュレーションデータによる検定のRスクリプトはここに書いた。
http://egg.2ch.net/test/read.cgi/hosp/1483665995/82
ガイドラインに引用されている論文すら、あんまり信用できないと思った。
“Statistics are like bikinis. What they reveal is suggestive, but what they conceal is vital.”
中卒で受けられる国試って何だろね？
その一文だけで頭が悪いのがわかる。
レスが返って来て勉強になるなぁ。
# ABCDEFGに対してなら
# BCDEFGAが一番勝率高い気がする
library(gtools)
n=7
k=2
perm=permutations(n,n)
Q=perm[1,]
np=nrow(perm)
p1st=numeric(np)
for(i in 1:np){
P=perm[i,]
tre=combn(n,k)
nt=ncol(tre)
re=numeric()
for(j in 1:nt){
re[j]=min(which(tre[1,j]==P),which(tre[2,j]==P))-
min(which(tre[1,j]==Q),which(tre[2,j]==Q))
}
p1st[i]=sum(re<0)
}
plot(p1st)
p1st[which.max(p1st)]
(p.max=which(p1st==15))
print(matrix(LETTERS[perm[p.max,]],ncol=7),quote=F)
#
library(gtools)
n=8
k=2
perm=permutations(n,n)
Q=perm[1,]
np=nrow(perm)
p1st=numeric(np)
for(i in 1:np){
P=perm[i,]
tre=combn(n,k)
nt=ncol(tre)
re=numeric()
for(j in 1:nt){
re[j]=max(which(tre[1,j]==P),which(tre[2,j]==P))-
max(which(tre[1,j]==Q),which(tre[2,j]==Q))
}
p1st[i]=sum(re<0)
}
plot(p1st)
mv=p1st[which.max(p1st)]
(p.max=which(p1st==mv))
print(matrix(LETTERS[perm[p.max,]],ncol=8),quote=F)
ド底辺シリツ医大生が８人いてそのうち３人は裏口入学であることが判明している。
８人をA,B,C,D,E,F,G,Hとする。
A,B,C,D,E,F,G,Hの順に調査して３人みつかれば調査は終了とする。
A,B,C,D,E,F,G,Hの順の調査と比べて早くみつかる可能性の探索順を列挙せよ。
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8]
[1,] A B D E F G H C
[2,] A C D E F G H B
[3,] A D B E F G H C
[4,] A D C E F G H B
[5,] B A D E F G H C
[6,] B C D E F G H A
[7,] B D A E F G H C
[8,] B D C E F G H A
[9,] C A D E F G H B
[10,] C B D E F G H A
[11,] C D A E F G H B
[12,] C D B E F G H A
[13,] D A B E F G H C
[14,] D A C E F G H B
[15,] D B A E F G H C
[16,] D B C E F G H A
[17,] D C A E F G H B
[18,] D C B E F G H A
おい、ド底辺頭脳よ、これであっているか検証してみろ。
y=1:(m*n)
(z=matrix(y,ncol=n,byrow=T))
(P=as.vector(z))
(Q=as.vector(t(z)))
PQ <- function(x){
p=q=numeric(k)
for(i in 1:k){
p[i]=which(P==x[i])
q[i]=which(Q==x[i])
}
min(p)-min(q)
}
tre=combn(m*n,k)
re=apply(tre,2,PQ)
return(c(短軸有利=sum(re<0),長軸有利=sum(re>0),同等=sum(re==0)))
}
sapply(1:12,function(k) treasure(3,4,k))
sapply(1:20,function(k) treasure(4,5,k))
宅建国試浪人の中卒事務員さん
算数の問題ですらないじゃん、
おまえは問題作成すらできないドアホなのか？
最近のトピックをつかったこういう問題面白いだろ？
答える頭はお前にはないだろうけど。
ド底辺シリツ医大生が８人いてそのうち３人は裏口入学であることが判明している。
８人をA,B,C,D,E,F,G,Hとする。
A,B,C,D,E,F,G,Hの順に調査して３人みつかれば調査は終了とする。
A,B,C,D,E,F,G,Hの順の調査と比べて早くみつかる可能性の探索順を列挙せよ。
ある医大で合格率の男女比が1.2で男子優位という結果だったという。
定員100で男子800人女子200人が受験して合格率の男女比が
1.2であったときに統計的には有意差があると言えるか？
できない椰子はド底辺シリツ医大卒と同じ頭脳レベルといえる。
東京医大、本来合格者入学許可へ 今年の受験生５０人
2018年10月25日 02時06分
東京医科大＝８月、東京都新宿区
東京医科大が今年の入試で本来合格ラインを上回っていたのに、不正の影響で不合格となった受験生５０人に対し、来年４月の入学を認める方針を固めたことが２４日、関係者への取材で分かった。
昨年の本来合格者１９人については、難しいとの意見が出ているもようだ。東京医大は５０人のうち入学希望が多数に上った場合は、来年の一般入試の募集人員減も検討。
https://www.nishinippon.co.jp/sp/nnp/national/article/460101/
https://www.tokyo-med.ac.jp/med/enrollment.htmlによると
学年 第1学年 第2学年
在学者数 133 113
昨年入学者の留年者や退学者が０として、
大学が公式認定した裏口入学者が少なくとも今年は１３３人中５０人、昨年が１１３人中１９人ということになる。
裏口入学率の期待値、最頻値、およびその９５％信頼区間を求めよ。
y=c(50,19)
N=c(133,113)
Ntotal=length(y)
a=1
b=1
dataList=list(y=y,N=N,Ntotal=Ntotal,a=a,b=b)
# JAGS model
modelString ="
model{
for(i in 1:Ntotal){
y[i] ~ dbin(theta,N[i])
}
theta ~ dbeta(a,b)
}
"
writeLines(modelString,'TEMPmodel.txt')
jagsModel=jags.model('TEMPmodel.txt',data=dataList)
codaSamples=coda.samples(jagsModel,var=c('theta'),n.iter=20000,na.rm=TRUE)
summary(codaSamples)
js=as.vector(as.matrix(codaSamples))
BEST::plotPost(js,,xlab="裏口確率")
BEST::plotPost(js,showMode = TRUE,xlab="裏口確率")
昨年と今年で裏口入学率に違いがあったといえるか？
裏口入学率の差の期待値とその９５％信頼区間を求めよ
解法はここに置いた
https://rio2016.5ch.net/test/read.cgi/math/1490734993/208
裏口入学率の事前分布は一様分布よりJefferey分布の方がいいかなと思ってやってみたが、殆ど数値に影響なかったな。
宅建国試浪人の中卒事務員さん
問題の数式はどれだよ？
東京医大、本来合格者入学許可へ 今年の受験生５０人
2018年10月25日 02時06分
東京医科大＝８月、東京都新宿区
東京医科大が今年の入試で本来合格ラインを上回っていたのに、不正の影響で不合格となった受験生５０人に対し、来年４月の入学を認める方針を固めたことが２４日、関係者への取材で分かった。
昨年の本来合格者１９人については、難しいとの意見が出ているもようだ。東京医大は５０人のうち入学希望が多数に上った場合は、来年の一般入試の募集人員減も検討。
https://www.nishinippon.co.jp/sp/nnp/national/article/460101/
https://www.tokyo-med.ac.jp/med/enrollment.htmlによると
学年 第1学年 第2学年
在学者数 133 113
昨年入学者の留年者や退学者が０として、
大学が公式認定した裏口入学者が少なくとも今年は１３３人中５０人、昨年が１１３人中１９人ということになる。
裏口入学率の期待値、最頻値、およびその９５％信頼区間を求めよ。
https://www.nicovideo.jp/watch/sm27736306
外れ値扱いせず、対数正規分布に従うデータとして検定してみた。
負の値になるシミュレーションデータの組み合わせは除外して対数化して検定
n1=17 ; n2=12 ;m1=36.2 ;m2=56.1 ; sd1=21.5 ; sd2=30.1
fx1 = function(){
tmp=scale(rnorm(n1))*sd1+m1
while(min(tmp)<0){
tmp=scale(rnorm(n1))*sd1+m1
}
return(tmp)
}
fx2 = function(){
tmp=scale(rnorm(n2))*sd2+m2
while(min(tmp)<0) tmp=scale(rnorm(n2))*sd2+m2
return(tmp)
}
k=1e4
T.p_value=replicate(k,t.test(log(fx1()),log(fx2()),var=T)$p.value)
W.p_value=replicate(k,t.test(log(fx1()),log(fx2()))$p.value)
mean(T.p_value) ; quantile(T.p_value,c(0.025,0.975))
mean(W.p_value) ; quantile(W.p_value,c(0.025,0.975))
> mean(T.p_value) ; quantile(T.p_value,c(0.025,0.975))
[1] 0.1453533
2.5% 97.5%
0.04098323 0.50619976
> mean(W.p_value) ; quantile(W.p_value,c(0.025,0.975))
[1] 0.1407244
2.5% 97.5%
0.0313094 0.5523005
全く、有意差なしの結論になった。
こういう風にちゃんと数字を出して問題文を自作しろよ。
東京医大、本来合格者入学許可へ 今年の受験生５０人
2018年10月25日 02時06分
東京医科大＝８月、東京都新宿区
東京医科大が今年の入試で本来合格ラインを上回っていたのに、不正の影響で不合格となった受験生５０人に対し、来年４月の入学を認める方針を固めたことが２４日、関係者への取材で分かった。
昨年の本来合格者１９人については、難しいとの意見が出ているもようだ。東京医大は５０人のうち入学希望が多数に上った場合は、来年の一般入試の募集人員減も検討。
https://www.nishinippon.co.jp/sp/nnp/national/article/460101/
https://www.tokyo-med.ac.jp/med/enrollment.htmlによると
学年 第1学年 第2学年
在学者数 133 113
昨年入学者の留年者や退学者が０として、
大学が公式認定した裏口入学者が少なくとも今年は１３３人中５０人、昨年が１１３人中１９人ということになる。
裏口入学率の期待値、最頻値、およびその９５％信頼区間を求めよ。
やはり事務員には無理だったか
算数の問題だ おらぁ
https://www.nicovideo.jp/watch/sm27841268
答えるもなにも問題を書けよ、リンクは踏まないから。
３ｘ４が完成
> (t34=sapply(1:12,function(k) treasure0(3,4,k)))
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12]
短軸有利 5 26 73 133 167 148 91 37 9 1 0 0
長軸有利 5 27 76 140 176 153 92 37 9 1 0 0
同等 2 13 71 222 449 623 609 421 202 64 12 1
４ｘ５が完成
> (t45=sapply(1:20,function(k) treasure0(4,5,k)))
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12]
短軸有利 9 84 463 1776 5076 11249 19797 28057 32243 30095 22749 13820
長軸有利 9 83 453 1753 5075 11353 20057 28400 32528 30250 22803 13831
同等 2 23 224 1316 5353 16158 37666 69513 103189 124411 122408 98319
[,13] [,14] [,15] [,16] [,17] [,18] [,19] [,20]
短軸有利 6656 2486 695 137 17 1 0 0
長軸有利 6657 2486 695 137 17 1 0 0
同等 64207 33788 14114 4571 1106 188 20 1
treasure0 <- function(m=3,n=4,k=2){
y=1:(m*n)
(z=matrix(y,ncol=n,byrow=T))
(P=as.vector(z))
(Q=as.vector(t(z)))
PQ <- function(x){
p=q=numeric(k)
for(i in 1:k){
p[i]=which(P==x[i])
q[i]=which(Q==x[i])
}
min(p)-min(q)
}
tre=combn(m*n,k)
re=apply(tre,2,PQ)
return(c(短軸有利=sum(re<0),長軸有利=sum(re>0),同等=sum(re==0)))
}
国試浪人には無理だろうが、さっさと解かんか！
https://www.nicovideo.jp/watch/sm27912940
数値を出して自作問題を書けよ。
統計スレに相応しい問題にしろよ。
これ答えてみ！
昨年入学者の留年者や退学者が０として、
東京医大が公式認定した裏口入学者が少なくとも今年は１３３人中５０人、昨年が１１３人中１９人ということになる。
裏口入学率の期待値、最頻値、およびその９５％信頼区間を求めよ。
サイコロを降ってどちらか一方が１であればそちらが勝者。
どちらも１であるときは引き分け
どちらも１でないならば少なくともどちらかが１がでるまでサイコロをふる。
P君、Q君の勝つ確率を求めよ。
p=1/2
q=1/3
q: win
(1-p)*q + (1-p)^2*(1-q)*q+(1-p)^3*(1-q)^2*q+(1-p)^4*(1-q)^3*q+....
=(1-p)*q *( 1 + (1-p)*(1-q) + ((1-p)*(1-q))^2 + ((1-p)*(1-q))^3+...
let r=(1-p)*(1-q)=1/2 * 2/3 =1/3
=(1-p)*q *(1 + r + r^2 + r^3 + ...) = (1-1/2)*1/3 * 3/2 = 1/4 = 0.25
p:win
(1-1/3) * 1/2 * 3/2 = 0.5
draw 1-1/4-1/2= 0.25
六面体のサイコロでP君のサイコロは３面が１、Q君のサイコロは２面が１とする。
サイコロを降ってどちらか一方が１であればそちらが勝者。
どちらも１であるときはもしくはどちらも１でないならば どちらか一方だけが１が出て勝者が決まるまで繰り返す。
P君、Q君の勝つ確率を求めよ。
no_draw rule
Σ[1,∞](1/4)^i = 1/4 *(1-1/4)= 1/3
Pr[P:win]=1/2+1/3*1/2=2/3
Pr[Q:win]1/4+1/3*1/4=1/3
で解ける（ド底辺シリツ医大卒の裏口バカには無理）が、シミュレーションプログラムの練習をしてみる。
P=c(1,1,1,3,4,5)
Q=c(1,1,2,3,4,5)
sub = function(){
p=sample(P,1)
q=sample(Q,1)
if(p==1 & q!=1) return(1)
if(p!=1 & q==1) return(-1)
return(0)
}
throw <- function(){
r=sub()
while(r==0) r=sub()
return(r)
}
re=replicate(1e3,mean(replicate(1e3,throw()==-1)))
summary(re)
> summary(re)
Min. 1st Qu. Median Mean 3rd Qu. Max.
0.2840 0.3230 0.3330 0.3331 0.3430 0.3830
理論値と合致。
シミュレーションのデバッグの方が面倒だった。
算数の問題 の答えは まだか？
やっぱり 解けないんだなＷ
最近のトピックを題材にした問題
これ答えてみ！
昨年入学者の留年者や退学者が０として、
東京医大が公式認定した裏口入学者が少なくとも今年は１３３人中５０人、昨年が１１３人中１９人ということになる。
裏口入学率の期待値、最頻値、およびその９５％信頼区間を求めよ。
ド底辺シリツ医大卒なら無理だろうが、国立大学でていて解けないなら恥ずかしいね。
し! _ -── ‐- ､ , -─-､ -‐─_ﾉ
小 国 /／￣＞ ´ ￣ ￣ ｀ヽ Y , ´ ） 事 え
学 試 L_ ／ ／ ヽ 務 |
生 浪 / ' ' i員 !? マ
ま 人 / / く ジ
で が l ,ｨ/! / /l/!,l ／厶,
だ 許 i ,.lrH‐|'| /‐!-Lﾊ_ l /-!'|/l ／｀'ﾒ､_iヽ
よ さ l | |_|_|_|/| / /__!__ |/!ﾄi i/-- ､ ﾚ!/ / ,-- ﾚ､⌒Y⌒ヽ
ね れ _ゝ|/'/⌒ヽ ヽﾄ､|/ '/￣｀ヾ 、ヽﾄ､Ｎ'/⌒ヾ ,ｲ￣｀ヾ,ﾉ!
l る 「 l ′ 「1 /てヽ′| | | 「L! ' i'ひ} ﾘ
の ヽ | ヽ__Ｕ, ､ヽ シノ ﾉ! ! |ヽ_､ｿ, ヾシ _ノ _ﾉ
-┐ は ,√ ! ￣ ﾘ l ! ￣ ￣ ７/
ﾚ'⌒ヽ/ ! | 〈 _人__人ﾉ_ i く //!
人_,､ノL_,iノ! /! ヽ r─‐- ､ 「 Ｌ_ヽ r─‐- ､ u ノ/
/ / lﾄ､ ＼ ヽ, -‐┤ ﾉ キ 了＼ ヽ, -‐┤ /／
ハ キ { / ヽ,ﾄ､ヽ/!｀ｈﾉ ） モ |/! 「ヽ, `ｰ ／） _ ‐'
ハ ャ ヽ/ r-､‐' // / |-‐ く | ＞ / / ｀'／／-‐､ ／
ハ ハ ＞ ／＼＼// / /ヽ_ ! イ （ / / ／／ / `ｧ-‐ '
ハ ハ / /! ヽ レ'/ ﾉ ＞ ' ∠ -‐ ￣ノヽ /
{ i l ! / フ / -‐ /￣/〉 〈 ＼ /!
最近のトピックを題材にした問題
これ答えてみ！
昨年入学者の留年者や退学者が０として、
東京医大が公式認定した裏口入学者が少なくとも今年は１３３人中５０人、昨年が１１３人中１９人ということになる。
裏口入学率の期待値、最頻値、およびその９５％信頼区間を求めよ。
ド底辺シリツ医大卒なら無理だろうが、国立大学でていて解けないなら恥ずかしいね。
見物人たちがそれを見てフルボッコにするスレである
事務員 とは？
同一者の別名として、薄汚いジジイ、国試浪人、統計野郎、自称医科歯科、がある
自称医科歯科卒、実際は九州の駅弁国立出身で、卒業後は実家の東京に帰り国試浪人となり23年間経過、家庭教師バイトなどを経て現在は事務員、とされている
本人は、勤務医でたまに開業医の手伝いと内視鏡バイト、専門医なし、と主張しているが、連日連夜の異常な書き込み数の多さからは、勤務医とは考え難く、彼の職業がたとえ何であったとしても、人としてド底辺なことは間違いがない
自ら事務員であると告白したこともある
https://egg.5ch.net/test/read.cgi/hosp/1531459372/108-109
自作自演も頻繁に行なっている
事務仕事の際に手にした他人の給与明細や同窓会費振込票を盗撮し、自分のものとしてアップロードしたこともある、犯罪なんじゃねーの？
統計絶対主義でマウントを取ろうとするが、大学卒業後の人生の大部分においてそれが何の役に立つのかはなはだ疑問である
統計に基づいた重病の治療成績を患者に説明しても、患者の希望する治療は患者の事情によって異なることは一定年数以上の臨床経験があるものなら誰でも知っていることだ
それが理解できない彼は、彼自身が素性を明らかにしているようなものである
コンプ薬屋同様に、私立医への執拗な誹謗中傷を数年余にわたって続けている
裏口批判をしているが、実際にそれが可能な資産家の子弟がいるであろう右派スレには近寄らない、一度書き込んだ形跡があったが指摘したら別人だと言って逃げた
弱いものが多そうなスレしか狙わないのもコンプ薬屋と共通する異常者の特徴である
劣等コンプレックスの塊なんだろうな
自分の主張に対して都合の悪い突込みが入ると、相手を私立医と決めつけて、さてはシリツだな、裏口バカ、というセリフでワンパターンに返すことが多い
国試問題を挙げて簡単だとほざいてますが、本番で通らなければお話になりません
いくらネットでわめいていても、医師国試の本番で通らなければお話になりません
大事なことなので２回言いました
それはそうと高学歴スレに宣伝して来てやったぞ
ありがたく思えド底辺め
http://itest.5ch.net/test/read.cgi/newsplus/1540436974/l50
>>803
残念ながら俺、東大卒じゃないのよ。
1期校は滑り止めに受けた理一通ったけど行かなかった。
答えるもなにも問題を書けよ、リンクは踏まないから。
最近のトピックを題材にした問題
これ答えてみ！
昨年入学者の留年者や退学者が０として、
東京医大が公式認定した裏口入学者が少なくとも今年は１３３人中５０人、昨年が１１３人中１９人ということになる。
裏口入学率の期待値、最頻値、およびその９５％信頼区間を求めよ。
ド底辺シリツ医大卒なら無理だろうが、国立大学でていて解けないなら恥ずかしいね。
k=2
n=m+1
の特殊ケースを移植してくれた人がいた。
パラメータを変えるだけで宝の数を増やせる仕様でないのは残念。
int main(){
int i,j,P[5000],Q[5000],c,m,n,mn,Pwin,Qwin,Draw,pp,qq;
for(m=1;m<70;m++){
n=m+1;mn=m*n;
for(i=0,c=1;i<m;i++)for(j=0;j<n;j++)P[j*m+i+1]=Q[i*n+j+1]=c++;
for(i=1,Pwin=Qwin=Draw=0;i<mn;i++)for(j=i+1;j<=mn;j++){
pp=P[i]>P[j]?P[j]:P[i];
qq=Q[i]>Q[j]?Q[j]:Q[i];
if(pp>qq)Pwin++;else if(pp<qq) Qwin++;else Draw++;
}
printf("%3d*%3d: %d, %d, %d\n",m,n,Pwin,Qwin,Draw);
}
return 0;
}
というわけで 回答まだぁ
それはそうとド底辺事務員の好きな高学歴スレに
宣伝して来てやったぞ
ありがたく思え
http://asahi.5ch.net/test/read.cgi/newsplus/1540436974/600-
入試の時だけ成績が良くても、その後の生活で人はダメになるんやね
国立私立問わず医学部に入学しても、その後の生活がダメダメで
国試に通らなかったり、専門医も取れなかったりすると
人としてダメダメになるんやね
y=1:(m*n)
(z=matrix(y,ncol=n,byrow=T))
(P=as.vector(z))
(Q=as.vector(t(z)))
PQ <- function(x){
p=q=numeric(k)
for(i in 1:k){
p[i]=which(P==x[i])
q[i]=which(Q==x[i])
}
min(p)-min(q)
}
tre=combn(m*n,k)
re=apply(tre,2,PQ)
return(c(短軸有利=sum(re<0),長軸有利=sum(re>0),同等=sum(re==0)))
}
結局、
combn(m*n,k)
ここがボトルネックなんだよなぁ。
12部屋から6部屋選ぶ組み合わせは924通りしかないのに
20部屋から10部屋だと184756通り、
30部屋から15部屋だと155117520通り、
という感じなのでどうしても時間やメモリを食う。
#include<stdio.h>
int main(){
int i,j,P[10000],Q[10000],c,m,n,mn,Pwin,Qwin,Draw,pp,qq;
for(m=1;m<100;m++){
n=m+1;
mn=m*n;
for(i=0,c=1;i<m;i++)for(j=0;j<n;j++)P[j*m+i+1]=Q[i*n+j+1]=c++;
for(i=1,Pwin=Qwin=Draw=0;i<mn;i++)for(j=i+1;j<=mn;j++){
pp=P[i]>P[j]?P[j]:P[i];
qq=Q[i]>Q[j]?Q[j]:Q[i];
if(pp>qq)Pwin++;else if(pp<qq) Qwin++;else Draw++;
}
printf("%3d*%3d: %d, %d, %d\n",m,n,Pwin,Qwin,Draw);
}
return 0;
}
90* 91: 16820566, 16703175, 10214
91* 92: 17575980, 17454585, 10441
92* 93: 18356554, 18231065, 10671
93* 94: 19162841, 19033167, 10903
94* 95: 19995399, 19861448, 11138
95* 96: 20854793, 20716472, 11375
96* 97: 21741593, 21598808, 11615
97* 98: 22656376, 22509032, 11857
98* 99: 23599724, 23447725, 12102
99*100: 24572226, 24415475, 12349
このコードをもとに宝を増やすように改変したつもりで数学板投稿したらをバグを指摘された。勉強になって( ・∀・)ｲｲ!!
このスレのド底辺からは学ぶことがないなあ。
F=c(178,32,20,12,8,8,8,8,7,7,7,7,7,7,8,10,12,13,15,16,17,19,20,22,23,24,25,27,28,30,31,32,34,36,39,41,42,45,50,56,
62,68,73,79,85,94,104,114,124,134,145,159,174,189,202,215,226,237,250,268,291,318,346,372,399,433,471,511,554,603,662,729,802,874,954,1053,1180,1332,1505,1699,1909,2143,2409,2701,3004,3310,3622,3938,4253,4531,4757,4918,5025,
5024,4876,4598,4132,3594,3025,2464,1941,1477,1085,769,525,345,217,132,76,42,22,11,5,2,1,0)
M=c(202,34,24,16,11,10,10,10,9,8,7,7,8,11,13,17,21,26,32,39,45,49,51,53,55,55,54,54,54,56,57,59,61,65,69,73,75,78,
84,93,103,113,122,131,144,159,176,195,215,236,257,283,310,340,373,411,450,488,525,568,620,688,764,839,910,994,
1081,1166,1256,1349,1450,1561,1675,1776,1885,2021,2185,2377,2594,2819,3046,3279,3504,3714,3900,4043,4116,4127,
4080,3973,3810,3580,3302,2967,2567,2123,1718,1352,1034,768,554,387,262,171,108,66,39,22,12,6,3,2,1)
LE <-function(ndx,Y,N0=10^5){
n=length(ndx)
lx=numeric(n)
lx[1]=N0
for(i in 1:(n-1))
lx[i+1] <- lx[i] - ndx[i]
nqx=ndx/lx
nLx=numeric(n)
for(i in 1:n)
nLx[i] <- mean(c(lx[i],lx[i+1]))
nLx[n]=0
Tx=rev(cumsum(rev(nLx)))
le=Tx/lx
return(round(le[Y+1],2))
}
yome = function(x){
le=LE(m,x)
round(uniroot(function(x,u0) LE(f,x)-le,c(1,100))$root)
}
y=sapply(18:80,yome)
plot(18:80,y-18:80)
https://m.youtube.com/watch?v=ryUjUlIgI9I&;list=PL9Aupg5SItT6sfFeXgtmOtsq9R5yCkp3G&t=1s&index=24
この動画は part１ が 2009年に投稿され
最終回まであと１話となっています
最終回の登校日はいつになるでしょう？
あらゆる手段を用いて求めましょう
Haskellの遅延IOを使うととりあえずのメモリ不足は克服できる。
combinations :: Int -> [a] -> [[a]]
combinations 0 _ = [ [] ]
combinations n xs = [ y:ys | y:xs' <- tails xs, ys <- combinations (n-1) xs']
Prelude> take 5 $ combinations 15 [1..30]
[[1,2,3,4,5,6,7,8,9,10,11,12,13,14,15],[1,2,3,4,5,6,7,8,9,10,11,12,13,14,16],[1,2,3,4,5,6,7,8,9,10,11,12,13,14,17],[1,2,3,4,5,6,7,8,9,10,11,12,13,14,18],[1,2,3,4,5,6,7,8,9,10,11,12,13,14,19]]
Prelude> tre !! 100000
[1,2,3,4,5,6,7,8,11,12,17,20,21,25,30]
10万個目の組み合わせも出してはくれるが、処理が終わる時間が予想がつかないなぁ。
min(p) - min(q)までHaskellに移植できた。
import Data.List
import Data.List.Split
k = 2
q = [1..12]
matQ = chunksOf 3 q
matP = transpose matQ
p = concat matP
combinations :: Int -> [a] -> [[a]]
combinations 0 _ = [ [] ]
combinations n xs = [ y:ys | y:xs' <- tails xs, ys <- combinations (n-1) xs']
tre = combinations 2 q
ip x1 x2 = minimum [elemIndices x1 p, elemIndices x2 p] !! 0
iq x1 x2 = minimum (elemIndices x1 q, elemIndices x2 q) !! 0
pqi x1 x2 = ip x1 x2 - iq x1 x2
import Data.List
import Data.List.Split
m = 5 -- 縦マス(短軸）
n = 6 -- 横マス(長軸)
k = 5 -- 宝の数
q = [0..m*n-1]
matQ = chunksOf m q
matP = transpose matQ --行列を転置して
p = concat matP -- 配列に変換
combinations :: Int -> [a] -> [[a]]
combinations 0 _ = [ [] ]
combinations n xs = [ y:ys | y:xs' <- tails xs, ys <- combinations (n-1) xs']
treasure = combinations k q -- 宝の組み合わせ
ip y = minimum $ map(\x -> elemIndices x p!!0) y -- 宝の、配列ｐでのindex列を求めて最小値を返す
iq y = minimum $ map(\x -> elemIndices x q!!0) y
idxp = map ip treasure -- 宝の組み合せで実行して
idxq = map iq treasure
p_q = zipWith (-) idxp idxq -- 差をとって大小判別
p1st = length $ filter (<0) p_q -- 短軸方向探索ｐが先に宝をみつける
q1st = length $ filter (>0) p_q
draw = length $ filter (==0) p_q
main = do
putStrLn $ "p1st = " ++ show p1st ++ ", q1st = " ++ show q1st ++ ", draw = " ++ show draw
import System.Environment
import Data.List
import Data.List.Split
combinations :: Int -> [a] -> [[a]]
combinations 0 _ = [ [] ]
combinations n xs = [ y:ys | y:xs' <- tails xs, ys <- combinations (n-1) xs']
main = do
argList <- getArgs -- m : 縦マス(短軸） n : 横マス(長軸) k : 宝の数
let m = read (argList !! 0)
n = read (argList !! 1)
k = read (argList !! 2)
q = [0..m*n-1]
matQ = chunksOf n q
matP = transpose matQ --行列を転置して
p = concat matP -- 配列に変換
treasure = combinations k q -- 宝の組み合わせ
ip y = minimum $ map(\x -> elemIndices x p!!0) y -- 宝の、配列ｐでのindex列を求めて最小値を返す
iq y = minimum $ map(\x -> elemIndices x q!!0) y
idxp = map ip treasure -- 宝の組み合せで実行して
idxq = map iq treasure
p_q = zipWith (-) idxp idxq -- 差をとって大小判別
p1st = length $ filter (<0) p_q -- 短軸方向探索ｐが先に宝をみつける
q1st = length $ filter (>0) p_q
draw = length $ filter (==0) p_q
putStrLn $ "p1st = " ++ show p1st ++ ", q1st = " ++ show q1st ++ ", draw = " ++ show draw
>treasure 5 6 8
p1st = 1827737, q1st = 1825076, draw = 2200112
p1st = 7995426, q1st = 8023257, draw = 14026332
p1st = 4130886, q1st = 4139080, draw = 6037184
さて 算数の問題です
https://m.youtube.com/watch?v=ryUjUlIgI9I&;list=PL9Aupg5SItT6sfFeXgtmOtsq9R5yCkp3G&t=1s&index=24
この動画は part１ が 2009年に投稿され
最終回まであと１話となっています
最終回の登校日はいつになるでしょう？
あらゆる手段を用いて求めましょう
５×６マスで宝の数を１０まで増やしていくと、
D:\bin>for %i in (1,2,3,4,5,6,7,8,9,10) do treasure 5 6 %i
D:\bin>treasure 5 6 1
p1st = 14, q1st = 14, draw = 2
D:\bin>treasure 5 6 2
p1st = 203, q1st = 197, draw = 35
D:\bin>treasure 5 6 3
p1st = 1801, q1st = 1727, draw = 532
D:\bin>treasure 5 6 4
p1st = 11418, q1st = 11008, draw = 4979
D:\bin>treasure 5 6 5
p1st = 55469, q1st = 54036, draw = 33001
D:\bin>treasure 5 6 6
p1st = 215265, q1st = 211894, draw = 166616
D:\bin>treasure 5 6 7
p1st = 685784, q1st = 680768, draw = 669248
D:\bin>treasure 5 6 8
p1st = 1827737, q1st = 1825076, draw = 2200112
D:\bin>treasure 5 6 9
p1st = 4130886, q1st = 4139080, draw = 6037184
D:\bin>treasure 5 6 10
p1st = 7995426, q1st = 8023257, draw = 14026332
１：同等
１～８：短軸探索有利
９、１０：長軸探索有利
という結果になった。
久しぶりにバッチコマンドを書いた
リンクは踏まないから問題文をかけよ。
＞あらゆる手段を用いて求めましょう
答： お前が答を書け
解答終了！！！
>>838
数学板の賢者がｃでプログラムするのを期待していたが、ｃだと最初にメモリを割り当てなくちゃいけないから難しいんじゃないかな？
動的メモリ確保にしてメモリ不足を回避する必要がでてくると思う。
Rで３０個から１５個取り出す組み合わせをしようとしたら
> nrow(combn(30,15))
Error: cannot allocate vector of size 8.7 Gb
のメッセージがでて実行不能だった。
シミュレーションで頻度を出して確率を推測してみることにした。
m=5
n=6
mn=m*n
P=as.vector(matrix(1:mn,ncol=n,byrow=T))
Q=1:mn
sim <- function(k=15,all=FALSE){
tre=sample(mn,k)
p=q=numeric(k)
for(i in 1:k){
p[i]=which(tre[i]==P)
q[i]=which(tre[i]==Q)
}
p_order=ifelse(all,max(p),min(p))
q_order=ifelse(all,max(q),min(q))
p_order - q_order
}
choose(30,15)
re15=replicate(1e5,sim(15))
mean(re15<0) < mean(re15>0)
c(p1st_sim=mean(re15<0), q1st_sim=mean(re15>0) ,draw_sim=mean(re15==0))
> c(p1st_sim=mean(re15<0), q1st_sim=mean(re15>0) ,draw_sim=mean(re15==0))
p1st_sim q1st_sim draw_sim
0.16354 0.16515 0.67131
自分で回答が出せなければ０点だぞW
https://www.nicovideo.jp/watch/sm30364838
mn=m*n
Q=1:mn
(mat=matrix(Q,ncol=n,byrow=T))
(P=as.vector(mat))
tre=combn(mn,k)
PQ <- function(x){
p=q=p_q=numeric(k)
for(i in 1:k){
p[i]=which(P==x[i])
q[i]=which(Q==x[i])
p_q[i]=p[i]-q[i]
}
return(p_q)
}
re=apply(tre,2,PQ)
result=matrix(rep(NA,k*3),ncol=3)
colnames(result)=c('p1st','q1st','even')
for(i in 1:k){
result[i,] = c(sum(re[i,]<0),sum(re[i,]>0),sum(re[i,]==0))
}
return(result)
}
treasures(4,5,5)
# http://tpcg.io/Ph7TUQ
p1st = 13346984, q1st = 13395944, draw = 27884372
D:\bin>treasure 5 6 12
p1st = 19312228, q1st = 19372871, draw = 47808126
この結果は面白いな
全体としては互角なんだが、勝負のルールによって勝者がかわるのがこれで分かった。
> treasures(4,5,5)
p1st q1st even
[1,] 1948 9680 3876
[2,] 5488 10016 0
[3,] 7752 7752 0
[4,] 10016 5488 0
[5,] 9680 1948 3876
メモリ不足でクラッシュするかと思ったが案外、頑強だな。
エラー処理皆無でコードを書いたのだが。
１億を超える演算をこなしている。
Haskellのコンパイラーは優秀で感心。
D:\bin>treasure 5 6 13
p1st = 24301031, q1st = 24358063, draw = 71100756
算数の問題の答えはまだぁ
まぁオマエの頭じゃ無理だろうな
見物人たちがそれを見てフルボッコにするスレである
事務員 とは？
同一者の別名として、薄汚いジジイ、国試浪人、統計野郎、自称医科歯科、がある
自称医科歯科卒、実際は九州の駅弁国立出身で、卒業後は実家の東京に帰り国試浪人となり23年間経過、家庭教師バイトなどを経て現在は事務員、とされている
本人は、勤務医でたまに開業医の手伝いと内視鏡バイト、専門医なし、と主張しているが、連日連夜の異常な書き込み数の多さからは、勤務医とは考え難く、彼の職業がたとえ何であったとしても、人としてド底辺なことは間違いがない
自ら事務員であると告白したこともある
https://egg.5ch.net/test/read.cgi/hosp/1531459372/108-109
自作自演も頻繁に行なっている
事務仕事の際に手にした他人の給与明細や同窓会費振込票を盗撮し、自分のものとしてアップロードしたこともある、犯罪なんじゃねーの？
統計絶対主義でマウントを取ろうとするが、大学卒業後の人生の大部分においてそれが何の役に立つのかはなはだ疑問である
統計に基づいた重病の治療成績を患者に説明しても、患者の希望する治療は患者の事情によって異なることは一定年数以上の臨床経験があるものなら誰でも知っていることだ
それが理解できない彼は、彼自身が素性を明らかにしているようなものである
コンプ薬屋同様に、私立医への執拗な誹謗中傷を数年余にわたって続けている
裏口批判をしているが、実際にそれが可能な資産家の子弟がいるであろう右派スレには近寄らない、一度書き込んだ形跡があったが指摘したら別人だと言って逃げた
弱いものが多そうなスレしか狙わないのもコンプ薬屋と共通する異常者の特徴である
劣等コンプレックスの塊なんだろうな
自分の主張に対して都合の悪い突込みが入ると、相手を私立医と決めつけて、さてはシリツだな、裏口バカ、というセリフでワンパターンに返すことが多い
国試問題を挙げて簡単だとほざいてますが、本番で通らなければお話になりません
いくらネットでわめいていても、医師国試の本番で通らなければお話になりません
大事なことなので２回言いました
問題文がないのだから、無理だよ。
＞あらゆる手段を用いて求めましょう
答： お前が答を書け
解答終了！！！
mn=m*n
Q=1:mn
(mat=matrix(Q,ncol=n,byrow=T))
(P=as.vector(mat))
tre=combn(mn,k)
PQk <- function(x){
p=q=p_q=numeric(k)
for(i in 1:k){
p[i]=which(P==x[i])
q[i]=which(Q==x[i])
}
pq=sort(unique(c(p,q)))
np=as.numeric(pq[1:k] %in% p)
nq=as.numeric(pq[1:k] %in% q)
10*np + nq
}
(re=apply(tre,2,PQk))
(result=matrix(NA,nrow=k,ncol=3))
for(i in 1:k){
result[i,]=c(sum(re[i,]==10),sum(re[i,]==1 ),sum(re[i,]==11))
}
colnames(result)=c('P_gets','Q_gets','both_get')
result
}
treasure_order(4,5,5)
■ このスレッドは過去ログ倉庫に格納されています
ニュース
- 橋下徹氏 大谷翔平に苦言「口座を見ていたら防げた」「本人にも責任がある」反社会勢力に巨額資金流れた可能性指摘 [Anonymous★]
- 「おじが食人部族の犠牲」 バイデン氏記憶違いか [少考さん★]
- 「一切払うつもりない」「漫画村」元運営者に約17億円の賠償命令 人気漫画を無断で掲載 [夜のけいちゃん★]
- 【文春】社員に向かって「意外とお腹太ってるね」いなば食品の女帝・稲葉優子会長（54）の“嫌がらせ”肉声《独占入手》 [Ailuropoda melanoleuca★]
- 宮迫博之、粗品から“あいつ呼び”＆「あんなもん先輩ちゃう」とディスられた件に言及「はっきり言うと…」 [muffin★]
- 橋下徹氏 大谷翔平に苦言「口座を見ていたら防げた」「本人にも責任がある」反社会勢力に巨額資金流れた可能性指摘 ★2 [Anonymous★]
- 00:00:00.000
- ☝(ὢ-᷅ )ここで一つ自己紹介しておこう。俺は>>2。人呼んで>>3の>>4だ
- 【実況】博衣こよりのえちえちCities:Skylines2🧪★5
- タバコやめたい
- (っ,,･᷄ὢ･᷅,,c)きんたまがもちもちすぎて困ってる
- 妹が四六時中肌身離さずウサギのぬいぐるみを抱えてるんだがｗ