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

Exercise 1

us_adults <- tibble(
  climate_change_affects = c(rep("Yes", 62000), rep("No", 38000))
)
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

58.3% of people in my sample think climate change affects their local community.

Exercise 2

I would expect another student’s proportion to be similar but not identical. The reason for it is we cannot be certain the sample will take the same proportion of answers every time.

Exercise 3

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

95% Confidence means we are 95% confident that the Yes answer is between the lower and upper confidence interval.

Exercise 4

Yes, it does capture the real proportion.

Exercise 5

I would expect 95% of the intervals to capture the true population.

Exercise 6

I could not find the app referred to. Trying to answer the question by programmatically running the described steps:

  1. Obtain a random sample.
  2. Calculate the sample proportion, and use these to calculate and store the lower and upper bounds of the confidence intervals.
  3. Repeat these steps 50 times.
df <- data.frame(NA, NA)

for (i in 1:50) { #repeat 50 times
  temp_vector <- samp %>%
                      specify(response = climate_change_affects, success = "Yes") %>%
                      generate(reps = 1000, type = "bootstrap") %>%
                      calculate(stat = "prop") %>%
                      get_ci(level = 0.95)  
  if (i == 1) { 
    df <- temp_vector 
  } else { 
    df <- rbind(df, temp_vector)  
  }

}
df %>%
  mutate(within_range = case_when(lower_ci <= 0.62 & upper_ci >= 0.62 ~ "Yes",
                                  lower_ci > 0.62 | upper_ci < .62 ~ "No"))%>% 
  count(within_range) %>%
  mutate(p = n /sum(n))
## # A tibble: 1 x 3
##   within_range     n     p
##   <chr>        <int> <dbl>
## 1 Yes             50     1

The proportion is higher than the confidence level. Not sure of the reason.

Exercise 7

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

I would expect the interval to be narrower because the confidence level is lower.

Exercise 8

I chose 50% confidence level and the boundaries were very narrow. I expect this to be due to the fact that we raised our uncertainty.

Exercise 9

df <- data.frame(NA, NA)

for (i in 1:50) { #repeat 50 times
  temp_vector <- samp %>%
                      specify(response = climate_change_affects, success = "Yes") %>%
                      generate(reps = 1000, type = "bootstrap") %>%
                      calculate(stat = "prop") %>%
                      get_ci(level = 0.50)  
  if (i == 1) { 
    df <- temp_vector 
  } else { 
    df <- rbind(df, temp_vector)  
  }

}

 
df %>%
  mutate(within_range = case_when(lower_ci <= 0.62 & upper_ci >= 0.62 ~ "Yes",
                                  lower_ci > 0.62 | upper_ci < .62 ~ "No"))%>% 
  count(within_range) %>%
  mutate(p = n /sum(n))
## # A tibble: 1 x 3
##   within_range     n     p
##   <chr>        <int> <dbl>
## 1 Yes             50     1

By lowering our confidence level, we got a proportion of samples withing range of 68%, opposite to the 100% we got before.

Exercise 10

df <- data.frame(NA, NA)

for (i in 1:50) { #repeat 50 times
  temp_vector <- samp %>%
                      specify(response = climate_change_affects, success = "Yes") %>%
                      generate(reps = 1000, type = "bootstrap") %>%
                      calculate(stat = "prop") %>%
                      get_ci(level = 0.20)  
  if (i == 1) { 
    df <- temp_vector 
  } else { 
    df <- rbind(df, temp_vector)  
  }

}

 
df %>%
  mutate(within_range = case_when(lower_ci <= 0.62 & upper_ci >= 0.62 ~ "Yes",
                                  lower_ci > 0.62 | upper_ci < .62 ~ "No"))%>% 
  count(within_range) %>%
  mutate(p = n /sum(n))
## # A tibble: 2 x 3
##   within_range     n     p
##   <chr>        <int> <dbl>
## 1 No               1  0.02
## 2 Yes             49  0.98

When I try 20% confidence level, I don’t get a single observation to agree with the real proportion.

