library(tidyverse)
library(openintro)
library(infer)

Exercise 1

set.seed(10000)

us_adults <- tibble(
  climate_change_affects = c(rep("Yes", 62000), rep("No", 38000))
)


ggplot(us_adults, aes(x = climate_change_affects)) +
  geom_bar() +
  labs(
    x = "", y = "",
    title = "Do you think climate change is affecting your local community?"
  ) +
  coord_flip() 

us_adults %>%
  count(climate_change_affects) %>%
  mutate(p = n /sum(n))
## # A tibble: 2 x 3
##   climate_change_affects     n     p
## * <chr>                  <int> <dbl>
## 1 No                     38000  0.38
## 2 Yes                    62000  0.62

In my sample 63.3% think climate change is affecting their community.

n <- 60
samp <- us_adults %>%
  sample_n(size = n)

samp %>%
  count(climate_change_affects) %>%
  mutate(p = n /sum(n))
## # A tibble: 2 x 3
##   climate_change_affects     n     p
## * <chr>                  <int> <dbl>
## 1 No                        22 0.367
## 2 Yes                       38 0.633

Exercise 2

No. The sample size is pretty small in comparison to the population, so I would suspect that more often than not each sample taken would have different proportions.

Exercise 3

The confidence interval in this case tells us there is a 95% chance our sample proportion falls within our confidence interval.

Exercise 4

Our sample proportion is 63% which is 1% away from the population proportion. Our confidence interval is 0.55-0.78. So, yes our sample proportion falls within our confidence interval.

Exercise 5

I would expect 95% of the students would achieve a sample proportion that falls within our confidence interval. Since we chose a confidence level of 95%.

Exercise 6

I produced 1 confidence interval that did not include the population proportion. 49/50 = 98% of my intervals include the true proportions. It does not match exactly with our confidence interval, but if we looped this more times I’m sure it would get closer.

results <- data_frame()
## Warning: `data_frame()` is deprecated as of tibble 1.1.0.
## Please use `tibble()` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_warnings()` to see where this warning was generated.
for (i in 1:50) {
  rnd_samp <- us_adults %>%
    sample_n(size = 60)
  
  val <- rnd_samp %>%
    specify(response = climate_change_affects, success = "Yes") %>%
    generate(reps = 1000, type = "bootstrap") %>%
    calculate(stat = "prop") %>%
    get_ci(level = 0.95)
  
  results <- rbind(results, val)
}

results %>%
  filter(lower_ci > 0.63 | upper_ci < 0.63)
## # A tibble: 3 x 2
##   lower_ci upper_ci
##      <dbl>    <dbl>
## 1    0.65     0.867
## 2    0.683    0.883
## 3    0.383    0.617

Exercise 7

I would expect the range to decrease, because the less confident we are the smaller the range will be. The larger the range the more confidence we have. After running the code my suspicisions we correct. The range is smaller.

samp %>%
    specify(response = climate_change_affects, success = "Yes") %>%
    generate(reps = 1000, type = "bootstrap") %>%
    calculate(stat = "prop") %>%
    get_ci(level = 0.75)
## # A tibble: 1 x 2
##   lower_ci upper_ci
##      <dbl>    <dbl>
## 1    0.567      0.7

Exercise 8

I chose a confidence level of 90% on our n=60 sample. The lower bound is 53% and the upper bound is 73%. This means there is a 90% probability that the true population’s proportion will fall between 53%-73%.

samp %>%
    specify(response = climate_change_affects, success = "Yes") %>%
    generate(reps = 1000, type = "bootstrap") %>%
    calculate(stat = "prop") %>%
    get_ci(level = 0.90)
## # A tibble: 1 x 2
##   lower_ci upper_ci
##      <dbl>    <dbl>
## 1    0.533    0.733

Exercise 9

After running my code I had 6 confidence intervals in which the population proportion did not fall between them. 44/50 = 88% which is pretty close to my confidence level of 90%

