Merge pull request #56 from UUPharmacometrics/dev

improved error check of distrib plot functions

NAMESPACE

@@ -37,7 +37,7 @@ export(cov_qq)
 export(data_opt)
 export(default_plot_problem)
 export(distinct)
-export(drop_static_cols)
+export(drop_fixed_cols)
 export(dv_preds_vs_idv)
 export(dv_vs_idv)
 export(dv_vs_ipred)

R/plot_amt.R

@@ -3,8 +3,8 @@
 #' @description Plot of the change in compartment amounts over the independent variable
 #'
 #' @inheritParams dv_vs_pred
-#' @param drop_static Should columns that only have a single unique value 
-#' (i.e. static) be dropped.
+#' @param drop_fixed Should columns that only have a single unique value 
+#' (i.e. fixed) be dropped.
 #' 
 #' @inheritSection xplot_scatter Layers mapping
 #' @inheritSection xplot_scatter Faceting
@@ -17,7 +17,7 @@
 amt_vs_idv <- function(xpdb,
                        mapping  = NULL,
                        group    = 'ID',
-                       drop_static = TRUE,
+                       drop_fixed = TRUE,
                        type     = 'l',
                        title    = 'Compartments amount vs. @x | @run',
                        subtitle = 'Ofv: @ofv',
@@ -39,8 +39,8 @@ amt_vs_idv <- function(xpdb,
   if (!any(names(extra_args) == 'ncol')) extra_args$ncol <- 3
 
   amt_col <- xp_var(xpdb, problem, type = 'a')$col
-  if (drop_static) {
-    amt_col <- drop_static_cols(xpdb, problem, cols = amt_col, quiet = quiet)
+  if (drop_fixed) {
+    amt_col <- drop_fixed_cols(xpdb, problem, cols = amt_col, quiet = quiet)
   }
   if (is.null(amt_col)) {
     stop('No compartment amount column found in the xpdb data index.', call. = FALSE)

R/plot_distibution.R

@@ -6,8 +6,8 @@
 #' @param type String setting the type of plot to be used. Can be histogram 'h',
 #' density 'd', rug 'r' or any combination of the three.
 #' @param guide Should the guide (e.g. reference distribution) be displayed.
-#' @param drop_static Should columns that only have a single unique value 
-#' (i.e. static) be dropped.
+#' @param drop_fixed Should columns that only have a single unique value 
+#' (i.e. fixed) be dropped.
 #' 
 #' @inheritSection xplot_distrib Layers mapping
 #' @inheritSection xplot_scatter Faceting
@@ -29,7 +29,7 @@
 #' @export
 prm_distrib <- function(xpdb,
                         mapping  = NULL,
-                        drop_static = TRUE,
+                        drop_fixed = TRUE,
                         type     = 'hr',
                         title    = 'Parameter distribution | @run',
                         subtitle = 'Based on @nind individuals',
@@ -48,8 +48,8 @@ prm_distrib <- function(xpdb,
                                                variable = 'variable')
 
   prm_col <- xp_var(xpdb, problem, type = 'param')$col
-  if (drop_static) {
-    prm_col <- drop_static_cols(xpdb, problem, cols = prm_col, quiet = quiet)
+  if (drop_fixed) {
+    prm_col <- drop_fixed_cols(xpdb, problem, cols = prm_col, quiet = quiet)
   }
   if (is.null(prm_col)) {
     stop('No parameter column found in the xpdb data index.', call. = FALSE)
@@ -71,7 +71,7 @@ prm_distrib <- function(xpdb,
 #' @export
 eta_distrib <- function(xpdb,
                         mapping  = NULL,
-                        drop_static = TRUE,
+                        drop_fixed = TRUE,
                         type     = 'hr',
                         title    = 'Eta distribution | @run',
                         subtitle = 'Based on @nind individuals, Eta shrink: @etashk',
@@ -90,8 +90,8 @@ eta_distrib <- function(xpdb,
                                                variable = 'variable')
 
   eta_col <- xp_var(xpdb, problem, type = 'eta')$col
-  if (drop_static) {
-    eta_col <- drop_static_cols(xpdb, problem, cols = eta_col, quiet = quiet)
+  if (drop_fixed) {
+    eta_col <- drop_fixed_cols(xpdb, problem, cols = eta_col, quiet = quiet)
   }
   if (is.null(eta_col)) {
     stop('No eta column found in the xpdb data index.', call. = FALSE)
@@ -163,7 +163,7 @@ res_distrib <- function(xpdb,
 #' @export
 cov_distrib <- function(xpdb,
                         mapping  = NULL,
-                        drop_static = TRUE,
+                        drop_fixed = TRUE,
                         type     = 'hr',
                         title    = 'Continuous covariates distribution | @run',
                         subtitle = 'Based on @nind individuals',
@@ -182,8 +182,8 @@ cov_distrib <- function(xpdb,
                                                variable = 'variable')
 
   cov_col <- xp_var(xpdb, problem, type = 'contcov')$col
-  if (drop_static) {
-    cov_col <- drop_static_cols(xpdb, problem, cols = cov_col, quiet = quiet)
+  if (drop_fixed) {
+    cov_col <- drop_fixed_cols(xpdb, problem, cols = cov_col, quiet = quiet)
   }
   if (is.null(cov_col)) {
     stop('No continuous covariate column found in the xpdb data index.', call. = FALSE)

R/plot_minimization.R

@@ -42,14 +42,19 @@ prm_vs_iteration <- function(xpdb,
   if (missing(quiet)) quiet <- xpdb$options$quiet
   if (missing(facets)) facets <- 'variable'
   x_var <- 'ITERATION'
+  msg(c('Parameters non-varying across ', x_var, ' not shown.'), quiet)
 
   xplot_scatter(xpdb = xpdb, group = group, quiet = quiet,
                 opt = data_opt(problem = problem, subprob = subprob,
                                method = method, source = 'ext',
                                filter = function(x) {
-                                 x %>% 
+                                 x <- x %>% 
                                    dplyr::filter(.[, x_var] >= 0) %>% 
                                    dplyr::select_if(.predicate = function(x) dplyr::n_distinct(x) > 1)
+                                 if (ncol(x[, colnames(x) != x_var]) == 0) {
+                                   stop('No parameters varying across ', x_var, ' were found.', call. = FALSE)
+                                 }
+                                 x
                                }, tidy = TRUE, index_col = x_var,
                                post_processing = reorder_factors(prefix = NA)),
                 mapping = aes_c(aes_string(x = x_var, y = 'value'), mapping),
@@ -87,15 +92,19 @@ grd_vs_iteration <- function(xpdb,
   if (missing(quiet)) quiet <- xpdb$options$quiet
   if (missing(facets)) facets <- 'variable'
   x_var <- 'ITERATION'
-  msg('Static parameters not shown.', quiet)
+  msg(c('Parameters non-varying across ', x_var, ' not shown.'), quiet)
 
   xplot_scatter(xpdb = xpdb, group = group, quiet = quiet,
                 opt = data_opt(problem = problem, subprob = subprob, 
                                method = method, source = 'grd',
                                filter = function(x) {
-                                 x %>% 
+                                 x <- x %>% 
                                    dplyr::filter(.[, x_var] >= 0) %>% 
                                    dplyr::select_if(.predicate = function(x) dplyr::n_distinct(x) > 1)
+                                 if (ncol(x[, colnames(x) != x_var]) == 0) {
+                                   stop('No parameters varying across ', x_var, ' were found.', call. = FALSE)
+                                 }
+                                 x
                                }, tidy = TRUE, index_col = x_var, 
                                post_processing = reorder_factors(prefix = 'GRD(', suffix = ')')),
                 mapping = aes_c(aes_string(x = x_var, y = 'value'), mapping),

R/plot_qq.R

@@ -5,8 +5,8 @@
 #' @inheritParams dv_vs_pred
 #' @param type String setting the type of plot. Can only be points 'p'.
 #' @param guide Should the guide (e.g. reference line) be displayed.
-#' @param drop_static Should columns that only have a single unique value 
-#' (i.e. static) be dropped.
+#' @param drop_fixed Should columns that only have a single unique value 
+#' (i.e. fixed) be dropped.
 #' 
 #' @inheritSection xplot_qq Layers mapping
 #' @inheritSection xplot_scatter Faceting
@@ -29,7 +29,7 @@
 #' @export
 prm_qq <- function(xpdb,
                    mapping  = NULL,
-                   drop_static = TRUE,
+                   drop_fixed = TRUE,
                    type     = 'p',
                    title    = 'QQ plot of parameters | @run',
                    subtitle = 'Based on @nind individuals',
@@ -48,8 +48,8 @@ prm_qq <- function(xpdb,
                                                variable = 'variable')
 
   prm_col <- xp_var(xpdb, problem, type = 'param')$col
-  if (drop_static) {
-    prm_col <- drop_static_cols(xpdb, problem, cols = prm_col, quiet = quiet)
+  if (drop_fixed) {
+    prm_col <- drop_fixed_cols(xpdb, problem, cols = prm_col, quiet = quiet)
   }
   if (is.null(prm_col)) {
     stop('No parameter column found in the xpdb data index.', call. = FALSE)
@@ -73,7 +73,7 @@ prm_qq <- function(xpdb,
 #' @export
 eta_qq <- function(xpdb,
                    mapping  = NULL,
-                   drop_static = TRUE,
+                   drop_fixed = TRUE,
                    type     = 'p',
                    title    = 'QQ plot of etas | @run',
                    subtitle = 'Based on @nind individuals, Eta shrink: @etashk',
@@ -92,8 +92,8 @@ eta_qq <- function(xpdb,
                                                variable = 'variable')
 
   eta_col <- xp_var(xpdb, problem, type = 'eta')$col
-  if (drop_static) {
-    eta_col <- drop_static_cols(xpdb, problem, cols = eta_col, quiet = quiet)
+  if (drop_fixed) {
+    eta_col <- drop_fixed_cols(xpdb, problem, cols = eta_col, quiet = quiet)
   }
   if (is.null(eta_col)) {
     stop('No eta column found in the xpdb data index.', call. = FALSE)
@@ -169,7 +169,7 @@ res_qq <- function(xpdb,
 #' @export
 cov_qq <- function(xpdb,
                    mapping  = NULL,
-                   drop_static = TRUE,
+                   drop_fixed = TRUE,
                    type     = 'p',
                    title    = 'QQ plot of continuous covariates | @run',
                    subtitle = 'Based on @nind individuals',
@@ -188,8 +188,8 @@ cov_qq <- function(xpdb,
                                                variable = 'variable')
 
   cov_col <- xp_var(xpdb, problem, type = 'contcov')$col
-  if (drop_static) {
-    cov_col <- drop_static_cols(xpdb, problem, cols = cov_col, quiet = quiet)
+  if (drop_fixed) {
+    cov_col <- drop_fixed_cols(xpdb, problem, cols = cov_col, quiet = quiet)
   }
   if (is.null(cov_col)) {
     stop('No continuous covariate column found in the xpdb data index.', call. = FALSE)

R/xplot_helpers.R

@@ -294,19 +294,30 @@ last_file_method <- function(xpdb, ext, problem, subprob) {
 #' 
 #' @keywords internal
 #' @export
-drop_static_cols <- function(xpdb, problem, cols, quiet) {
+drop_fixed_cols <- function(xpdb, problem, cols, quiet) {
   if (is.null(cols)) return()
+
+  # Get the column names to be removed
   cols_rm <- get_data(xpdb, problem = problem) %>% 
     dplyr::select_(.dots = cols) %>%
     dplyr::select_if(.predicate = function(x) length(unique(x)) == 1) %>% 
     colnames()
   if (length(cols_rm) == 0) return(cols)
+
+  # Get the column names to be kept
+  cols <- dplyr::setdiff(x = cols, y = cols_rm)
+  if (length(cols) == 0) {
+    stop('No non-fixed variables available for plotting.', call. = FALSE)
+  }
+
+  # Print message
   dplyr::if_else(length(cols_rm) > 5, 
                  stringr::str_c(stringr::str_c(cols_rm[1:5], collapse = ', '), 
                                 '... and', length(cols_rm) - 5 , 'more', sep = ' '),
                  stringr::str_c(cols_rm , collapse = ', ')) %>%
-                 {msg(c('Dropped static variables ', .,'.'), quiet)}
-  dplyr::setdiff(x = cols, y = cols_rm)
+                 {msg(c('Dropped fixed variables ', .,'.'), quiet)}
+
+  cols
 }