Merge pull request #180 from UUPharmacometrics/dev

Update master to 0.4.9

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: xpose
 Type: Package
 Title: Diagnostics for Pharmacometric Models
-Version: 0.4.8
+Version: 0.4.9
 Authors@R: c(
       person('Benjamin', 'Guiastrennec',
              role  = c('aut', 'cre', 'cph'),

NEWS.md

@@ -1,3 +1,6 @@
+# xpose 0.4.9
+* Compatibility fix for dplyr 1.0.0 and vpc 1.2.0
+
 # xpose 0.4.8
 * Compatibility fix for ggplot 3.3.0 and tibble 3.0.0
 

R/read_nm_tables.R

@@ -348,12 +348,18 @@ combine_tables <- function(x) {
     return(dplyr::tibble(data = list(), index = list()))
   }
 
+  # Prepare the combined data
+  # Note: here the data may contain duplicated columns so 
+  #       we de-duplicate them in base R to avoid errors 
+  #       with the tidyverse.
+  tmp_df <- do.call("cbind", unname(x$data))
+  tmp_df <- tmp_df[, which(!duplicated(names(tmp_df))) ] %>% 
+    tibble::as_tibble() %>% 
+    tidyr::drop_na(dplyr::one_of('ID')) %>%
+    list()
+
   # Combine tables
-  dplyr::tibble(data = x$data %>%
-                  dplyr::bind_cols() %>%
-                  purrr::set_names(make.unique(names(.))) %>%
-                  tidyr::drop_na(dplyr::one_of('ID')) %>%
-                  list(),
+  dplyr::tibble(data  = tmp_df,
                 index = list(dplyr::bind_rows(x$index)))
 }
 

R/summarise_nm_model.R

@@ -239,7 +239,7 @@ sum_nobs <- function(model, software) {
     x %>% 
       dplyr::mutate(subprob = 0,
                     label = 'nobs',
-                    value = stringr::str_match(.$code, '\\d+')) %>% 
+                    value = stringr::str_extract(.$code, '\\d+')) %>% 
       dplyr::select(dplyr::one_of('problem', 'subprob', 'label', 'value'))
   }
 }
@@ -256,7 +256,7 @@ sum_nind <- function(model, software) {
     x %>% 
       dplyr::mutate(subprob = 0,
                     label = 'nind',
-                    value = stringr::str_match(.$code, '\\d+')) %>% 
+                    value = stringr::str_extract(.$code, '\\d+')) %>% 
       dplyr::select(dplyr::one_of('problem', 'subprob', 'label', 'value'))
   }
 }

R/vpc_data.R

@@ -118,6 +118,13 @@ vpc_data <- function(xpdb,
                             sim_cols = sim_cols, ci = opt$ci, uloq = opt$uloq, lloq = opt$lloq, 
                             smooth = FALSE, vpcdb = TRUE, verbose = !quiet) 
   } else if (vpc_type == 'censored') {
+
+    # TEMPORARY check compatibility of versions
+    if (utils::packageVersion("dplyr") > "0.8.5" & utils::packageVersion("vpc") < "1.2.1") {
+      stop(paste0("`dplyr` (v", utils::packageVersion("dplyr"),  
+                  ") and `vpc` (v", utils::packageVersion("vpc"), ") are not compatible with each other."), call. = FALSE)
+    }
+
     vpc_dat <- vpc::vpc_cens(obs = obs_data, sim = sim_data, psn_folder = NULL, bins = opt$bins, 
                              n_bins = opt$n_bins, bin_mid = opt$bin_mid, obs_cols = obs_cols, 
                              sim_cols = sim_cols, stratify = stratify, ci = opt$ci, 
@@ -150,6 +157,8 @@ vpc_data <- function(xpdb,
                                    'ylab', 'labeller')) %>%
     purrr::map_at('vpc_dat', function(x) {
       x <- x %>% 
+        dplyr::ungroup() %>% 
+        dplyr::mutate_all(.funs = unname) %>% # remove warning in gather
         tidyr::gather(key = 'tmp', value = 'value', dplyr::matches('\\.(low|med|up)')) %>% 
         tidyr::separate(col = !!rlang::sym('tmp'), 
                         into = c('Simulations', 'ci'), sep = '\\.') %>% 
@@ -179,6 +188,7 @@ vpc_data <- function(xpdb,
       if (vpc_type == 'continuous') {
         x <- x %>% 
           dplyr::ungroup() %>%
+          dplyr::mutate_all(.funs = unname) %>% # remove warning in gather
           tidyr::gather(key = 'Observations', value = 'value', dplyr::one_of('obs5', 'obs50', 'obs95')) %>% 
           dplyr::mutate(Observations = factor(.$Observations, levels = c('obs5', 'obs50', 'obs95'),
                                               labels = c(stringr::str_c(min(opt$pi)*100, 'th percentile'), 

data-raw/xpdb_ex_pk.R

@@ -7,18 +7,18 @@
 library(xpose)
 
 # Generate xpdb
-xpdb_ex_pk <- xpose_data(runno = '001',
-                         dir   = here::here('inst/extdata/'), 
+xpdb_ex_pk <- xpose_data(runno = "001",
+                         dir   = here::here("inst/extdata/"), 
                          quiet = FALSE)
 
 # Overwrite directory paths to make it look clean in examples
-xpdb_ex_pk$summary$value[xpdb_ex_pk$summary$label == 'dir'] <- 'analysis/models/pk/'
-xpdb_ex_pk$options$dir <- 'analysis/models/pk/'
-attr(xpdb_ex_pk$code, 'dir') <- 'analysis/models/pk/'
+xpdb_ex_pk$summary$value[xpdb_ex_pk$summary$label == "dir"] <- "data"
+xpdb_ex_pk$options$dir <- "data"
+attr(xpdb_ex_pk$code, "dir") <- "data"
 
 # Ensure the xpose data class is preserved
 xpdb_ex_pk <- xpose::as.xpdb(xpdb_ex_pk)
 
 # Export rda to data folder
-save(xpdb_ex_pk, file = here::here('data/xpdb_ex_pk.rda'), 
+save(xpdb_ex_pk, file = here::here("data/xpdb_ex_pk.rda"), 
      compress = 'xz', version = 2)