Part I: exponential random variables

This project investigates the distribution of the sample mean of 40 exponential random variables using a simulation in R. It compares the simulated sample mean and variance to their theoretical values and demonstrates that the sampling distribution of the mean is approximately normal, as predicted by the Central Limit Theorem.

Preparation


#given parameters from course
lambda <- 0.2
n <- 40
simulations <- 1000

#get means of exponential distribution
set.seed(42)
means = NULL
for (i in 1 : simulations){
  means <- c(means, mean(rexp(n, lambda)))
}

#get theoretical values
theoretical_mean <- 1 / lambda
theoretical_sd <- (1 / lambda) / sqrt(n)
theoretical_var <- theoretical_sd^2

#get sample results
sample_mean <- mean(means)
sample_var <- var(means)

Answer questions

Show the sample mean and compare it to the theoretical mean of the distribution.

paste("Theoretical mean:", theoretical_mean)
[1] "Theoretical mean: 5"
paste("Simulated mean via sample", round(sample_mean,2))
[1] "Simulated mean via sample 4.99"
hist(means, breaks = 40, prob = TRUE,
     main = "Distribution of sample means",
     xlab = "Sample Mean",
     xlim = c(1.5,8.5))
abline(v = theoretical_mean, col = "red", lwd = 2, lty = 2)
abline(v = sample_mean, col = "blue", lwd = 2)
legend("topright",
       legend = c("Theoretical mean", "Sample mean"),
       col = c("red", "blue"),
       lwd = 2,
       lty = c(2,1))

Show how variable the sample is (via variance) and compare it to the theoretical variance of the distribution.

paste("Theoretical variance:", theoretical_var)
[1] "Theoretical variance: 0.625"
paste("Simulated variance via sample:", round(sample_var,2))
[1] "Simulated variance via sample: 0.63"

Show that the distribution is approximately normal.

hist(means, breaks = 40, prob = TRUE,
     main = "Distribution of means",
     xlab = "Mean",
     xlim = c(1.5,8.5))
curve(dnorm(x, mean = theoretical_mean, sd = theoretical_sd),
      col = "red", lwd = 2, add = TRUE)

In red we see the corresponding normal distribution. Our samples follow this curve quite nicely.

Part II: ToothGrowth dataset analysis

According to the ToothGrowth Documentation:

The Effect of Vitamin C on Tooth Growth in Guinea Pigs Description The response is the length of odontoblasts (cells responsible for tooth growth) in 60 guinea pigs. Each animal received one of three dose levels of vitamin C (0.5, 1, and 2 mg/day) by one of two delivery methods, orange juice or ascorbic acid (a form of vitamin C and coded as VC).

Format:
A data frame with 60 observations on 3 variables.

[,1] len numeric Tooth length
[,2] supp factor Supplement type (VC or OJ)
[,3] dose numeric Dose in milligrams/day

summary(ToothGrowth)
      len        supp         dose      
 Min.   : 4.20   OJ:30   Min.   :0.500  
 1st Qu.:13.07   VC:30   1st Qu.:0.500  
 Median :19.25           Median :1.000  
 Mean   :18.81           Mean   :1.167  
 3rd Qu.:25.27           3rd Qu.:2.000  
 Max.   :33.90           Max.   :2.000  

If we compare the two columns supp and dose we see that the two supplements OJ and VC were given in comparable doses and replicates:

table(ToothGrowth$dose[which(ToothGrowth$supp == "OJ")])

0.5   1   2 
 10  10  10 
table(ToothGrowth$dose[which(ToothGrowth$supp == "VC")])

0.5   1   2 
 10  10  10 

If we plot the tooth growth length density according to the supplements we get two similar, but not overlapping curves.


plot(density(ToothGrowth$len[which(ToothGrowth$supp == "OJ")]),
     xlim = c(-10,50),
     col = "red",
     lwd = 2,
     main = "Density plot denpending on supp")
points(density(ToothGrowth$len[which(ToothGrowth$supp == "VC")]),
       type = "l",
       col = "blue",
       lwd = 2)
legend("topright", 
       legend = c("OJ", "VC"), 
       lty = 1, 
       col = c("blue", "red"), 
       lwd = 2)

If we split up the tooth growth length into dose and supplements we see an increase in length depending on the supplement that is more clear at lower dosage levels.

boxplot(ToothGrowth$len ~ ToothGrowth$supp*ToothGrowth$dose,
        frame = FALSE,
        col = c("white", "steelblue"),
        names = c('OJ 0.5', 'VC 0.5', 'OJ 1', 'VC 1', 'OJ 2', 'VC 2'),
        xlab = "",
        ylab = "Length")

