[Date Index]
[Thread Index]
[Author Index]
Re: Insoluble marbles-in-urn problem?
*To*: mathgroup at smc.vnet.net
*Subject*: [mg119996] Re: Insoluble marbles-in-urn problem?
*From*: DrMajorBob <btreat1 at austin.rr.com>
*Date*: Mon, 4 Jul 2011 06:45:50 -0400 (EDT)
*References*: <201107030811.EAA21357@smc.vnet.net>
*Reply-to*: drmajorbob at yahoo.com
Surprising, perhaps, but also slow.
Here, I have reduced n and added Print statements to shows what you're
actually doing:
Timing[rag = Table[x, {x, 1, 12}];
For[i = 1, i < Length[rag] + 1, i++,
rag[[i]] = Table[RandomInteger[{0, 9}], {n, 1, 10}]];
bug = Table[x, {x, 1, Length[rag]}];
For[i = 1, i < Length[rag] + 1, i++,
bug[[i]] = RandomInteger[{1, 10}]];
selection = Table[rag[[i, bug[[i]]]], {i, 1, Length[rag]}];
freq := Table[Count[rag[[i]], selection[[i]]], {i, 1, Length[rag]}];
bull = Tally[Characters[freq]]; bullsort = Sort[bull];
Print@Transpose@{rag, selection, freq};
Print@{bull, bullsort, bullsort[[1, 2]]};
N[(Length[rag] - bullsort[[1, 2]])/Length[rag], 10]]
{{{1,4,0,3,7,6,8,7,5,4},0,1},{{7,9,9,9,9,4,5,3,8,8},8,2},{{7,2,1,3,0,0,4,7,7,3},3,2},{{0,1,3,2,2,6,8,3,0,0},2,2},{{1,4,7,2,8,0,2,8,4,9},8,2},{{2,2,2,3,6,6,4,7,7,0},6,2},{{2,8,7,2,6,1,9,5,5,3},3,1},{{3,6,6,0,5,8,6,0,3,6},0,2},{{4,0,5,8,8,0,0,3,5,6},4,1},{{2,4,1,9,4,1,2,6,8,6},9,1},{{0,8,0,6,3,5,0,9,3,7},3,2},{{8,5,6,1,5,8,4,0,3,8},1,1}}
{{{Characters[1],5},{Characters[2],7}},{{Characters[1],5},{Characters[2],7}},5}
{0.000677, 0.5833333333}
From each draw of size ten, you've drawn a marble, then counted how many
in the ten match that marble. "freq" collects those counts. "Characters"
has no logical place in all this, but removing it makes no difference, so
never mind.
"bullsort" in this case showed that "freq" was 1 five times and 2 seven
times.
bullsort[[1,2]] counts how many times "freq" was its minimum value. In
this case, the minimum is 1.
Length@rag - bullsort[[1,2]] / Length@rag == (12 - 5) / 12 == 7 / 12 ==
0.58333
If the minimum is 1 -- as it usually WILL be in a sample of size one
million -- this is the probability that it is possible to draw the same
number a second time. (The minimum is not NECESSARILY 1, of course.)
Here's a faster, simpler code:
Clear[p]
p[1] := Module[{ten = RandomInteger[{0, 9}, 10]},
Boole[Count[ten, RandomChoice@ten] > 1]
]
p[n_] /; n <= 10^6 := Mean@Array[p[1] &, n]
p[n_] := Module[{k = Round[n/2]}, {k, n - k}.{p[k], p[n - k]}/n]
Timing@p[10^7]
N@Last@%
{6.67044, 6123121/10000000}
0.612312
Timing@p[10^8]
N@Last@%
{65.5279, 61259847/100000000}
0.612598
I suspect the theoretical result is
1. - (9/10)^9
0.61258
but I'm not sure. I'm looking into it.
Bobby
On Sun, 03 Jul 2011 03:11:34 -0500, John Feth <johnfeth at gmail.com> wrote:
> There is a huge urn full of marbles, each marked with a single digit:
> 0, 1, 2, 3, 4, 5, 6, 7, 8, or 9. The marked marble quantities are
> uniformly distributed between all of the digits and the marbles are
> thoroughly mixed. You look away, choose 10 marbles, and put them in a
> black velvet bag.
>
> When you have some time, you look away, open the bag, and remove one
> marble. You close the bag, look at the digit on the marble, open a
> beer perhaps, and calculate the probability that there is at least one
> more marble in the bag with the same digit.
>
> The answer is brute forced below is there a formal way to obtain the
> answer? I don't believe the marbles-in-urn standby, the
> hypergeometric distribution, is any help at all.
>
> Copy and paste the algorithm below into Mathematica (V6 or newer) to
> find the surprising answer, estimated from a million tests in about 16
> seconds.
>
> Timing[rag=Table[x,{x,1,1000000}];For[i=1,i<Length[rag]+1,i+
> +,rag[[i]]=Table[RandomInteger[{0,9}],{n,1,10}]];bug=Table[x,{x,
> 1,Length[rag]}];For[i=1,i<Length[rag]+1,i+
> +,bug[[i]]=RandomInteger[{1,10}]];selection=Table[rag[[i,bug[[i]]]],{i,
> 1,Length[rag]}];freq:=Table[Count[rag[[i]],selection[[i]]],{i,
> 1,Length[rag]}];bull=Tally[Characters[freq]];bullsort=Sort[bull];N[(Length[rag]-
> bullsort[[1,2]])/Length[rag],10]]
>
> Below are some definitions that might make the algorithm above a
> little less opaque.
>
> rag is a table of 10 digit random strings below
>
> (*rag=Table[x,{x,1,3}];For[i=1,i<Length[rag]+1,i+
> +,rag[[i]]=Table[RandomInteger[{0,9}],{n,1,10}]];rag
> {{9,6,5,3,4,9,1,7,4,3},{8,5,7,7,0,0,5,6,3,5},{1,1,8,0,9,0,4,3,4,3}}*)
>
> bug is a table of which digit to pick from each rag[ [ ] ] above, i.e.
> the 4th from the left in rag[[1]], the 2nd from the left in rag[[2]],
> etc.
>
> (*bug=Table[x,{x,1,Length[rag]}];For[i=1,i<Length[rag]+1,i+
> +,bug[[i]]=RandomInteger[{1,10}]];bug
> {4,2,5}*)
>
> selection is a table of the values of the digit picked above, i.e.,
> the 4th digit in rag[[1]] is a 3, the 2nd digit in rag[[2]] is a 5,
> etc.
>
> (*selection=Table[rag[[i,bug[[i]]]],{i,1,Length[rag]}]
> {3,5,9}*)
>
> freq is a table of the number selected digits in rag[[n]], i.e., there
> are two 3s in rag[[1]], three 5s in rag[[2]], one 9 in rag[[3]], etc.
>
> (*freq=Table[Count[rag[[i]],selection[[i]]],{i,1,Length[rag]}]
> {2,3,1}*)
>
> bull tallies how many times the chosen digit occurs
>
> (*bull=Tally[Characters[freq]]
> {{Characters[2],1},{Characters[3],1},{Characters[1],1}}*)
>
> bullsort tallies the number of times the chosen digit occurs; the
> chosen digit occurred once one time (9's above), twice one time (4's
> above), and once three times (5's above)
>
> (*bullsort=Sort[bull]
> {{Characters[1],1},{Characters[2],1},{Characters[3],1}}*)
>
>
--
DrMajorBob at yahoo.com
Prev by Date:
**Re: Insoluble marbles-in-urn problem?**
Next by Date:
**Re: Numerical accuracy/precision - this is a bug or a feature?**
Previous by thread:
**Re: Insoluble marbles-in-urn problem?**
Next by thread:
**Re: Insoluble marbles-in-urn problem?**
| |