• 確率論者あかねちゃん3についての補遺

    2018-10-12 06:004

    ここから先は大学生向けやで。



    1.確率密度関数を用いて3問目を計算する

     動画の通りxとyの場合分けをすると面倒なので、ここでは簡単に、最初の分割で出来た短い線分の長さをxとおいてしまうことにする。
     このとき、xは0≦x<L/2上で一様分布する。
     また、2回目の分割でできた線分の一方の長さをyとすると、yは0≦y≦L-x上で一様分布する。
     3本目の線分の長さはL-x-yである。   
     上記によって線分の長さから三角形ができる条件が分かる。y>L/2-x ,y<L/2 ,x<L/2である。つまり0≦x<L/2,L/2-x<y<L/2である。
     整理すると、

     ①xは0≦x<L/2上で一様分布し、yは0≦y≦L-x上で一様分布する。
     ②①において三角形が出来る条件は0≦x<L/2,L/2-x<y<L/2である。

     あとは確率密度関数の積分をして確率を求めるだけです。
     一様分布の確率密度関数は区間の差を分母に持ってくるだけですし、積分区間は三角形が出来る条件を当てはめればよいですね。従って以下が導けます。







    2.エクセルVBAを用いた平面内の点の分布

    動画内でも紹介しましたが、あかねちゃんが作ってくれたマクロをおすそわけします。
    使い方等は各自検索してみてください。
    ちなみに、1.では、線分の短いほうをxとしても一般性を失わないため0≦x<L/2としましたが、マクロでは視覚的なわかりやすさを重視して0≦x≦1の一様分布とし、線分の短い方をxとはしていませんので注意(マキちゃんの説明と同じ絵になるようにしています)。
    ただし、確率としては同じになりますので問題ありません。


    ===以下、最下部までコピペしてください===

    Option Explicit
    ' 40000の部分が無作為な点を打つ回数。数字を増やすとグラフが見えづらくなるし重くなるので注意'
    Const N As Long = 40000

    Sub 無作為に三分割()
    ' データ作成'
    Dim A As Long, i As Long
    Dim x As Double, y As Double
    Randomize Timer
    Cells(1, 1).Value = "条件を満たす座標数"
    Cells(1, 2).Value = "全座標数"
    Cells(1, 3).Value = "確率"
    Cells(1, 5).Value = "無作為に選択された点x"
    Cells(1, 6).Value = "無作為に選択された点y"
    Cells(1, 7).Value = "条件を満たす点x"
    Cells(1, 8).Value = "条件を満たす点y"
    Cells(2, 1).Value = 0
    Cells(2, 2).Value = 0
    Cells(2, 3).Value = "=A2/B2"
    Cells(3, 2).Value = "[参考]真の確率:"
    Cells(3, 2).HorizontalAlignment = xlRight
    Cells(3, 3).Formula = 0.25
    While Cells(2, 2).Value < N
    'xとyを同時に、無作為に取る⇔x、yともに0から1の一様分布⇔x、yともにRND関数で表せる'
    '※xもyも「他方の影響を受けない」ため面積問題に置き換えられる。グラフを見れば点が一様に分布しているのがわかる'
    x = Rnd: y = Rnd
    A = 2 + Cells(2, 2).Value
    'x<yのとき、3つの線分はx,y-x,1-yとなるから、三角形が出来る条件はy>1/2,y<1/2+x,x<1/2'
    If x < y And y > 0.5 And y < 0.5 + x And x < 0.5 Then
    Cells(2, 1).Value = Cells(2, 1).Value + 1
    Cells(A, 7).Value = x: Cells(A, 8).Value = y
    End If
    'x>=yのとき、3つの線分はy,x-y,1-xとなるから、三角形が出来る条件はx>1/2,x<1/2+y,y<1/2'
    If x >= y And x > 0.5 And x < 0.5 + y And y < 0.5 Then
    Cells(2, 1).Value = Cells(2, 1).Value + 1
    Cells(A, 7).Value = x: Cells(A, 8).Value = y
    End If
    Cells(A, 5).Value = x: Cells(A, 6).Value = y
    Cells(2, 2).Value = Cells(2, 2).Value + 1
    Wend

    ' グラフ削除'
    With ActiveSheet
    For i = .ChartObjects.Count To 1 Step -1
    .ChartObjects(i).Delete
    Next i
    End With

    ' グラフ作成'
    With ActiveSheet.Shapes.AddChart
    .Name = "あかねちゃん"
    .Chart.ChartType = xlXYScatter
    .Chart.HasTitle = True
    .Chart.ChartTitle.Text = "領域イメージ"
    .Chart.HasLegend = False
    .Chart.SeriesCollection.NewSeries
    .Chart.SeriesCollection(1).XValues = Range(Cells(2, 5), Cells(N + 1, 5))
    .Chart.SeriesCollection(1).Values = Range(Cells(2, 6), Cells(N + 1, 6))
    .Chart.SeriesCollection(1).MarkerStyle = -4118
    .Chart.SeriesCollection(1).MarkerSize = 2

    .Chart.SeriesCollection.NewSeries
    .Chart.SeriesCollection(2).XValues = Range(Cells(2, 7), Cells(N + 1, 7))
    .Chart.SeriesCollection(2).Values = Range(Cells(2, 8), Cells(N + 1, 8))
    .Chart.SeriesCollection(2).MarkerStyle = -4118
    .Chart.SeriesCollection(2).MarkerSize = 2
    End With

    With ActiveSheet.Shapes.AddChart
    .Name = "あおいちゃん"
    .Chart.ChartType = xlXYScatter
    .Chart.HasTitle = True
    .Chart.ChartTitle.Text = "一様分布の確認"
    .Chart.HasLegend = False
    .Chart.SeriesCollection.NewSeries
    .Chart.SeriesCollection(1).XValues = Range(Cells(2, 5), Cells(N + 1, 5))
    .Chart.SeriesCollection(1).Values = Range(Cells(2, 6), Cells(N + 1, 6))
    .Chart.SeriesCollection(1).MarkerStyle = -4118
    .Chart.SeriesCollection(1).MarkerSize = 2
    End With

    With ActiveSheet.ChartObjects("あおいちゃん")
    .Top = Range("A4").Top
    .Left = Range("A4").Left
    .Width = Range("A4:I4").Width
    .Height = Range("A4:I31").Height
    End With

    With ActiveSheet.ChartObjects("あかねちゃん")
    .Top = Range("J4").Top
    .Left = Range("J4").Left
    .Width = Range("J4:R4").Width
    .Height = Range("J4:J31").Height
    End With


    End Sub
    Sub 無作為に二分割後長い方をさらに無作為に二分割()
    Dim A As Long, i As Long
    Dim x As Double, y As Double
    Randomize Timer
    Cells(1, 1).Value = "条件を満たす座標数"
    Cells(1, 2).Value = "全座標数"
    Cells(1, 3).Value = "確率"
    Cells(1, 5).Value = "無作為に選択された点x"
    Cells(1, 6).Value = "点x決定後、残りの長い方を分割するための点y"
    Cells(1, 7).Value = "条件を満たす点x"
    Cells(1, 8).Value = "条件を満たす点y"
    Cells(2, 1).Value = 0
    Cells(2, 2).Value = 0
    Cells(2, 3).Value = "=A2/B2"
    Cells(3, 2).Value = "参考:真の確率"
    Cells(3, 2).HorizontalAlignment = xlRight
    Cells(3, 3).Formula = "=Log(4, Exp(1)) - 1"
    While Cells(2, 2).Value < N
    'xは0から1の一様分布だが、yは①「x>0.5のとき0からxの一様分布」、②「x<=0.5のとき0から1-xの一様分布」の2つで場合分けが必要となる'
    '※yの区間にxが絡んできている。そのため、この時点で「一方は他方の影響を受けない」という条件に反するため面積問題に置き換えられない点に注意'
    'グラフを見ると濃淡があり、一様に分布していないことがわかる'
    'xを0から1のRND関数としたあと、x>0.5のときy=RND*x,x<=0.5のときy=RND*(1-x)と表せることに着目する'
    x = Rnd
    A = 2 + Cells(2, 2).Value
    'x>0.5のときy=RND*x'
    If x > 0.5 Then
    y = Rnd * x
    'x>0.5のとき、3つの線分はy,x-y,1-xとなるから、三角形が出来る条件はx>1/2,x<1/2+y,y<1/2'
    If x > 0.5 And x < 0.5 + y And y < 0.5 Then
    Cells(2, 1).Value = Cells(2, 1).Value + 1
    Cells(A, 7).Value = x: Cells(A, 8).Value = y
    End If
    End If
    'x<=0.5のときy=RND*(1-x)'
    If x <= 0.5 Then
    y = Rnd * (1 - x)
    'x<=0.5のとき、3つの線分はx,y,1-x-yとなるから、三角形が出来る条件はy>1/2-x,x<1/2,y<1/2'
    If y > 0.5 - x And x < 0.5 And y < 0.5 Then
    Cells(2, 1).Value = Cells(2, 1).Value + 1
    Cells(A, 7).Value = x: Cells(A, 8).Value = y
    End If
    End If
    Cells(A, 5).Value = x: Cells(A, 6).Value = y
    Cells(2, 2).Value = Cells(2, 2).Value + 1
    Wend

    ' グラフ削除'
    With ActiveSheet
    For i = .ChartObjects.Count To 1 Step -1
    .ChartObjects(i).Delete
    Next i
    End With

    ' グラフ作成'
    With ActiveSheet.Shapes.AddChart
    .Name = "あかねちゃん"
    .Chart.ChartType = xlXYScatter
    .Chart.HasTitle = True
    .Chart.ChartTitle.Text = "領域イメージ"
    .Chart.HasLegend = False
    .Chart.SeriesCollection.NewSeries
    .Chart.SeriesCollection(1).XValues = Range(Cells(2, 5), Cells(N + 1, 5))
    .Chart.SeriesCollection(1).Values = Range(Cells(2, 6), Cells(N + 1, 6))
    .Chart.SeriesCollection(1).MarkerStyle = -4118
    .Chart.SeriesCollection(1).MarkerSize = 2

    .Chart.SeriesCollection.NewSeries
    .Chart.SeriesCollection(2).XValues = Range(Cells(2, 7), Cells(N + 1, 7))
    .Chart.SeriesCollection(2).Values = Range(Cells(2, 8), Cells(N + 1, 8))
    .Chart.SeriesCollection(2).MarkerStyle = -4118
    .Chart.SeriesCollection(2).MarkerSize = 2
    End With

    With ActiveSheet.Shapes.AddChart
    .Name = "あおいちゃん"
    .Chart.ChartType = xlXYScatter
    .Chart.HasTitle = True
    .Chart.ChartTitle.Text = "一様分布の確認"
    .Chart.HasLegend = False
    .Chart.SeriesCollection.NewSeries
    .Chart.SeriesCollection(1).XValues = Range(Cells(2, 5), Cells(N + 1, 5))
    .Chart.SeriesCollection(1).Values = Range(Cells(2, 6), Cells(N + 1, 6))
    .Chart.SeriesCollection(1).MarkerStyle = -4118
    .Chart.SeriesCollection(1).MarkerSize = 2
    End With

    With ActiveSheet.ChartObjects("あおいちゃん")
    .Top = Range("A4").Top
    .Left = Range("A4").Left
    .Width = Range("A4:I4").Width
    .Height = Range("A4:I31").Height
    End With

    With ActiveSheet.ChartObjects("あかねちゃん")
    .Top = Range("J4").Top
    .Left = Range("J4").Left
    .Width = Range("J4:R4").Width
    .Height = Range("J4:J31").Height
    End With

    '精度の問題はさておき、たかだか数万回の試行を見ても、明らかに1/3には収束しそうにないことが分かると思う'

    End Sub



  • 広告