In the previous post, I used the R function dexp in my discrete Bayes function. Sometimes you need to make slight changes to the functions in the R stats package for a given problem.

Here is a finite population sampling problem. A small community has 100 voters and you are interested in learning about the number, say M, who will vote for a school levy. You take a random sample of size 20 (without replacement) and 12 are in support of the levy. What have you learned about M?

Here the sampling density is hypergeometric — the probability that will be in favor out of 20 given that M in the population favor the levy — this is given by the hypergeometric probability

There is a function dhyper that computes this probability, but uses a different parametrization. So I write a new function dhyper2 that uses my parametrization.

dhyper2=function(x,M,sample.size=n,pop.size=N)

dhyper(x,M,N-M,n)

dhyper2=function(y,M,sample.size=n,pop.size=N)

dhyper(y,M,N-M,n)

Ok, we’re ready to go. I again read in the special functions to handle the discrete bayes calculations.

source(”http://bayes.bgsu.edu/m6480/R/discrete.bayes.functions.R”)

Here M (the number in favor in the population) can be any value from 0 to 100. I place a uniform prior on these values.

> prior=rep(1/101,101)

> names(prior)=0:100

I define n (sample size), y (number in favor in sample) and N (population size):

> n=20; y=12; N=100

Now I can apply the function discrete.bayes with inputs dhyper2 (the sampling density), prior, and the observed number in favor. I indicate also the known sample size and population size.

> s=discrete.bayes(dhyper2,prior,y,sample.size=n,pop.size=100)

By using the plot and summary methods, I plot the posterior for M and display a 90% probability interval.

> plot(s,xlab=”M”,ylab=”Probability”,col=”orange”)

> summary(s)

$coverage

[1] 0.9061118

$set

[1] 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68

[26] 69 70 71 72 73 74

We see that P(44 <= M <= 74) = 0.906

### Like this:

Like Loading...

*Related*