t.test(len ~ supp, data = ToothGrowth)

    Welch Two Sample t-test

data:  len by supp
t = 1.9153, df = 55.309, p-value = 0.06063
alternative hypothesis: true difference in means between group OJ and group VC is not equal to 0
95 percent confidence interval:
 -0.1710156  7.5710156
sample estimates:
mean in group OJ mean in group VC 
        20.66333         16.96333 

We do not see a statistical difference between the two supplement groups OJ and VC at alpha = 0.05. But as shown above there might be a dose dependency. For this we perform multiple tests and adjust the resulting p-values accordingly

t1 <- t.test(len ~ supp, data = ToothGrowth[ToothGrowth$dose == 0.5, ])
t2 <- t.test(len ~ supp, data = ToothGrowth[ToothGrowth$dose == 1.0, ])
t3 <- t.test(len ~ supp, data = ToothGrowth[ToothGrowth$dose == 2.0, ])

p_raw <- c(t1$p.value, t2$p.value, t3$p.value)

# BH correction due to multiple testing
p_adj <- p.adjust(p_raw, method = "BH")

#
data.frame(
  Dose = c(0.5, 1.0, 2.0),
  Raw_p = round(p_raw, 4),
  Adjusted_p_BH = round(p_adj, 4)
)

With adjusted p-values of 0.0095 and 0.0031 we see strong significance of increased tooth growth length at lower dosages depending on the type of supplement. At concentrations of 0.5 and 1 mg/day orange juice seems to enhance tooth growth compared to ascorbic acid.