results <- data_frame()

for (i in 1:50) {
  rnd_samp <- us_adults %>%
    sample_n(size = 60)
  
  val <- rnd_samp %>%
    specify(response = climate_change_affects, success = "Yes") %>%
    generate(reps = 1000, type = "bootstrap") %>%
    calculate(stat = "prop") %>%
    get_ci(level = 0.90)
  
  results <- rbind(results, val)
}

results %>%
  filter(lower_ci > 0.63 | upper_ci < 0.63)
## # A tibble: 8 x 2
##   lower_ci upper_ci
##      <dbl>    <dbl>
## 1    0.633    0.817
## 2    0.7      0.867
## 3    0.633    0.817
## 4    0.4      0.6  
## 5    0.7      0.867
## 6    0.633    0.833
## 7    0.65     0.833
## 8    0.633    0.833

Exercise 10

I changed my confidence level to 80%. I expect my confidence interval to drop compared to my previous calculation with a level of 90%.

samp %>%
    specify(response = climate_change_affects, success = "Yes") %>%
    generate(reps = 1000, type = "bootstrap") %>%
    calculate(stat = "prop") %>%
    get_ci(level = 0.80)
## # A tibble: 1 x 2
##   lower_ci upper_ci
##      <dbl>    <dbl>
## 1     0.55    0.717

Exercise 11

The plot shows us that the larger the sample size is the smaller the distance will be between the upper and lower bounds of the confidence interval.

results <- data_frame()
sample_size <- 10

for (i in 1:100) {
  
  rnd_samp <- us_adults %>%
    sample_n(size = sample_size)
  
  sample_size <- sample_size + 5
  
  val <- rnd_samp %>%
    specify(response = climate_change_affects, success = "Yes") %>%
    generate(reps = 1000, type = "bootstrap") %>%
    calculate(stat = "prop") %>%
    get_ci(level = 0.90)
  
  results <- rbind(results, val)
}

plot(results$upper_ci - results$lower_ci)

Exercise 12

When the repetitions are between 1 and 50 the variance is higher. But after 50 repetitions the variance stabilizes.

results <- data_frame()
repititions <- 1

for (i in 1:100) {
  
  rnd_samp <- us_adults %>%
    sample_n(size = 60)
  
  val <- rnd_samp %>%
    specify(response = climate_change_affects, success = "Yes") %>%
    generate(reps = repititions, type = "bootstrap") %>%
    calculate(stat = "prop") %>%
    get_ci(level = 0.90)
  
  repititions <- repititions + 2
  
  results <- rbind(results, val)
}

plot(results$upper_ci - results$lower_ci)

