diff --git a/DESCRIPTION b/DESCRIPTION
index 981bbe9..875c73e 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -52,7 +52,8 @@ Suggests:
remotes,
vpc,
rmarkdown,
- testthat (>= 2.1.0)
+ testthat (>= 2.1.0),
+ vdiffr (>= 1.0.0)
License: MIT + file LICENSE
LazyData: true
Encoding: UTF-8
diff --git a/R/plot.R b/R/plot.R
index 5d58efe..9ab30dd 100644
--- a/R/plot.R
+++ b/R/plot.R
@@ -23,7 +23,7 @@
#' \code{"top", "bottom", "left", "right"}.
#' @param facet.scales A character string specifying the \code{scales} argument to use for faceting. Options
#' are \code{"free", "fixed"}.
-#' @param custom.theme A character string specifying theme from ggplot2 package.
+#' @param custom.theme A custom ggplot2 theme supplied either as a character string, function, or object of class \code{"theme"}.
#' @param censoring.type A character string specifying additional blq/alq plots to include. Only applicable if
#' \code{\link{censoring}} was performed.
#' @param censoring.output A character string specifying whether to return percentage of blq/alq plots as an
@@ -50,7 +50,7 @@ plot.tidyvpcobj <- function(x,
ribbon.alpha = 0.1,
legend.position="top",
facet.scales="free",
- custom.theme = "ggplot2::theme_bw",
+ custom.theme = NULL,
censoring.type = c("none", "both", "blq", "alq"),
censoring.output = c("grid", "list"),
...) {
@@ -58,244 +58,414 @@ plot.tidyvpcobj <- function(x,
xbin <- lo <- hi <- qname <- md <- y <- xleft <- xright <- ypc <- l.ypc <- bin <- blq <- alq <- pname <- NULL
. <- list
- point_shape_vec <- c("circle" = 1, "circle-fill" = 19, "diamond" = 5, "diamond-fill" = 18,
- "square" = 0, "square-fill" = 15, "triangle-fill" = 17, "triangle" = 2)
- if(!point.shape %in% names(point_shape_vec))
- stop(paste0("point.shape must be one of ", paste0(names(point_shape_vec), collapse = ", ")))
-
- point.shape <- as.numeric(point_shape_vec[names(point_shape_vec) == point.shape])
-
vpc <- x
- vpc.type <- vpc$vpc.type
+ vpc_type <- vpc$vpc.type
+
+ if(is.null(vpc_type)) vpc_type <- "continuous"
+
+ if(vpc_type == "continuous"){
+ g <-
+ plot_continuous(
+ vpc,
+ show.stats,
+ show.points,
+ show.boundaries,
+ show.binning,
+ ribbon.alpha,
+ color,
+ linetype,
+ facet,
+ facet.scales,
+ point.size, point.shape, point.stroke, point.alpha
+ )
+ } else {
+ g <-
+ plot_categorical(
+ vpc,
+ ribbon.alpha,
+ facet,
+ facet.scales,
+ point.size,
+ point.shape,
+ point.stroke,
+ point.alpha
+ )
+
- if(is.null(vpc.type)) vpc.type <- "continuous"
+ }
- qlvls <- levels(vpc$stats$qname)
- qlbls <- paste0(100*as.numeric(sub("^q", "", qlvls)), "%")
+ # add theme
+ if (is.null(custom.theme)) {
+ g <- g + ggplot2::theme_bw() + tidyvpc_theme(legend.position = legend.position)
+ } else if (is.character(custom.theme)) {
+ g <- g + eval(parse(text = paste0(custom.theme, "()")))
+ } else if (is.function(custom.theme)) {
+ g <- g + custom.theme()
+ } else if (inherits(custom.theme, "theme")) {
+ g <- g + custom.theme
+ }
+
+ # add labels
+ if (is.null(xlab)) {
+ xlab <- "TIME"
+ }
- if (isTRUE(vpc$predcor)) {
- ylab <- paste0(ylab, "\nPrediction Corrected")
+ if (is.null(ylab)) {
+ ylab <-
+ sprintf("Observed/Simulated probabilities and associated %s%% CI",
+ 100 * vpc$conf.level)
+ if (isTRUE(vpc$predcor)) {
+ ylab <- ifelse(length(ylab) == 0,
+ "Prediction Corrected",
+ paste0(ylab, "\nPrediction Corrected"))
+ }
}
+
+ g <- g + ggplot2::xlab(xlab)
+ g <- g + ggplot2::ylab(ylab)
+
+
+ # blq/alq plot
+ censoring.type <- match.arg(censoring.type)
+ censoring.output <- match.arg(censoring.output)
+ grid_args <- as.list(substitute(list(...)))
- has_ggplot2 <- requireNamespace("ggplot2", quietly=TRUE)
- if (!has_ggplot2) {
- stop("Package 'ggplot2' is required for plotting. Please install it to use this method.")
+ if (vpc_type == "continuous" && censoring.type != "none") {
+ g_blq <- g_alq <- NULL
+
+ if (censoring.type %in% c("both", "blq")) {
+ g_blq <-
+ plot_censored(vpc, type = "blq", facet.scales, custom.theme, legend.position)
+ }
+
+ if (censoring.type %in% c("both", "alq")) {
+ g_alq <-
+ plot_censored(vpc, type = "alq", facet.scales, custom.theme, legend.position)
+ }
+
+ grid_list <-
+ c(list(g, g_blq,g_alq),
+ grid_args)
+ grid_list <-
+ grid_list[!sapply(grid_list, function(x)
+ is.null(x) || is.symbol(x))]
+
+ if (censoring.output == "grid") {
+ #Return egg
+ g <- do.call(egg::ggarrange, grid_list)
+ } else {
+ #Return list
+ g <- setdiff(grid_list, grid_args)
+ }
}
- if(vpc.type == "continuous"){
+ g
+}
+
+
+plot_continuous <-
+ function(vpc,
+ show.stats,
+ show.points,
+ show.boundaries,
+ show.binning,
+ ribbon.alpha,
+ color,
+ linetype,
+ facet,
+ facet.scales,
+ point.size,
+ point.shape,
+ point.stroke,
+ point.alpha) {
+ alq <-bin <- blq <- hi <-l.ypc <-lo <- md <- pname <- qname <- x <- xleft <- xright <- y <- ypc <- NULL
+ . <- list
+ method <- vpc$vpc.method$method
+ qlvls <- levels(vpc$stats$qname)
+ qlbls <- paste0(100 * as.numeric(sub("^q", "", qlvls)), "%")
+ point_shape_vec <- .get_point_shapes()
+ if (!point.shape %in% names(point_shape_vec))
+ stop(paste0("point.shape must be one of ", paste0(names(point_shape_vec), collapse = ", ")))
+ point.shape <-
+ as.numeric(point_shape_vec[names(point_shape_vec) == point.shape])
+
+ if (method == "binning") {
+ xvar <- "xbin"
+ } else {
+ xvar <- "x"
+ }
+
if (show.stats) {
- if (!is.null(vpc$rqss.obs.fits)) {
- g <- ggplot2::ggplot(vpc$stats, ggplot2::aes(x = x)) +
- ggplot2::geom_ribbon(ggplot2::aes(ymin=lo, ymax=hi, fill=qname, col=qname, group=qname), alpha=ribbon.alpha, col=NA) +
- ggplot2::geom_line(ggplot2::aes(y=md, col=qname, group=qname)) +
- ggplot2::geom_line(ggplot2::aes(y=y, linetype=qname), linewidth=1) +
+ g <- ggplot2::ggplot(vpc$stats, ggplot2::aes(x = !!sym(xvar))) +
+ ggplot2::geom_ribbon(
+ ggplot2::aes(
+ ymin = lo,
+ ymax = hi,
+ fill = qname,
+ col = qname,
+ group = qname
+ ),
+ alpha = ribbon.alpha,
+ col = NA
+ ) +
+ ggplot2::geom_line(ggplot2::aes(y = md, col = qname, group = qname)) +
+ ggplot2::geom_line(ggplot2::aes(y = y, linetype = qname), linewidth =
+ 1) +
ggplot2::scale_colour_manual(
- name=sprintf("Simulated Percentiles\nMedian (lines) %s%% CI (areas)", 100*vpc$conf.level),
- values=color,
- breaks=qlvls,
- labels=qlbls) +
+ name = sprintf(
+ "Simulated Percentiles\nMedian (lines) %s%% CI (areas)",
+ 100 * vpc$conf.level
+ ),
+ values = color,
+ breaks = qlvls,
+ labels = qlbls
+ ) +
ggplot2::scale_fill_manual(
- name=sprintf("Simulated Percentiles\nMedian (lines) %s%% CI (areas)", 100*vpc$conf.level),
- values=color,
- breaks=qlvls,
- labels=qlbls) +
+ name = sprintf(
+ "Simulated Percentiles\nMedian (lines) %s%% CI (areas)",
+ 100 * vpc$conf.level
+ ),
+ values = color,
+ breaks = qlvls,
+ labels = qlbls
+ ) +
ggplot2::scale_linetype_manual(
- name="Observed Percentiles\n(black lines)",
- values=linetype,
- breaks=qlvls,
- labels=qlbls) +
+ name = "Observed Percentiles\n(black lines)",
+ values = linetype,
+ breaks = qlvls,
+ labels = qlbls
+ ) +
ggplot2::guides(
- fill=ggplot2::guide_legend(order=2),
- colour=ggplot2::guide_legend(order=2),
- linetype=ggplot2::guide_legend(order=1)) +
- ylab(sprintf("Observed/Simulated probabilities and associated %s%% CI", 100*vpc$conf.level)) +
- xlab("TIME")
+ fill = ggplot2::guide_legend(order = 2),
+ colour = ggplot2::guide_legend(order = 2),
+ linetype = ggplot2::guide_legend(order = 1)
+ )
} else {
- g <- ggplot2::ggplot(vpc$stats, ggplot2::aes(x = xbin)) +
- ggplot2::geom_ribbon(ggplot2::aes(ymin=lo, ymax=hi, fill=qname, col=qname, group=qname), alpha=ribbon.alpha, col=NA) +
- ggplot2::geom_line(ggplot2::aes(y=md, col=qname, group=qname)) +
- ggplot2::geom_line(ggplot2::aes(y=y, linetype=qname), linewidth=1) +
- ggplot2::scale_colour_manual(
- name=sprintf("Simulated Percentiles\nMedian (lines) %s%% CI (areas)", 100*vpc$conf.level),
- values=color,
- breaks=qlvls,
- labels=qlbls) +
- ggplot2::scale_fill_manual(
- name=sprintf("Simulated Percentiles\nMedian (lines) %s%% CI (areas)", 100*vpc$conf.level),
- values=color,
- breaks=qlvls,
- labels=qlbls) +
- ggplot2::scale_linetype_manual(
- name="Observed Percentiles\n(black lines)",
- values=linetype,
- breaks=qlvls,
- labels=qlbls) +
- ggplot2::guides(
- fill=ggplot2::guide_legend(order=2),
- colour=ggplot2::guide_legend(order=2),
- linetype=ggplot2::guide_legend(order=1)) +
- ylab(sprintf("Observed/Simulated probabilities and associated %s%% CI", 100*vpc$conf.level)) +
- xlab("TIME")
+ g <- ggplot2::ggplot(vpc$strat)
}
- } else {
- g <- ggplot2::ggplot(vpc$strat)
- }
-
- if (show.points) {
- points.dat <- copy(vpc$obs)
- if (isTRUE(vpc$predcor)) {
- if(isTRUE(vpc$loess.ypc)) {
+
+ if (show.points) {
+ points.dat <- copy(vpc$obs)
+ if (isTRUE(vpc$predcor) && method == "binless") {
points.dat[, y := l.ypc]
- } else {
+ } else if (isTRUE(vpc$predcor)) {
points.dat[, y := ypc]
}
- }
- if (show.binning) {
- reorder2 <- function(y, x) {
- y <- stats::reorder(y, x)
- (1:nlevels(y))[y]
+ if (show.binning) {
+ reorder2 <- function(y, x) {
+ y <- stats::reorder(y, x)
+ (1:nlevels(y))[y]
+ }
+ points.dat[, color := reorder2(factor(bin), x), by = vpc$strat]
+ points.dat[, color := factor(color)]
+ points.dat <- points.dat[!(blq | alq)]
+ g <-
+ g + ggplot2::geom_point(
+ data = points.dat,
+ ggplot2::aes(x = x, y = y, color = color),
+ size = point.size,
+ alpha = point.alpha,
+ shape = point.shape,
+ stroke = point.stroke,
+ show.legend = FALSE
+ ) +
+ ggplot2::scale_color_brewer(palette = "Set1")
+ } else {
+ points.dat <- points.dat[!(blq | alq)]
+ g <-
+ g + ggplot2::geom_point(
+ data = points.dat,
+ ggplot2::aes(x = x, y = y),
+ size = point.size,
+ shape = point.shape,
+ stroke = point.stroke,
+ alpha = point.alpha
+ )
}
- points.dat[, color := reorder2(factor(bin), x), by=vpc$strat]
- points.dat[, color := factor(color)]
- points.dat <- points.dat[!(blq|alq)]
- g <- g + ggplot2::geom_point(data=points.dat, ggplot2::aes(x=x, y=y, color=color),
- size=point.size, alpha=point.alpha, shape = point.shape, stroke = point.stroke, show.legend=FALSE) +
- ggplot2::scale_color_brewer(palette="Set1")
- } else {
- points.dat <- points.dat[!(blq|alq)]
- g <- g + ggplot2::geom_point(data=points.dat, ggplot2::aes(x=x, y=y),
- size=point.size, shape = point.shape, stroke = point.stroke, alpha=point.alpha)
}
- }
-
- if (show.boundaries) {
- if(is.null(vpc$rqss.obs.fits)) {
+
+ if (show.boundaries && method == "binning") {
if (!is.null(vpc$strat)) {
- boundaries <- bininfo(vpc)[, .(x=sort(unique(c(xleft, xright)))), by=names(vpc$strat)]
+ boundaries <-
+ bininfo(vpc)[, .(x = sort(unique(c(xleft, xright)))), by = names(vpc$strat)]
} else {
- boundaries <- bininfo(vpc)[, .(x=sort(unique(c(xleft, xright))))]
+ boundaries <- bininfo(vpc)[, .(x = sort(unique(c(xleft, xright))))]
}
if (show.binning) {
- g <- g + ggplot2::geom_vline(data=boundaries, ggplot2::aes(xintercept=x), linewidth=ggplot2::rel(0.5), col="gray80") +
- ggplot2::theme(panel.grid=ggplot2::element_blank())
+ g <-
+ g + ggplot2::geom_vline(
+ data = boundaries,
+ ggplot2::aes(xintercept = x),
+ linewidth = ggplot2::rel(0.5),
+ col = "gray80"
+ ) +
+ ggplot2::theme(panel.grid = ggplot2::element_blank())
}
- g <- g + ggplot2::geom_rug(data=boundaries, ggplot2::aes(x=x), sides="t", linewidth=1)
+ g <-
+ g + ggplot2::geom_rug(
+ data = boundaries,
+ ggplot2::aes(x = x),
+ sides = "t",
+ linewidth = 1
+ )
}
- }
-
- if(facet){
- if (!is.null(vpc$strat)) {
- g <- g + ggplot2::facet_grid(as.formula(paste("qname ~", paste0(names(vpc$strat), collapse = " + "), sep = " ")), scales=facet.scales, as.table = FALSE)
- } else {
- g <- g + ggplot2::facet_grid(qname ~ ., scales=facet.scales, as.table =FALSE )
- }
- } else {
- if (!is.null(vpc$strat)) {
- if(length(as.list(vpc$strat.formula)) == 3) {
- g <- g + ggplot2::facet_grid(vpc$strat.formula, scales=facet.scales)
+
+ if (facet) {
+ if (!is.null(vpc$strat)) {
+ g <-
+ g + ggplot2::facet_grid(as.formula(paste(
+ "qname ~", paste0(names(vpc$strat), collapse = " + "), sep = " "
+ )),
+ scales = facet.scales,
+ as.table = FALSE)
} else {
- g <- g + ggplot2::facet_wrap(names(vpc$strat), scales=facet.scales)
+ g <-
+ g + ggplot2::facet_grid(qname ~ ., scales = facet.scales, as.table = FALSE)
+ }
+ } else {
+ if (!is.null(vpc$strat)) {
+ if (length(as.list(vpc$strat.formula)) == 3) {
+ g <- g + ggplot2::facet_grid(vpc$strat.formula, scales = facet.scales)
+ } else {
+ g <- g + ggplot2::facet_wrap(names(vpc$strat), scales = facet.scales)
+ }
}
}
+ g
}
- } else {
- if(vpc$vpc.method$method == "binless"){
- g <- ggplot(vpc$stats, aes(x = x)) +
- geom_ribbon(aes(ymin = lo, ymax = hi, fill = pname, col = pname, group = pname), alpha = ribbon.alpha, col = NA) +
- geom_line(aes(y = md, col = pname, group = pname)) +
- geom_line(aes(y = y, linetype = pname), linewidth = 1) +
- geom_point(aes(x = x, y = y), size = point.size, alpha = point.alpha, shape = point.shape, stroke = point.stroke) +
- ylab(sprintf("Observed/Simulated probabilities and associated %s%% CI", 100*vpc$conf.level)) +
- xlab("TIME") +
- scale_colour_manual(name = sprintf("Simulated \nMedian (lines) %s%% CI (areas)",100*vpc$conf.level) , breaks = levels(vpc$stats$pname), values = .get_colors(length(levels(vpc$stats$pname))), labels = levels(vpc$stats$pname)) +
- scale_fill_manual(name = sprintf("Simulated \nMedian (lines) %s%% CI (areas)",100*vpc$conf.level), breaks = levels(vpc$stats$pname), values = .get_colors(length(levels(vpc$stats$pname))), labels = levels(vpc$stats$pname)) +
- scale_linetype_manual(name = "Observed \nMedian (lines)", breaks = levels(vpc$stats$pname), values = .get_lines(length(levels(vpc$stats$pname))), labels = levels(vpc$stats$pname)) +
- guides(fill = guide_legend(order = 2), colour = guide_legend(order = 2), linetype = guide_legend(order = 1))
+
+plot_categorical <-
+ function(vpc,
+ ribbon.alpha,
+ facet,
+ facet.scales,
+ point.size,
+ point.shape,
+ point.stroke,
+ point.alpha) {
+
+ y <- md <- pname <- hi <- lo <- NULL
+
+ method <- vpc$vpc.method$method
+ if (method == "binning") {
+ xvar <- "xbin"
} else {
- g <- ggplot(vpc$stats, aes(x = xbin)) +
- geom_ribbon(aes(ymin = lo, ymax = hi, fill = pname, col = pname, group = pname), alpha = ribbon.alpha, col = NA) +
+ xvar <- "x"
+ }
+
+ point_shape_vec <- .get_point_shapes()
+ if (!point.shape %in% names(point_shape_vec))
+ stop(paste0("point.shape must be one of ", paste0(names(point_shape_vec), collapse = ", ")))
+ point.shape <-
+ as.numeric(point_shape_vec[names(point_shape_vec) == point.shape])
+
+ g <- ggplot(vpc$stats, aes(x = !!sym(xvar))) +
+ geom_ribbon(
+ aes(
+ ymin = lo,
+ ymax = hi,
+ fill = pname,
+ col = pname,
+ group = pname
+ ),
+ alpha = ribbon.alpha,
+ col = NA
+ ) +
geom_line(aes(y = md, col = pname, group = pname)) +
geom_line(aes(y = y, linetype = pname), linewidth = 1) +
- geom_point(aes(x = xbin, y = y), size = point.size, alpha = point.alpha, shape = point.shape, stroke = point.stroke) +
- ylab(sprintf("Observed/Simulated probabilities and associated %s%% CI", 100*vpc$conf.level)) +
- xlab("TIME") +
- scale_colour_manual(name = sprintf("Simulated \nMedian (lines) %s%% CI (areas)",100*vpc$conf.level), breaks = levels(vpc$stats$pname), values = .get_colors(length(levels(vpc$stats$pname))), labels = levels(vpc$stats$pname)) +
- scale_fill_manual(name = sprintf("Simulated \nMedian (lines) %s%% CI (areas)",100*vpc$conf.level), breaks = levels(vpc$stats$pname), values = .get_colors(length(levels(vpc$stats$pname))), labels = levels(vpc$stats$pname)) +
- scale_linetype_manual(name = "Observed \nMedian (lines)", breaks = levels(vpc$stats$pname), values = .get_lines(length(levels(vpc$stats$pname))), labels = levels(vpc$stats$pname)) +
- guides(fill = guide_legend(order = 2), colour = guide_legend(order = 2), linetype = guide_legend(order = 1))
- }
-
- if(facet){
+ geom_point(
+ aes(x = !!sym(xvar), y = y),
+ size = point.size,
+ alpha = point.alpha,
+ shape = point.shape,
+ stroke = point.stroke
+ ) +
+ scale_colour_manual(
+ name = sprintf(
+ "Simulated \nMedian (lines) %s%% CI (areas)",
+ 100 * vpc$conf.level
+ ) ,
+ breaks = levels(vpc$stats$pname),
+ values = .get_colors(length(levels(vpc$stats$pname))),
+ labels = levels(vpc$stats$pname)
+ ) +
+ scale_fill_manual(
+ name = sprintf(
+ "Simulated \nMedian (lines) %s%% CI (areas)",
+ 100 * vpc$conf.level
+ ),
+ breaks = levels(vpc$stats$pname),
+ values = .get_colors(length(levels(vpc$stats$pname))),
+ labels = levels(vpc$stats$pname)
+ ) +
+ scale_linetype_manual(
+ name = "Observed \nMedian (lines)",
+ breaks = levels(vpc$stats$pname),
+ values = .get_lines(length(levels(vpc$stats$pname))),
+ labels = levels(vpc$stats$pname)
+ ) +
+ guides(
+ fill = guide_legend(order = 2),
+ colour = guide_legend(order = 2),
+ linetype = guide_legend(order = 1)
+ )
+
+ if (facet) {
if (!is.null(vpc$strat)) {
- g <- g + ggplot2::facet_grid(as.formula(paste(paste0(names(vpc$strat), collapse = " + "), "~", "pname", sep = " ")), scales=facet.scales, as.table = TRUE, labeller = label_both)
+ g <-
+ g + ggplot2::facet_grid(
+ as.formula(paste(
+ paste0(names(vpc$strat), collapse = " + "), "~", "pname", sep = " "
+ )),
+ scales = facet.scales,
+ as.table = TRUE,
+ labeller = label_both
+ )
} else {
- g <- g + ggplot2::facet_grid(~ pname, scales=facet.scales, as.table = FALSE, labeller = label_both)
+ g <-
+ g + ggplot2::facet_grid(
+ ~ pname,
+ scales = facet.scales,
+ as.table = FALSE,
+ labeller = label_both
+ )
}
} else {
if (!is.null(vpc$strat)) {
- g <- g + ggplot2::facet_wrap(names(vpc$strat), scales=facet.scales, label = label_both)
+ g <-
+ g + ggplot2::facet_wrap(names(vpc$strat), scales = facet.scales, label = label_both)
}
}
-
-
- }
-
- # add theme
- g <- g + eval(parse(text = paste0(custom.theme, "()"))) +
- tidyvpc_theme(legend.position = legend.position)
-
- # blq/alq plot
- censoring.type <- match.arg(censoring.type)
- censoring.output <- match.arg(censoring.output)
- grid_args <- as.list(substitute(list(...)))
-
- if (vpc.type == "continuous" && censoring.type != "none") {
- g_blq <- g_alq <- NULL
-
- if (censoring.type %in% c("both", "blq")) {
- g_blq <- plot_censored(vpc, type = "blq", facet.scales) +
- eval(parse(text = paste0(custom.theme, "()"))) +
- tidyvpc_theme(legend.position = legend.position)
- }
- if (censoring.type %in% c("both", "alq")) {
- g_alq <- plot_censored(vpc, type = "alq", facet.scales) +
- eval(parse(text = paste0(custom.theme, "()"))) +
- tidyvpc_theme(legend.position = legend.position)
- }
-
- grid_list <-
- c(list(g, g_blq,g_alq),
- grid_args)
- grid_list <-
- grid_list[!sapply(grid_list, function(x)
- is.null(x) || is.symbol(x))]
+ return(g)
- if (censoring.output == "grid") {
- g <- do.call(egg::ggarrange, grid_list)
- } else {
- g <- setdiff(grid_list, grid_args)
- }
}
- g
-}
-
plot_censored <-
- function(x,
+ function(vpc,
type = c("blq", "alq"),
facet.scales = c("free", "fixed"),
+ custom.theme,
+ legend.position,
...) {
- stopifnot(inherits(x, "tidyvpcobj"))
+
+ stopifnot(inherits(vpc, "tidyvpcobj"))
hi <- lo <- md <- xbin <- y <- NULL
+ method <- vpc$vpc.method$method
+ if(method == "binning") {
+ xvar <- "xbin"
+ } else {
+ xvar <- "x"
+ }
+
type <- match.arg(type)
df_name <- paste0("pct", type)
- df <- x[[df_name]]
+ df <- vpc[[df_name]]
if (is.null(df)) {
stop(
df_name,
@@ -307,20 +477,20 @@ plot_censored <-
g <- ggplot(df)
- if (!is.null(x$strat)) {
- if (length(as.list(x$strat.formula)) == 3) {
- g <- g + ggplot2::facet_grid(x$strat.formula, scales = facet.scales)
+ if (!is.null(vpc$strat)) {
+ if (length(as.list(vpc$strat.formula)) == 3) {
+ g <- g + ggplot2::facet_grid(vpc$strat.formula, scales = facet.scales)
} else {
- g <- g + ggplot2::facet_wrap(names(x$strat), scales = facet.scales)
+ g <- g + ggplot2::facet_wrap(names(vpc$strat), scales = facet.scales)
}
}
g <- g +
- geom_ribbon(aes(x = xbin, ymin = lo, ymax = hi),
+ geom_ribbon(aes(x = !!sym(xvar), ymin = lo, ymax = hi),
fill = "red",
alpha = .2) +
- geom_line(aes(x = xbin, y = md, color = "simulated")) +
- geom_line(aes(x = xbin, y = y, color = "observed")) +
+ geom_line(aes(x = !!sym(xvar), y = md, color = "simulated")) +
+ geom_line(aes(x = !!sym(xvar), y = y, color = "observed")) +
ggplot2::scale_colour_manual(
name = paste0(
"Percentage of ",
@@ -333,6 +503,17 @@ plot_censored <-
) +
labs(x = "TIME", y = paste0("% ", toupper(type)))
+ # add theme
+ if (is.null(custom.theme)) {
+ g <- g + ggplot2::theme_bw() + tidyvpc_theme(legend.position = legend.position)
+ } else if (is.character(custom.theme)) {
+ g <- g + eval(parse(text = paste0(custom.theme, "()")))
+ } else if (is.function(custom.theme)) {
+ g <- g + custom.theme()
+ } else if (inherits(custom.theme, "theme")) {
+ g <- g + custom.theme
+ }
+
return(g)
}
@@ -358,9 +539,15 @@ plot_censored <-
lines[1:n]
}
+.get_point_shapes <- function(){
+ point_shape_vec <- c("circle" = 1, "circle-fill" = 19, "diamond" = 5, "diamond-fill" = 18,
+ "square" = 0, "square-fill" = 15, "triangle-fill" = 17, "triangle" = 2)
+}
+
tidyvpc_theme <- function(legend.position) {
ggplot2::theme(
- legend.text = ggplot2::element_text(size = 6),
+ legend.title = ggplot2::element_text(size = 10),
+ legend.text = ggplot2::element_text(size = 7),
legend.position = legend.position,
legend.spacing = unit(.1, "cm"),
legend.direction = "horizontal",
diff --git a/man/plot.tidyvpcobj.Rd b/man/plot.tidyvpcobj.Rd
index 1044eff..f6c8169 100644
--- a/man/plot.tidyvpcobj.Rd
+++ b/man/plot.tidyvpcobj.Rd
@@ -22,7 +22,7 @@
ribbon.alpha = 0.1,
legend.position = "top",
facet.scales = "free",
- custom.theme = "ggplot2::theme_bw",
+ custom.theme = NULL,
censoring.type = c("none", "both", "blq", "alq"),
censoring.output = c("grid", "list"),
...
@@ -67,7 +67,7 @@ category (categorical VPC).}
\item{facet.scales}{A character string specifying the \code{scales} argument to use for faceting. Options
are \code{"free", "fixed"}.}
-\item{custom.theme}{A character string specifying theme from ggplot2 package.}
+\item{custom.theme}{A custom ggplot2 theme supplied either as a character string, function, or object of class \code{"theme"}.}
\item{censoring.type}{A character string specifying additional blq/alq plots to include. Only applicable if
\code{\link{censoring}} was performed.}
diff --git a/tests/testthat/_snaps/plot/bins-without-stats.svg b/tests/testthat/_snaps/plot/bins-without-stats.svg
new file mode 100644
index 0000000..2a49aa1
--- /dev/null
+++ b/tests/testthat/_snaps/plot/bins-without-stats.svg
@@ -0,0 +1,548 @@
+
+
diff --git a/tests/testthat/_snaps/plot/bins-ypc-without-stats.svg b/tests/testthat/_snaps/plot/bins-ypc-without-stats.svg
new file mode 100644
index 0000000..ba80b35
--- /dev/null
+++ b/tests/testthat/_snaps/plot/bins-ypc-without-stats.svg
@@ -0,0 +1,538 @@
+
+
diff --git a/tests/testthat/_snaps/plot/censored-plot-with-aql.svg b/tests/testthat/_snaps/plot/censored-plot-with-aql.svg
new file mode 100644
index 0000000..3c3c60b
--- /dev/null
+++ b/tests/testthat/_snaps/plot/censored-plot-with-aql.svg
@@ -0,0 +1,1876 @@
+
+
diff --git a/tests/testthat/_snaps/plot/censored-plot-with-bql-aql.svg b/tests/testthat/_snaps/plot/censored-plot-with-bql-aql.svg
new file mode 100644
index 0000000..75e8e94
--- /dev/null
+++ b/tests/testthat/_snaps/plot/censored-plot-with-bql-aql.svg
@@ -0,0 +1,2436 @@
+
+
diff --git a/tests/testthat/_snaps/plot/censored-plot-with-bql.svg b/tests/testthat/_snaps/plot/censored-plot-with-bql.svg
new file mode 100644
index 0000000..e6d9fb5
--- /dev/null
+++ b/tests/testthat/_snaps/plot/censored-plot-with-bql.svg
@@ -0,0 +1,1890 @@
+
+
diff --git a/tests/testthat/_snaps/plot/one-sided-strat-formula-with-facet-wrap.svg b/tests/testthat/_snaps/plot/one-sided-strat-formula-with-facet-wrap.svg
new file mode 100644
index 0000000..06b43d9
--- /dev/null
+++ b/tests/testthat/_snaps/plot/one-sided-strat-formula-with-facet-wrap.svg
@@ -0,0 +1,891 @@
+
+
diff --git a/tests/testthat/_snaps/plot/two-sided-strat-formula-with-facet-grid.svg b/tests/testthat/_snaps/plot/two-sided-strat-formula-with-facet-grid.svg
new file mode 100644
index 0000000..026a9ed
--- /dev/null
+++ b/tests/testthat/_snaps/plot/two-sided-strat-formula-with-facet-grid.svg
@@ -0,0 +1,895 @@
+
+
diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R
new file mode 100644
index 0000000..72c4e38
--- /dev/null
+++ b/tests/testthat/test-plot.R
@@ -0,0 +1,106 @@
+get_os <- function(){
+ sysinf <- Sys.info()
+ if (!is.null(sysinf)){
+ os <- sysinf['sysname']
+ if (os == 'Darwin')
+ os <- "osx"
+ } else { ## mystery machine
+ os <- .Platform$OS.type
+ if (grepl("^darwin", R.version$os))
+ os <- "osx"
+ if (grepl("linux-gnu", R.version$os))
+ os <- "linux"
+ }
+ tolower(os)
+}
+
+test_that("plot.tidyvpcobj plots binning without stats", {
+ testthat::skip_if_not(get_os() == "windows")
+ testthat::skip_on_cran()
+
+ obs_data <- obs_data[MDV == 0]
+ sim_data <- sim_data[MDV == 0]
+ obs_data$PRED <- sim_data[REP == 1, PRED]
+
+ vpc <- observed(obs_data, x = TIME, y = DV)
+ vpc <- simulated(vpc, sim_data, y = DV)
+ vpc <- binning(vpc, bin = NTIME)
+
+ options(warn = -1)
+ vdiffr::expect_doppelganger("Bins without stats",
+ plot(vpc))
+
+ vpc <- predcorrect(vpc, pred = PRED)
+ vdiffr::expect_doppelganger("Bins ypc without stats",
+ plot(vpc))
+ options(warn = 0)
+
+})
+
+
+test_that("plot.tidyvpcobj plots censoring", {
+ testthat::skip_if_not(get_os() == "windows")
+ testthat::skip_on_cran()
+
+ obs_data <- obs_data[MDV == 0]
+ sim_data <- sim_data[MDV == 0]
+ obs_data$LLOQ <- obs_data[, ifelse(STUDY == "Study A", 50, 25)]
+ obs_data$ULOQ <- obs_data[, ifelse(STUDY == "Study A", 125, 100)]
+
+ vpc <- observed(obs_data, x = TIME, y = DV)
+ vpc <- simulated(vpc, sim_data, y = DV)
+ vpc <- censoring(vpc, blq = DV < LLOQ, lloq = LLOQ, alq = DV > ULOQ, uloq = ULOQ)
+ vpc <-stratify(vpc, ~ STUDY)
+ vpc <- binning(vpc, bin = NTIME)
+ vpc <- vpcstats(vpc, qpred = c(0.1, 0.5, 0.9))
+
+ options(warn = -1)
+ vdiffr::expect_doppelganger("Censored plot with bql",
+ plot(vpc, censoring.type = "blq"))
+
+ vdiffr::expect_doppelganger("Censored plot with aql",
+ plot(vpc, censoring.type = "alq"))
+
+ vdiffr::expect_doppelganger("Censored plot with bql aql",
+ plot(vpc, censoring.type = "both"))
+
+ plot_list <- plot(vpc, censoring.type = "both", censoring.output = "list")
+ testthat::expect_true(length(plot_list) == 3)
+ testthat::expect_true(all(sapply(plot_list, ggplot2::is.ggplot)))
+
+ plot_grid <- plot(vpc, censoring.type = "both", censoring.output = "grid", nrow = 1, ncol = 3)
+ testthat::expect_true(inherits(plot_grid, "egg"))
+ options(warn = 0)
+
+})
+
+test_that("plot.tidyvpcobj plots stratified", {
+ testthat::skip_if_not(get_os() == "windows")
+ testthat::skip_on_cran()
+
+ obs_data <- obs_data[MDV == 0]
+ sim_data <- sim_data[MDV == 0]
+
+ options(warn = -1)
+ #two-sided strat formula
+ vpc <- observed(obs_data, x = TIME, y = DV)
+ vpc <- simulated(vpc, sim_data, y = DV)
+ vpc <- stratify(vpc, GENDER ~ STUDY)
+ vpc <- binning(vpc, bin = NTIME)
+ vpc <- vpcstats(vpc, qpred = c(0.1, 0.5, 0.9), quantile.type = 6)
+
+ vdiffr::expect_doppelganger("Two sided strat formula with facet_grid",
+ plot(vpc))
+
+ #one-sided strat formula
+ vpc <- observed(obs_data, x = TIME, y = DV)
+ vpc <- simulated(vpc, sim_data, y = DV)
+ vpc <- stratify(vpc, ~ GENDER + STUDY)
+ vpc <- binless(vpc)
+ vpc <- vpcstats(vpc, qpred = c(0.1, 0.5, 0.9), quantile.type = 6)
+
+ vdiffr::expect_doppelganger("One sided strat formula with facet_wrap",
+ plot(vpc))
+ options(warn = 0)
+})
+
\ No newline at end of file