Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Allow vpc to be an s3 method. #94

Open
wants to merge 3 commits into
base: master
Choose a base branch
from
Open

Allow vpc to be an s3 method. #94

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
fc39263
Allow vpc to be an s3 method.
mattfidler Apr 23, 2018
b6556b1
Fix vpc check issues
mattfidler Apr 23, 2018
d6324b2
Update plot_vpc.R
mattfidler May 11, 2018
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 2 additions & 0 deletions .travis.yml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -6,5 +6,7 @@ apt_packages:
- libudunits2-dev
r_packages:
- covr
r_github_packages:
- ronkeizer/vpc
after_success:
- Rscript -e 'library(covr); codecov()'
4 changes: 2 additions & 2 deletions DESCRIPTION
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
Package: xpose
Type: Package
Title: Diagnostics for Pharmacometric Models
Version: 0.4.2
Version: 0.4.3
Authors@R: c(
person('Benjamin', 'Guiastrennec',
role = c('aut', 'cre', 'cph'),
Expand Down Expand Up @@ -58,7 +58,7 @@ Imports:
tidyr (>= 0.6),
utils,
stats,
vpc (>= 1.0.0)
vpc (>= 1.0.2)
Suggests:
gridExtra,
rmarkdown,
Expand Down
3 changes: 3 additions & 0 deletions NAMESPACE
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -13,6 +13,7 @@ S3method(summarise,xpose_data)
S3method(summarize,xpose_data)
S3method(summary,xpose_data)
S3method(ungroup,xpose_data)
S3method(vpc,xpose_data)
export("%>%")
export(absval_res_vs_idv)
export(absval_res_vs_pred)
Expand Down Expand Up @@ -92,6 +93,7 @@ export(only_obs)
export(parse_arg)
export(parse_nm_files)
export(parse_title)
export(plot_vpc)
export(pred_vs_idv)
export(prm_distrib)
export(prm_qq)
Expand Down Expand Up @@ -154,3 +156,4 @@ importFrom(dplyr,ungroup)
importFrom(ggforce,facet_grid_paginate)
importFrom(ggforce,facet_wrap_paginate)
importFrom(purrr,"%>%")
importFrom(vpc,vpc)
130 changes: 71 additions & 59 deletions R/plot_vpc.R
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,23 +1,23 @@
#' Visual predictive checks
#'
#' @description Generate visual predictive checks (VPC)
#'
#' @description Generate visual predictive checks (VPC)
#'
#' @param xpdb An xpose database object.
#' @param vpc_type Only used when multiple vpc data are present in the same xpdb. The type of
#' vpc to be created. Can be one of can be one of: 'continuous', 'categorical',
#' @param vpc_type Only used when multiple vpc data are present in the same xpdb. The type of
#' vpc to be created. Can be one of can be one of: 'continuous', 'categorical',
#' 'censored' or 'time-to-event'.
#' @param smooth Should the bins be smoothed (connect bin midpoints, default) or shown as rectangular boxes.
#' @param mapping List of aesthetics mappings to be used for the xpose plot
#' @param mapping List of aesthetics mappings to be used for the xpose plot
#' (e.g. \code{point_color}).
#' @param type String setting the type of plot to be used. Can be points 'p',
#' line 'l', area 'a', rug 'r' and text 't' or any combination of the five.
#' @param facets Either a character string to use \link[ggplot2]{facet_wrap}
#' @param facets Either a character string to use \link[ggplot2]{facet_wrap}
#' or a formula to use \link[ggplot2]{facet_grid}.
#' @param title Plot title. Use \code{NULL} to remove.
#' @param subtitle Plot subtitle. Use \code{NULL} to remove.
#' @param caption Page caption. Use \code{NULL} to remove.
#' @param log String assigning logarithmic scale to axes, can be either '',
#' 'x', y' or 'xy'.
#' @param log String assigning logarithmic scale to axes, can be either '',
#' 'x', y' or 'xy'.
#' @param guide Enable guide display in vpc continuous (e.g. lloq and uloq lines).
#' @param gg_theme A ggplot2 theme object (e.g. \code{\link[ggplot2]{theme_classic}}).
#' @param xp_theme An xpose theme or vector of modifications to the xpose theme
Expand All @@ -26,10 +26,11 @@
#' @param line_linetype Lines linetype, should be a vector of 3 values (i.e. low, med, high).
#' @param quiet Logical, if \code{FALSE} messages are printed to the console.
#' @param ... any additional aesthetics.
#'
#' @inheritParams vpc::vpc
#'
#' @section Layers mapping:
#' Plots can be customized by mapping arguments to specific layers. The naming convention is
#' layer_option where layer is one of the names defined in the list below and option is
#' Plots can be customized by mapping arguments to specific layers. The naming convention is
#' layer_option where layer is one of the names defined in the list below and option is
#' any option supported by this layer e.g. point_color = 'blue', area_fill = 'green', etc.
#' \itemize{
#' \item point: options to \code{geom_point}
Expand All @@ -46,11 +47,11 @@
#' @inheritSection xplot_scatter Template titles
#' @seealso \code{\link{vpc_data}}
#' @examples
#' xpdb_ex_pk %>%
#' vpc_data(opt = vpc_opt(n_bins = 7)) %>%
#' xpdb_ex_pk %>%
#' vpc_data(opt = vpc_opt(n_bins = 7)) %>%
#' vpc()
#' @export
vpc <- function(xpdb,
plot_vpc <- function(xpdb,
vpc_type = NULL,
mapping = NULL,
smooth = TRUE,
Expand All @@ -70,63 +71,63 @@ vpc <- function(xpdb,
# Check input
check_xpdb(xpdb, check = 'special')
if (missing(quiet)) quiet <- xpdb$options$quiet

# Fetch data
if (!any(xpdb$special$method == 'vpc')) {
if (!any(xpdb$special$method == 'vpc')) {
stop('No VPC data available. Please refer to the function `vpc_data()` function.', call. = FALSE)
} else if (sum(xpdb$special$method == 'vpc') > 1) {
if (is.null(vpc_type)) {
stop('Several VPC data are associated with this xpdb. Please use the argument `vpc_type`.', call. = FALSE)
} else {
vpc_type <- match.arg(vpc_type, choices = c('continuous', 'categorical', 'censored', 'time-to-event'))
if (!vpc_type %in% xpdb$special[xpdb$special$method == 'vpc', ]$type) {
stop(c('No data are available for ', vpc_type, ' VPC. Change `vpc_type` to one of: ',
stop(c('No data are available for ', vpc_type, ' VPC. Change `vpc_type` to one of: ',
stringr::str_c(xpdb$special[xpdb$special$method == 'vpc', ]$type, collapse = ', '), '.'), call. = FALSE)
}
vpc_dat <- xpdb$special[xpdb$special$method == 'vpc' & xpdb$special$type == vpc_type, ]
}
} else {
if (!is.null(vpc_type) && !stringr::str_detect(xpdb$special$type, vpc_type)) {
stop(c('No data are available for ', vpc_type, ' VPC. Change `vpc_type` to ',
stop(c('No data are available for ', vpc_type, ' VPC. Change `vpc_type` to ',
xpdb$special[xpdb$special$method == 'vpc', ]$type, '.'), call. = FALSE)
}
vpc_dat <- xpdb$special[xpdb$special$method == 'vpc', ]
vpc_type <- vpc_dat$type
}
vpc_prob <- vpc_dat$problem
vpc_prob <- vpc_dat$problem
vpc_dat <- vpc_dat$data[[1]]

# Check that all faceting variable are present vpc_dat
if (missing(facets)) facets <- vpc_dat$facets
if (is.formula(facets)) {
stratify <- all.vars(facets)
} else {
stratify <- facets
}
if (!all(stratify %in% colnames(vpc_dat$vpc_dat) &
if (!all(stratify %in% colnames(vpc_dat$vpc_dat) &
stratify %in% colnames(vpc_dat$aggr_obs))) {
unique(c(stratify[!stratify %in% colnames(vpc_dat$vpc_dat)],
stratify[!stratify %in% colnames(vpc_dat$aggr_obs)])) %>%
stringr::str_c(collapse = ', ') %>%
{stop('Faceting variable: ', ., ' not found. Use `stratify` to add a stratification variable in vpc_data().',
unique(c(stratify[!stratify %in% colnames(vpc_dat$vpc_dat)],
stratify[!stratify %in% colnames(vpc_dat$aggr_obs)])) %>%
stringr::str_c(collapse = ', ') %>%
{stop('Faceting variable: ', ., ' not found. Use `stratify` to add a stratification variable in vpc_data().',
call. = FALSE)}
}

# Check type
check_plot_type(type, allowed = c('a', 'l', 'p', 'r', 't'))

# Assing xp_theme and gg_theme
if (!missing(xp_theme)) xpdb <- update_themes(xpdb = xpdb, xp_theme = xp_theme)
if (missing(gg_theme)) gg_theme <- xpdb$gg_theme

# Create ggplot base
if (is.null(mapping)) mapping <- aes()
xp <- ggplot(data = NULL, mapping) + gg_theme
xp <- ggplot(data = NULL, mapping) + gg_theme

# Add shadded areas
if (stringr::str_detect(type, stringr::fixed('a', ignore_case = TRUE))) {
if (smooth) {
xp <- xp + xp_geoms(mapping = aes_c(aes_string(area_x = 'bin_mid',
xp <- xp + xp_geoms(mapping = aes_c(aes_string(area_x = 'bin_mid',
area_ymin = 'low',
area_ymax = 'up',
area_group = 'group',
Expand Down Expand Up @@ -154,7 +155,7 @@ vpc <- function(xpdb,
...)
}
}

# Add lines
if (stringr::str_detect(type, stringr::fixed('l', ignore_case = TRUE))) {
xp <- xp + xp_geoms(mapping = aes_c(aes_string(line_x = 'bin_mid',
Expand All @@ -167,7 +168,7 @@ vpc <- function(xpdb,
line_data = vpc_dat$aggr_obs,
...)
}

# Add points
if (stringr::str_detect(type, stringr::fixed('p', ignore_case = TRUE))) {
if (vpc_dat$type == 'continuous') {
Expand All @@ -182,7 +183,7 @@ vpc <- function(xpdb,
warning('Points (type = \'p\') can only be added with continuous VPC.', call. = FALSE)
}
}

# Add text
if (stringr::str_detect(type, stringr::fixed('t', ignore_case = TRUE))) {
if (vpc_dat$type == 'continuous') {
Expand All @@ -194,11 +195,11 @@ vpc <- function(xpdb,
ggfun = 'geom_text',
text_data = vpc_dat$obs,
...)
} else {
} else {
warning('Text (type = \'t\') can only be added with continuous VPC.', call. = FALSE)
}
}

# Add guides
if (guide && vpc_type == 'continuous' && (!is.null(vpc_dat$lloq) | !is.null(vpc_dat$uloq))) {
xp <- xp + xp_geoms(xp_theme = xpdb$xp_theme,
Expand All @@ -207,9 +208,9 @@ vpc <- function(xpdb,
guide_yintercept = purrr::flatten_dbl(vpc_dat[c('lloq','uloq')]),
...)
}

# Define scales
xp <- xp +
xp <- xp +
labs(x = vpc_dat$obs_cols[['idv']], y = vpc_dat$obs_cols[['dv']]) +
xp_geoms(mapping = mapping,
xp_theme = xpdb$xp_theme,
Expand All @@ -221,59 +222,70 @@ vpc <- function(xpdb,
name = 'yscale',
ggfun = stringr::str_c('scale_y_', check_scales('y', log)),
...)

# Add rug
if (stringr::str_detect(type, stringr::fixed('r', ignore_case = TRUE))) {
extra_arg <- list(...)
if (!'rug_sides' %in% names(extra_arg)) extra_arg$rug_sides <- 't'
xp <- xp + do.call('xp_geoms',
xp <- xp + do.call('xp_geoms',
c(extra_arg,
list(mapping = aes_c(aes_string(rug_x = 'idv'), mapping),
xp_theme = xpdb$xp_theme,
name = 'rug',
ggfun = 'geom_rug',
rug_data = vpc_dat$aggr_obs %>%
dplyr::distinct_(.dots = c('bin', stratify), .keep_all = TRUE) %>%
dplyr::filter(!is.na(.$bin)) %>%
tidyr::gather(key = 'edges', value = 'idv', dplyr::one_of('bin_min', 'bin_max')) %>%
rug_data = vpc_dat$aggr_obs %>%
dplyr::distinct_(.dots = c('bin', stratify), .keep_all = TRUE) %>%
dplyr::filter(!is.na(.$bin)) %>%
tidyr::gather(key = 'edges', value = 'idv', dplyr::one_of('bin_min', 'bin_max')) %>%
dplyr::distinct_(.dots = c(stratify, 'idv'), .keep_all = TRUE))
))
}

# Define panels
if (!is.null(facets)) {
xp <- xp + xpose_panels(xp_theme = xpdb$xp_theme,
xp <- xp + xpose_panels(xp_theme = xpdb$xp_theme,
extra_args = c(list(facets = facets), list(...)))
}

# Add labels
xp <- xp + labs(title = title, subtitle = subtitle, caption = caption)

# Add limits whenever needed
if (vpc_dat$type == 'categorical') xp <- xp + coord_cartesian(ylim = c(0, 1))

# Add color scales
xp <- xp +
xp <- xp +
scale_fill_manual(values = area_fill) +
scale_linetype_manual(values = line_linetype)

# Add metadata to plots
xp$xpose <- dplyr::data_frame(problem = vpc_prob, subprob = 0L,
descr = c('VPC directory', 'Number of simulations for VPC',
'VPC confidence interval', 'VPC prediction interval',
xp$xpose <- dplyr::data_frame(problem = vpc_prob, subprob = 0L,
descr = c('VPC directory', 'Number of simulations for VPC',
'VPC confidence interval', 'VPC prediction interval',
'VPC lower limit of quantification', 'VPC upper limit of quantification'),
label = c('vpcdir', 'vpcnsim', 'vpcci', 'vpcpi', 'vpclloq', 'vpculoq'),
value = c(vpc_dat$vpc_dir, vpc_dat$nsim,
value = c(vpc_dat$vpc_dir, vpc_dat$nsim,
100*diff(vpc_dat$opt$ci), 100*diff(vpc_dat$opt$pi),
ifelse(is.null(vpc_dat$lloq), 'na', vpc_dat$lloq),
ifelse(is.null(vpc_dat$uloq), 'na', vpc_dat$uloq))) %>%
dplyr::bind_rows(xpdb$summary) %>%
ifelse(is.null(vpc_dat$uloq), 'na', vpc_dat$uloq))) %>%
dplyr::bind_rows(xpdb$summary) %>%
{list(fun = stringr::str_c('vpc_', vpc_dat$type),
summary = .,
problem = vpc_prob,
quiet = quiet,
xp_theme = xpdb$xp_theme[stringr::str_c(c('title', 'subtitle', 'caption'), '_suffix')])}

# Ouptut the plot
structure(xp, class = c('xpose_plot', class(xp)))
}
}

##' @export
##' @method vpc xpose_data
##' @rdname plot_vpc
vpc.xpose_data <- function(sim, ...){
plot_vpc(xpdb=sim, ...);
}

##' @importFrom vpc vpc
##' @export
vpc::vpc
Loading