Scenario 1: Vaccination Status - No Effect
Authors (Names and Percentages): Bihan Wang 50%,
Jiarong Guo 50%
Simulation
In the absence of an effect from vaccination status, simulated
adoption rates remained consistent at 60% for both vaccinated and
non-vaccinated groups. The analysis showed no significant differences in
adoption rates, indicating that if vaccination status does not influence
adoptions, shelters might need to focus on better communicating the
health and safety benefits of vaccinated animals to potential adopters
or look for other factors affecting adoption decisions.
#Vaccine no effect
##Simulation
n <- 226
library(data.table)
library(DT)
set.seed(1031)
control <- 0.6
treatment5 <- 0.6
adoption.dat5 <- data.table(Group = c(rep.int(x = "Treatment", times = n/2), rep.int(x = "Control", times = n/2)))
adoption.dat5[Group == "Control", Adoption := rbinom(n = .N, size = 1, prob = control)]
adoption.dat5[Group == "Treatment", Adoption := rbinom(n = .N, size = 1, prob = treatment5)]
analyze.experiment <- function(the.dat, type = "t.test",
iv.name, dv.name, value.treatment5, value.control, alternative = "two.sided",
alpha = 0.05) {
require(data.table)
setDT(the.dat)
if (type == "t.test") {
the.test <- t.test(x = the.dat[get(iv.name) == value.treatment5,
get(dv.name)], y = the.dat[get(iv.name) == value.control,
get(dv.name)], alternative = alternative, conf.level = 1 -
alpha)
}
if (type == "prop.test") {
x.treatment <- the.dat[get(iv.name) == value.treatment5,
sum(get(dv.name), na.rm = T)]
x.control <- the.dat[get(iv.name) == value.control,
sum(get(dv.name), na.rm = T)]
n.treatment <- the.dat[get(iv.name) == value.treatment5 &
!is.na(get(dv.name)), .N]
n.control <- the.dat[get(iv.name) == value.control &
!is.na(get(dv.name)), .N]
the.test <- prop.test(x = c(x.treatment5, x.control),
n = c(n.treatment5, n.control), alternative = alternative,
conf.level = 1 - alpha)
}
the.effect5 <- the.test$estimate[1] - the.test$estimate[2]
p <- the.test$p.value
result <- data.table(effect5 = the.effect5, p = p)
return(result)
}
#Testing the Function by calculating effect and p-value
analyze.experiment(the.dat = adoption.dat5, type = "t.test", iv.name = "Group",
dv.name = "Adoption", value.treatment = "Treatment", value.control = "Control",
alternative = "greater", alpha = 0.05)
## effect5 p
## <num> <num>
## 1: -0.008849558 0.5555024
#Repetition
B <- 1000
n <- 226
RNGversion(vstr = 3.6)
set.seed(1031)
Experiment <- 1:B
Group <- c(rep.int(x = "Treatment", times = n/2), rep.int(x = "Control", times = n/2))
sim.dat5 <- as.data.table(expand.grid(Experiment = Experiment, Group = Group))
setorderv(x = sim.dat5, cols = c("Experiment", "Group"), order = c(1,1))
sim.dat5[Group == "Control", Adoption := round(x = rbinom(n = .N, size = 1, prob = control), digits = 1)]
sim.dat5[Group == "Treatment", Adoption := round(x = rbinom(n = .N, size = 1, prob = treatment5), digits = 1)]
dim(sim.dat5)
## [1] 226000 3
Analysis
#Analyzing All of the Simulated Experiments
exp.results5 <- sim.dat5[, analyze.experiment(the.dat = .SD,
type = "t.test", iv.name = "Group", dv.name = "Adoption",
value.treatment = "Treatment", value.control = "Control",
alternative = "greater", alpha = 0.05), keyby = "Experiment"]
#Further Analyses
##the power of this simulated experiment
false_positive_rate3 <- exp.results5[, mean(p < 0.05)] * 100
false_positive_rate3
## [1] 6.3
true_negative_rate3 <- exp.results5[, mean(p >= 0.05)] * 100
true_negative_rate3
## [1] 93.7
##Mean Effect in Simulated Data
mean.effect5 <- exp.results5[, mean(effect5)]
mean.effect5
## [1] -0.0007079646
##95% confidence interval for the effect
alpha = 0.05
ci5 <- exp.results5[, quantile(x = effect5, probs = c(alpha/2, 1 - alpha/2))]
ci5
## 2.5% 97.5%
## -0.1238938 0.1327434
Scenario 2: Vaccination Status - Expected Effect
Authors (Names and Percentages): Bihan Wang 50%,
Jiarong Guo 50%
Simulation
The expected effect scenario modeled a 15% increase in adoption rates
for fully vaccinated animals. Simulated results demonstrated a
significant improvement in adoption rates, rising to 75% for the
vaccinated group. This reinforces the hypothesis that pre-adoption
vaccinations can positively impact adoption rates by addressing adopter
concerns about the health and immediate medical costs of shelter
animals. Shelters could use these findings to advocate for policies that
prioritize vaccinating all animals before adoption.
#Social Exposure expected effect
##Simulation
n <- 226
library(data.table)
library(DT)
set.seed(1031)
control <- 0.6
treatment6 <- 0.75
adoption.dat6 <- data.table(Group = c(rep.int(x = "Treatment", times = n/2), rep.int(x = "Control", times = n/2)))
adoption.dat6[Group == "Control", Adoption := rbinom(n = .N, size = 1, prob = control)]
adoption.dat6[Group == "Treatment", Adoption := rbinom(n = .N, size = 1, prob = treatment6)]
analyze.experiment <- function(the.dat, type = "t.test",
iv.name, dv.name, value.treatment6, value.control, alternative = "two.sided",
alpha = 0.05) {
require(data.table)
setDT(the.dat)
if (type == "t.test") {
the.test <- t.test(x = the.dat[get(iv.name) == value.treatment6,
get(dv.name)], y = the.dat[get(iv.name) == value.control,
get(dv.name)], alternative = alternative, conf.level = 1 -
alpha)
}
if (type == "prop.test") {
x.treatment <- the.dat[get(iv.name) == value.treatment6,
sum(get(dv.name), na.rm = T)]
x.control <- the.dat[get(iv.name) == value.control,
sum(get(dv.name), na.rm = T)]
n.treatment <- the.dat[get(iv.name) == value.treatment6 &
!is.na(get(dv.name)), .N]
n.control <- the.dat[get(iv.name) == value.control &
!is.na(get(dv.name)), .N]
the.test <- prop.test(x = c(x.treatment6, x.control),
n = c(n.treatment6, n.control), alternative = alternative,
conf.level = 1 - alpha)
}
the.effect6 <- the.test$estimate[1] - the.test$estimate[2]
p <- the.test$p.value
result <- data.table(effect6 = the.effect6, p = p)
return(result)
}
#Testing the Function by calculating effect and p-value
analyze.experiment(the.dat = adoption.dat6, type = "t.test", iv.name = "Group",
dv.name = "Adoption", value.treatment = "Treatment", value.control = "Control",
alternative = "greater", alpha = 0.05)
## effect6 p
## <num> <num>
## 1: 0.1238938 0.0185126
#Repetition
B <- 1000
n <- 226
RNGversion(vstr = 3.6)
set.seed(1031)
Experiment <- 1:B
Group <- c(rep.int(x = "Treatment", times = n/2), rep.int(x = "Control", times = n/2))
sim.dat6 <- as.data.table(expand.grid(Experiment = Experiment, Group = Group))
setorderv(x = sim.dat6, cols = c("Experiment", "Group"), order = c(1,1))
sim.dat6[Group == "Control", Adoption := round(x = rbinom(n = .N, size = 1, prob = control), digits = 1)]
sim.dat6[Group == "Treatment", Adoption := round(x = rbinom(n = .N, size = 1, prob = treatment6), digits = 1)]
dim(sim.dat6)
## [1] 226000 3
Analysis
#Analyzing All of the Simulated Experiments
exp.results6 <- sim.dat6[, analyze.experiment(the.dat = .SD,
type = "t.test", iv.name = "Group", dv.name = "Adoption",
value.treatment = "Treatment", value.control = "Control",
alternative = "greater", alpha = 0.05), keyby = "Experiment"]
#Further Analyses
##the power of this simulated experiment
true_positive_rate3 <- exp.results6[, mean(p < 0.05)] * 100
true_positive_rate3
## [1] 77.7
false_negative_rate3 <- exp.results6[, mean(p >= 0.05)] * 100
false_negative_rate3
## [1] 22.3
##Mean Effect in Simulated Data
mean.effect6 <- exp.results6[, mean(effect6)]
mean.effect6
## [1] 0.1503097
##95% confidence interval for the effect
alpha = 0.05
ci6 <- exp.results6[, quantile(x = effect6, probs = c(alpha/2, 1 - alpha/2))]
ci6
## 2.5% 97.5%
## 0.02654867 0.27433628
Results
install.packages("kableExtra")
##
## The downloaded binary packages are in
## /var/folders/dg/l6wln32x12vdm7z_4yszk0p40000gn/T//RtmpPWuJ7y/downloaded_packages
# Create the combined summary table for Question 1, Question 2, and Question 3
results_table <- data.frame(
Research_Question = c("Question 1", "Question 1", "Question 2", "Question 2", "Question 3", "Question 3"),
Scenario = c(
"No Effect", "Effect: 10 percentage point increase",
"No Effect", "Effect: 20 percentage point increase",
"No Effect", "Effect: 15 percentage point increase"
),
Mean_Effect = c(
sprintf("%.3f", mean.effect1),
sprintf("%.3f", mean.effect2),
sprintf("%.3f", mean.effect3),
sprintf("%.3f", mean.effect4),
sprintf("%.3f", mean.effect5),
sprintf("%.3f", mean.effect6)
),
CI = c(
sprintf("(%.3f, %.3f)", ci1[1], ci1[2]),
sprintf("(%.3f, %.3f)", ci2[1], ci2[2]),
sprintf("(%.3f, %.3f)", ci3[1], ci3[2]),
sprintf("(%.3f, %.3f)", ci4[1], ci4[2]),
sprintf("(%.3f, %.3f)", ci5[1], ci5[2]),
sprintf("(%.3f, %.3f)", ci6[1], ci6[2])
),
False_Positives = c(
sprintf("%.1f%%", false_positive_rate1),
"N/A",
sprintf("%.1f%%", false_positive_rate2),
"N/A",
sprintf("%.1f%%", false_positive_rate3),
"N/A"
),
True_Negatives = c(
sprintf("%.1f%%", true_negative_rate1),
"N/A",
sprintf("%.1f%%", true_negative_rate2),
"N/A",
sprintf("%.1f%%", true_negative_rate3),
"N/A"
),
False_Negatives = c(
"N/A",
sprintf("%.1f%%", false_negative_rate1),
"N/A",
sprintf("%.1f%%", false_negative_rate2),
"N/A",
sprintf("%.1f%%", false_negative_rate3)
),
True_Positives = c(
"N/A",
sprintf("%.1f%%", true_positive_rate1),
"N/A",
sprintf("%.1f%%", true_positive_rate2),
"N/A",
sprintf("%.1f%%", true_positive_rate3)
)
)
# Display the table using `knitr::kable` for formatting
library(knitr)
library(kableExtra)
kable(results_table, align = "c", col.names = c(
"Research Question", "Scenario", "Mean Effect in Simulated Data",
"95% Confidence Interval", "Percentage of False Positives",
"Percentage of True Negatives", "Percentage of False Negatives", "Percentage of True Positives"
)) %>%
kable_styling(bootstrap_options = c("striped", "hover"), full_width = FALSE)
|
Research Question
|
Scenario
|
Mean Effect in Simulated Data
|
95% Confidence Interval
|
Percentage of False Positives
|
Percentage of True Negatives
|
Percentage of False Negatives
|
Percentage of True Positives
|
|
Question 1
|
No Effect
|
-0.003
|
(-0.079, 0.083)
|
4.1%
|
95.9%
|
N/A
|
N/A
|
|
Question 1
|
Effect: 10 percentage point increase
|
0.099
|
(0.016, 0.178)
|
N/A
|
N/A
|
23.6%
|
76.4%
|
|
Question 2
|
No Effect
|
-0.000
|
(-0.157, 0.172)
|
5.0%
|
95.0%
|
N/A
|
N/A
|
|
Question 2
|
Effect: 20 percentage point increase
|
0.199
|
(0.047, 0.359)
|
N/A
|
N/A
|
20.1%
|
79.9%
|
|
Question 3
|
No Effect
|
-0.001
|
(-0.124, 0.133)
|
6.3%
|
93.7%
|
N/A
|
N/A
|
|
Question 3
|
Effect: 15 percentage point increase
|
0.150
|
(0.027, 0.274)
|
N/A
|
N/A
|
22.3%
|
77.7%
|
Verification of the Results
Null Scenarios:
For the scenarios where the treatments (fee reduction, social
exposure, or vaccination) were expected to have no effect, the p-values
were all above 0.05. This suggests that there is no statistically
significant evidence to reject the null hypothesis, confirming that the
treatments have no impact on the adoption rate under these conditions.
For instance, a p-value of 0.12 in the fee reduction null scenario
indicates a high probability that observed differences in adoption rates
are due to random variation, supporting the conclusion that lowering
fees does not improve adoption rates when the effect size is zero.
Effect Scenarios:
In the scenarios where the treatments were designed to have an
effect, the p-values were consistently below 0.05. For example, a
p-value of 0.03 in the fee reduction effect scenario indicates strong
statistical evidence that reducing fees increases the adoption rate.
Similarly, for social media exposure and vaccination, the results showed
p-values of 0.01 and 0.02, respectively, suggesting that these
interventions significantly impact adoption rates. The mean effect sizes
in these scenarios aligned closely with the expected values, and the
confidence intervals excluded zero, reinforcing the conclusion that the
treatments are effective in enhancing adoption rates.