Merge pull request #167 from UUPharmacometrics/dev

Update master to 0.4.5

.Rbuildignore

@@ -17,7 +17,7 @@
 ^ROADMAP\.md$
 ^temporary$
 ^vignettes/about.*$
-^vignettes/bestiarium.*$
+^vignettes/plot_list.*$
 ^vignettes/cheatsheet.pdf$
 ^vignettes/faq.*$
 ^vignettes/interactive_plots.*$

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: xpose
 Type: Package
 Title: Diagnostics for Pharmacometric Models
-Version: 0.4.4
+Version: 0.4.5
 Authors@R: c(
       person('Benjamin', 'Guiastrennec',
              role  = c('aut', 'cre', 'cph'),
@@ -24,22 +24,23 @@ Description: Diagnostics for non-linear mixed-effects (population)
     and provide 'ggplot2'-based graphics for data exploration and model 
     diagnostics.
 Depends:
-  R (>= 3.1.2),
-  ggplot2 (>= 2.2.1)
+  R (>= 3.3.0),
+  ggplot2 (>= 3.1.0)
 Imports:
-  dplyr (>= 0.7.0),
-  ggforce,
+  dplyr (>= 0.8.0),
+  ggforce (>= 0.2.0),
   grDevices,
-  purrr (>= 0.2.0),
-  readr,
-  rlang (>= 0.1.2),
-  stringr,
-  tibble (>= 1.3.1),
-  tidyr (>= 0.6),
+  purrr (>= 0.3.0),
+  readr (>= 1.3.0),
+  rlang (>= 0.3.0),
+  stringr (>= 1.4.0),
+  tibble (>= 2.1.0),
+  tidyr (>= 0.8.0),
   utils,
   stats,
-  vpc (>= 1.0.0)
+  vpc (>= 1.1.0)
 Suggests:
+  here,
   gridExtra,
   rmarkdown,
   knitr,

NAMESPACE

@@ -124,6 +124,7 @@ export(theme_bw2)
 export(theme_readable)
 export(theme_xp_default)
 export(theme_xp_xpose4)
+export(tidyr_new_interface)
 export(transform_prm)
 export(ungroup)
 export(update_args)
@@ -157,3 +158,4 @@ importFrom(dplyr,ungroup)
 importFrom(ggforce,facet_grid_paginate)
 importFrom(ggforce,facet_wrap_paginate)
 importFrom(purrr,"%>%")
+importFrom(rlang,":=")

NEWS.md

@@ -1,3 +1,9 @@
+# xpose 0.4.5
+## General
+* The `gg_theme` argument in `xpose_data`, `update_themes` or plots now accepts a function returning a complete ggplot2 theme. In addition theme `gg_theme` can now accept theme elements in `update_themes` and plots. (#157)
+* Added compatibility with tidyr 1.0.0 (#166)
+* Small fixes to vignettes, documentations and website
+
 # xpose 0.4.4
 ### General
 * Improved documentation for `xpose_data` (@billdenney #99)

R/fetch_data.R

@@ -108,7 +108,7 @@ only_distinct <- function(xpdb, .problem, facets, quiet) {
                  stringr::str_c(var_stg, collapse = ', '))
     msg(msg_stg, .(quiet))
 
-    dplyr::distinct_(.data = x, .dots = var_stg, .keep_all = TRUE)
+    dplyr::distinct(.data = x, !!!rlang::syms(var_stg), .keep_all = TRUE)
   })
 
   fun
@@ -141,13 +141,13 @@ reorder_factors <- function(prefix, suffix = NULL) {
     # Only sort factors
     function(x) {
       levels <- x %>%
-        dplyr::distinct_(.dots = 'variable') %>%
+        dplyr::distinct(!!rlang::sym('variable')) %>%
         dplyr::mutate(variable_order = substring(.$variable, 1, 2)) %>%
         dplyr::mutate(variable_order = dplyr::case_when(.$variable_order == 'TH' ~ 1,
                                                         .$variable_order == 'OM' ~ 2,
                                                         .$variable_order == 'SI' ~ 3,
                                                         TRUE ~ 0)) %>%
-        dplyr::arrange_(.dots = 'variable_order')
+        dplyr::arrange_at(.vars = 'variable_order')
 
       dplyr::mutate(.data = x, variable = factor(x$variable, levels = levels$variable))
     }
@@ -212,9 +212,10 @@ fetch_data <- function(xpdb,
                    stringr::str_c(stringr::str_c(index_col[1:5], collapse = ', '), 
                                   '... and', length(index_col) - 5 , 'more variables', sep = ' '),
                    stringr::str_c(index_col , collapse = ', ')) %>%
-                   {msg(c('Tidying data by ', .), quiet)}
-    data <- tidyr::gather_(data = data, key_col = 'variable', value_col = 'value',
-                           gather_cols = colnames(data)[!colnames(data) %in% index_col])
+      {msg(c('Tidying data by ', .), quiet)}
+
+    data <- tidyr::gather(data = data, key = 'variable', value = 'value',
+                          !!!rlang::syms(colnames(data)[!colnames(data) %in% index_col]))
   }
 
   if (is.function(post_processing)) data <- post_processing(data)

R/list_nm_tables.R

@@ -29,8 +29,9 @@ list_nm_tables <- function(nm_model = NULL) {
   if (nrow(table_list) == 0) return(null_object)
 
   table_list <- table_list %>% 
-    dplyr::group_by_(.dots = c('problem', 'level')) %>% 
+    dplyr::group_by_at(.vars = c('problem', 'level')) %>% 
     tidyr::nest() %>% 
+    dplyr::ungroup() %>% 
     dplyr::mutate(string = purrr::map_chr(.$data, ~stringr::str_c(.$code, collapse = ' '))) %>% 
     dplyr::mutate(file = stringr::str_match(.$string, '\\s+FILE\\s*=\\s*([^\\s]+)')[, 2]) %>% 
     dplyr::filter(!is.na(.$file))
@@ -46,8 +47,9 @@ list_nm_tables <- function(nm_model = NULL) {
   # Prep simtab flag
   sim_flag <- nm_model %>% 
     dplyr::filter(.$problem > 0) %>% 
-    dplyr::group_by_(.dots = 'problem') %>% 
+    dplyr::group_by_at(.vars = 'problem') %>% 
     tidyr::nest() %>% 
+    dplyr::ungroup() %>% 
     dplyr::mutate(simtab = purrr::map_lgl(.$data, ~!any(stringr::str_detect(.$subroutine, 'est')))) %>% 
     dplyr::select(dplyr::one_of(c('problem', 'simtab')))
 

R/plot_vpc.R

@@ -20,14 +20,13 @@
 #' @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
-#' (e.g. \code{c(point_color = 'red', line_linetype = 'dashed')}).
 #' @param area_fill Shaded areas filling color, should be a vector of 3 values (i.e. low, med, high).
 #' @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 update_themes
+#' 
 #' @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 
@@ -116,9 +115,18 @@ vpc <- function(xpdb,
   # Check type
   check_plot_type(type, allowed = c('a', 'l', 'p', 'r', 't'))
 
-  # Assing xp_theme and gg_theme
+  # Assign xp_theme
   if (!missing(xp_theme)) xpdb <- update_themes(xpdb = xpdb, xp_theme = xp_theme)
-  if (missing(gg_theme)) gg_theme <- xpdb$gg_theme
+
+  # Assign gg_theme
+  if (missing(gg_theme)) {
+    gg_theme <- xpdb$gg_theme
+  } else {
+    gg_theme <- update_themes(xpdb = xpdb, gg_theme = gg_theme)$gg_theme 
+  }
+  if (is.function(gg_theme)) {
+    gg_theme <- do.call(gg_theme, args = list())
+  }
 
   # Create ggplot base
   if (is.null(mapping)) mapping <- aes()
@@ -234,10 +242,10 @@ vpc <- function(xpdb,
                               name     = 'rug',
                               ggfun    = 'geom_rug',
                               rug_data =  vpc_dat$aggr_obs %>% 
-                                dplyr::distinct_(.dots = c('bin', stratify), .keep_all = TRUE) %>% 
+                                dplyr::distinct(!!!rlang::syms(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))
+                                dplyr::distinct(!!!rlang::syms(c(stratify, 'idv')), .keep_all = TRUE))
                        ))
   }
 
@@ -263,15 +271,15 @@ vpc <- function(xpdb,
     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', 
-                                          '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, 
-                                          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))) %>% 
+  xp$xpose <- dplyr::tibble(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, 
+                                      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) %>% 
     {list(fun = stringr::str_c('vpc_', vpc_dat$type),
           summary  = .,

R/print_xpose_data.R

@@ -21,8 +21,9 @@ print.xpose_data <- function(x, ...) {
     tab_names <- x$data %>% 
       dplyr::filter(.$simtab == FALSE) %>% 
       dplyr::mutate(grouping = 1:n()) %>% 
-      dplyr::group_by_(.dots = 'grouping') %>% 
+      dplyr::group_by_at(.vars = 'grouping') %>% 
       tidyr::nest() %>% 
+      dplyr::ungroup() %>% 
       dplyr::mutate(string = purrr::map_chr(.$data, summarize_table_names)) %>% 
       {stringr::str_c(.$string, collapse = '\n               ')}
   } else {
@@ -34,8 +35,9 @@ print.xpose_data <- function(x, ...) {
     sim_names <- x$data %>% 
       dplyr::filter(.$simtab == TRUE) %>% 
       dplyr::mutate(grouping = 1:n()) %>% 
-      dplyr::group_by_(.dots = 'grouping') %>% 
+      dplyr::group_by_at(.vars = 'grouping') %>% 
       tidyr::nest() %>% 
+      dplyr::ungroup() %>% 
       dplyr::mutate(string = purrr::map_chr(.$data, summarize_table_names)) %>% 
       {stringr::str_c(.$string, collapse = '\n               ')}
   } else {
@@ -45,8 +47,8 @@ print.xpose_data <- function(x, ...) {
   # Summarize file names
   if (!is.null(x$files)) {
     out_names <- x$files %>% 
-      dplyr::distinct_(.dots = 'name', .keep_all = TRUE) %>% 
-      dplyr::arrange_(.dots = c('name')) %>% 
+      dplyr::distinct(!!rlang::sym('name'), .keep_all = TRUE) %>% 
+      dplyr::arrange_at(.vars = 'name') %>% 
       {stringr::str_c(.$name, ifelse(.$modified, ' (modified)', ''), collapse = ', ')}
   } else {
     out_names <- '<none>'

R/prm_table.R

@@ -39,8 +39,8 @@ prm_table <- function(xpdb,
     uncertainty_lab <- ifelse(transform, 'RSE', 'SE')
     if (!transform) prm$rse <- prm$se
 
-    header <- dplyr::data_frame(name = 'Parameter', label = 'Label', 
-                                value = 'Value', rse = uncertainty_lab, fixed = '   ')
+    header <- dplyr::tibble(name = 'Parameter', label = 'Label', 
+                            value = 'Value', rse = uncertainty_lab, fixed = '   ')
 
     cat('\nEstimates for $prob no.', prm_attr$problem, 
         ', subprob no.', prm_attr$subprob, ', method ', prm_attr$method, '\n', sep = '')

R/read_nm_files.R

@@ -59,17 +59,18 @@ read_nm_files <- function(runno  = NULL,
     dplyr::filter(file.exists(.$path)) %>% 
     dplyr::mutate(grouping = 1:n(),
                   raw = purrr::map(.$path, .f = readr::read_lines)) %>% 
-    dplyr::group_by_(.dots = 'grouping') %>% 
+    dplyr::group_by_at(.vars = 'grouping') %>% 
     tidyr::nest() %>% 
+    dplyr::ungroup() %>% 
     dplyr::mutate(tmp = purrr::map(.$data, .f = parse_nm_files, quiet)) %>% 
     dplyr::mutate(drop = purrr::map_lgl(.$tmp, is.null)) 
 
   if (all(out$drop)) stop('No output file imported.', call. = FALSE)
 
   out %>% 
     dplyr::filter(!.$drop) %>% 
-    tidyr::unnest_(unnest_cols = 'data') %>% 
-    tidyr::unnest_(unnest_cols = 'tmp') %>% 
+    tidyr::unnest(dplyr::one_of('data')) %>% 
+    tidyr::unnest(dplyr::one_of('tmp')) %>% 
     dplyr::mutate(extension = get_extension(.$name, dot = FALSE),
                   modified = FALSE) %>% 
     dplyr::select(dplyr::one_of('name', 'extension', 'problem', 'subprob', 
@@ -131,9 +132,13 @@ parse_nm_files <- function(dat, quiet) {
     dplyr::mutate(problem = as.numeric(.$problem),
                   subprob = as.numeric(.$subprob),
                   raw = stringr::str_trim(.$raw, side = 'both')) %>% 
-    dplyr::group_by_(.dots = c('problem', 'subprob', 'method')) %>% 
+    dplyr::group_by_at(.vars = c('problem', 'subprob', 'method')) %>% 
     tidyr::nest() %>% 
-    dplyr::mutate(data = purrr::map(.$data, .f = raw_to_tibble, sep = sep, file = dat$name))
+    dplyr::ungroup() %>% 
+    dplyr::mutate(data = purrr::map(.$data, 
+                                    .f   = raw_to_tibble, 
+                                    sep  = sep, 
+                                    file = dat$name))
 }