Make list_vars return a list of vars invisibly (Fix UUPharmacometrics…

…#124)

NAMESPACE

@@ -143,9 +143,11 @@ export(xpose_data)
 export(xpose_panels)
 export(xpose_save)
 import(ggplot2)
+importFrom(dplyr,bind_rows)
 importFrom(dplyr,distinct)
 importFrom(dplyr,filter)
 importFrom(dplyr,group_by)
+importFrom(dplyr,group_by_at)
 importFrom(dplyr,mutate)
 importFrom(dplyr,n)
 importFrom(dplyr,rename)
@@ -157,3 +159,6 @@ importFrom(dplyr,ungroup)
 importFrom(ggforce,facet_grid_paginate)
 importFrom(ggforce,facet_wrap_paginate)
 importFrom(purrr,"%>%")
+importFrom(purrr,map)
+importFrom(stringr,str_c)
+importFrom(tidyr,nest)

NEWS.md

@@ -1,5 +1,6 @@
 # xpose 0.4.4
 ### General
+* `list_vars` now invisbly returns a list (@billdenney #124)
 * Improved documentation for `xpose_data` (@billdenney #99)
 * Fixed VPC error in the documentation (@callistosp #130)
 * Fixed bug leading to errors when plotting poorly formatted ETA name (@romainfrancois #127)
@@ -66,7 +67,7 @@
 
 ### Data import/edit
 * Improved `dir` and `file` arguments usage
-* Improved error robustness of `xpose_data()` 
+* Improved error robustness of `xpose_data()`
 * Added new dplyr verbs for xpdb editing: `slice()`, `select()`, `rename()`, `distinct()`, `summarize()`, `group_by()` and `ungroup()`
 * dplyr verbs can now also be used to edit vpc data
 * Added `irep()` function to add simulation counter to any dataset
@@ -88,7 +89,7 @@
 * New internal data structure using nested tibbles
 * Improvement of documentation, and testing
 
-### Data import 
+### Data import
 #### `read_nm_tables()`
 * Handles NONMEM tables in .csv, .zip format
 * Handles multiple $PROB and tables with FIRSTONLY option

R/vars_list.R

@@ -4,57 +4,105 @@
 #' 
 #' @param xpdb An \code{xpose_data} object from which the model code will be extracted.
 #' @param .problem The problem to be used, by lists all available problems.
-#' 
+#' @return Prints the list of all available variables, and returns that list
+#'   invisibly.  The name of the list is the problem number, the names of the
+#'   elements of the sub-lists are the variable types, and the values of the
+#'   sub-lists are the column names.
 #' @seealso \code{\link{set_var_types}}
 #' @examples
 #' list_vars(xpdb_ex_pk)
 #' @export
-list_vars <- function(xpdb, .problem = NULL) {
-  # Check input
-  check_xpdb(xpdb, check = 'data')
-
+#' @importFrom dplyr group_by_at
+#' @importFrom purrr map
+#' @importFrom stringr str_c
+list_vars <- function(xpdb, .problem=NULL) {
+  name_map <-
+    c(
+      "id"="Subject identifier (id)",
+      "occ"="Occasion flag (occ)", 
+      "na"="Not attributed (na)", 
+      "amt"="Dose amount (amt)", 
+      "idv"="Independent variable (idv)", 
+      "ipred"="Model individual predictions (ipred)", 
+      "pred"="Model typical predictions (pred)", 
+      "res"="Residuals (res)", 
+      "evid"="Event identifier (evid)", 
+      "dv"="Dependent variable (dv)", 
+      "catcov"="Categorical covariates (catcov)", 
+      "contcov"="Continuous covariates (contcov)", 
+      "param"="Model parameter (param)", 
+      "eta"="Eta (eta)", 
+      "a"="Compartment amounts (a)", 
+      "dvid"="DV identifier (dvid)", 
+      "mdv"="Missing dependent variable (mdv)"
+    )
+  ret <- list_vars_prep(xpdb, .problem=.problem)
+  ret_print <-
+    lapply(
+      X=ret,
+      FUN=function(x) {
+        new_names <- name_map[names(x)]
+        new_names <-
+          sprintf(
+            # left-justified, space-filled with the required number of
+            # characters
+            fmt=paste0("%-", max(nchar(new_names)) + 1, "s"),
+            new_names
+          )
+        setNames(object=x, nm=new_names)
+      }
+    )
+  lapply(
+    X=names(ret_print),
+    FUN=function(x) {
+      cat("\nList of available variables for problem no. ", x, "\n", sep="")
+      cat(
+        sprintf(
+          " - %s: %s\n",
+          names(ret_print[[x]]),
+          sapply(X=ret_print[[x]], FUN=paste, collapse=", ")
+        ),
+        sep=""
+      )
+    }
+  )
+  invisible(ret)
+}
+
+#' @importFrom tidyr nest
+#' @importFrom dplyr bind_rows
+list_vars_prep <- function(xpdb, .problem=NULL) {
+  check_xpdb(xpdb, check = "data")
   x <- xpdb$data
-
   if (!is.null(.problem)) {
     if (!all(.problem %in% x$problem)) {
-      stop('Problem no.', stringr::str_c(.problem[!.problem %in% x$problem], collapse = ', '), 
-           ' not found in the data.', call. = FALSE)
+      stop(
+        "Problem no.",
+        stringr::str_c(.problem[!.problem %in% x$problem], collapse = ", "),
+        " not found in the data.", 
+        call. = FALSE
+      )
     }
     x <- x[x$problem %in% .problem, ]
   }
-
-  order <- c('id', 'dv', 'idv', 'dvid', 'occ', 'amt', 'evid', 'mdv', 'pred', 'ipred', 
-             'param', 'eta', 'res', 'catcov', 'contcov', 'a', 'na')
-
-  x <- x %>% 
-    dplyr::mutate(grouping = as.integer(.$problem)) %>% 
-    dplyr::group_by_(.dots = 'grouping') %>% 
-    tidyr::nest() %>% 
-    {purrr::map(.$data, function(df) {
-      cat('\nList of available variables for problem no.', df$problem[1], '\n')
-      df$index[[1]] %>% 
-        dplyr::group_by_(.dots = 'type') %>% 
-        tidyr::nest() %>% 
-        dplyr::mutate(string = purrr::map_chr(.$data, ~stringr::str_c(unique(.$col), collapse = ', ')),
-                      descr = dplyr::case_when(.$type == 'id' ~ 'Subject identifier (id)',
-                                               .$type == 'occ' ~ 'Occasion flag (occ)',
-                                               .$type == 'na' ~ 'Not attributed (na)',
-                                               .$type == 'amt' ~ 'Dose amount (amt)',
-                                               .$type == 'idv' ~ 'Independent variable (idv)',
-                                               .$type == 'ipred' ~ 'Model individual predictions (ipred)',
-                                               .$type == 'pred' ~ 'Model typical predictions (pred)',
-                                               .$type == 'res' ~ 'Residuals (res)',
-                                               .$type == 'evid' ~ 'Event identifier (evid)',
-                                               .$type == 'dv' ~ 'Dependent variable (dv)',
-                                               .$type == 'catcov' ~ 'Categorical covariates (catcov)',
-                                               .$type == 'contcov' ~ 'Continuous covariates (contcov)',
-                                               .$type == 'param' ~ 'Model parameter (param)',
-                                               .$type == 'eta' ~ 'Eta (eta)',
-                                               .$type == 'a' ~ 'Compartment amounts (a)',
-                                               .$type == 'dvid' ~ 'DV identifier (dvid)',
-                                               .$type == 'mdv' ~ 'Missing dependent variable (mdv)')) %>% 
-        dplyr::mutate(descr = stringr::str_pad(.$descr, 37, 'right')) %>% 
-        dplyr::slice(order(match(.$type, order))) %>% 
-        {stringr::str_c(' -', .$descr, ':', .$string, sep = ' ')} %>% 
-        cat(sep = '\n')})}
+  type_order <-
+    c("id", "dv", "idv", "dvid",  "occ", "amt", "evid", "mdv", "pred",
+      "ipred", "param", "eta", "res", "catcov", "contcov", "a", "na")
+  ret <-
+    tidyr::nest(
+      data=dplyr::group_by_at(.tbl=x, .vars="problem")
+    )
+  ret$list_of_vars <-
+    purrr::map(
+      .x=ret$data,
+      .f=function(y) {
+        ret <- list()
+        current_index <- dplyr::bind_rows(y$index)
+        for (current_type in intersect(type_order, current_index$type)) {
+          ret[[current_type]] <- unique(current_index$col[current_index$type %in% current_type])
+        }
+        ret
+      }
+    )
+  setNames(object=ret$list_of_vars, nm=as.character(ret$problem))
 }

tests/testthat/test-console_outputs.R

@@ -15,7 +15,7 @@ print_text_modified <- paste0('run001.lst overview: \n - Software: nonmem 7.3.0
 prm_text_1   <- '\nReporting transformed parameters:\nFor the OMEGA and SIGMA matrices, values are reported as standard deviations for the diagonal elements and as correlations for the off-diagonal elements. The relative standard errors (RSE) for OMEGA and SIGMA are reported on the approximate standard deviation scale (SE/variance estimate)/2. Use `transform = FALSE` to report untransformed parameters.\n\nEstimates for $prob no.1, subprob no.0, method foce\n Parameter  Label      Value        RSE\n THETA1     TVCL       26.29        0.03391\n THETA2     TVV        1.348        0.0325\n THETA3     TVKA       4.204        0.1925\n THETA4     LAG        0.208        0.07554\n THETA5     Prop. Err  0.2046       0.1097\n THETA6     Add. Err   0.01055      0.3466\n THETA7     CRCL on CL 0.007172     0.2366\n OMEGA(1,1) IIV CL     0.2701       0.08616\n OMEGA(2,2) IIV V      0.195        0.1643\n OMEGA(3,3) IIV KA     1.381        0.1463\n SIGMA(1,1)            1        fix  - '
 prm_text_2   <- '\nReporting untransformed parameters:\nFor the OMEGA and SIGMA matrices, values are reported as variances for the diagonal elements and as covariances for the off-diagonal elements.\n\nEstimates for $prob no.1, subprob no.0, method foce\n Parameter  Label      Value        SE\n THETA1     TVCL       26.29        0.8915\n THETA2     TVV        1.348        0.04381\n THETA3     TVKA       4.204        0.8091\n THETA4     LAG        0.208        0.01571\n THETA5     Prop. Err  0.2046       0.02244\n THETA6     Add. Err   0.01055      0.003658\n THETA7     CRCL on CL 0.007172     0.001697\n OMEGA(1,1) IIV CL     0.07295      0.01257\n OMEGA(2,2) IIV V      0.03802      0.0125\n OMEGA(3,3) IIV KA     1.907        0.5582\n SIGMA(1,1)            1        fix  - '
 summary_text <- '\nSummary for problem no. 0 [Global information] \n - Software                      @software   : nonmem\n - Software version              @version    : 7.3.0\n - Run directory                 @dir        : analysis/models/pk/\n - Run file                      @file       : run001.lst\n - Run number                    @run        : run001\n - Reference model               @ref        : 000\n - Run description               @descr      : NONMEM PK example for xpose\n - Run start time                @timestart  : Mon Oct 16 13:34:28 CEST 2017\n - Run stop time                 @timestop   : Mon Oct 16 13:34:35 CEST 2017\n\nSummary for problem no. 1 [Parameter estimation] \n - Input data                    @data       : ../../mx19_2.csv\n - Number of individuals         @nind       : 74\n - Number of observations        @nobs       : 476\n - ADVAN                         @subroutine : 2\n - Estimation method             @method     : foce-i\n - Termination message           @term       : MINIMIZATION SUCCESSFUL\n - Estimation runtime            @runtime    : 00:00:02\n - Objective function value      @ofv        : -1403.905\n - Number of significant digits  @nsig       : 3.3\n - Covariance step runtime       @covtime    : 00:00:03\n - Condition number              @condn      : 21.5\n - Eta shrinkage                 @etashk     : 9.3 [1], 28.7 [2], 23.7 [3]\n - Epsilon shrinkage             @epsshk     : 14.9 [1]\n - Run warnings                  @warnings   : (WARNING 2) NM-TRAN INFERS THAT THE DATA ARE POPULATION.\n\nSummary for problem no. 2 [Model simulations] \n - Input data                    @data       : ../../mx19_2.csv\n - Number of individuals         @nind       : 74\n - Number of observations        @nobs       : 476\n - Estimation method             @method     : sim\n - Number of simulations         @nsim       : 20\n - Simulation seed               @simseed    : 221287\n - Run warnings                  @warnings   : (WARNING 2) NM-TRAN INFERS THAT THE DATA ARE POPULATION.\n                                               (WARNING 22) WITH $MSFI AND \"SUBPROBS\", \"TRUE=FINAL\" ...'
-vars_text    <- '\nList of available variables for problem no. 1 \n - Subject identifier (id)               : ID\n - Dependent variable (dv)               : DV\n - Independent variable (idv)            : TIME\n - Dose amount (amt)                     : AMT\n - Event identifier (evid)               : EVID\n - Model typical predictions (pred)      : PRED\n - Model individual predictions (ipred)  : IPRED\n - Model parameter (param)               : KA, CL, V, ALAG1\n - Eta (eta)                             : ETA1, ETA2, ETA3\n - Residuals (res)                       : CWRES, IWRES, RES, WRES\n - Categorical covariates (catcov)       : SEX, MED1, MED2\n - Continuous covariates (contcov)       : CLCR, AGE, WT\n - Compartment amounts (a)               : A1, A2\n - Not attributed (na)                   : DOSE, SS, II, TAD, CPRED'
+vars_text    <- '\nList of available variables for problem no. 1\n - Subject identifier (id)              : ID\n - Dependent variable (dv)              : DV\n - Independent variable (idv)           : TIME\n - Dose amount (amt)                    : AMT\n - Event identifier (evid)              : EVID\n - Model typical predictions (pred)     : PRED\n - Model individual predictions (ipred) : IPRED\n - Model parameter (param)              : KA, CL, V, ALAG1\n - Eta (eta)                            : ETA1, ETA2, ETA3\n - Residuals (res)                      : CWRES, IWRES, RES, WRES\n - Categorical covariates (catcov)      : SEX, MED1, MED2\n - Continuous covariates (contcov)      : CLCR, AGE, WT\n - Compartment amounts (a)              : A1, A2\n - Not attributed (na)                  : DOSE, SS, II, TAD, CPRED'
 
 # Tests start here --------------------------------------------------------
 test_that('Check print.xpose_data returns a proper message', {

tests/testthat/test-edits.R

@@ -18,7 +18,7 @@ test_xpdb_1 <- vpc_data(xpdb_ex_pk, opt = vpc_opt(n_bins = 2), quiet = TRUE)
 ctrl_xpdb_1 <- test_xpdb_1
 ctrl_xpdb_1$special$data[[1]]$vpc_dat <- dplyr::filter(.data = ctrl_xpdb_1$special$data[[1]]$vpc_dat, bin == 2)
 
-ctrl_list_vars_1 <- '\nList of available variables for problem no. 1 \n - Subject identifier (id)               : ID\n - Dependent variable (dv)               : DV\n - Independent variable (idv)            : TIME\n - Dose amount (amt)                     : AMT\n - Event identifier (evid)               : EVID\n - Model typical predictions (pred)      : PRED\n - Model individual predictions (ipred)  : IPRED\n - Model parameter (param)               : KA, CL, V, ALAG1\n - Eta (eta)                             : ETA1, ETA2, ETA3\n - Residuals (res)                       : CWRES, IWRES, RES, WRES\n - Categorical covariates (catcov)       : SEX, MED1, MED2\n - Continuous covariates (contcov)       : CLCR, AGE, WT\n - Compartment amounts (a)               : A1, A2\n - Not attributed (na)                   : DOSE, SS, II, CPRED, DV2\n\nList of available variables for problem no. 2 \n - Subject identifier (id)               : ID\n - Dependent variable (dv)               : DV\n - Independent variable (idv)            : TIME\n - Dose amount (amt)                     : AMT\n - Event identifier (evid)               : EVID\n - Model individual predictions (ipred)  : IPRED\n - Not attributed (na)                   : DOSE, SEX, CLCR, AGE, WT, DV2'
+ctrl_list_vars_1 <- '\nList of available variables for problem no. 1\n - Subject identifier (id)              : ID\n - Dependent variable (dv)              : DV\n - Independent variable (idv)           : TIME\n - Dose amount (amt)                    : AMT\n - Event identifier (evid)              : EVID\n - Model typical predictions (pred)     : PRED\n - Model individual predictions (ipred) : IPRED\n - Model parameter (param)              : KA, CL, V, ALAG1\n - Eta (eta)                            : ETA1, ETA2, ETA3\n - Residuals (res)                      : CWRES, IWRES, RES, WRES\n - Categorical covariates (catcov)      : SEX, MED1, MED2\n - Continuous covariates (contcov)      : CLCR, AGE, WT\n - Compartment amounts (a)              : A1, A2\n - Not attributed (na)                  : DOSE, SS, II, CPRED, DV2\n\nList of available variables for problem no. 2\n - Subject identifier (id)              : ID\n - Dependent variable (dv)              : DV\n - Independent variable (idv)           : TIME\n - Dose amount (amt)                    : AMT\n - Event identifier (evid)              : EVID\n - Model individual predictions (ipred) : IPRED\n - Not attributed (na)                  : DOSE, SEX, CLCR, AGE, WT, DV2'
 
 # Tests start here --------------------------------------------------------
 

tests/testthat/test-vars-list.R

@@ -0,0 +1,36 @@
+context('vars list')
+
+test_that("list_vars()", {
+  expect_output(test_ret <- list_vars(xpdb_ex_pk))
+  expect_equal(
+    test_ret,
+    invisible(list(
+      `1` =
+        list(
+          id = "ID",
+          dv = "DV",
+          idv = "TIME",
+          amt = "AMT", 
+          evid = "EVID",
+          pred = "PRED",
+          ipred = "IPRED",
+          param = c("KA", "CL", "V", "ALAG1"),
+          eta = c("ETA1", "ETA2", "ETA3"),
+          res = c("CWRES", "IWRES", "RES", "WRES"),
+          catcov = c("SEX", "MED1", "MED2"),
+          contcov = c("CLCR", "AGE", "WT"),
+          a = c("A1", "A2"),
+          na = c("DOSE", "SS", "II", "TAD", "CPRED")
+        ),
+      `2` =
+        list(
+          id = "ID",
+          dv = "DV",
+          idv = "TIME",
+          amt = "AMT",
+          evid = "EVID",
+          ipred = "IPRED",
+          na = c("DOSE", "TAD", "SEX", "CLCR", "AGE", "WT"))
+    ))
+  )
+})