canvasCIProp <- setRefClass("canvasCIPropClass", contains = "canvasPlotClass",
methods = list(
calcStat = function(i = which.sample, y = NULL, canvas = .self) {
if (stat.method == "normal: +/- t s.e.") {
calcPropTCIWald(samples[[i]], y, canvas)
} else if (stat.method == "normal: +/- 2 s.e.") {
calcPropCI2Wald(samples[[i]], y, canvas)
} else if (stat.method == "normal: +/- 1/sqrt(n)") {
calcPropCIRootN(samples[[i]], y, canvas)
} else if (stat.method == "bootstrap: percentile") {
calcCIBootPercProp(samples[[i]], y, canvas)
} else if (stat.method == "bootstrap: +/- 2 s.e.") {
calcCIBootSEMeanProp(samples[[i]], y, canvas)
} else if (stat.method == "bootstrap: +/- t s.e.") {
calcCIBootTSEMeanProp(samples[[i]], y, canvas)
}
},
calcAllStats = function(x, y = NULL, canvas = .self) {
if (stat.method == "normal: +/- t s.e.") {
calcPropTCIWald(x, y, canvas)
} else if (stat.method == "normal: +/- 2 s.e.") {
calcPropCI2Wald(x, y, canvas)
} else if (stat.method == "normal: +/- 1/sqrt(n)") {
calcPropCIRootN(x, y, canvas)
} else if (stat.method == "bootstrap: percentile") {
calcCIBootPercProp(x, y, canvas)
} else if (stat.method == "bootstrap: +/- 2 s.e.") {
calcCIBootSEMeanProp(x, y, canvas)
} else if (stat.method == "bootstrap: +/- t s.e.") {
calcCIBootTSEMeanProp(x, y, canvas)
}
},
plotSample = function(env, i = which.sample) {
plotCISampleProportions(.self, env, i)
},
showLabels = function() {
ciLabels(.self)
},
plotDataStat = function(env, ...) {
addPropLine(.self, env)
},
plotSampleStat = function(env, i = which.sample, ...) {
plotPropCI(.self, env, i, ...)
},
plotStatDist = function(env, ...) {
plotCIDistPropMean(.self, env)
},
animateSample = function(...) {
dropPointsProp(.self, ...)
},
animateStat = function(env, n.steps) {
dropCI(.self, env, n.steps)
},
displayResult = function(env, cov.message) {
CIcounter(.self, env, cov.message, fun = mean)
},
handle1000 = function(env, ...) {
ci1000(.self, env, fun = NULL)
}))
load_CI_proportion <- function(e) {
confidence_check(e)
e$c1$stat.in.use <- svalue(e$stat)
e$cimethod <- svalue(e$cimeth)
e$c1$stat.method <- e$cimethod
# There is something messy going on with viewports and
# gTrees, such that when attempting to import them, we
# end up with "uninitializedField"s. Assign to a temp
# var and reassign later.
tmp.vps <- e$c1$viewports
tmp.image <- e$c1$image
e$c1$viewports <- NULL
e$c1$image <- NULL
tmp.canvas <- canvasCIProp$new()
tmp.canvas$import(e$c1)
e$c1 <- tmp.canvas
e$c1$viewports <- tmp.vps
e$c1$image <- tmp.image
e$results <- NULL
}
plotCISampleProportions <- function(canvas, e, i) {
canvas$rmGrobs(c("dataPlot.ci.1", "samplePlot.propbar.1", "samplePlot.stat.1"))
x <- canvas$samples[[i]]
x[x != canvas$loi] <- canvas$loi.alt
canvas$image <- addGrob(canvas$image,
propbarGrob(data = x,
y = 0.1,
height = 0.4,
draw.points = length(canvas$x) < 100,
lois = c(canvas$loi, canvas$loi.alt),
name = "samplePlot.propbar.1",
vp = canvas$graphPath("sample")))
}
calcPropTCIWald <- function(x, y = NULL, canvas) {
n <- length(x)
x <- as.character(x)
loiN <- length(x[x == canvas$loi])
prop <- loiN / n
se <- sqrt((prop * (1 - prop)) / n)
prop + c(-1, 1) * qt(0.975, n - 1) * se
}
calcPropCI2Wald <- function(x, y = NULL, canvas) {
n <- length(x)
x <- as.character(x)
loiN <- length(x[x == canvas$loi])
prop <- loiN / n
se <- sqrt((prop * (1 - prop)) / n)
prop + c(-2, 2)*se
}
calcPropCIRootN <- function(x, y = NULL, canvas) {
n <- length(x)
x <- as.character(x)
prop <- mean(x == canvas$loi)
prop + c(-1, 1) * (1 / sqrt(n))
}
calcCIBootPercProp <- function(x, y = NULL, canvas) {
n <- length(x)
nboots <- 999
samps <- matrix(sample(x, size = nboots*n, replace = TRUE),
nrow = nboots, ncol = n)
props <- apply(samps, 1, function(obs) {
obsx <- as.character(obs)
loiN <- length(obsx[obsx == canvas$loi])
prop <- loiN / length(obs)
prop
})
quantile(props, prob = c(0.025, 0.975), type = 1)
}
calcCIBootSEMeanProp <- function(x, y = NULL, canvas) {
n <- length(x)
nboots <- 1000
samps <- matrix(sample(x, size = nboots*n, replace = TRUE),
nrow = nboots, ncol = n)
props <- apply(samps, 1, function(obs) {
obsx <- as.character(obs)
loiN <- length(obsx[obsx == canvas$loi])
prop <- loiN / length(obs)
prop
})
se <- sd(props)
mean(props) + c(-2, 2) * se
}
calcCIBootTSEMeanProp <- function(x, y = NULL, canvas) {
n <- length(x)
nboots <- 1000
samps <- matrix(sample(x, size = nboots*n, replace = TRUE), nrow = nboots,
ncol = n)
props <- apply(samps, 1, function(obs) {
obsx <- as.character(obs)
loiN <- length(obsx[obsx == canvas$loi])
prop <- loiN / length(obs)
prop
})
se <- sd(props)
mean(props) + c(-1, 1) * qt(0.975, n - 1) * se
}
addPropLine <- function(canvas, e) {
x <- canvas$loi.data
n <- length(x)
loiN <- length(x[x == canvas$loi])
prop <- loiN / n
canvas$image <- addGrob(canvas$image,
segmentsGrob(x0 = prop, x1 = prop, y0 = 0,
y1 = 3, default.units = "native",
gp = gpar(col = "grey60", lty = "dashed"),
vp = canvas$graphPath("animation.field"),
name = "hline"))
}
plotPropCI <- function(canvas, e, i, pause = FALSE) {
if (pause){
method <- strsplit(svalue(e$cimeth), ":")[[1]][1]
ciCalcLabel <- textGrob(paste("Calculating", method, "CI..."),
x = unit(0.5, "npc"), y = unit(0.6, "npc"),
just = c("centre", "top"), vp = canvas$graphPath("sample"),
gp = gpar(fontface = 2), name = "samplePlot.ciCalcLabel")
canvas$image <- addGrob(canvas$image, ciCalcLabel)
if (canvas$stopAnimation)
return()
canvas$pauseImage(15)
canvas$rmGrobs("samplePlot.ciCalcLabel")
}
bounds <- canvas$stat.dist[[i]]
x <- mean(bounds)
if (x == 0 | x == 1) {
canvas$image <- addGrob(canvas$image,
rectGrob(x = unit(x, "native"), y = unit(0.2, "native"),
width = unit(0.005, "native"),
height = unit(0.03, "native"),
gp = gpar(col = "red", fill = "red"),
vp = canvas$graphPath("sample"),
name = "samplePlot.stat.1"))
} else {
canvas$image <- addGrob(canvas$image,
rectGrob(x = unit(x, "native"), y = unit(0.2, "native"),
width = unit(diff(bounds), "native"),
height = unit(0.015, "native"),
gp = gpar(col = "#FF7F00",
fill = "#FF7F00"), vp = canvas$graphPath("sample"),
name = "samplePlot.stat.1"))
}
}
plotCIDistPropMean <- function(canvas, e) {
i <- canvas$which.sample
bounds <- canvas$getStat(i)
x <- mean(bounds)
data <- as.character(canvas$loi.data)
n <- length(data)
loiN <- length(data[data == canvas$loi])
X <- loiN / n
if (X >= bounds[1] & X <= bounds[2]) color <- "green" else color <- "red"
current <- data.frame(x = x, width = diff(c(bounds)), color = color)
if ("statPlot.stat.dist" %in% childNames(canvas$image)) {
dist.grob <- getGrob(canvas$image, gPath(c("statPlot.stat.dist")))
dist.df <- dist.grob$data
if (nrow(dist.df) >= 40) dist.df <- dist.df[-1,]
dist.df <- rbind(dist.df[, -4], current)
} else dist.df <- current
dist.df$y <- 0.02 * 1:nrow(dist.df)
green <- dist.df[dist.df$color == "green",]
red <- dist.df[dist.df$color == "red",]
if (nrow(green) > 0) {
greenRects <- rectGrob(x = unit(green$x, "native"),
y = unit(green$y, "native"), width = unit(green$width, "native"),
height = unit(0.015, "native"), vp = canvas$graphPath("stat"),
gp = gpar(col = NA, fill = "green"))
} else greenRects <- NULL
if (nrow(red) > 0) {
red$width <- ifelse(red$width == 0 | red$width == 1, 0.005, red$width)
redRects <- rectGrob(x = unit(red$x, "native"),
y = unit(red$y, "native"), width = unit(red$width, "native"),
height = unit(0.015, "native"), vp = canvas$graphPath("stat"),
gp = gpar(col = NA, fill = "red"))
} else redRects <- NULL
new.dist <- gTree(data = dist.df, name = "statPlot.stat.dist",
childrenvp = canvas$viewports, children = gList(greenRects, redRects))
canvas$image <- addGrob(canvas$image, new.dist)
}
dropPointsProp <- function(canvas, n.steps, n.slow, keep.plot, move = TRUE) {
canvas$rmGrobs(c("samplePlot.points.1", "samplePlot.points",
"samplePlot.propbar.1", "samplePlot.stat.1", "samplePlot.datapoints.1"))
index <- canvas$indexes[[canvas$which.sample]]
x <- canvas$x[index]
if (move) {
sampSelectLabel <- textGrob("Selecting sample...", x = unit(0.5, "npc"), y = unit(0.6, "npc"),
just = c("centre", "top"), vp = canvas$graphPath("sample"),
gp = gpar(fontface = 2), name = "samplePlot.sampSelectLabel")
canvas$image <- addGrob(canvas$image, sampSelectLabel)
}
# Grabbing point positions from data prop grob
dp <- getGrob(canvas$image, gPath("dataPlot"))
# When we have points available to us, attempt to accurately
# animate between the data and the sample.
if (dp$points.present) {
dpx <- dp$x[index]
dpy <- dp$y[index]
seekViewport("data.data.1")
dpx <- convertX(dpx, "native", valueOnly = TRUE)
dpy <- convertY(dpy, "native", valueOnly = TRUE)
upViewport(0)
# Creating sample prop grob to get point positions from
sp <- propbarGrob(data = x,
y = 0.1,
height = 0.4,
lois = c(canvas$loi, canvas$loi.alt),
name = "samplePlot",
vp = canvas$graphPath("sample"))
spx <- sp$x
spy <- sp$y
seekViewport("sample.data.1")
spx <- convertX(spx, "native", valueOnly = TRUE)
spy <- convertY(spy, "native", valueOnly = TRUE)
upViewport(0)
y.start <- dpy + 2
y.end <- spy + 1
y.step <- (y.end - y.start)/n.steps
x.step <- (spx - dpx) / n.steps
n.slow <- min(n.slow, length(x))
# Lighting up of sampled points.
cols <- ifelse(x == canvas$loi, "deepskyblue", "red3")
if (move) {
for (i in 1:length(x)) {
canvas$image <- addGrob(canvas$image,
pointsGrob(dpx[1:i], y = dpy[1:i],
vp = canvas$graphPath("data"),
pch = 19,
gp = gpar(col = cols),
name = "samplePlot.data.samp"))
speed <- if (i <= n.slow) 10 else 1
if (canvas$stopAnimation)
return()
canvas$pauseImage(speed)
}
if (canvas$stopAnimation)
return()
canvas$pauseImage(20)
}
canvas$image <- addGrob(canvas$image,
pointsGrob(dpx, y = dpy, vp = canvas$graphPath("data"),
pch = 19,
gp = gpar(col = cols),
name = "samplePlot.data.samp"))
# Dropping of points.
if (move){
for (i in 1:n.steps){
y.pos <- y.start + (y.step * i)
x.pos <- dpx + (x.step * i)
canvas$image <- addGrob(canvas$image,
pointsGrob(x.pos, y.pos, vp = canvas$graphPath("animation.field"),
gp = gpar(col = cols),
pch = 19, name = "samplePlot.temp"))
if (canvas$stopAnimation)
return()
canvas$drawImage()
}
canvas$pauseImage(10)
canvas$rmGrobs(c("samplePlot.sampSelectLabel", "samplePlot.temp"))
plotCISampleProportions(canvas, NULL, canvas$which.sample)
canvas$pauseImage(10)
}
canvas$image <- removeGrob(canvas$image, gPath("samplePlot.data.samp"))
} else {
# In the case where we don't have access to points,
# just make up random locations.
dataProp <- dp$p
depth <- downViewport("data.data.1")
point.width <- convertWidth(unit(1, "char"), "npc", valueOnly = TRUE)
point.height <- convertHeight(unit(1, "char"), "npc", valueOnly = TRUE)
upViewport(depth)
# Work out where the points are to be randomly
# allocated within each "bar"
leftBar.left <- point.width
leftBar.right <- dataProp - point.width
rightBar.left <- dataProp + point.width
rightBar.right <- 1 - point.width
bar.top <- 0.45 + 0.1 - point.height
bar.bottom <- 0.1 + point.height
# Creating sample prop grob to get prop from
sp <- propbarGrob(data = x,
y = 0.1,
height = 0.4,
draw.points = FALSE,
lois = c(canvas$loi, canvas$loi.alt),
name = "samplePlot",
vp = canvas$graphPath("sample"))
sampleProp <- sp$p
# Show no more than 100 points
n.points <- min(100, length(x))
n.left <- round(sampleProp * n.points)
n.right <- round((1 - sampleProp) * n.points)
# Generate left locations
lpx <- runif(n.left, leftBar.left, leftBar.right)
lpy <- runif(n.left, bar.bottom, bar.top)
# Generate right locations
rpx <- runif(n.right, rightBar.left, rightBar.right)
rpy <- runif(n.right, bar.bottom, bar.top)
# Will need to scale points to that they are able to
# fit within the sample propbar nicely.
# Will either be squeezing them closer together or spreading them apart
# horizontally, but vertically they will always be closer together.
# Scale factor from data -> sample
v.scale.factor <- (0.4 - 2*point.height) / (0.45 - 2*point.height)
left.scale.factor <- (sampleProp - 2*point.width) / (dataProp - 2*point.width)
right.scale.factor <- ((1 - sampleProp) - 2*point.width) / ((1 - dataProp) - 2*point.width)
# Turning into animation.field coordinates
lpy <- lpy + 2
rpy <- rpy + 2
# Vector of indices to select points from
point.inds <- sample(n.points)
data.py <- c(lpy, rpy)[point.inds]
data.px <- c(lpx, rpx)[point.inds]
sample.py <- ((data.py - 2 - point.height) * v.scale.factor) + 1 + point.height
sample.px <- sapply(data.px, function(x) {
if (x > dataProp) {
# Right group
((x - dataProp - point.width) * right.scale.factor) + point.width + sampleProp
} else {
# Left group
((x - point.width) * left.scale.factor) + point.width
}
})
# Lighting up of sampled points.
cols <- ifelse(point.inds > n.left, "red3", "deepskyblue")
if (move) {
for (i in 1:n.points) {
canvas$image <- addGrob(canvas$image,
pointsGrob(data.px[1:i], y = data.py[1:i],
vp = canvas$graphPath("animation.field"),
pch = 19,
gp = gpar(col = cols),
name = "samplePlot.data.samp"))
speed <- if (i <= n.slow) 10 else 1
if (canvas$stopAnimation)
return()
canvas$pauseImage(speed)
}
# Force pause before points drop.
if (canvas$stopAnimation)
return()
canvas$pauseImage(20)
}
canvas$image <- addGrob(canvas$image,
pointsGrob(x = data.px, y = data.py,
vp = canvas$graphPath("animation.field"),
pch = 19,
gp = gpar(col = cols),
name = "samplePlot.data.samp"))
x.step <- (sample.px - data.px) / n.steps
y.step <- (sample.py - data.py) / n.steps
# Dropping of points.
if (move){
for (i in 1:n.steps) {
y.pos <- data.py + (y.step * i)
x.pos <- data.px + (x.step * i)
dropped.points <- pointsGrob(x.pos, y.pos,
vp = canvas$graphPath("animation.field"),
gp = gpar(col = cols),
pch = 19, name = "samplePlot.temp")
canvas$image <- addGrob(canvas$image, dropped.points)
if (canvas$stopAnimation)
return()
canvas$drawImage()
}
canvas$pauseImage(10)
plotCISampleProportions(canvas, NULL, canvas$which.sample)
canvas$image <- addGrob(canvas$image, dropped.points)
if (canvas$stopAnimation)
return()
canvas$pauseImage(20)
canvas$rmGrobs(c("samplePlot.sampSelectLabel", "samplePlot.temp"))
}
canvas$rmGrobs("samplePlot.data.samp")
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.