Mathematica 9 is now available
Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
2007
*January
*February
*March
*April
*May
*June
*July
*August
*September
*October
*Archive Index
*Ask about this page
*Print this page
*Give us feedback
*Sign up for the Wolfram Insider

MathGroup Archive 2007

[Date Index] [Thread Index] [Author Index]

Search the Archive

Re: Dice problem

  • To: mathgroup at smc.vnet.net
  • Subject: [mg81364] Re: Dice problem
  • From: Mark Fisher <particlefilter at gmail.com>
  • Date: Thu, 20 Sep 2007 03:56:47 -0400 (EDT)
  • References: <fcnm1e$shs$1@smc.vnet.net>

On Sep 18, 1:00 am, "AngleWyrm" <anglew... at yahoo.com> wrote:
> With a set of three six-sided dice, display the chance-weights and
> probabilities of each outcome:
>
> numSides=6; numDice=3;
> poly = Sum[x^i, {i, numSides}]^numDice // Expand;
> c = CoefficientList[poly, x];
> Table[{x, c[[x + 1]], c[[x + 1]]/Total[c] // N}, {x, numDice,
> numDice numSides}] // TableForm
>
> So far, so good. Next, I want to model this discrete distribution with a
> continuous distribution. That is to say, I want a continuous distribution
> that produces the same probabilities at these sixteen points (3..18). My
> first attempt was to take the Mean and StandardDeviation of my coefficients
> list, and attempt to generate a gaussian distribution on it like so:
>
> test = RandomReal[ NormalDistribution[Mean[c], StandardDeviation[c]], 1000];
> ListPlot[test]
> {Min[test], Max[test]} // N
>
> But the result produces a much larger range of outcomes, approximately {-25,
> 45}. Any set generated on this larger range will have smaller probabilities
> for the target range of 3..18.
>
> Is there some method or model to reduce the error between the mathematical
> model and the dataset?

Is this what you're looking for?

tally = Tally[Total /@ Flatten[Outer[List, #, #, #] &[Range[6]], 2]];
probs = #/{1, Total[tally[[All, 2]]]} & /@ tally;
mean = #[[All, 1]].#[[All, 2]] &[probs] // N;
variance = (#[[All, 1]] - 21/2)^2.#[[All, 2]] &[probs] // N;
ifun = Interpolation[probs];
intval = NIntegrate[ifun[x], {x, 2.5, 18.5}];

Check the mean:
NIntegrate[(ifun[x]/intval) x, {x, 2.5, 18.5}] == mean

Check the variance:
NIntegrate[(ifun[x]/intval) (x - 10.5)^2, {x, 2.5, 18.5}] - variance

Look at the pdf:
Plot[ifun[x]/intval, {x, 2.5, 18.5}] // Quiet

Compare the densities with the probabilities;
(ifun /@ Range[3, 18]) == probs[[All, 2]]

Compare the probabilities with the probabilities
(NIntegrate[ifun[x], {x, # - .5, # + .5}] & /@ Range[3, 18])/
  probs[[All, 2]] // Log

This produces a continuous pdf (ifun) over the range 2.5 to 18.5 for
which the density ifun[i] equals the probability of i and the
probability NIntegerate[ifun[x],{x,i-.5,i+.5}] is pretty close the
probability of i. The mean of ifun matches exactly and the variance is
slightly too small.

--Mark



  • Prev by Date: Re: Re: plotmarkers in Listplot
  • Next by Date: Re: LegendreP error (bug?) in Mathematica
  • Previous by thread: Re: Dice problem
  • Next by thread: Fitting parameters of nonlinear diff equation system