Zhiguang Huo (Caleb)
Monday November 4th, 2019
Simulation (a.k.a Monte Carlo simulation):
Why we need simulation studies
Typical Monte Carlo simulation involves the following procedures:
Illustration:
\(X \sim f(\theta)\), \(T = T(X)\), where \(T\) is an estimator, or a procedure
Note: 20% trimmed mean indicates average value after deleting first 10% quantile and last 10% quantile.
E.g. 1,2,…,10
k: estimator index, including: mean, median, mean20%
\[T^{mean} = \frac{1}{n}\sum_{i=1}^n X_i\]
Can be calculated analytically
\[T^{median} = Median_{i=1}^n X_i\]
Variance is hard to be calculated analytically
Can be calculated
\[T^{mean20\%} = \frac{1}{0.8n}\sum_{i=0.1n+1}^{0.9n} X_i\]
Variance is hard to be calculated analytically
No analytic solution, we can evaluate using simulation studies.
mu <- 1; B <- 1000; n <- 20
Ts <- matrix(0,nrow=B,ncol=3)
colnames(Ts) <- c("mean", "median", "mean 20% trim")
for(b in 1:B){
set.seed(b)
x <- rnorm(n, mean = mu)
Ts[b,1] <- mean(x)
Ts[b,2] <- median(x)
Ts[b,3] <- mean(x, trim = 0.1)
}
bias <- abs(apply(Ts,2,function(x) mean(x) - mu))
vars <- apply(Ts,2,var)
MSE <- bias^2 + vars
RE <- MSE[1]/MSE
comparisonTable <- rbind(bias, vars, MSE, RE)
colnames(comparisonTable) <- c("mean", "median", "mean 20% trim")
comparisonTable
## mean median mean 20% trim
## bias 3.832736e-05 0.006673072 0.000688909
## vars 5.174830e-02 0.074680145 0.054550469
## MSE 5.174830e-02 0.074724675 0.054550944
## RE 1.000000e+00 0.692519633 0.948623449
mu <- 1; B <- 1000; n <- 20
Ts <- matrix(0,nrow=B,ncol=3)
colnames(Ts) <- c("mean", "median", "mean 20% trim")
for(b in 1:B){
set.seed(b)
x <- rexp(n, rate = mu)
Ts[b,1] <- mean(x)
Ts[b,2] <- median(x)
Ts[b,3] <- mean(x, trim = 0.1)
}
bias <- abs(apply(Ts,2,function(x) mean(x) - mu))
vars <- apply(Ts,2,var)
MSE <- bias^2 + vars
RE <- MSE[1]/MSE
comparisonTable <- rbind(bias, vars, MSE, RE)
colnames(comparisonTable) <- c("mean", "median", "mean 20% trim")
comparisonTable
## mean median mean 20% trim
## bias 0.01040018 0.26539760 0.13243138
## vars 0.05021121 0.05052217 0.04247023
## MSE 0.05031938 0.12095806 0.06000830
## RE 1.00000000 0.41600681 0.83854029
Assume \(X \sim Cauchy(\mu,\gamma)\) with \(\mu = 0\) and \(\gamma = 1\). \[f(x; \mu, \gamma) = \frac{1}{\pi (1 + x^2)}\]
mu <- 0; B <- 1000; n <- 20
Ts <- matrix(0,nrow=B,ncol=3)
colnames(Ts) <- c("mean", "median", "mean 20% trim")
for(b in 1:B){
set.seed(b)
x <- rcauchy(n, location = mu)
Ts[b,1] <- mean(x)
Ts[b,2] <- median(x)
Ts[b,3] <- mean(x, trim = 0.1)
}
bias <- abs(apply(Ts,2,function(x) mean(x) - mu))
vars <- apply(Ts,2,var)
MSE <- bias^2 + vars
RE <- MSE[1]/MSE
comparisonTable <- rbind(bias, vars, MSE, RE)
colnames(comparisonTable) <- c("mean", "median", "mean 20% trim")
comparisonTable
## mean median mean 20% trim
## bias 0.1187952 5.811866e-03 2.969290e-03
## vars 742.5037597 1.467307e-01 3.738797e-01
## MSE 742.5178721 1.467645e-01 3.738885e-01
## RE 1.0000000 5.059247e+03 1.985934e+03
Uniformly minimum-variance unbiased estimator (UMVUE) is an unbiased estimator that has lower variance than any other unbiased estimator for all possible values of the parameter.
Blue: the best linear unbiased estimator (BLUE) of the coefficients is given by the ordinary least squares (OLS) estimator,
\[\hat{\beta}^{ols} = \arg \min_\beta \frac{1}{2}\|y - X\beta\|^2_2\]
Modern statistics care about both bias and variance of an estimator instead of only unbiased estimator.
Lasso estimator
\[\hat{\beta}^{lasso} = \arg \min_\beta \frac{1}{2} \|y - X\beta\|^2_2 + \lambda \|\beta\|_1\]
Model setup:
Goal:
## Loaded lars 1.2
beta0 <- 1; beta1 <- 3; beta2 <- 5
beta3 <- beta4 <- beta5 <- 0
beta <- c(beta0,beta1,beta2,beta3,beta4,beta5)
p <- 5; n <- 30
set.seed(32611)
X0 <- matrix(rnorm(p*n),nrow=n)
X <- cbind(1, X0) ## X fixed
Y0 <- X %*% as.matrix(beta, ncol=1)
B <- 1000
beta_ols <- replicate(n = B, expr = list())
beta_lasso <- replicate(n = B, expr = list())
for(b in 1:B){
set.seed(b)
error <- rnorm(length(Y0), sd = 3)
Y <- Y0 + error
abeta_ols <- lm(Y~X0)$coefficients
beta_ols[[b]] <- abeta_ols
alars <- lars(x = X, y = Y, intercept=F)
beta_lasso[[b]] <- alars
}
beta_ols_hat <- Reduce("+",beta_ols)/length(beta_ols)
beta_ols_bias <- sqrt(sum((beta_ols_hat - beta)^2))
beta_ols_variance <- sum(Reduce("+", lapply(beta_ols,function(x) (x - beta_ols_hat)^2))/(length(beta_ols) - 1))
beta_ols_MSE <- beta_ols_bias + beta_ols_variance
as <- seq(0,10,0.1)
lassoCoef <- lapply(beta_lasso, function(alars){
alassoCoef <- t(coef(alars, s=as, mode="lambda"))
alassoCoef
} )
beta_lasso_hat <- Reduce("+",lassoCoef)/length(lassoCoef)
beta_lasso_bias <- sqrt(colSums((beta_lasso_hat - beta)^2))
beta_lasso_variance <- colSums(Reduce("+", lapply(lassoCoef,function(x) (x - beta_lasso_hat)^2))/(length(beta_ols) - 1))
beta_lasso_MSE <- beta_lasso_bias + beta_lasso_variance
par(mfrow=c(2,2))
plot(x = as, y = beta_lasso_bias, type = "l", xlab="lambda", main="bias")
abline(h = beta_ols_bias, lty=2)
legend("topleft", legend = c("lasso", "OLS"), col = 1, lty = c(1,2))
plot(x = as, y = beta_lasso_variance, col=4, type = "l", xlab="lambda", main="variance")
abline(h = beta_ols_variance, lty=2, col=4)
legend("bottomleft", legend = c("lasso", "OLS"), col = 4, lty = c(1,2))
plot(x = as, y = beta_lasso_MSE, col=2, type = "l", xlab="lambda", main="MSE")
abline(h = beta_ols_MSE, lty=2, col=2)
legend("topleft", legend = c("lasso", "OLS"), col = 2, lty = c(1,2))
plot(x = as, y = beta_lasso_MSE, ylim = c(min(beta_lasso_bias), max(beta_lasso_MSE)),
type="n", xlab="lambda", main="MSE = bias^2 + variance")
lines(x = as, y = beta_lasso_MSE, type = "l", col=2)
lines(x = as, y = beta_lasso_variance, col=4)
lines(x = as, y = beta_lasso_bias, col=1)
legend("bottomright", legend = c("bias", "variance", "MSE"), col = c(1,4,2), lty = c(1))
Consider the following tests:
Consider using the following simulation setting
alpha <- 0.05; mu=0; n <- 20; B <- 1000
counts <- 0
for(b in 1:B){
set.seed(b)
x <- rnorm(n, mean=mu)
atest <- t.test(x)
if(atest$p.value < alpha){
counts <- counts + 1
}
}
counts/B
## [1] 0.05
alpha <- 0.05; mu=0; n <- 20; B <- 1000
counts <- 0
for(b in 1:B){
set.seed(b)
x <- rnorm(n, mean=mu)
atest <- wilcox.test(x)
if(atest$p.value < alpha){
counts <- counts + 1
}
}
counts/B
## [1] 0.047
alpha <- 0.05; mu=0; n <- 20; B <- 1000
counts <- 0
for(b in 1:B){
set.seed(b)
x <- rnorm(n, mean=mu)[1:10]
atest <- t.test(x)
if(atest$p.value < alpha){
counts <- counts + 1
}
}
counts/B
## [1] 0.056
alpha <- 0.05; mu=0; mu1 <- 1; n <- 20; B <- 1000
counts <- 0
for(b in 1:B){
set.seed(b)
x <- rnorm(n, mean=mu1)
atest <- t.test(x)
if(atest$p.value < alpha){
counts <- counts + 1
}
}
counts / B
## [1] 0.985
library(pwr)
alpha <- 0.05; mu=0; mu1 <- 1; n <- 20; B <- 1000
pwr.t.test(n = n, d = mu1, sig.level = alpha, type = "one.sample", alternative = "two.sided")
##
## One-sample t test power calculation
##
## n = 20
## d = 1
## sig.level = 0.05
## power = 0.9885913
## alternative = two.sided
alpha <- 0.05; mu=0; mu1 <- 1; n <- 20; B <- 1000
counts <- 0
for(b in 1:B){
set.seed(b)
x <- rnorm(n, mean=mu1)
atest <- wilcox.test(x)
if(atest$p.value < alpha){
counts <- counts + 1
}
}
counts / B
## [1] 0.979
alpha <- 0.05; mu=0; mu1 <- 1; n <- 20; B <- 1000
counts <- 0
for(b in 1:B){
set.seed(b)
x <- rnorm(n, mean=mu1)[1:10]
atest <- t.test(x)
if(atest$p.value < alpha){
counts <- counts + 1
}
}
counts / B
## [1] 0.805
In general, the larger sample sizes, the larger power.
alpha <- 0.05; mu=0; mu1 <- 1; n <- 20; B <- 1000
pwr.t.test(n = 10, d = mu1, sig.level = alpha, type = "one.sample", alternative = "two.sided")
##
## One-sample t test power calculation
##
## n = 10
## d = 1
## sig.level = 0.05
## power = 0.8030969
## alternative = two.sided
Size of a test: Generate data under \(H_0\), at alpha level 0.05, the proportation of rejecting \(H_0\) is the size of a test
Power of a test: Generate data under \(H_A\), at alpha level 0.05, the proportation of rejecting \(H_0\) is the power of a test
A \(1 - \alpha\) confidence interval for parameter \(\mu\) is an interval \(C_n = (a,b)\) where \(a = a(X_1, \ldots, X_n)\) and \(b = b(X_1, \ldots, X_n)\) are functions of the data such that \[P(\mu \in C_n) \ge 1 - \alpha\] In other words, \((a,b)\) traps \(\mu\) with probability \(1 - \alpha\). We call \(1 - \alpha\) the coverage of the confidence interval.
Interpretation:
mu <- 1
B <- 1000
n <- 10
x <- rnorm(n, mean=mu)
c(mean(x) - qt(0.975, n-1) * sd(x) / sqrt(n), mean(x) + qt(0.975, n-1) * sd(x) / sqrt(n))
## [1] 0.400803 2.219041
##
## One Sample t-test
##
## data: x
## t = 3.2595, df = 9, p-value = 0.009847
## alternative hypothesis: true mean is not equal to 0
## 95 percent confidence interval:
## 0.400803 2.219041
## sample estimates:
## mean of x
## 1.309922
counts <- 0
for(b in 1:B){
set.seed(b)
x <- rnorm(n, mean=mu)
atest <- t.test(x)
if(atest$conf.int[1] < mu & mu < atest$conf.int[2]){
counts <- counts + 1
}
}
counts/B
## [1] 0.944
Performance for large \(n\), (e.g., \(n=100\))
\(95\%\) confidence interval: \((\bar{X} - 1.96 \times \frac{\hat{\sigma}}{\sqrt{n}}, \bar{X} + 1.96 \times \frac{\hat{\sigma}}{\sqrt{n}})\)
set.seed(32611)
B <- 1000 ## number of test
counts <- 0 ## number of accepted tests
n <- 100
mu <- 1
alpha <- 0.05
for(b in 1:B){
x <- rnorm(n, mean=mu, sd = 1)
lb <- mean(x) - qnorm(alpha/2, lower.tail = F) * sd(x)/sqrt(n)
ub <- mean(x) + qnorm(alpha/2, lower.tail = F) * sd(x)/sqrt(n)
if(lb < mu & ub > mu){
counts <- counts + 1
}
}
print(counts/B)
## [1] 0.945
behavior in small sample sizes (e.g., \(n=10\))
\(95\%\) confidence interval: \((\bar{X} - 1.96 \times \frac{\hat{\sigma}}{\sqrt{n}}, \bar{X} + 1.96 \times \frac{\hat{\sigma}}{\sqrt{n}})\)
set.seed(32611)
B <- 1000 ## number of test
counts <- 0 ## number of accepted tests
n <- 10
mu <- 1
alpha <- 0.05
for(b in 1:B){
x <- rnorm(n, mean=mu, sd = 1)
lb <- mean(x) - qnorm(alpha/2, lower.tail = F) * sd(x)/sqrt(n)
ub <- mean(x) + qnorm(alpha/2, lower.tail = F) * sd(x)/sqrt(n)
if(lb < mu & ub > mu){
counts <- counts + 1
}
}
print(counts/B)
## [1] 0.909
Problem setting:
\[T = | \frac {\sum_{i = 1}^NZ_i I(L_i=1)} {\sum_{i = 1}^N I(L_i=1)} - \frac {\sum_{i = 1}^NZ_i I(L_i=2)} {\sum_{i = 1}^N I(L_i=2)} |,\] where \(N = n + m\). Therefore the test statistic \(T = g(L,Z)\) is a function of \(L\) and \(Z\).
where \(L_\pi\) is a permutation of the labels and the sum is over all permutations.
Sometimes summing over all possible permutations is infeasible. But it suffices to use a random sample of permutation.
Permutation test procedure:
If we observe \(X_1, \ldots, X_n\) and \(Y_1, \ldots, Y_m\), how can we test if the mean of \(X\) and mean of \(Y\) have a difference.
n <- 100
m <- 100
set.seed(32611)
x <- rnorm(n,0,1)
y <- rnorm(n,0,2)
adataFrame <- data.frame(data=c(x,y),label=gl(2,n))
T <- with(adataFrame, mean(data[label==1] - data[label==2]))
B <- 1000
TB <- numeric(B)
for(b in 1:B){
set.seed(b)
bdataFrame <- adataFrame
bdataFrame$label <- sample(bdataFrame$labe)
TB[b] <- with(bdataFrame, mean(data[label==1] - data[label==2]))
}
pvalue = mean(TB >= T)
pvalue
## [1] 0.353
\(\begin{aligned} P(\mbox{at least one significant result}) &= 1 - P(\mbox{no significant result}) \\ & = 1 - (1 - 0.05)^{20} \\ & \approx 0.64 \\ \end{aligned}\)
\(\begin{aligned} P(\mbox{at least one significant result}) &= 1 - P(\mbox{no significant result}) \\ & = 1 - (1 - 0.0025)^{20} \\ & \approx 0.0488 \\ \end{aligned}\)
Under the null hypothesis, the p-values follow \(U(0,1)\).
B <- 1000
n <- 20 ## number of tests
N <- 15 ## number of samples per test
alpha <- 0.05
count <- 0
for(b in 1:B){
set.seed(b)
ax <- replicate(n, rnorm(N),simplify = F)
ap <- sapply(ax,function(avec) t.test(avec)$p.value)
if(any(ap < alpha/n)){
count <- count + 1
}
}
count/B
## [1] 0.045
qvalue <- p.adjust(pval, "BH")
test_fdr <- qvalue < 0.05
table_fdr <- table(SigLabel, test_fdr)
table_fdr
## test_fdr
## SigLabel FALSE TRUE
## 0 8951 49
## 0.0828389118685122 27 973
## [1] 0.04794521
## test_raw
## SigLabel FALSE TRUE
## 0 8562 438
## 0.0828389118685122 0 1000
fpr_raw <- sum(test_raw & !SigLabel) / sum(test_raw)
fnr_raw <- sum(!test_raw & SigLabel) / sum(!test_raw)
fpr_raw
## [1] 0.3045897
## [1] 0
test_bonferroni <- pval < 0.05/length(pval)
table_bonferroni <- table(SigLabel, test_bonferroni)
table_bonferroni
## test_bonferroni
## SigLabel FALSE TRUE
## 0 9000 0
## 0.0828389118685122 862 138
fpr_bonferroni <- sum(test_bonferroni & !SigLabel) / sum(test_bonferroni)
fnr_bonferroni <- sum(!test_bonferroni & SigLabel) / sum(!test_bonferroni)
fpr_bonferroni
## [1] 0
## [1] 0.08740621
qvalue <- p.adjust(pval, "BH")
test_fdr <- qvalue < 0.05
table_fdr <- table(SigLabel, test_fdr)
table_fdr
## test_fdr
## SigLabel FALSE TRUE
## 0 8951 49
## 0.0828389118685122 27 973
fpr_fdr <- sum(test_fdr & !SigLabel) / sum(test_fdr)
fnr_fdr <- sum(!test_fdr & SigLabel) / sum(!test_fdr)
fpr_fdr
## [1] 0.04794521
## [1] 0.003007351