1000人の女性の中の1位とパートナーになるには？

#5/21、20時半：ミスを発見、手直ししました。
http://news.nicovideo.jp/watch/nw3531686

鳩山由紀夫の論文が話題になっていた。
しかし、検索しても該当する論文を見つけられなかった。教えてエライ人。

→ツイッターで教えていただきました。
あほ on Twitter: "こんにちは。該当する論文は https://t.co/lsGb6VNSaL で紹介されている紀要かと思います。368番目というのは1000/eですね。… "

＞その論文では、1000人いる女性のなかから最高のパートナーを見つけるにはどうすればいいか、何番目で決めるのがいいのか、かなり複雑な計算式で割り出している。1度断ったら2度目はない。まず、1番目は絶対に断らなければならない。そして368人目までを断る。そして368番目の女性を基準にして少しでもいい人を選んだ場合、最適なパートナーである可能性が高いと証明している。

シミュレーションでやってみる。

1000人の中で1位の女性を選べる確率が一番高い戦略とは？

ランダムに選ぶと、1位を選べる確率は1/1000。

368番めを基準と書いているけど、i番目を基準に、それ以上の女性とあったら決定というシミュレーションだとランダムよりはマシだが成功率が低い
136番目を基準にした場合の1.03%が最大。ブレが大きくもっとシミュレーション回数を増やす必要があるけどどうみても悪いのでやらない。

N <- 1000  #女性の数
Sim <- 10000 #シミュレーション回数

miryoku <- seq_len(N)   #低いほど良い　つまり順位
# i 回目を基準に、それ以上なら決定 999.1000は選ぶ余地がなくランダムと同じなので省く
result.2 <- matrix(0, nrow=N-2, ncol = Sim)
for(i in 1:(N-2)){
      for(j in seq_len(Sim)){
      temp <- sample(miryoku, N - i + 1, replace = FALSE)
      flag.1 <- (temp[2:(N-i+1)] < temp[1])
      if(sum(flag.1 == 1)){
            result.2[i, j] <- temp[1 + which.max(flag.1 == 1)]
      }else{
            result.2[i, j] <- temp[N - i + 1]
      }
}
}


rate_1st_2 <- numeric(nrow(result.2))
for(i in seq_len(nrow(result.2))){
      rate_1st_2[i] <-   sum(result.2[i,] == 1) / Sim 
      
}

なので、ここはi番目までのなかで”ベストの女性”よりも更に良い女性と出逢えば決定とすると解釈する。

result.3 <- matrix(0, nrow=N-2, ncol = Sim)
for(i in 1:(N-2)){
      for(j in seq_len(Sim)){
            temp <- sample(miryoku, N, replace = FALSE)
            kijun <- min(temp[1:i])
            flag.1 <- (temp[(i+1):N] < kijun)
            if(sum(flag.1 == 1)){
                  result.3[i, j] <- temp[1 + which.max(flag.1 == 1)]
            }else{
                  result.3[i, j] <- temp[N]
            }
      }
}


rate_1st <- numeric(nrow(result.3))
for(i in seq_len(nrow(result.3))){
    rate_1st[i] <-   sum(result.3[i,] == 1) / Sim 
      
}

plot(rate_1st, xlab="i番目までのベストの女性を基準", ylab="1位の女性とパートナーになれる確率")
rate_1st[which.max(rate_1st)]
plot(smooth.spline(rate_1st), xlab="i番目までのベストの女性を基準", ylab="1位の女性とパートナーになれる確率")
sp <- smooth.spline(rate_1st)
which.max(smooth.spline(rate_1st))
which.max(sp$y)

今回のシミュレーションでは322番目までの中で一番良い人を基準に、それ以後それより良い人と出逢えば決定するというアルゴリズムが一番良くなった。1000人中1位の女性と37.9%もの確率でパートナーになれるという。平滑化すると、346番目で36.8%となかなか理論値に近い結果となった。
＃教えていただいたリンク先だと1000/e番目で、３７％＝1/eになるらしい。

思ったより高いね。

#22時追記　
３７％の施行で１位ゲット
６６％施行で１０番以内ゲット
という神がかり的なアルゴリズムだった