LS0tDQp0aXRsZTogIkRTNjA2LUxhYjVCIg0KYXV0aG9yOiAiR2VvcmdlIENydXoiDQpkYXRlOiAiYHIgU3lzLkRhdGUoKWAiDQpvdXRwdXQ6IG9wZW5pbnRybzo6bGFiX3JlcG9ydA0KLS0tDQoNCmBgYHtyIGxvYWQtcGFja2FnZXMsIG1lc3NhZ2U9RkFMU0V9DQpsaWJyYXJ5KHRpZHl2ZXJzZSkNCmxpYnJhcnkob3BlbmludHJvKQ0KbGlicmFyeShpbmZlcikNCmBgYA0KDQoNCiMjIyBFeGVyY2lzZSAxDQpgYGB7cn0NCnVzX2FkdWx0cyA8LSB0aWJibGUoDQogIGNsaW1hdGVfY2hhbmdlX2FmZmVjdHMgPSBjKHJlcCgiWWVzIiwgNjIwMDApLCByZXAoIk5vIiwgMzgwMDApKQ0KKQ0KYGBgDQoNCmBgYHtyfQ0KbiA8LSA2MA0Kc2FtcCA8LSB1c19hZHVsdHMgJT4lDQogIHNhbXBsZV9uKHNpemUgPSBuKQ0KYGBgDQoNCmBgYHtyfQ0Kc2FtcCAlPiUNCiAgY291bnQoY2xpbWF0ZV9jaGFuZ2VfYWZmZWN0cykgJT4lDQogIG11dGF0ZShwID0gbiAvc3VtKG4pKQ0KYGBgDQo1OC4zJSBvZiBwZW9wbGUgaW4gbXkgc2FtcGxlIHRoaW5rIGNsaW1hdGUgY2hhbmdlIGFmZmVjdHMgdGhlaXIgbG9jYWwgY29tbXVuaXR5LiANCg0KIyMjIEV4ZXJjaXNlIDINCkkgd291bGQgZXhwZWN0IGFub3RoZXIgc3R1ZGVudCdzIHByb3BvcnRpb24gdG8gYmUgc2ltaWxhciBidXQgbm90IGlkZW50aWNhbC4gIFRoZSByZWFzb24gZm9yIGl0IGlzIHdlIGNhbm5vdCBiZSBjZXJ0YWluIHRoZSBzYW1wbGUgd2lsbCB0YWtlIHRoZSBzYW1lIHByb3BvcnRpb24gb2YgYW5zd2VycyBldmVyeSB0aW1lLiANCg0KIyMjIEV4ZXJjaXNlIDMNCg0KYGBge3J9DQpzYW1wICU+JQ0KICBzcGVjaWZ5KHJlc3BvbnNlID0gY2xpbWF0ZV9jaGFuZ2VfYWZmZWN0cywgc3VjY2VzcyA9ICJZZXMiKSAlPiUNCiAgZ2VuZXJhdGUocmVwcyA9IDEwMDAsIHR5cGUgPSAiYm9vdHN0cmFwIikgJT4lDQogIGNhbGN1bGF0ZShzdGF0ID0gInByb3AiKSAlPiUNCiAgZ2V0X2NpKGxldmVsID0gMC45NSkNCmBgYA0KDQo5NSUgQ29uZmlkZW5jZSBtZWFucyB3ZSBhcmUgOTUlIGNvbmZpZGVudCB0aGF0IHRoZSBZZXMgYW5zd2VyIGlzIGJldHdlZW4gdGhlIGxvd2VyIGFuZCB1cHBlciBjb25maWRlbmNlIGludGVydmFsLiANCg0KIyMjIEV4ZXJjaXNlIDQNClllcywgaXQgZG9lcyBjYXB0dXJlIHRoZSByZWFsIHByb3BvcnRpb24uIA0KDQojIyMgRXhlcmNpc2UgNQ0KSSB3b3VsZCBleHBlY3QgOTUlIG9mIHRoZSBpbnRlcnZhbHMgdG8gY2FwdHVyZSB0aGUgdHJ1ZSBwb3B1bGF0aW9uLiANCg0KIyMjIEV4ZXJjaXNlIDYNCkkgY291bGQgbm90IGZpbmQgdGhlIGFwcCByZWZlcnJlZCB0by4gVHJ5aW5nIHRvIGFuc3dlciB0aGUgcXVlc3Rpb24gYnkgcHJvZ3JhbW1hdGljYWxseSBydW5uaW5nIHRoZSBkZXNjcmliZWQgc3RlcHM6DQoNCjEuIE9idGFpbiBhIHJhbmRvbSBzYW1wbGUuDQoyLiBDYWxjdWxhdGUgdGhlIHNhbXBsZSBwcm9wb3J0aW9uLCBhbmQgdXNlIHRoZXNlIHRvIGNhbGN1bGF0ZSBhbmQgc3RvcmUgdGhlIGxvd2VyIGFuZCB1cHBlciBib3VuZHMgb2YgdGhlIGNvbmZpZGVuY2UgaW50ZXJ2YWxzLg0KMy4gUmVwZWF0IHRoZXNlIHN0ZXBzIDUwIHRpbWVzLg0KDQoNCg0KYGBge3J9DQpkZiA8LSBkYXRhLmZyYW1lKE5BLCBOQSkNCg0KZm9yIChpIGluIDE6NTApIHsgI3JlcGVhdCA1MCB0aW1lcw0KICB0ZW1wX3ZlY3RvciA8LSBzYW1wICU+JQ0KICAgICAgICAgICAgICAgICAgICAgIHNwZWNpZnkocmVzcG9uc2UgPSBjbGltYXRlX2NoYW5nZV9hZmZlY3RzLCBzdWNjZXNzID0gIlllcyIpICU+JQ0KICAgICAgICAgICAgICAgICAgICAgIGdlbmVyYXRlKHJlcHMgPSAxMDAwLCB0eXBlID0gImJvb3RzdHJhcCIpICU+JQ0KICAgICAgICAgICAgICAgICAgICAgIGNhbGN1bGF0ZShzdGF0ID0gInByb3AiKSAlPiUNCiAgICAgICAgICAgICAgICAgICAgICBnZXRfY2kobGV2ZWwgPSAwLjk1KSAgDQogIGlmIChpID09IDEpIHsgDQogICAgZGYgPC0gdGVtcF92ZWN0b3IgDQogIH0gZWxzZSB7IA0KICAgIGRmIDwtIHJiaW5kKGRmLCB0ZW1wX3ZlY3RvcikgIA0KICB9DQoNCn0NCg0KYGBgDQoNCmBgYHtyfQ0KZGYgJT4lDQogIG11dGF0ZSh3aXRoaW5fcmFuZ2UgPSBjYXNlX3doZW4obG93ZXJfY2kgPD0gMC42MiAmIHVwcGVyX2NpID49IDAuNjIgfiAiWWVzIiwNCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICBsb3dlcl9jaSA+IDAuNjIgfCB1cHBlcl9jaSA8IC42MiB+ICJObyIpKSU+JSANCiAgY291bnQod2l0aGluX3JhbmdlKSAlPiUNCiAgbXV0YXRlKHAgPSBuIC9zdW0obikpDQpgYGANClRoZSBwcm9wb3J0aW9uIGlzIGhpZ2hlciB0aGFuIHRoZSBjb25maWRlbmNlIGxldmVsLiAgTm90IHN1cmUgb2YgdGhlIHJlYXNvbi4gDQoNCiMjIyBFeGVyY2lzZSA3DQoNCmBgYHtyfQ0Kc2FtcCAlPiUNCiAgc3BlY2lmeShyZXNwb25zZSA9IGNsaW1hdGVfY2hhbmdlX2FmZmVjdHMsIHN1Y2Nlc3MgPSAiWWVzIikgJT4lDQogIGdlbmVyYXRlKHJlcHMgPSAxMDAwLCB0eXBlID0gImJvb3RzdHJhcCIpICU+JQ0KICBjYWxjdWxhdGUoc3RhdCA9ICJwcm9wIikgJT4lDQogIGdldF9jaShsZXZlbCA9IDAuNSkNCmBgYA0KDQpJIHdvdWxkIGV4cGVjdCB0aGUgaW50ZXJ2YWwgdG8gYmUgbmFycm93ZXIgYmVjYXVzZSB0aGUgY29uZmlkZW5jZSBsZXZlbCBpcyBsb3dlci4gIA0KDQojIyMgRXhlcmNpc2UgOA0KDQpJIGNob3NlIDUwJSBjb25maWRlbmNlIGxldmVsIGFuZCB0aGUgYm91bmRhcmllcyB3ZXJlIHZlcnkgbmFycm93LiAgSSBleHBlY3QgdGhpcyB0byBiZSBkdWUgdG8gdGhlIGZhY3QgdGhhdCB3ZSByYWlzZWQgb3VyIHVuY2VydGFpbnR5Lg0KDQojIyMgRXhlcmNpc2UgOQ0KDQpgYGB7cn0NCmRmIDwtIGRhdGEuZnJhbWUoTkEsIE5BKQ0KDQpmb3IgKGkgaW4gMTo1MCkgeyAjcmVwZWF0IDUwIHRpbWVzDQogIHRlbXBfdmVjdG9yIDwtIHNhbXAgJT4lDQogICAgICAgICAgICAgICAgICAgICAgc3BlY2lmeShyZXNwb25zZSA9IGNsaW1hdGVfY2hhbmdlX2FmZmVjdHMsIHN1Y2Nlc3MgPSAiWWVzIikgJT4lDQogICAgICAgICAgICAgICAgICAgICAgZ2VuZXJhdGUocmVwcyA9IDEwMDAsIHR5cGUgPSAiYm9vdHN0cmFwIikgJT4lDQogICAgICAgICAgICAgICAgICAgICAgY2FsY3VsYXRlKHN0YXQgPSAicHJvcCIpICU+JQ0KICAgICAgICAgICAgICAgICAgICAgIGdldF9jaShsZXZlbCA9IDAuNTApICANCiAgaWYgKGkgPT0gMSkgeyANCiAgICBkZiA8LSB0ZW1wX3ZlY3RvciANCiAgfSBlbHNlIHsgDQogICAgZGYgPC0gcmJpbmQoZGYsIHRlbXBfdmVjdG9yKSAgDQogIH0NCg0KfQ0KDQogDQpkZiAlPiUNCiAgbXV0YXRlKHdpdGhpbl9yYW5nZSA9IGNhc2Vfd2hlbihsb3dlcl9jaSA8PSAwLjYyICYgdXBwZXJfY2kgPj0gMC42MiB+ICJZZXMiLA0KICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgIGxvd2VyX2NpID4gMC42MiB8IHVwcGVyX2NpIDwgLjYyIH4gIk5vIikpJT4lIA0KICBjb3VudCh3aXRoaW5fcmFuZ2UpICU+JQ0KICBtdXRhdGUocCA9IG4gL3N1bShuKSkNCmBgYA0KQnkgbG93ZXJpbmcgb3VyIGNvbmZpZGVuY2UgbGV2ZWwsIHdlIGdvdCBhIHByb3BvcnRpb24gb2Ygc2FtcGxlcyB3aXRoaW5nIHJhbmdlIG9mIDY4JSwgb3Bwb3NpdGUgdG8gdGhlIDEwMCUgd2UgZ290IGJlZm9yZS4gDQoNCiMjIyBFeGVyY2lzZSAxMA0KDQpgYGB7cn0NCmRmIDwtIGRhdGEuZnJhbWUoTkEsIE5BKQ0KDQpmb3IgKGkgaW4gMTo1MCkgeyAjcmVwZWF0IDUwIHRpbWVzDQogIHRlbXBfdmVjdG9yIDwtIHNhbXAgJT4lDQogICAgICAgICAgICAgICAgICAgICAgc3BlY2lmeShyZXNwb25zZSA9IGNsaW1hdGVfY2hhbmdlX2FmZmVjdHMsIHN1Y2Nlc3MgPSAiWWVzIikgJT4lDQogICAgICAgICAgICAgICAgICAgICAgZ2VuZXJhdGUocmVwcyA9IDEwMDAsIHR5cGUgPSAiYm9vdHN0cmFwIikgJT4lDQogICAgICAgICAgICAgICAgICAgICAgY2FsY3VsYXRlKHN0YXQgPSAicHJvcCIpICU+JQ0KICAgICAgICAgICAgICAgICAgICAgIGdldF9jaShsZXZlbCA9IDAuMjApICANCiAgaWYgKGkgPT0gMSkgeyANCiAgICBkZiA8LSB0ZW1wX3ZlY3RvciANCiAgfSBlbHNlIHsgDQogICAgZGYgPC0gcmJpbmQoZGYsIHRlbXBfdmVjdG9yKSAgDQogIH0NCg0KfQ0KDQogDQpkZiAlPiUNCiAgbXV0YXRlKHdpdGhpbl9yYW5nZSA9IGNhc2Vfd2hlbihsb3dlcl9jaSA8PSAwLjYyICYgdXBwZXJfY2kgPj0gMC42MiB+ICJZZXMiLA0KICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgIGxvd2VyX2NpID4gMC42MiB8IHVwcGVyX2NpIDwgLjYyIH4gIk5vIikpJT4lIA0KICBjb3VudCh3aXRoaW5fcmFuZ2UpICU+JQ0KICBtdXRhdGUocCA9IG4gL3N1bShuKSkNCmBgYA0KV2hlbiBJIHRyeSAyMCUgY29uZmlkZW5jZSBsZXZlbCwgSSBkb24ndCBnZXQgYSBzaW5nbGUgb2JzZXJ2YXRpb24gdG8gYWdyZWUgd2l0aCB0aGUgcmVhbCBwcm9wb3J0aW9uLiANCg0KDQoNCg0KDQouLi4NCg0K