LS0tCnRpdGxlOiAiTGFiIE5hbWUiCmF1dGhvcjogIkpvcmRhbiBHbGVuZHJhbmdlIgpkYXRlOiAiYHIgU3lzLkRhdGUoKWAiCm91dHB1dDogb3BlbmludHJvOjpsYWJfcmVwb3J0Ci0tLQoKYGBge3IgbG9hZC1wYWNrYWdlcywgbWVzc2FnZT1GQUxTRX0KbGlicmFyeSh0aWR5dmVyc2UpCmxpYnJhcnkob3BlbmludHJvKQpsaWJyYXJ5KGluZmVyKQpgYGAKCiMjIyBFeGVyY2lzZSAxCgpgYGB7cn0Kc2V0LnNlZWQoMTAwMDApCgp1c19hZHVsdHMgPC0gdGliYmxlKAogIGNsaW1hdGVfY2hhbmdlX2FmZmVjdHMgPSBjKHJlcCgiWWVzIiwgNjIwMDApLCByZXAoIk5vIiwgMzgwMDApKQopCgoKZ2dwbG90KHVzX2FkdWx0cywgYWVzKHggPSBjbGltYXRlX2NoYW5nZV9hZmZlY3RzKSkgKwogIGdlb21fYmFyKCkgKwogIGxhYnMoCiAgICB4ID0gIiIsIHkgPSAiIiwKICAgIHRpdGxlID0gIkRvIHlvdSB0aGluayBjbGltYXRlIGNoYW5nZSBpcyBhZmZlY3RpbmcgeW91ciBsb2NhbCBjb21tdW5pdHk/IgogICkgKwogIGNvb3JkX2ZsaXAoKSAKYGBgCgpgYGB7cn0KdXNfYWR1bHRzICU+JQogIGNvdW50KGNsaW1hdGVfY2hhbmdlX2FmZmVjdHMpICU+JQogIG11dGF0ZShwID0gbiAvc3VtKG4pKQpgYGAKCkluIG15IHNhbXBsZSA2My4zJSB0aGluayBjbGltYXRlIGNoYW5nZSBpcyBhZmZlY3RpbmcgdGhlaXIgY29tbXVuaXR5LgoKYGBge3J9Cm4gPC0gNjAKc2FtcCA8LSB1c19hZHVsdHMgJT4lCiAgc2FtcGxlX24oc2l6ZSA9IG4pCgpzYW1wICU+JQogIGNvdW50KGNsaW1hdGVfY2hhbmdlX2FmZmVjdHMpICU+JQogIG11dGF0ZShwID0gbiAvc3VtKG4pKQpgYGAKIyMjIEV4ZXJjaXNlIDIKCk5vLiBUaGUgc2FtcGxlIHNpemUgaXMgcHJldHR5IHNtYWxsIGluIGNvbXBhcmlzb24gdG8gdGhlIHBvcHVsYXRpb24sIHNvIEkgd291bGQgc3VzcGVjdCB0aGF0IG1vcmUgb2Z0ZW4gdGhhbiBub3QgZWFjaCBzYW1wbGUgdGFrZW4gd291bGQgaGF2ZSBkaWZmZXJlbnQgcHJvcG9ydGlvbnMuCgojIyMgRXhlcmNpc2UgMwoKVGhlIGNvbmZpZGVuY2UgaW50ZXJ2YWwgaW4gdGhpcyBjYXNlIHRlbGxzIHVzIHRoZXJlIGlzIGEgOTUlIGNoYW5jZSBvdXIgc2FtcGxlIHByb3BvcnRpb24gZmFsbHMgd2l0aGluIG91ciBjb25maWRlbmNlIGludGVydmFsLgoKIyMjIEV4ZXJjaXNlIDQKCk91ciBzYW1wbGUgcHJvcG9ydGlvbiBpcyA2MyUgd2hpY2ggaXMgMSUgYXdheSBmcm9tIHRoZSBwb3B1bGF0aW9uIHByb3BvcnRpb24uIE91ciBjb25maWRlbmNlIGludGVydmFsIGlzIDAuNTUtMC43OC4gU28sIHllcyBvdXIgc2FtcGxlIHByb3BvcnRpb24gZmFsbHMgd2l0aGluIG91ciBjb25maWRlbmNlIGludGVydmFsLgoKIyMjIEV4ZXJjaXNlIDUKCkkgd291bGQgZXhwZWN0IDk1JSBvZiB0aGUgc3R1ZGVudHMgd291bGQgYWNoaWV2ZSBhIHNhbXBsZSBwcm9wb3J0aW9uIHRoYXQgZmFsbHMgd2l0aGluIG91ciBjb25maWRlbmNlIGludGVydmFsLiBTaW5jZSB3ZSBjaG9zZSBhIGNvbmZpZGVuY2UgbGV2ZWwgb2YgOTUlLiAKCiMjIyBFeGVyY2lzZSA2CgpJIHByb2R1Y2VkIDEgY29uZmlkZW5jZSBpbnRlcnZhbCB0aGF0IGRpZCBub3QgaW5jbHVkZSB0aGUgcG9wdWxhdGlvbiBwcm9wb3J0aW9uLiA0OS81MCA9IDk4JSBvZiBteSBpbnRlcnZhbHMgaW5jbHVkZSB0aGUgdHJ1ZSBwcm9wb3J0aW9ucy4gSXQgZG9lcyBub3QgbWF0Y2ggZXhhY3RseSB3aXRoIG91ciBjb25maWRlbmNlIGludGVydmFsLCBidXQgaWYgd2UgbG9vcGVkIHRoaXMgbW9yZSB0aW1lcyBJJ20gc3VyZSBpdCB3b3VsZCBnZXQgY2xvc2VyLiAKCmBgYHtyfQoKcmVzdWx0cyA8LSBkYXRhX2ZyYW1lKCkKCmZvciAoaSBpbiAxOjUwKSB7CiAgcm5kX3NhbXAgPC0gdXNfYWR1bHRzICU+JQogICAgc2FtcGxlX24oc2l6ZSA9IDYwKQogIAogIHZhbCA8LSBybmRfc2FtcCAlPiUKICAgIHNwZWNpZnkocmVzcG9uc2UgPSBjbGltYXRlX2NoYW5nZV9hZmZlY3RzLCBzdWNjZXNzID0gIlllcyIpICU+JQogICAgZ2VuZXJhdGUocmVwcyA9IDEwMDAsIHR5cGUgPSAiYm9vdHN0cmFwIikgJT4lCiAgICBjYWxjdWxhdGUoc3RhdCA9ICJwcm9wIikgJT4lCiAgICBnZXRfY2kobGV2ZWwgPSAwLjk1KQogIAogIHJlc3VsdHMgPC0gcmJpbmQocmVzdWx0cywgdmFsKQp9CgpyZXN1bHRzICU+JQogIGZpbHRlcihsb3dlcl9jaSA+IDAuNjMgfCB1cHBlcl9jaSA8IDAuNjMpCgpgYGAKCiMjIyBFeGVyY2lzZSA3CgpJIHdvdWxkIGV4cGVjdCB0aGUgcmFuZ2UgdG8gZGVjcmVhc2UsIGJlY2F1c2UgdGhlIGxlc3MgY29uZmlkZW50IHdlIGFyZSB0aGUgc21hbGxlciB0aGUgcmFuZ2Ugd2lsbCBiZS4gVGhlIGxhcmdlciB0aGUgcmFuZ2UgdGhlIG1vcmUgY29uZmlkZW5jZSB3ZSBoYXZlLiBBZnRlciBydW5uaW5nIHRoZSBjb2RlIG15IHN1c3BpY2lzaW9ucyB3ZSBjb3JyZWN0LiBUaGUgcmFuZ2UgaXMgc21hbGxlci4KCmBgYHtyfQpzYW1wICU+JQogICAgc3BlY2lmeShyZXNwb25zZSA9IGNsaW1hdGVfY2hhbmdlX2FmZmVjdHMsIHN1Y2Nlc3MgPSAiWWVzIikgJT4lCiAgICBnZW5lcmF0ZShyZXBzID0gMTAwMCwgdHlwZSA9ICJib290c3RyYXAiKSAlPiUKICAgIGNhbGN1bGF0ZShzdGF0ID0gInByb3AiKSAlPiUKICAgIGdldF9jaShsZXZlbCA9IDAuNzUpCmBgYAoKIyMjIEV4ZXJjaXNlIDgKCkkgY2hvc2UgYSBjb25maWRlbmNlIGxldmVsIG9mIDkwJSBvbiBvdXIgbj02MCBzYW1wbGUuIFRoZSBsb3dlciBib3VuZCBpcyA1MyUgYW5kIHRoZSB1cHBlciBib3VuZCBpcyA3MyUuIFRoaXMgbWVhbnMgdGhlcmUgaXMgYSA5MCUgcHJvYmFiaWxpdHkgdGhhdCB0aGUgdHJ1ZSBwb3B1bGF0aW9uJ3MgcHJvcG9ydGlvbiB3aWxsIGZhbGwgYmV0d2VlbiA1MyUtNzMlLgoKYGBge3J9CnNhbXAgJT4lCiAgICBzcGVjaWZ5KHJlc3BvbnNlID0gY2xpbWF0ZV9jaGFuZ2VfYWZmZWN0cywgc3VjY2VzcyA9ICJZZXMiKSAlPiUKICAgIGdlbmVyYXRlKHJlcHMgPSAxMDAwLCB0eXBlID0gImJvb3RzdHJhcCIpICU+JQogICAgY2FsY3VsYXRlKHN0YXQgPSAicHJvcCIpICU+JQogICAgZ2V0X2NpKGxldmVsID0gMC45MCkKYGBgCgojIyMgRXhlcmNpc2UgOQoKQWZ0ZXIgcnVubmluZyBteSBjb2RlIEkgaGFkIDYgY29uZmlkZW5jZSBpbnRlcnZhbHMgaW4gd2hpY2ggdGhlIHBvcHVsYXRpb24gcHJvcG9ydGlvbiBkaWQgbm90IGZhbGwgYmV0d2VlbiB0aGVtLiA0NC81MCA9IDg4JSB3aGljaCBpcyBwcmV0dHkgY2xvc2UgdG8gbXkgY29uZmlkZW5jZSBsZXZlbCBvZiA5MCUKCmBgYHtyfQpyZXN1bHRzIDwtIGRhdGFfZnJhbWUoKQoKZm9yIChpIGluIDE6NTApIHsKICBybmRfc2FtcCA8LSB1c19hZHVsdHMgJT4lCiAgICBzYW1wbGVfbihzaXplID0gNjApCiAgCiAgdmFsIDwtIHJuZF9zYW1wICU+JQogICAgc3BlY2lmeShyZXNwb25zZSA9IGNsaW1hdGVfY2hhbmdlX2FmZmVjdHMsIHN1Y2Nlc3MgPSAiWWVzIikgJT4lCiAgICBnZW5lcmF0ZShyZXBzID0gMTAwMCwgdHlwZSA9ICJib290c3RyYXAiKSAlPiUKICAgIGNhbGN1bGF0ZShzdGF0ID0gInByb3AiKSAlPiUKICAgIGdldF9jaShsZXZlbCA9IDAuOTApCiAgCiAgcmVzdWx0cyA8LSByYmluZChyZXN1bHRzLCB2YWwpCn0KCnJlc3VsdHMgJT4lCiAgZmlsdGVyKGxvd2VyX2NpID4gMC42MyB8IHVwcGVyX2NpIDwgMC42MykKCmBgYAoKIyMjIEV4ZXJjaXNlIDEwCgpJIGNoYW5nZWQgbXkgY29uZmlkZW5jZSBsZXZlbCB0byA4MCUuIEkgZXhwZWN0IG15IGNvbmZpZGVuY2UgaW50ZXJ2YWwgdG8gZHJvcCBjb21wYXJlZCB0byBteSBwcmV2aW91cyBjYWxjdWxhdGlvbiB3aXRoIGEgbGV2ZWwgb2YgOTAlLgoKYGBge3J9CnNhbXAgJT4lCiAgICBzcGVjaWZ5KHJlc3BvbnNlID0gY2xpbWF0ZV9jaGFuZ2VfYWZmZWN0cywgc3VjY2VzcyA9ICJZZXMiKSAlPiUKICAgIGdlbmVyYXRlKHJlcHMgPSAxMDAwLCB0eXBlID0gImJvb3RzdHJhcCIpICU+JQogICAgY2FsY3VsYXRlKHN0YXQgPSAicHJvcCIpICU+JQogICAgZ2V0X2NpKGxldmVsID0gMC44MCkKYGBgCgoKIyMjIEV4ZXJjaXNlIDExCgpUaGUgcGxvdCBzaG93cyB1cyB0aGF0IHRoZSBsYXJnZXIgdGhlIHNhbXBsZSBzaXplIGlzIHRoZSBzbWFsbGVyIHRoZSBkaXN0YW5jZSB3aWxsIGJlIGJldHdlZW4gdGhlIHVwcGVyIGFuZCBsb3dlciBib3VuZHMgb2YgdGhlIGNvbmZpZGVuY2UgaW50ZXJ2YWwuCgpgYGB7cn0KcmVzdWx0cyA8LSBkYXRhX2ZyYW1lKCkKc2FtcGxlX3NpemUgPC0gMTAKCmZvciAoaSBpbiAxOjEwMCkgewogIAogIHJuZF9zYW1wIDwtIHVzX2FkdWx0cyAlPiUKICAgIHNhbXBsZV9uKHNpemUgPSBzYW1wbGVfc2l6ZSkKICAKICBzYW1wbGVfc2l6ZSA8LSBzYW1wbGVfc2l6ZSArIDUKICAKICB2YWwgPC0gcm5kX3NhbXAgJT4lCiAgICBzcGVjaWZ5KHJlc3BvbnNlID0gY2xpbWF0ZV9jaGFuZ2VfYWZmZWN0cywgc3VjY2VzcyA9ICJZZXMiKSAlPiUKICAgIGdlbmVyYXRlKHJlcHMgPSAxMDAwLCB0eXBlID0gImJvb3RzdHJhcCIpICU+JQogICAgY2FsY3VsYXRlKHN0YXQgPSAicHJvcCIpICU+JQogICAgZ2V0X2NpKGxldmVsID0gMC45MCkKICAKICByZXN1bHRzIDwtIHJiaW5kKHJlc3VsdHMsIHZhbCkKfQoKcGxvdChyZXN1bHRzJHVwcGVyX2NpIC0gcmVzdWx0cyRsb3dlcl9jaSkKYGBgCgojIyMgRXhlcmNpc2UgMTIKCldoZW4gdGhlIHJlcGV0aXRpb25zIGFyZSBiZXR3ZWVuIDEgYW5kIDUwIHRoZSB2YXJpYW5jZSBpcyBoaWdoZXIuIEJ1dCBhZnRlciA1MCByZXBldGl0aW9ucyB0aGUgdmFyaWFuY2Ugc3RhYmlsaXplcy4KCmBgYHtyfQpyZXN1bHRzIDwtIGRhdGFfZnJhbWUoKQpyZXBpdGl0aW9ucyA8LSAxCgpmb3IgKGkgaW4gMToxMDApIHsKICAKICBybmRfc2FtcCA8LSB1c19hZHVsdHMgJT4lCiAgICBzYW1wbGVfbihzaXplID0gNjApCiAgCiAgdmFsIDwtIHJuZF9zYW1wICU+JQogICAgc3BlY2lmeShyZXNwb25zZSA9IGNsaW1hdGVfY2hhbmdlX2FmZmVjdHMsIHN1Y2Nlc3MgPSAiWWVzIikgJT4lCiAgICBnZW5lcmF0ZShyZXBzID0gcmVwaXRpdGlvbnMsIHR5cGUgPSAiYm9vdHN0cmFwIikgJT4lCiAgICBjYWxjdWxhdGUoc3RhdCA9ICJwcm9wIikgJT4lCiAgICBnZXRfY2kobGV2ZWwgPSAwLjkwKQogIAogIHJlcGl0aXRpb25zIDwtIHJlcGl0aXRpb25zICsgMgogIAogIHJlc3VsdHMgPC0gcmJpbmQocmVzdWx0cywgdmFsKQp9CgpwbG90KHJlc3VsdHMkdXBwZXJfY2kgLSByZXN1bHRzJGxvd2VyX2NpKQpgYGA=