LS0tDQp0aXRsZTogIlN0YXRpc3RpY2FsIGludGVyZmVyZW5jZSBDb3Vyc2UgUHJvamVjdCINCmF1dGhvcjogYnkgU1JpbmdzaGFuZGwNCm91dHB1dDogaHRtbF9ub3RlYm9vaw0KLS0tDQoNCiMgUGFydCBJOiBleHBvbmVudGlhbCByYW5kb20gdmFyaWFibGVzDQpUaGlzIHByb2plY3QgaW52ZXN0aWdhdGVzIHRoZSBkaXN0cmlidXRpb24gb2YgdGhlIHNhbXBsZSBtZWFuIG9mIDQwIGV4cG9uZW50aWFsIHJhbmRvbSB2YXJpYWJsZXMgdXNpbmcgYSBzaW11bGF0aW9uIGluIFIuIEl0IGNvbXBhcmVzIHRoZSBzaW11bGF0ZWQgc2FtcGxlIG1lYW4gYW5kIHZhcmlhbmNlIHRvIHRoZWlyIHRoZW9yZXRpY2FsIHZhbHVlcyBhbmQgZGVtb25zdHJhdGVzIHRoYXQgdGhlIHNhbXBsaW5nIGRpc3RyaWJ1dGlvbiBvZiB0aGUgbWVhbiBpcyBhcHByb3hpbWF0ZWx5IG5vcm1hbCwgYXMgcHJlZGljdGVkIGJ5IHRoZSBDZW50cmFsIExpbWl0IFRoZW9yZW0uDQoNCiMjIFByZXBhcmF0aW9uDQoNCmBgYHtyIHByZXBhcmF0aW9ufQ0KDQojZ2l2ZW4gcGFyYW1ldGVycyBmcm9tIGNvdXJzZQ0KbGFtYmRhIDwtIDAuMg0KbiA8LSA0MA0Kc2ltdWxhdGlvbnMgPC0gMTAwMA0KDQojZ2V0IG1lYW5zIG9mIGV4cG9uZW50aWFsIGRpc3RyaWJ1dGlvbg0Kc2V0LnNlZWQoNDIpDQptZWFucyA9IE5VTEwNCmZvciAoaSBpbiAxIDogc2ltdWxhdGlvbnMpew0KICBtZWFucyA8LSBjKG1lYW5zLCBtZWFuKHJleHAobiwgbGFtYmRhKSkpDQp9DQoNCiNnZXQgdGhlb3JldGljYWwgdmFsdWVzDQp0aGVvcmV0aWNhbF9tZWFuIDwtIDEgLyBsYW1iZGENCnRoZW9yZXRpY2FsX3NkIDwtICgxIC8gbGFtYmRhKSAvIHNxcnQobikNCnRoZW9yZXRpY2FsX3ZhciA8LSB0aGVvcmV0aWNhbF9zZF4yDQoNCiNnZXQgc2FtcGxlIHJlc3VsdHMNCnNhbXBsZV9tZWFuIDwtIG1lYW4obWVhbnMpDQpzYW1wbGVfdmFyIDwtIHZhcihtZWFucykNCmBgYA0KIyMgQW5zd2VyIHF1ZXN0aW9ucw0KIyMjIFNob3cgdGhlIHNhbXBsZSBtZWFuIGFuZCBjb21wYXJlIGl0IHRvIHRoZSB0aGVvcmV0aWNhbCBtZWFuIG9mIHRoZSBkaXN0cmlidXRpb24uDQoNCg0KYGBge3IgcXVlc3Rpb24xfQ0KcGFzdGUoIlRoZW9yZXRpY2FsIG1lYW46IiwgdGhlb3JldGljYWxfbWVhbikNCnBhc3RlKCJTaW11bGF0ZWQgbWVhbiB2aWEgc2FtcGxlIiwgcm91bmQoc2FtcGxlX21lYW4sMikpDQoNCmhpc3QobWVhbnMsIGJyZWFrcyA9IDQwLCBwcm9iID0gVFJVRSwNCiAgICAgbWFpbiA9ICJEaXN0cmlidXRpb24gb2Ygc2FtcGxlIG1lYW5zIiwNCiAgICAgeGxhYiA9ICJTYW1wbGUgTWVhbiIsDQogICAgIHhsaW0gPSBjKDEuNSw4LjUpKQ0KYWJsaW5lKHYgPSB0aGVvcmV0aWNhbF9tZWFuLCBjb2wgPSAicmVkIiwgbHdkID0gMiwgbHR5ID0gMikNCmFibGluZSh2ID0gc2FtcGxlX21lYW4sIGNvbCA9ICJibHVlIiwgbHdkID0gMikNCmxlZ2VuZCgidG9wcmlnaHQiLA0KICAgICAgIGxlZ2VuZCA9IGMoIlRoZW9yZXRpY2FsIG1lYW4iLCAiU2FtcGxlIG1lYW4iKSwNCiAgICAgICBjb2wgPSBjKCJyZWQiLCAiYmx1ZSIpLA0KICAgICAgIGx3ZCA9IDIsDQogICAgICAgbHR5ID0gYygyLDEpKQ0KYGBgDQoNCiMjIyBTaG93IGhvdyB2YXJpYWJsZSB0aGUgc2FtcGxlIGlzICh2aWEgdmFyaWFuY2UpIGFuZCBjb21wYXJlIGl0IHRvIHRoZSB0aGVvcmV0aWNhbCB2YXJpYW5jZSBvZiB0aGUgZGlzdHJpYnV0aW9uLg0KDQpgYGB7ciBxdWVzdGlvbjJ9DQpwYXN0ZSgiVGhlb3JldGljYWwgdmFyaWFuY2U6IiwgdGhlb3JldGljYWxfdmFyKQ0KcGFzdGUoIlNpbXVsYXRlZCB2YXJpYW5jZSB2aWEgc2FtcGxlOiIsIHJvdW5kKHNhbXBsZV92YXIsMikpDQpgYGANCg0KIyMjIFNob3cgdGhhdCB0aGUgZGlzdHJpYnV0aW9uIGlzIGFwcHJveGltYXRlbHkgbm9ybWFsLg0KDQpgYGB7ciBxdWVzdGlvbjN9DQpoaXN0KG1lYW5zLCBicmVha3MgPSA0MCwgcHJvYiA9IFRSVUUsDQogICAgIG1haW4gPSAiRGlzdHJpYnV0aW9uIG9mIG1lYW5zIiwNCiAgICAgeGxhYiA9ICJNZWFuIiwNCiAgICAgeGxpbSA9IGMoMS41LDguNSkpDQpjdXJ2ZShkbm9ybSh4LCBtZWFuID0gdGhlb3JldGljYWxfbWVhbiwgc2QgPSB0aGVvcmV0aWNhbF9zZCksDQogICAgICBjb2wgPSAicmVkIiwgbHdkID0gMiwgYWRkID0gVFJVRSkNCmBgYA0KDQpJbiByZWQgd2Ugc2VlIHRoZSBjb3JyZXNwb25kaW5nIG5vcm1hbCBkaXN0cmlidXRpb24uIE91ciBzYW1wbGVzIGZvbGxvdyB0aGlzIGN1cnZlIHF1aXRlIG5pY2VseS4NCg0KIyBQYXJ0IElJOiBUb290aEdyb3d0aCBkYXRhc2V0IGFuYWx5c2lzDQoNCkFjY29yZGluZyB0byB0aGUgVG9vdGhHcm93dGggRG9jdW1lbnRhdGlvbjoNCg0KVGhlIEVmZmVjdCBvZiBWaXRhbWluIEMgb24gVG9vdGggR3Jvd3RoIGluIEd1aW5lYSBQaWdzDQpEZXNjcmlwdGlvbg0KVGhlIHJlc3BvbnNlIGlzIHRoZSBsZW5ndGggb2Ygb2RvbnRvYmxhc3RzIChjZWxscyByZXNwb25zaWJsZSBmb3IgdG9vdGggZ3Jvd3RoKSBpbiA2MCBndWluZWEgcGlncy4gRWFjaCBhbmltYWwgcmVjZWl2ZWQgb25lIG9mIHRocmVlIGRvc2UgbGV2ZWxzIG9mIHZpdGFtaW4gQyAoMC41LCAxLCBhbmQgMiBtZy9kYXkpIGJ5IG9uZSBvZiB0d28gZGVsaXZlcnkgbWV0aG9kcywgb3JhbmdlIGp1aWNlIG9yIGFzY29yYmljIGFjaWQgKGEgZm9ybSBvZiB2aXRhbWluIEMgYW5kIGNvZGVkIGFzIFZDKS4NCg0KRm9ybWF0OiAgDQpBIGRhdGEgZnJhbWUgd2l0aCA2MCBvYnNlcnZhdGlvbnMgb24gMyB2YXJpYWJsZXMuDQoNClssMV0JbGVuCW51bWVyaWMJVG9vdGggbGVuZ3RoICANClssMl0Jc3VwcAlmYWN0b3IJU3VwcGxlbWVudCB0eXBlIChWQyBvciBPSikgIA0KWywzXQlkb3NlCW51bWVyaWMJRG9zZSBpbiBtaWxsaWdyYW1zL2RheSANCg0KYGBge3J9DQpzdW1tYXJ5KFRvb3RoR3Jvd3RoKQ0KYGBgDQpJZiB3ZSBjb21wYXJlIHRoZSB0d28gY29sdW1ucyBzdXBwIGFuZCBkb3NlIHdlIHNlZSB0aGF0IHRoZSB0d28gc3VwcGxlbWVudHMgT0ogYW5kIFZDIHdlcmUgZ2l2ZW4gaW4gY29tcGFyYWJsZSBkb3NlcyBhbmQgcmVwbGljYXRlczoNCmBgYHtyfQ0KdGFibGUoVG9vdGhHcm93dGgkZG9zZVt3aGljaChUb290aEdyb3d0aCRzdXBwID09ICJPSiIpXSkNCmBgYA0KDQoNCmBgYHtyfQ0KdGFibGUoVG9vdGhHcm93dGgkZG9zZVt3aGljaChUb290aEdyb3d0aCRzdXBwID09ICJWQyIpXSkNCmBgYA0KSWYgd2UgcGxvdCB0aGUgdG9vdGggZ3Jvd3RoIGxlbmd0aCBkZW5zaXR5IGFjY29yZGluZyB0byB0aGUgc3VwcGxlbWVudHMgd2UgZ2V0IHR3byBzaW1pbGFyLCBidXQgbm90IG92ZXJsYXBwaW5nIGN1cnZlcy4NCmBgYHtyfQ0KDQpwbG90KGRlbnNpdHkoVG9vdGhHcm93dGgkbGVuW3doaWNoKFRvb3RoR3Jvd3RoJHN1cHAgPT0gIk9KIildKSwNCiAgICAgeGxpbSA9IGMoLTEwLDUwKSwNCiAgICAgY29sID0gInJlZCIsDQogICAgIGx3ZCA9IDIsDQogICAgIG1haW4gPSAiRGVuc2l0eSBwbG90IGRlbnBlbmRpbmcgb24gc3VwcGxlbWVudCIpDQpwb2ludHMoZGVuc2l0eShUb290aEdyb3d0aCRsZW5bd2hpY2goVG9vdGhHcm93dGgkc3VwcCA9PSAiVkMiKV0pLA0KICAgICAgIHR5cGUgPSAibCIsDQogICAgICAgY29sID0gImJsdWUiLA0KICAgICAgIGx3ZCA9IDIpDQpsZWdlbmQoInRvcHJpZ2h0IiwgDQogICAgICAgbGVnZW5kID0gYygiT0oiLCAiVkMiKSwgDQogICAgICAgbHR5ID0gMSwgDQogICAgICAgY29sID0gYygiYmx1ZSIsICJyZWQiKSwgDQogICAgICAgbHdkID0gMikNCg0KYGBgDQpJZiB3ZSBzcGxpdCB1cCB0aGUgdG9vdGggZ3Jvd3RoIGxlbmd0aCBpbnRvIGRvc2UgYW5kIHN1cHBsZW1lbnRzIHdlIHNlZSBhbiBpbmNyZWFzZSBpbiBsZW5ndGggZGVwZW5kaW5nIG9uIHRoZSBzdXBwbGVtZW50IHRoYXQgaXMgbW9yZSBjbGVhciBhdCBsb3dlciBkb3NhZ2UgbGV2ZWxzLg0KYGBge3J9DQpib3hwbG90KFRvb3RoR3Jvd3RoJGxlbiB+IFRvb3RoR3Jvd3RoJHN1cHAqVG9vdGhHcm93dGgkZG9zZSwNCiAgICAgICAgZnJhbWUgPSBGQUxTRSwNCiAgICAgICAgY29sID0gYygid2hpdGUiLCAic3RlZWxibHVlIiksDQogICAgICAgIG5hbWVzID0gYygnT0ogMC41JywgJ1ZDIDAuNScsICdPSiAxJywgJ1ZDIDEnLCAnT0ogMicsICdWQyAyJyksDQogICAgICAgIHhsYWIgPSAiIiwNCiAgICAgICAgeWxhYiA9ICJMZW5ndGgiKQ0KYGBgDQoNCmBgYHtyfQ0KdC50ZXN0KGxlbiB+IHN1cHAsIGRhdGEgPSBUb290aEdyb3d0aCkNCg0KYGBgDQpXZSBkbyBub3Qgc2VlIGEgc3RhdGlzdGljYWwgZGlmZmVyZW5jZSBiZXR3ZWVuIHRoZSB0d28gc3VwcGxlbWVudCBncm91cHMgT0ogYW5kIFZDIGF0IGFscGhhID0gMC4wNS4gQnV0IGFzIHNob3duIGFib3ZlIHRoZXJlIG1pZ2h0IGJlIGEgZG9zZSBkZXBlbmRlbmN5LiBGb3IgdGhpcyB3ZSBwZXJmb3JtIG11bHRpcGxlIHRlc3RzIGFuZCBhZGp1c3QgdGhlIHJlc3VsdGluZyBwLXZhbHVlcyBhY2NvcmRpbmdseQ0KDQpgYGB7cn0NCnQxIDwtIHQudGVzdChsZW4gfiBzdXBwLCBkYXRhID0gVG9vdGhHcm93dGhbVG9vdGhHcm93dGgkZG9zZSA9PSAwLjUsIF0pDQp0MiA8LSB0LnRlc3QobGVuIH4gc3VwcCwgZGF0YSA9IFRvb3RoR3Jvd3RoW1Rvb3RoR3Jvd3RoJGRvc2UgPT0gMS4wLCBdKQ0KdDMgPC0gdC50ZXN0KGxlbiB+IHN1cHAsIGRhdGEgPSBUb290aEdyb3d0aFtUb290aEdyb3d0aCRkb3NlID09IDIuMCwgXSkNCg0KcF9yYXcgPC0gYyh0MSRwLnZhbHVlLCB0MiRwLnZhbHVlLCB0MyRwLnZhbHVlKQ0KDQojIEJIIGNvcnJlY3Rpb24gZHVlIHRvIG11bHRpcGxlIHRlc3RpbmcNCnBfYWRqIDwtIHAuYWRqdXN0KHBfcmF3LCBtZXRob2QgPSAiQkgiKQ0KDQpkYXRhLmZyYW1lKA0KICBEb3NlID0gYygwLjUsIDEuMCwgMi4wKSwNCiAgUmF3X3AgPSByb3VuZChwX3JhdywgNCksDQogIEFkanVzdGVkX3BfQkggPSByb3VuZChwX2FkaiwgNCkNCikNCmBgYA0KV2l0aCBhZGp1c3RlZCBwLXZhbHVlcyBvZiAwLjAwOTUgYW5kIDAuMDAzMSB3ZSBzZWUgc3Ryb25nIHNpZ25pZmljYW5jZSBvZiBpbmNyZWFzZWQgdG9vdGggZ3Jvd3RoIGxlbmd0aCBhdCBsb3dlciBkb3NhZ2VzIGRlcGVuZGluZyBvbiB0aGUgdHlwZSBvZiBzdXBwbGVtZW50LiBBdCBjb25jZW50cmF0aW9ucyBvZiAwLjUgYW5kIDEgbWcvZGF5IG9yYW5nZSBqdWljZSBzZWVtcyB0byBlbmhhbmNlIHRvb3RoIGdyb3d0aCBjb21wYXJlZCB0byBhc2NvcmJpYyBhY2lkLg0KDQo=