diff --git a/NAMESPACE b/NAMESPACE index fbe244e5..ad9355ac 100755 --- a/NAMESPACE +++ b/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) diff --git a/NEWS.md b/NEWS.md index e3690e03..040e4ad7 100755 --- a/NEWS.md +++ b/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 diff --git a/R/vars_list.R b/R/vars_list.R index 4e015f6a..6bae9ff9 100755 --- a/R/vars_list.R +++ b/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)) } diff --git a/man/list_vars.Rd b/man/list_vars.Rd index 1f970226..60f1abbc 100755 --- a/man/list_vars.Rd +++ b/man/list_vars.Rd @@ -11,6 +11,12 @@ list_vars(xpdb, .problem = NULL) \item{.problem}{The problem to be used, by lists all available problems.} } +\value{ +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. +} \description{ Function listing all available variables in an xpdb object. } diff --git a/tests/testthat/test-console_outputs.R b/tests/testthat/test-console_outputs.R index 607ca7ce..a926d9b0 100755 --- a/tests/testthat/test-console_outputs.R +++ b/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', { diff --git a/tests/testthat/test-edits.R b/tests/testthat/test-edits.R index 7fcbc4cc..2dd882e0 100755 --- a/tests/testthat/test-edits.R +++ b/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 -------------------------------------------------------- diff --git a/tests/testthat/test-vars-list.R b/tests/testthat/test-vars-list.R new file mode 100644 index 00000000..5925ca38 --- /dev/null +++ b/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")) + )) + ) +})