diff --git a/NAMESPACE b/NAMESPACE index 94d3e8a5..e3fb93c1 100755 --- a/NAMESPACE +++ b/NAMESPACE @@ -15,7 +15,9 @@ S3method(summary,xpose_data) S3method(ungroup,xpose_data) export("%>%") export(absval_res_vs_idv) +export(absval_res_vs_ipred) export(absval_res_vs_pred) +export(absval_res_vs_tad) export(add_facet_var) export(aes_c) export(aes_filter) @@ -24,6 +26,7 @@ export(all_data_problem) export(all_file_problem) export(amt_vs_idv) export(append_suffix) +export(apply_formats) export(as.ctime) export(as.nm.table.list) export(as.xpdb) @@ -62,6 +65,10 @@ export(get_prm) export(get_prm_transformation_formulas) export(get_special) export(get_summary) +export(get_var_labels) +export(get_var_labels_units) +export(get_var_types) +export(get_var_units) export(grab_iter) export(grd_vs_iteration) export(group_by) @@ -111,9 +118,12 @@ export(reorder_factors) export(res_distrib) export(res_qq) export(res_vs_idv) +export(res_vs_ipred) export(res_vs_pred) +export(res_vs_tad) export(select) export(set_var_labels) +export(set_var_labels_units) export(set_var_types) export(set_var_units) export(slice) diff --git a/R/plot_residuals.R b/R/plot_residuals.R index 1eec4a86..01fa1c6d 100755 --- a/R/plot_residuals.R +++ b/R/plot_residuals.R @@ -6,6 +6,7 @@ #' \itemize{ #' \item RES: model residuals #' \item WRES: weighted model residuals +#' \item IWRES: individual weighted model residuals #' \item CWRES: conditional weighted model residuals #' \item EWRES/ECWRES: Monte Carlo based model residuals #' \item NPDE: Normalized prediction distribution error @@ -125,6 +126,133 @@ absval_res_vs_pred <- function(xpdb, } +#' Residuals plotted against individual predictions +#' +#' @description Model residuals plotted against individual predictions (IPRED). +#' +#' The residuals can be one of: +#' \itemize{ +#' \item RES: model residuals +#' \item WRES: weighted model residuals +#' \item IWRES: individual weighted model residuals +#' \item CWRES: conditional weighted model residuals +#' \item EWRES/ECWRES: Monte Carlo based model residuals +#' \item NPDE: Normalized prediction distribution error +#' } +#' +#' @inheritParams dv_vs_pred +#' @param res Type of residual to be used. Default is "CWRES". +#' @inheritSection xplot_scatter Layers mapping +#' @inheritSection xplot_scatter Faceting +#' @inheritSection xplot_scatter Template titles +#' @seealso \code{\link{xplot_scatter}} +#' @examples +#' # Standard residual +#' res_vs_ipred(xpdb_ex_pk, res = c('IWRES', 'CWRES')) +#' +#' # Absolute value of the residuals +#' absval_res_vs_ipred(xpdb_ex_pk, res = 'CWRES') +#' +#' @export +res_vs_ipred <- function(xpdb, + mapping = NULL, + res = 'CWRES', + group = 'ID', + type = 'pls', + title = '@y vs. @x | @run', + subtitle = 'Ofv: @ofv', + caption = '@dir', + tag = NULL, + log = NULL, + guide = TRUE, + facets, + .problem, + quiet, + ...) { + # Check input + check_xpdb(xpdb, check = 'data') + if (missing(.problem)) .problem <- default_plot_problem(xpdb) + check_problem(.problem, .subprob = NULL, .method = NULL) + if (missing(quiet)) quiet <- xpdb$options$quiet + + if (length(res) > 1) { + if (missing(facets)) facets <- add_facet_var(facets = xpdb$xp_theme$facets, + variable = 'variable') + opt <- data_opt(.problem = .problem, + filter = only_obs(xpdb, .problem, quiet), + tidy = TRUE, value_col = res) + vars <- aes_c(aes( + x = .data[[xp_var(xpdb, .problem, type = 'ipred')$col]], + y = .data[["value"]]), mapping) + } else { + if (missing(facets)) facets <- xpdb$xp_theme$facets + opt <- data_opt(.problem = .problem, + filter = only_obs(xpdb, .problem, quiet)) + vars <- aes_c(aes( + x = .data[[xp_var(xpdb, .problem, type = 'pred')$col]], + y = .data[[toupper(res)]]), mapping) + } + + xplot_scatter(xpdb = xpdb, group = group, quiet = quiet, + opt = opt, mapping = vars, + type = type, guide = guide, facets = facets, + xscale = check_scales('x', log), + yscale = check_scales('y', log), + title = title, subtitle = subtitle, caption = caption, + tag = tag, plot_name = stringr::str_remove(deparse(match.call()[[1]]), "(\\w+\\.*)+::"), + guide_slope = 0, ...) +} + + +#' @rdname res_vs_pred +#' @export +absval_res_vs_ipred <- function(xpdb, + mapping = NULL, + res = 'CWRES', + group = 'ID', + type = 'pls', + title = '@y vs. @x | @run', + subtitle = 'Ofv: @ofv', + caption = '@dir', + tag = NULL, + log = NULL, + guide = FALSE, + facets, + .problem, + quiet, + ...) { + # Check input + check_xpdb(xpdb, check = 'data') + if (missing(.problem)) .problem <- default_plot_problem(xpdb) + check_problem(.problem, .subprob = NULL, .method = NULL) + if (missing(quiet)) quiet <- xpdb$options$quiet + + if (length(res) > 1) { + if (missing(facets)) facets <- add_facet_var(facets = xpdb$xp_theme$facets, + variable = 'variable') + opt <- data_opt(.problem = .problem, + filter = only_obs(xpdb, .problem, quiet), + tidy = TRUE, value_col = res) + vars <- aes_c(aes(x = .data[[xp_var(xpdb, .problem, type = 'ipred')$col]], + y = abs(.data[["value"]])), mapping) + } else { + if (missing(facets)) facets <- xpdb$xp_theme$facets + opt <- data_opt(.problem = .problem, + filter = only_obs(xpdb, .problem, quiet)) + vars <- aes_c(aes(x = .data[[xp_var(xpdb, .problem, type = 'ipred')$col]], + y = abs(.data[[toupper(res)]])), mapping) + } + + xplot_scatter(xpdb = xpdb, group = group, quiet = quiet, + opt = opt, mapping = vars, + type = type, guide = guide, facets = facets, + xscale = check_scales('x', log), + yscale = check_scales('y', log), + title = title, subtitle = subtitle, caption = caption, + tag = tag, plot_name = stringr::str_remove(deparse(match.call()[[1]]), "(\\w+\\.*)+::"), + guide_slope = 0, ...) +} + #' Residuals plotted against the independent variable #' #' @description Model residuals plotted against the independent variable (IDV). @@ -247,3 +375,131 @@ absval_res_vs_idv <- function(xpdb, tag = tag, plot_name = stringr::str_remove(deparse(match.call()[[1]]), "(\\w+\\.*)+::"), guide_slope = 0, ...) } + +#' Residuals plotted against the time after dose +#' +#' @description Model residuals plotted against the time after dose variable (IDV). +#' +#' The residuals can be one of: +#' \itemize{ +#' \item RES: model residuals +#' \item WRES: weighted model residuals +#' \item IWRES: individual weighted model residuals +#' \item CWRES: conditional weighted model residuals +#' \item EWRES/ECWRES: Monte Carlo based model residuals +#' \item NPDE: Normalized prediction distribution error +#' } +#' +#' @inheritParams dv_vs_pred +#' @param res Type of residual to be used. Default is "CWRES". +#' @inheritSection xplot_scatter Layers mapping +#' @inheritSection xplot_scatter Template titles +#' @seealso \code{\link{xplot_scatter}} +#' @examples +#' # Standard residual +#' res_vs_tad(xpdb_ex_pk, res = c('IWRES', 'CWRES')) +#' +#' @export +res_vs_tad <- function(xpdb, + mapping = NULL, + res = 'CWRES', + tad = c('TSPD', 'TSLD', 'TAD', 'TPD'), + group = 'ID', + type = 'pls', + title = '@y vs. @x | @run', + subtitle = 'Ofv: @ofv', + caption = '@dir', + tag = NULL, + log = NULL, + guide = TRUE, + facets, + .problem, + quiet, + ...) { + + # Check input + check_xpdb(xpdb, check = 'data') + if (missing(.problem)) .problem <- default_plot_problem(xpdb) + check_problem(.problem, .subprob = NULL, .method = NULL) + + # Change IDV variable type + vars <- xpobj$data[xpobj$data$problem == .problem, ]$index[[1]]$col + if ( length(tad) > 1 ) { + tads <- c('TSPD', 'TSLD', 'TAD', 'TPD') + tad <- tads[ tads %in% vars][1] + } + if ( !tad %in% vars ){ + stop( + paste(tad, 'not present in data') + ) + } + xpdb <- set_var_types(xpdb = xpdb, .problem = .problem, idv = tad) + + # Get plot + res_vs_idv( + xpdb = xpdb, + mapping = mapping, + res = res, + group = group, + type = type, + title = title, + subtitle = subtitle, + caption = caption, + tag = tag, + log = log, + guide = guide, + facets = facets, + .problem = .problem, + quiet = quiet, + ... + ) +} + +#' @rdname res_vs_tad +#' @export +absval_res_vs_tad <- function(xpdb, + mapping = NULL, + res = 'CWRES', + group = 'ID', + type = 'pls', + title = '@y vs. @x | @run', + subtitle = 'Ofv: @ofv', + caption = '@dir', + tag = NULL, + log = NULL, + guide = FALSE, + facets, + .problem, + quiet, + ...) { + # Check input + check_xpdb(xpdb, check = 'data') + if (missing(.problem)) .problem <- default_plot_problem(xpdb) + check_problem(.problem, .subprob = NULL, .method = NULL) + if (missing(quiet)) quiet <- xpdb$options$quiet + + if (length(res) > 1) { + if (missing(facets)) facets <- add_facet_var(facets = xpdb$xp_theme$facets, + variable = 'variable') + opt <- data_opt(.problem = .problem, + filter = only_obs(xpdb, .problem, quiet), + tidy = TRUE, value_col = res) + vars <- aes_c(aes(x = .data[[xp_var(xpdb, .problem, type = 'tad')$col]], + y = abs(.data[["value"]])), mapping) + } else { + if (missing(facets)) facets <- xpdb$xp_theme$facets + opt <- data_opt(.problem = .problem, + filter = only_obs(xpdb, .problem, quiet)) + vars <- aes_c(aes(x = .data[[xp_var(xpdb, .problem, type = 'tad')$col]], + y = abs(.data[[toupper(res)]])), mapping) + } + + xplot_scatter(xpdb = xpdb, group = group, quiet = quiet, + opt = opt, mapping = vars, + type = type, guide = guide, facets = facets, + xscale = check_scales('x', log), + yscale = check_scales('y', log), + title = title, subtitle = subtitle, caption = caption, + tag = tag, plot_name = stringr::str_remove(deparse(match.call()[[1]]), "(\\w+\\.*)+::"), + guide_slope = 0, ...) +} diff --git a/R/plot_vpc.R b/R/plot_vpc.R index 106790e4..9da5afcb 100755 --- a/R/plot_vpc.R +++ b/R/plot_vpc.R @@ -219,7 +219,7 @@ vpc <- function(xpdb, # Define scales xp <- xp + - labs(x = vpc_dat$obs_cols[['idv']], y = vpc_dat$obs_cols[['dv']]) + + # labs(x = vpc_dat$obs_cols[['idv']], y = vpc_dat$obs_cols[['dv']]) + xp_geoms(mapping = mapping, xp_theme = xpdb$xp_theme, name = 'xscale', @@ -262,6 +262,23 @@ vpc <- function(xpdb, xp <- xp + labs(tag = tag) } + if ( isTRUE(xpdb$options$use_labelunit) ){ + + xvar <- vpc_dat$obs_cols[['idv']] + yvar <- vpc_dat$obs_cols[['dv']] + + if ( !is.null(xvar) && xvar != '' ){ + xp <- xp + xlab( + get_var_labels_units( xpdb = xpdb, xvar ) + ) + } + if ( !is.null(yvar) && yvar != '' ){ + xp <- xp + ylab( + get_var_labels_units( xpdb = xpdb, yvar ) + ) + } + } + # Add limits whenever needed if (vpc_dat$type == 'categorical') xp <- xp + coord_cartesian(ylim = c(0, 1)) diff --git a/R/read_nm_tables.R b/R/read_nm_tables.R index c35c7080..189a5977 100755 --- a/R/read_nm_tables.R +++ b/R/read_nm_tables.R @@ -419,13 +419,16 @@ merge_firstonly <- function(x, quiet) { #' #' @keywords internal #' @export -index_table <- function(x) { +index_table <- function(x) { tab_type <- dplyr::case_when( stringr::str_detect(x$name, 'patab') ~ 'param', # model parameters stringr::str_detect(x$name, 'catab') ~ 'catcov', # categorical covariate stringr::str_detect(x$name, 'cotab') ~ 'contcov', # continuous covariate TRUE ~ 'na') + tad.var <- c('TSPD', 'TSLD', 'TAD', 'TPD') + tad.var <- tad.var[ tad.var %in% (x$data[[1]] %>% colnames()) ][1] + x$data[[1]] %>% colnames() %>% dplyr::tibble(table = x$name, @@ -437,6 +440,7 @@ index_table <- function(x) { .$col == 'ID' ~ 'id', .$col == 'DV' ~ 'dv', .$col == 'TIME' ~ 'idv', + .$col == tad.var ~ 'tad', .$col == 'OCC' ~ 'occ', .$col == 'DVID' ~ 'dvid', .$col == 'AMT' ~ 'amt', @@ -448,4 +452,5 @@ index_table <- function(x) { stringr::str_detect(.$col, 'ETA\\d+|ET\\d+') ~ 'eta', stringr::str_detect(.$col, '^A\\d+$') ~ 'a', TRUE ~ tab_type)) + } diff --git a/R/vars_get.R b/R/vars_get.R new file mode 100644 index 00000000..aa86c726 --- /dev/null +++ b/R/vars_get.R @@ -0,0 +1,168 @@ +#' Get variable type, label or units +#' +#' @description Function designed to extract the type, label or unit associated +#' with variables +#' +#' @param xpdb An \code{xpose_data} object. +#' @param .problem The problem number to which the edits will be applied. +#' @param variable A vector of data variables +#' +#' @return A character vector +#' @examples +#' # Get variable types +#' get_var_types(xpdb_ex_pk, .problem = 1, c('ID', 'MED1') +#' +#' # Get variable labels +#' get_var_labels(xpdb_ex_pk, .problem = 1, c('ID', 'MED1') +#' +#' # Get variable units +#' get_var_units(xpdb_ex_pk, .problem = 1, c('ID', 'MED1') +#' +#' @name get_vars +#' @export +#' +get_var_types <- function(xpdb, ..., .problem = NULL) { + get_var_generic( + xpdb = xpdb, .problem = .problem, what = 'type', ... + ) +} + +#' @rdname get_vars +#' @export +get_var_labels <- function(xpdb, ..., .problem = NULL) { + tmp <- get_var_generic( + xpdb = xpdb, .problem = .problem, what = 'label', ... + ) + if ( any(is.na(tmp)) ){ + tmp[is.na(tmp)] <- names(tmp)[is.na(tmp)] + } + tmp +} + +#' @rdname get_vars +#' @export +get_var_units <- function(xpdb, ..., .problem = NULL) { + get_var_generic( + xpdb = xpdb, .problem = .problem, what = 'units', ... + ) +} + + +get_var_generic <- function(xpdb, .problem = NULL, what = NULL, ...) { + + check_xpdb(xpdb, check = 'data') + if (is.null(.problem)) + .problem <- default_plot_problem(xpdb) + if (!is.null(.problem) && !all(.problem %in% xpdb$data$problem)) { + stop('Problem no.', stringr::str_c(.problem[!.problem %in% xpdb$data$problem], collapse = ', '), + ' not found in model output data.', call. = FALSE) + } + + variables <- c(...) + + if (is.null(variables)) + return(NULL) + if (is.null(what)) + return(NULL) + + tmp <- xpdb$data$index[[.problem]] %>% + dplyr::filter( col %in% variables ) %>% + dplyr::left_join( + data.frame( + order_ = 1:length(variables), + col = variables + ), + by = 'col' + ) %>% + dplyr::arrange(order_) + + if ( what == 'type' ){ + res <- tmp %>% dplyr::pull( type ) + } else if ( what == 'label' ){ + res <- tmp %>% dplyr::pull( label ) + } else if ( what == 'units' ){ + res <- tmp %>% dplyr::pull( units ) + } else { + return(NULL) + } + names(res) <- tmp %>% dplyr::pull( col ) + if (length(res) == 0) + res <- NULL + res +} + +#' Extract variable labels and units +#' +#' @description Utility function to construct a string made of a variable label +#' and units, if present in xpose object. Units are surrounded by parenthesis or +#' sqaure brackets based upon 'xpose_square_bracket' option. +#' +#' @param xpdb An xpose database object. +#' @param .problem The $problem number to be used. +#' @param variable Variable(s) for which labels and units are to be extracted. +#' +#' @return A character string. +#' +#' @examples +#' labels_units <- data.frame( +#' col = c('ALAG1', 'CL', 'V'), +#' label = c('Lag time', 'Clearance', 'Volume'), +#' units = c('h', 'L/h', 'L') +#' ) +#' +#' get_var_labels_units(xpdb, 'ALAG1') +#' get_var_labels_units(xpdb, 'ALAG1', 'CL') +#' +#' @keywords internal +#' @export + +get_var_labels_units <- function(xpdb, ..., .problem = NULL){ + + check_xpdb(xpdb, check = 'data') + + variables <- c(...) + + if ( !is.null(.problem) ){ + tmp <- data.frame( + label = get_var_labels( xpdb = xpdb, .problem = .problem, ... ), + units = get_var_units( xpdb = xpdb, .problem = .problem, ... ) + ) + tmp <- tmp %>% + dplyr::mutate( col = row.names(tmp) ) + } else { + if ( is.null(xpdb$label_units) ){ + return(variables) + } + tmp <- xpdb$label_units %>% + dplyr::filter( col %in% variables ) %>% + dplyr::left_join( + data.frame( + order_ = 1:length(variables), + col = variables + ), + by = 'col' + ) %>% + dplyr::mutate( label = ifelse(is.na(label), col, label) ) %>% + dplyr::arrange(order_) + } + + if ( nrow(tmp)==0 ) + return(NULL) + + open_sep <- ifelse( isTRUE(xpdb$options$square_bracket), '[', '(') + close_sep <- ifelse( isTRUE(xpdb$options$square_bracket), ']', ')') + + tmp <- tmp %>% + dplyr::mutate( + label_units = ifelse( + is.na(units), + label, + paste0(label,' ', open_sep, units, close_sep) + ) + ) + + res <- tmp %>% dplyr::pull( label_units ) + names(res) <- tmp %>% dplyr::pull( col ) + res + +} diff --git a/R/vars_list.R b/R/vars_list.R index 22f5e38d..ca0402cd 100755 --- a/R/vars_list.R +++ b/R/vars_list.R @@ -23,8 +23,9 @@ list_vars <- function(xpdb, .problem = NULL) { 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') + order <- c('id', 'dv', 'idv', 'tad', 'dvid', 'occ', 'amt', 'evid', 'mdv', + 'pred', 'ipred', 'param', 'eta', 'res', 'catcov', 'contcov', 'a', + 'na') x <- x %>% dplyr::mutate(grouping = as.integer(.$problem)) %>% @@ -43,6 +44,7 @@ list_vars <- function(xpdb, .problem = NULL) { .$type == 'na' ~ 'Not attributed (na)', .$type == 'amt' ~ 'Dose amount (amt)', .$type == 'idv' ~ 'Independent variable (idv)', + .$type == 'tad' ~ 'Time after dose (tad)', .$type == 'ipred' ~ 'Model individual predictions (ipred)', .$type == 'pred' ~ 'Model typical predictions (pred)', .$type == 'res' ~ 'Residuals (res)', diff --git a/R/vars_set.R b/R/vars_set.R index f30a41c3..dc74639f 100755 --- a/R/vars_set.R +++ b/R/vars_set.R @@ -6,6 +6,7 @@ #' @param .problem The problem number to which the edits will be applied. #' @param ... Specifications of the edits to be made to the xpdb index. Edits are made as #' type and variable pairs e.g. idv = 'TAD' will assign TAD to the type idv (independent variable). +#' @param info A data frame of variable names, labels, and units. #' @param auto_factor With \code{set_var_types} only. If \code{TRUE} new columns assigned to the type 'catcov' will be converted to #' factor. #' @param quiet Logical, if \code{FALSE} messages are printed to the console. @@ -22,6 +23,7 @@ #' \item evid: Event identifier #' \item id: Subject identifier #' \item idv: Independent variable +#' \item tad: Time after dose #' \item ipred: Individual model predictions #' \item mdv: Missing dependent variable #' \item na: Not attributed @@ -35,7 +37,7 @@ #' @seealso \code{\link{list_vars}} #' @examples #' # Change variable type -#' xpdb_2 <- set_var_types(xpdb_ex_pk, .problem = 1, idv = 'TAD') +#' xpdb_2 <- set_var_types(xpdb_ex_pk, .problem = 1, catcov = 'DOSE') #' #' # Change labels #' xpdb_2 <- set_var_labels(xpdb_2, .problem = 1, ALAG1 = 'Lag time', CL = 'Clearance', V = 'Volume') @@ -43,8 +45,20 @@ #' # Change units #' xpdb_2 <- set_var_units(xpdb_2, .problem = 1, ALAG1 = 'h', CL = 'L/h', V = 'L') #' +#' labels_units <- data.frame( +#' col = c('ALAG1', 'CL', 'V'), +#' label = c('Lag time', 'Clearance', 'Volume'), +#' units = c('h', 'L/h', 'L') +#' ) +#' +#' xpdb_2 <- set_var_labels_units(xpdb_ex_pk, .problem = 1, info = labels_units) +#' #' @name set_vars +#' +#' @return A xpose object #' @export +#' +#' set_var_types <- function(xpdb, .problem = NULL, ..., auto_factor = TRUE, quiet) { # Check input check_xpdb(xpdb, check = 'data') @@ -92,7 +106,7 @@ set_var_types <- function(xpdb, .problem = NULL, ..., auto_factor = TRUE, quiet) } # Remove previous index when only one variable can be used at the time - single_type <- c('amt', 'dv', 'dvid', 'evid', 'id', 'idv', 'ipred', 'mdv', 'pred') + single_type <- c('amt', 'dv', 'dvid', 'evid', 'id', 'idv', 'tad', 'ipred', 'mdv', 'pred') single_type <- single_type[single_type %in% args$type] if (length(single_type) > 0) index$type[index$type %in% single_type] <- 'na' @@ -189,3 +203,736 @@ set_var_units <- function(xpdb, .problem = NULL, ..., quiet) { set_var_generic(xpdb = xpdb, .problem = .problem, quiet = quiet, what = 'units', ...) } + +#' @rdname set_vars +#' @export +set_var_labels_units <- function( + xpdb, + .problem = NULL, + info = NULL +){ + + check_xpdb(xpdb, check = 'data') + + if ( !is.data.frame(info) ){ + stop('Invalid info argument') + } + + if ( !all(names(info) == c('col', 'label', 'units')) ){ + stop('Invalid data frame structure in info') + } + + info <- info %>% + select( col, label, units ) + + if ( nrow(info) > nrow(unique(info)) ){ + stop('Duplicate variable entries in info') + } + + if ( is.null(.problem) ){ + .problem <- 1:length(xpdb$data$index) + } + + for (.prob in .problem){ + # Filter info to distinct variables present in data + tmp <- info %>% + dplyr::distinct( col, .keep_all = TRUE ) %>% + dplyr::filter( col %in% names(get_data(xpdb, .problem = .prob)) ) + + # Collapse labels and units information into strings + var_labels <- c() + var_units <- c() + for ( i in seq_len(nrow(tmp)) ){ + if ( is.na(tmp$label[i]) ){ + var_labels <- c( var_labels, paste0(tmp$col[i], ' = NA') ) + } else { + var_labels <- c( var_labels, paste0(tmp$col[i], ' = \'', tmp$label[i], '\'') ) + } + if ( is.na(tmp$units[i]) ){ + var_units <- c( var_units, paste0(tmp$col[i], ' = NA') ) + } else { + var_units <- c( var_units, paste0(tmp$col[i], ' = \'', tmp$units[i], '\'') ) + } + } + + var_labels <- paste(var_labels, collapse = ', ') + var_units <- paste(var_units, collapse = ', ') + + # Apply labels and units + if ( var_labels != '' ){ + eval( + parse( + text = sprintf( + 'xpdb <- set_var_labels(xpdb, .problem = %s, %s)', + .prob, + var_labels + ) + ) + ) + } + if ( var_units != '' ){ + eval( + parse( + text = sprintf( + 'xpdb <- set_var_units(xpdb, .problem = %s, %s)', + .prob, + var_units + ) + ) + ) + } + } + + xpdb <- unclass(xpdb) + + xpdb$label_units <- info + + as.xpdb(xpdb) +} + +#' @title Format numerical variables in data tables +#' +#' @description This function applies SAS-like formats to the numerical variables +#' according to a user-defined table of format definitions. Formatting is +#' performed by transforming the variables into factors. Discrete numerical +#' variables can become discrete character variables more suited for reporting +#' purposes. Additionally, formats can be used to discretize continuous +#' variables by defining ranges of values associated with specific formats. +#' +#' @param .data A data.frame or tibble of data +#' @param formats A data.frame with an expected structure defined in the Details +#' section +#' +#' @return An updated data object with the same dimension as the \code{.data} +#' argument. +#' +#' @details +#' Formats typically are intended to be applied to categorical variables (eg, sex) +#' to replace numerical values by character labels (eg, 0=Males, 1=Females). +#' However, formats can also be applied to continuous variables (eg, CrCL) to +#' coerce them into categorical variables by defining intervals (eg, >90=Normal +#' renal function). +#' +#' Format data.frames have the following expected structure: +#' \describe{ +#' \item{VARIABLE}{The (case sensitive) name of the variable to apply this +#' format to.} +#' \item{START}{The start of the interval. If missing, -Inf is assumed.} +#' \item{END}{The end of the interval (start and end can be identical when +#' dealing with format for categorical variables). If missing, +Inf is +#' assumed.} +#' \item{EXCLS}{Whether the start value of the interval should be excluded. +#' Can be set to 0/1 or FALSE/TRUE.} +#' \item{EXCLE}{Whether the end value of the interval should be excluded. +#' Can be set to 0/1 or FALSE/TRUE.} +#' \item{LABEL}{The format label to be applied for value of VARIABLE within +#' START and END} +#' \item{ORDER}{Ordering index of the interval} +#' } +#' +#' The complete definition of a variable format can and will typically span +#' multiple rows of the format data.frames (eg, for sex, 2 rows will be +#' required: one for the 0 value, and another one for the 1 value). Format +#' data.frames can contain format for variables which do not exist in \code{.data}. +#' +#' Data formatting will not be performed if the format definition for a variable +#' is invalid. A format definition will be deemed invalid if: \itemize{ +#' \item{formatting information is not provided for any variables included in +#' the data,} +#' \item{formatting information is not provided for all values included in the +#' data,} +#' \item{formatting information is provided for non-numeric variables,} +#' \item{EXCLS, EXCLE, LABEL, and/or ORDER are missing,} +#' \item{ranges defined by START and END overlaps, or} +#' \item{LABEL and ORDER are not consistent.} +#' } +#' +#' Note that while LABEL and ORDER must be consistent, several values (or +#' ranges of values) of a variable can be set to the same LABEL and ORDER. +#' +#' @examples +#' fmts <- data.frame( +#' variable = c("SEX", "SEX", "CLCR", "CLCR", "CLCR", "CLCR", "CLCR"), +#' start = c(1L, 2L, 90L, 60L, 30L, 15L, NA), +#' end = c(1L, 2L, NA, 90L, 60L, 30L, 15L), +#' excls = c(0L, 0L, 1L, 1L, 1L, 1L, 0L), +#' excle = c(0L, 0L, 0L, 0L, 0L, 0L, 0L), +#' label = c("Male", "Female", "Normal", "Mild", "Moderate", "Severe", "End of disease"), +#' order = c(1L, 2L, 1L, 2L, 3L, 4L, 5L) +#' ) +#' fmts +#' xp2 <- apply_formats(xpdb, .problem = 1, fmts) +#' +#' @rdname apply_formats +#' +#' @export +#' + +apply_formats <- function( + xpdb, + .problem, + formats, + quiet +){ + + are_range_overlapping <- function(ranges){ + + if ( nrow(ranges) == 1 ){ + return(FALSE) + } + ranges <- as.data.frame(ranges) + + ranges <- ranges[order(ranges[,1]),] + + if ( any(ranges[2,1:2]-ranges[1,1:2] < 0) ){ + stop('Range end(s) larger than range start(s)') + } + + # Check if edges overlap + edges <- c(t(as.matrix(ranges[,1:2]))) + + # Check if same edge is included in 2 consecutive interval + excls <- c(t(as.matrix(ranges[,3:4]))) + nr <- nrow(ranges) + same_edge <- diff(edges)[2*(1:(nr-1))]==0 & diff(excls)[2*(1:(nr-1))]==0 & + ranges[-1,3]==0 + + is.unsorted(edges) | any(same_edge) + + } + + df_collapse <- function(x){ + do.call(paste, c(unname(x), sep = '@')) + } + + if ( missing(quiet) ) + quiet <- !interactive() + + # Check xpdb + check_xpdb(xpdb, check = 'data') + + if ( missing(.problem) ){ + .problem <- default_plot_problem(xpdb) + } + + data <- get_data( xpdb, .problem = .problem ) %>% + dplyr::ungroup() + + # Check formats + if ( missing(formats) ){ + stop('Missing `formats` argument') + } + # formats must be a data.frame or a tibble + if ( !(is.data.frame(formats) | dplyr::is.tbl(formats)) ){ + stop( 'Invalid `formats` argument' ) + } + names(formats) <- toupper( names(formats) ) + + formats_col <- c('VARIABLE', 'START', 'END', 'EXCLS', 'EXCLE', 'LABEL', 'ORDER') + if ( !all( formats_col %in% names(formats) ) ){ + stop( 'Missing columns in `formats` argument' ) + } + + formats <- formats %>% + dplyr::ungroup() %>% + dplyr::select( VARIABLE, START, END, EXCLS, EXCLE, LABEL, ORDER ) + + if ( !is.character(formats$VARIABLE) | !is.character(formats$LABEL) ) { + stop('VARIABLE and LABEL columns in `formats` argument must be character') + } + + if ( !is.numeric(formats$START) | !is.numeric(formats$END) | !is.numeric(formats$ORDER) ) { + stop('START, END, and ORDER columns in `formats` argument must be numeric') + } + + if ( + !(is.numeric(formats$EXCLS) | is.logical(formats$EXCLS)) | + !(is.numeric(formats$EXCLE) | is.logical(formats$EXCLE)) + ){ + stop('EXCLS and EXCLE columns in `formats` argument must be integer or logical') + } + + if ( nrow(formats) == 0 ){ + if ( !quiet ) + warning( 'No available format. Formatting aborted.' ) + return( xpdb ) + } + + # Pre-process formats + formats <- formats %>% + # Ensure labels are characters + dplyr::mutate( LABEL = as.character(LABEL) ) %>% + # Filter out from formats variables which are not in data + dplyr::filter( VARIABLE %in% names(data) ) %>% + # Replace missing min with -inf and missing max with +inf + dplyr::mutate( + START = ifelse( is.na(START), -Inf, START ), + END = ifelse( is.na(END), +Inf, END ), + ) %>% + # Coerce exclusion columns to integer + dplyr::mutate( + EXCLS = as.integer(as.logical(EXCLS)), + EXCLE = as.integer(as.logical(EXCLE)) + ) %>% + # Filter out duplicated format rows + dplyr::distinct() + + if ( nrow(formats) == 0 ){ + if ( !quiet ) + warning( 'Variables in data have no available format' ) + return( xpdb ) + } + + # Trap formats with empty rows + empty_vars <- formats %>% + dplyr::filter( + START == -Inf & END == Inf & is.na(EXCLS) & is.na(EXCLE) & is.na(LABEL) & is.na(ORDER) + ) %>% + dplyr::distinct( VARIABLE) %>% + dplyr::pull( VARIABLE ) + + if ( length(empty_vars) > 0 ){ + formats <- formats %>% + dplyr::filter( !VARIABLE %in% empty_vars ) + if ( !quiet ){ + warning( + sprintf( + paste( + 'Format not applied for the following variables', + 'because of empty rows in format definition:\n %s\n'), + paste( empty_vars, collapse = ', ') + ) + ) + } + } + + # Trap formats with missing (NA) information + if ( any(is.na(formats)) ){ + na_vars <- formats %>% + dplyr::mutate( CHK = dplyr::if_any(.fns = is.na) ) %>% + dplyr::filter( CHK == TRUE ) %>% + dplyr::pull( VARIABLE ) + formats <- formats %>% + dplyr::filter( !VARIABLE %in% na_vars ) + if ( !quiet ){ + warning( + sprintf( + paste( + 'Format not applied for the following variable(s)', + 'because of missing values:\n %s\n'), + paste( na_vars, collapse = ', ') + ) + ) + } + } + + if ( nrow(formats) == 0 ){ + if ( !quiet ) + warning( 'Variables in data have no available format' ) + return( xpdb ) + } + + # Check for consistency of label and order numbers within variables + if ( + formats %>% dplyr::distinct( VARIABLE, LABEL) %>% nrow() != + formats %>% dplyr::distinct( VARIABLE, ORDER) %>% nrow() + ){ + if ( !quiet ) + warning( + paste( + 'Format not applied because the numbers of unique', + 'format labels and orders\n was not consistent for all variables' + ) + ) + return( xpdb ) + } + + tmp <- suppressWarnings( + formats %>% dplyr::distinct( VARIABLE, LABEL) %>% rownames() == + formats %>% dplyr::distinct( VARIABLE, ORDER) %>% rownames() + ) + if ( !all(tmp) ){ + vars <- formats[!tmp, 'VARIABLE'] + if ( !quiet ) + warning( + sprintf( + paste( + 'Format not applied because the indexes of unique format labels and', + 'orders\n were not consistent for the following variables:\n %s' + ), + paste(vars, collapse = ', ') + ) + ) + return( xpdb ) + } + + # Store formats for later usage + oformats <- formats + + # Check that formats do not overlap + error_fvars <- c() + fvars <- unique(formats$VARIABLE) + + for (var in fvars){ + tmp <- try( + formats %>% + dplyr::filter( VARIABLE == var) %>% + dplyr::select( START, END, EXCLS, EXCLE ) %>% + are_range_overlapping(), + silent = TRUE + ) + if ( class(tmp)=='try-error' || tmp ){ + error_fvars <- c(error_fvars, var) + } + } + + # Store formats for later usage + oformats <- formats + + if ( length(fvars) > 0 && length(error_fvars) > 0){ + fvars <- fvars[ !fvars%in%error_fvars ] + formats <- formats %>% + dplyr::filter( VARIABLE %in% fvars ) + if ( !quiet ) + warning( + sprintf( + paste( + 'Format not applied for the following variables because of invalid or', + '\n overlapping ranges:\n %s\n' + ), + paste(error_fvars, collapse = ', ') + ) + ) + } + + # Prevent formatting of character variables + error_fvars <- c() + for ( var in fvars ){ + if ( mode(data[[var]]) != 'numeric' ){ #note: mode also detects numeric factor + error_fvars <- c(error_fvars, var) + } + } + + if ( length(error_fvars) > 0 ){ + formats <- formats %>% + dplyr::filter( !VARIABLE %in% error_fvars ) + if ( !quiet ) + warning( + sprintf( + 'Non-numeric variable(s) cannot be formatted:\n %s\n', + paste(error_fvars, collapse = ', ') + ) + ) + } + + fvars <- formats %>% + dplyr::distinct( VARIABLE ) %>% + dplyr::pull( VARIABLE ) + + if ( nrow(formats) == 0 ){ + if ( !quiet ) + warning( 'Variables in data have no available format' ) + return( xpdb ) + } + + # Apply formats + + # Copy original variables + odata <- data %>% + dplyr::select( dplyr::any_of(fvars) ) + + # Determine which formats are defined with ranges + formats <- formats %>% + dplyr::mutate( ISRANGE = ifelse( abs(END - START) > 0, 1, 0) ) + + tmp <- formats %>% + dplyr::group_by( VARIABLE ) %>% + dplyr::summarize( + ISRANGE = max(ISRANGE), + .groups = 'keep' + ) + fvars_byrange <- tmp %>% + dplyr::filter( ISRANGE == 1 ) %>% + dplyr::pull( VARIABLE ) + fvars_byval <- tmp %>% + dplyr::filter( ISRANGE == 0 ) %>% + dplyr::pull( VARIABLE ) + + # Coerce EXCLS and EXCLE to 0 for fvars_byval + if ( + formats %>% + dplyr::filter( VARIABLE %in% fvars_byval ) %>% + dplyr::filter( EXCLS == 1L | EXCLE == 1L) %>% + nrow() > 0 + ){ + if ( !quiet ) + message( + sprintf( + paste( + 'Inclusion of start and end range values was assumed', + 'for the following variables:\n %s\n'), + paste(fvars_byval, collapse = ', ') + ) + ) + } + formats <- formats %>% + dplyr::mutate( + EXCLS = ifelse( VARIABLE %in% fvars_byval, 0L, EXCLS), + EXCLE = ifelse( VARIABLE %in% fvars_byval, 0L, EXCLE) + ) + + # Format variables in data + done <- c() + messages <- c() + nformats <- formats[c(),] + + for ( var in fvars ){ + + # Reset variable to NA + data[[var]] <- NA + + # Get format for var + format <- formats %>% + dplyr::filter( VARIABLE == var ) %>% + dplyr::distinct() + + # Subset format to values found in data, only for format defined by value + tmp <- format$START %in% unique(data[[var]]) + if ( var %in% fvars_byval && sum(tmp) > 0 ){ + format <- format %>% + dplyr::filter( START %in% unique(data[[var]]) ) + } + + # Re-order format + format <- format %>% + dplyr::arrange( ORDER ) + format$ORDER <- match( format$LABEL, unique(format$LABEL) ) + + # Convert to numeric data + if ( mode(odata[[var]]) == 'numeric' & inherits(odata[[var]], 'factor') ){ + vdata <- as.numeric( levels(odata[[var]]) )[ odata[[var]] ] + } else { + vdata <- odata[[var]] + } + + # Detect if variables include NA's, substitute value and add format if this + # is the case + hasNA <- FALSE + if ( any(is.na(vdata)) ){ + hasNA <- TRUE + + # Find replacement info + missingVal <- -99 + n <- 3 + while ( missingVal %in% vdata ){ + missingVal <- -sum(sapply(1:n, function(n) 9*10^(n-1))) + n <- n+1 + } + replacement <- 'Missing' + while ( any(format$LABEL == replacement) ){ + replacement <- sprintf('_%s_', replacement) + } + + # Replace in vdata + vdata[ is.na(vdata) ] <- missingVal + + # Replace NA in odata + if ( is.factor(odata[[var]]) ){ + odata[[var]] <- factor( + odata[[var]], + levels = c(levels(odata[[var]]), NA), + labels = c(levels(odata[[var]]), missingVal), + exclude = NULL + ) + } else { + odata[is.na(odata[[var]]), var] <- missingVal + } + + # Add format + format <- format %>% + dplyr::bind_rows( + data.frame( + VARIABLE = var, + START = missingVal, + END = missingVal, + EXCLS = 0L, + EXCLE = 0L, + LABEL = replacement, + ORDER = max(format$ORDER) + 1 + ) + ) + + messages <- c( + messages, + sprintf('Missing values were set to %s for variable %s\n', missingVal, var) + ) + } + + # Update nformat + nformats <- dplyr::bind_rows( nformats, format ) + + # Replace NA by order in var + # Add 1e-12 left and right of interval (proportionally) when >= or <= is + # used to deal with numerical representation issues + fs <- c() + + for ( f in 1:nrow(format) ){ + + matches <- eval( + parse( + text = paste( + 'vdata >', + ifelse( format$EXCLS[f] == 0, '= ', ' ' ), + ifelse( + format$EXCLS[f] == 0, + ifelse( + format$START[f] >= 0, + format$START[f]*(1-1e-12), + format$START[f]*(1+1e-12) + ), + format$START[f] + ), + ' & ','vdata <', + ifelse( format$EXCLE[f] == 0, '= ', ' ' ), + ifelse( + format$EXCLE[f] == 0, + ifelse( + format$END[f] >= 0, + format$END[f]*(1+1e-12), + format$END[f]*(1-1e-12) + ), + format$END[f] + ), + sep = '' + ) + ) + ) + matches <- !is.na(matches) & matches + if ( length(matches) > 0){ + data[matches, var] <- format$ORDER[f] + } + if ( any(matches) ){ + fs <- c(fs, f) + } + } + + # Check if remaining NA's (ie, label was not provided for all variable + # level in NONMEM table): if yes, revert to original var data; otherwise, + # apply labels and set var to formatted factors + + if ( any(is.na(data[[var]])) ){ + misvals <- unique( odata[is.na(data[[var]]),var] ) + nmisvals <- length(misvals) + misvals <- misvals[ 1:min(c(10, nmisvals)) ] + messages <- c( + messages, + sprintf( + paste( + 'Format not applied for %s because', + 'labels were not provided for the\n following value(s)%s: %s\n'), + var, + ifelse(nmisvals>10,' (only 10 shown)',''), + paste(misvals, collapse=', ') + ) + ) + data[[var]] <- odata[[var]] + } else { + data[[var]] <- factor( + data[[var]], + labels = unique(format$LABEL[fs]) + ) + class(data[[var]]) <- c('factor','formatted') + done <- c(done, var) + } + } + + # List formatted variables + if ( length(done) > 0 ){ + messages <- c( + messages, + sprintf( + paste( + 'The following variables have been formatted and', + 'coerced to factors:\n %s\n'), + paste(done, collapse=', ') + ) + ) + } + + if ( !quiet ) + cat( + sprintf( + '\n%s', + paste(messages, collapse='\n') + ) + ) + + # Store information + + # Bring back oformats + # Add original order variable in formats and nformats + formats <- oformats %>% + dplyr::mutate( + O_ORDER = ORDER, + ORDER = NA + ) + nformats <- nformats %>% + dplyr::select( -ISRANGE ) %>% + dplyr::mutate( O_ORDER = NA ) + + # Add Missing formats from nformats into formats + formats <- dplyr::bind_rows( + formats, + nformats[!df_collapse(nformats[, 1:6]) %in% df_collapse(formats[, 1:6]),] + ) + + # Re-order formats before next step and reset ORDER + formats <- formats %>% + dplyr::arrange( VARIABLE, O_ORDER ) %>% + dplyr::group_by( VARIABLE ) %>% + dplyr::mutate( + ORDER = dplyr::row_number() + ) %>% + dplyr::ungroup() %>% + dplyr::select( -O_ORDER ) %>% + as.data.frame() + + # Add O_VARIABLE + formats <- formats %>% + dplyr::mutate( + O_VARIABLE = paste0('o_', VARIABLE) + ) + + # Update object + names(odata) <- paste0( 'o_', names(odata) ) + xpdb$data$data[[.problem]] <- dplyr::bind_cols( data, odata ) + xpdb$formats <- formats + xpdb$data$index[[.problem]] <- dplyr::bind_rows( + xpdb$data$index[[.problem]], + xpdb$data$index[[.problem]] %>% + dplyr::filter( col %in% fvars) %>% + mutate( col = paste0('o_', col) ) + ) + var_types <- c() + for ( fvar in fvars ){ + if (get_var_type(xpdb, .problem, fvar) == 'catcov'){ + var_types <- c( + var_types, + paste0(fvar, ' = \'catcov\'') + ) + } + } + var_types <- paste(var_types, collapse = ', ') + eval( + parse( + text = sprintf( + 'xpdb <- set_var_types(xpdb, .problem = %s, %s)', + .problem, + var_types + ) + ) + ) + + as.xpdb(xpdb) + +} diff --git a/R/xplot_helpers.R b/R/xplot_helpers.R index 994a0ec9..e0bf81b7 100755 --- a/R/xplot_helpers.R +++ b/R/xplot_helpers.R @@ -469,3 +469,43 @@ add_facet_var <- function(facets, variable = 'variable') { new = stats::as.formula(stringr::str_c('~. + ', variable))) } } + +#' Extract variable from mapping argument +#' +#' @description Get the name of the variables used in a mapping argument, based +#' upon the coding standard used in the `xpose` package +#' +#' @param mapping A mapping object. +#' @param aes An aesthetic to be extracted +#' +#' @return The name of a variable. +#' +#' @examples +#' mapping <- aes(x = TIME, y = DV, point_color = MED1) +#' get_aes(mapping, 'x') +#' get_aes(mapping, point_colour) +#' @keywords internal + +get_aes <- function(mapping, aes){ + + aes <- substitute(aes) + + if (is.null(mapping) | is.null(aes)) + return(NULL) + + res <- sub( + '~', '', + sub( + '^~.data[[]+\"', '', + sub( + '\"[]]+$', '', + paste( mapping[as.character(evalq(aes))] ) ) + ) + ) + + if ( res == "NULL" ){ + return(NULL) + } + + res +} diff --git a/R/xplot_scatter.R b/R/xplot_scatter.R index 95a40129..ecae42cd 100755 --- a/R/xplot_scatter.R +++ b/R/xplot_scatter.R @@ -191,6 +191,23 @@ xplot_scatter <- function(xpdb, xp <- xp + labs(tag = tag) } + if ( isTRUE(xpdb$options$use_labelunit) ){ + + xvar <- get_aes(mapping, 'x') + yvar <- get_aes(mapping, 'y') + + if ( !is.null(xvar) && xvar != '' ){ + xp <- xp + xlab( + get_var_labels_units( xpdb = xpdb, xvar ) + ) + } + if ( !is.null(yvar) && yvar != '' ){ + xp <- xp + ylab( + get_var_labels_units( xpdb = xpdb, yvar ) + ) + } + } + # Add metadata to plots xp$xpose <- list(fun = plot_name, summary = xpdb$summary, @@ -198,9 +215,9 @@ xplot_scatter <- function(xpdb, subprob = attr(data, 'subprob'), method = attr(data, 'method'), quiet = quiet, - xp_theme = xpdb$xp_theme[stringr::str_c(c('title', 'subtitle', + xp_theme = xpdb$xp_theme[stringr::str_c(c('title', 'subtitle', 'caption', 'tag'), '_suffix')]) - # Ouptut the plot + # Output the plot as.xpose.plot(xp) } diff --git a/R/xpose_data.R b/R/xpose_data.R index 882a878e..fff0c6a1 100755 --- a/R/xpose_data.R +++ b/R/xpose_data.R @@ -177,9 +177,20 @@ xpose_data <- function(runno = NULL, attr(xp_theme, 'theme') <- as.character(substitute(xp_theme)) # Output xpose_data - list(code = model_code, summary = summary, data = data, - files = out_files, gg_theme = gg_theme, xp_theme = xp_theme, - options = list(dir = dirname(full_path), quiet = quiet, - manual_import = manual_import)) %>% + list( + code = model_code, + summary = summary, + data = data, + files = out_files, + gg_theme = gg_theme, + xp_theme = xp_theme, + options = list(dir = dirname(full_path), + quiet = quiet, + manual_import = manual_import, + use_labelunit = TRUE, + square_bracket = FALSE), + label_units = NULL, + formats = NULL + ) %>% structure(class = c('xpose_data', 'uneval')) } diff --git a/data/xpdb_ex_pk.rda b/data/xpdb_ex_pk.rda index 26433faf..9874d458 100755 Binary files a/data/xpdb_ex_pk.rda and b/data/xpdb_ex_pk.rda differ diff --git a/man/apply_formats.Rd b/man/apply_formats.Rd new file mode 100644 index 00000000..2d726325 --- /dev/null +++ b/man/apply_formats.Rd @@ -0,0 +1,84 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/vars_set.R +\name{apply_formats} +\alias{apply_formats} +\title{Format numerical variables in data tables} +\usage{ +apply_formats(xpdb, .problem, formats, quiet) +} +\arguments{ +\item{formats}{A data.frame with an expected structure defined in the Details +section} + +\item{.data}{A data.frame or tibble of data} +} +\value{ +An updated data object with the same dimension as the \code{.data} +argument. +} +\description{ +This function applies SAS-like formats to the numerical variables +according to a user-defined table of format definitions. Formatting is +performed by transforming the variables into factors. Discrete numerical +variables can become discrete character variables more suited for reporting +purposes. Additionally, formats can be used to discretize continuous +variables by defining ranges of values associated with specific formats. +} +\details{ +Formats typically are intended to be applied to categorical variables (eg, sex) +to replace numerical values by character labels (eg, 0=Males, 1=Females). +However, formats can also be applied to continuous variables (eg, CrCL) to +coerce them into categorical variables by defining intervals (eg, >90=Normal +renal function). + +Format data.frames have the following expected structure: +\describe{ + \item{VARIABLE}{The (case sensitive) name of the variable to apply this + format to.} + \item{START}{The start of the interval. If missing, -Inf is assumed.} + \item{END}{The end of the interval (start and end can be identical when + dealing with format for categorical variables). If missing, +Inf is + assumed.} + \item{EXCLS}{Whether the start value of the interval should be excluded. + Can be set to 0/1 or FALSE/TRUE.} + \item{EXCLE}{Whether the end value of the interval should be excluded. + Can be set to 0/1 or FALSE/TRUE.} + \item{LABEL}{The format label to be applied for value of VARIABLE within + START and END} + \item{ORDER}{Ordering index of the interval} + } + + The complete definition of a variable format can and will typically span + multiple rows of the format data.frames (eg, for sex, 2 rows will be + required: one for the 0 value, and another one for the 1 value). Format + data.frames can contain format for variables which do not exist in \code{.data}. + + Data formatting will not be performed if the format definition for a variable + is invalid. A format definition will be deemed invalid if: \itemize{ + \item{formatting information is not provided for any variables included in + the data,} + \item{formatting information is not provided for all values included in the + data,} + \item{formatting information is provided for non-numeric variables,} + \item{EXCLS, EXCLE, LABEL, and/or ORDER are missing,} + \item{ranges defined by START and END overlaps, or} + \item{LABEL and ORDER are not consistent.} + } + + Note that while LABEL and ORDER must be consistent, several values (or + ranges of values) of a variable can be set to the same LABEL and ORDER. +} +\examples{ +fmts <- data.frame( + variable = c("SEX", "SEX", "CLCR", "CLCR", "CLCR", "CLCR", "CLCR"), + start = c(1L, 2L, 90L, 60L, 30L, 15L, NA), + end = c(1L, 2L, NA, 90L, 60L, 30L, 15L), + excls = c(0L, 0L, 1L, 1L, 1L, 1L, 0L), + excle = c(0L, 0L, 0L, 0L, 0L, 0L, 0L), + label = c("Male", "Female", "Normal", "Mild", "Moderate", "Severe", "End of disease"), + order = c(1L, 2L, 1L, 2L, 3L, 4L, 5L) +) +fmts +xp2 <- apply_formats(xpdb, .problem = 1, fmts) + +} diff --git a/man/get_aes.Rd b/man/get_aes.Rd new file mode 100644 index 00000000..52564a03 --- /dev/null +++ b/man/get_aes.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/xplot_helpers.R +\name{get_aes} +\alias{get_aes} +\title{Extract variable from mapping argument} +\usage{ +get_aes(mapping, aes) +} +\arguments{ +\item{mapping}{A mapping object.} + +\item{aes}{An aesthetic to be extracted} +} +\value{ +The name of a variable. +} +\description{ +Get the name of the variables used in a mapping argument, based +upon the coding standard used in the `xpose` package +} +\examples{ +mapping <- aes(x = TIME, y = DV, point_color = MED1) +get_aes(mapping, 'x') +get_aes(mapping, point_colour) +} +\keyword{internal} diff --git a/man/get_var_labels_units.Rd b/man/get_var_labels_units.Rd new file mode 100644 index 00000000..99f3795a --- /dev/null +++ b/man/get_var_labels_units.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/vars_get.R +\name{get_var_labels_units} +\alias{get_var_labels_units} +\title{Extract variable labels and units} +\usage{ +get_var_labels_units(xpdb, ..., .problem = NULL) +} +\arguments{ +\item{xpdb}{An xpose database object.} + +\item{.problem}{The $problem number to be used.} + +\item{variable}{Variable(s) for which labels and units are to be extracted.} +} +\value{ +A character string. +} +\description{ +Utility function to construct a string made of a variable label +and units, if present in xpose object. Units are surrounded by parenthesis or +sqaure brackets based upon 'xpose_square_bracket' option. +} +\examples{ +labels_units <- data.frame( + col = c('ALAG1', 'CL', 'V'), + label = c('Lag time', 'Clearance', 'Volume'), + units = c('h', 'L/h', 'L') +) + +get_var_labels_units(xpdb, 'ALAG1') +get_var_labels_units(xpdb, 'ALAG1', 'CL') + +} +\keyword{internal} diff --git a/man/get_vars.Rd b/man/get_vars.Rd new file mode 100644 index 00000000..da0f01ad --- /dev/null +++ b/man/get_vars.Rd @@ -0,0 +1,40 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/vars_get.R +\name{get_vars} +\alias{get_vars} +\alias{get_var_types} +\alias{get_var_labels} +\alias{get_var_units} +\title{Get variable type, label or units} +\usage{ +get_var_types(xpdb, ..., .problem = NULL) + +get_var_labels(xpdb, ..., .problem = NULL) + +get_var_units(xpdb, ..., .problem = NULL) +} +\arguments{ +\item{xpdb}{An \code{xpose_data} object.} + +\item{.problem}{The problem number to which the edits will be applied.} + +\item{variable}{A vector of data variables} +} +\value{ +A character vector +} +\description{ +Function designed to extract the type, label or unit associated +with variables +} +\examples{ +# Get variable types +get_var_types(xpdb_ex_pk, .problem = 1, c('ID', 'MED1') + +# Get variable labels +get_var_labels(xpdb_ex_pk, .problem = 1, c('ID', 'MED1') + +# Get variable units +get_var_units(xpdb_ex_pk, .problem = 1, c('ID', 'MED1') + +} diff --git a/man/res_vs_ipred.Rd b/man/res_vs_ipred.Rd new file mode 100644 index 00000000..a12b9e4f --- /dev/null +++ b/man/res_vs_ipred.Rd @@ -0,0 +1,132 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot_residuals.R +\name{res_vs_ipred} +\alias{res_vs_ipred} +\title{Residuals plotted against individual predictions} +\usage{ +res_vs_ipred( + xpdb, + mapping = NULL, + res = "CWRES", + group = "ID", + type = "pls", + title = "@y vs. @x | @run", + subtitle = "Ofv: @ofv", + caption = "@dir", + tag = NULL, + log = NULL, + guide = TRUE, + facets, + .problem, + quiet, + ... +) +} +\arguments{ +\item{xpdb}{An xpose database object.} + +\item{mapping}{List of aesthetics mappings to be used for the xpose plot +(e.g. \code{point_color}).} + +\item{res}{Type of residual to be used. Default is "CWRES".} + +\item{group}{Grouping variable to be used for lines.} + +\item{type}{String setting the type of plot to be used. Can be points 'p', +line 'l', smooth 's' and text 't' or any combination of the four.} + +\item{title}{Plot title. Use \code{NULL} to remove.} + +\item{subtitle}{Plot subtitle. Use \code{NULL} to remove.} + +\item{caption}{Page caption. Use \code{NULL} to remove.} + +\item{tag}{Plot identification tag. Use \code{NULL} to remove.} + +\item{log}{String assigning logarithmic scale to axes, can be either '', +'x', y' or 'xy'.} + +\item{guide}{Enable guide display (e.g. unity line).} + +\item{facets}{Either a character string to use \code{\link[ggforce]{facet_wrap_paginate}} +or a formula to use \code{\link[ggforce]{facet_grid_paginate}}.} + +\item{.problem}{The $problem number to be used. By default returns +the last estimation problem.} + +\item{quiet}{Logical, if \code{FALSE} messages are printed to the console.} + +\item{...}{Any additional aesthetics to be passed on \code{xplot_scatter}.} +} +\description{ +Model residuals plotted against individual predictions (IPRED). + +The residuals can be one of: +\itemize{ + \item RES: model residuals + \item WRES: weighted model residuals + \item IWRES: individual weighted model residuals + \item CWRES: conditional weighted model residuals + \item EWRES/ECWRES: Monte Carlo based model residuals + \item NPDE: Normalized prediction distribution error +} +} +\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 +any option supported by this layer e.g. point_color = 'blue', smooth_method = 'lm', etc. +\itemize{ + \item point: options to \code{geom_point} + \item line: options to \code{geom_line} + \item guide: options to \code{geom_abline} + \item smooth: options to \code{geom_smooth} + \item text: options to \code{geom_text} + \item xscale: options to \code{scale_x_continuous} or \code{scale_x_log10} + \item yscale: options to \code{scale_y_continuous} or \code{scale_y_log10} +} +} + +\section{Faceting}{ + +Every xpose plot function has built-in faceting functionalities. Faceting arguments +are passed to the functions \code{\link[ggforce]{facet_wrap_paginate}} when the \code{facets} +argument is a character string (e.g. \code{facets = c('SEX', 'MED1')}) or +\code{\link[ggforce]{facet_grid_paginate}} when facets is a formula (e.g. \code{facets = SEX~MED1}). +All xpose plot functions accept all the arguments for the \code{\link[ggforce]{facet_wrap_paginate}} +and \code{\link[ggforce]{facet_grid_paginate}} functions e.g. \code{dv_vs_ipred(xpdb_ex_pk, +facets = SEX~MED1, ncol = 3, nrow = 3, page = 1, margins = TRUE, labeller = 'label_both')}. + +Faceting options can either be defined in plot functions (e.g. \code{dv_vs_ipred(xpdb_ex_pk, +facets = 'SEX')}) or assigned globally to an xpdb object via the \code{xp_theme} (e.g. \code{xpdb +<- update_themes(xpdb_ex_pk, xp_theme = list(facets = 'SEX'))}). In the latter example all plots +generate from this xpdb will automatically be stratified by `SEX`. + +By default, some plot functions use a custom stratifying variable named `variable`, e.g. +\code{eta_distrib()}. When using the \code{facets} argument, `variable` needs to be added manually +e.g. \code{facets = c('SEX', 'variable')} or \code{facets = c('SEX', 'variable')}, but is optional, +when using the \code{facets} argument in \code{xp_theme} variable is automatically added whenever needed. +} + +\section{Template titles}{ + +Template titles can be used to create highly informative diagnostics plots. +They can be applied to any plot title, subtitle, caption and tag. Template titles +are defined via a single string containing key variables staring with a `@` (e.g. `@ofv`) +which will be replaced by their actual value when rendering the plot. +For example `'@run, @nobs observations in @nind subjects'` would become +`'run001, 1022 observations in 74 subjects'`. The available key variables +are listed under \code{\link{template_titles}}. +} + +\examples{ +# Standard residual +res_vs_ipred(xpdb_ex_pk, res = c('IWRES', 'CWRES')) + +# Absolute value of the residuals +absval_res_vs_ipred(xpdb_ex_pk, res = 'CWRES') + +} +\seealso{ +\code{\link{xplot_scatter}} +} diff --git a/man/res_vs_pred.Rd b/man/res_vs_pred.Rd index d9bd3282..c37bcb9d 100755 --- a/man/res_vs_pred.Rd +++ b/man/res_vs_pred.Rd @@ -3,6 +3,7 @@ \name{res_vs_pred} \alias{res_vs_pred} \alias{absval_res_vs_pred} +\alias{absval_res_vs_ipred} \title{Residuals plotted against population predictions} \usage{ res_vs_pred( @@ -40,6 +41,24 @@ absval_res_vs_pred( quiet, ... ) + +absval_res_vs_ipred( + xpdb, + mapping = NULL, + res = "CWRES", + group = "ID", + type = "pls", + title = "@y vs. @x | @run", + subtitle = "Ofv: @ofv", + caption = "@dir", + tag = NULL, + log = NULL, + guide = FALSE, + facets, + .problem, + quiet, + ... +) } \arguments{ \item{xpdb}{An xpose database object.} @@ -84,6 +103,7 @@ The residuals can be one of: \itemize{ \item RES: model residuals \item WRES: weighted model residuals + \item IWRES: individual weighted model residuals \item CWRES: conditional weighted model residuals \item EWRES/ECWRES: Monte Carlo based model residuals \item NPDE: Normalized prediction distribution error diff --git a/man/res_vs_tad.Rd b/man/res_vs_tad.Rd new file mode 100644 index 00000000..6265f2b5 --- /dev/null +++ b/man/res_vs_tad.Rd @@ -0,0 +1,128 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot_residuals.R +\name{res_vs_tad} +\alias{res_vs_tad} +\alias{absval_res_vs_tad} +\title{Residuals plotted against the time after dose} +\usage{ +res_vs_tad( + xpdb, + mapping = NULL, + res = "CWRES", + tad = c("TSPD", "TSLD", "TAD", "TPD"), + group = "ID", + type = "pls", + title = "@y vs. @x | @run", + subtitle = "Ofv: @ofv", + caption = "@dir", + tag = NULL, + log = NULL, + guide = TRUE, + facets, + .problem, + quiet, + ... +) + +absval_res_vs_tad( + xpdb, + mapping = NULL, + res = "CWRES", + group = "ID", + type = "pls", + title = "@y vs. @x | @run", + subtitle = "Ofv: @ofv", + caption = "@dir", + tag = NULL, + log = NULL, + guide = FALSE, + facets, + .problem, + quiet, + ... +) +} +\arguments{ +\item{xpdb}{An xpose database object.} + +\item{mapping}{List of aesthetics mappings to be used for the xpose plot +(e.g. \code{point_color}).} + +\item{res}{Type of residual to be used. Default is "CWRES".} + +\item{group}{Grouping variable to be used for lines.} + +\item{type}{String setting the type of plot to be used. Can be points 'p', +line 'l', smooth 's' and text 't' or any combination of the four.} + +\item{title}{Plot title. Use \code{NULL} to remove.} + +\item{subtitle}{Plot subtitle. Use \code{NULL} to remove.} + +\item{caption}{Page caption. Use \code{NULL} to remove.} + +\item{tag}{Plot identification tag. Use \code{NULL} to remove.} + +\item{log}{String assigning logarithmic scale to axes, can be either '', +'x', y' or 'xy'.} + +\item{guide}{Enable guide display (e.g. unity line).} + +\item{facets}{Either a character string to use \code{\link[ggforce]{facet_wrap_paginate}} +or a formula to use \code{\link[ggforce]{facet_grid_paginate}}.} + +\item{.problem}{The $problem number to be used. By default returns +the last estimation problem.} + +\item{quiet}{Logical, if \code{FALSE} messages are printed to the console.} + +\item{...}{Any additional aesthetics to be passed on \code{xplot_scatter}.} +} +\description{ +Model residuals plotted against the time after dose variable (IDV). + +The residuals can be one of: +\itemize{ + \item RES: model residuals + \item WRES: weighted model residuals + \item IWRES: individual weighted model residuals + \item CWRES: conditional weighted model residuals + \item EWRES/ECWRES: Monte Carlo based model residuals + \item NPDE: Normalized prediction distribution error +} +} +\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 +any option supported by this layer e.g. point_color = 'blue', smooth_method = 'lm', etc. +\itemize{ + \item point: options to \code{geom_point} + \item line: options to \code{geom_line} + \item guide: options to \code{geom_abline} + \item smooth: options to \code{geom_smooth} + \item text: options to \code{geom_text} + \item xscale: options to \code{scale_x_continuous} or \code{scale_x_log10} + \item yscale: options to \code{scale_y_continuous} or \code{scale_y_log10} +} +} + +\section{Template titles}{ + +Template titles can be used to create highly informative diagnostics plots. +They can be applied to any plot title, subtitle, caption and tag. Template titles +are defined via a single string containing key variables staring with a `@` (e.g. `@ofv`) +which will be replaced by their actual value when rendering the plot. +For example `'@run, @nobs observations in @nind subjects'` would become +`'run001, 1022 observations in 74 subjects'`. The available key variables +are listed under \code{\link{template_titles}}. +} + +\examples{ +# Standard residual +res_vs_tad(xpdb_ex_pk, res = c('IWRES', 'CWRES')) + +} +\seealso{ +\code{\link{xplot_scatter}} +} diff --git a/man/set_vars.Rd b/man/set_vars.Rd index cb88cb96..00fd9a2f 100755 --- a/man/set_vars.Rd +++ b/man/set_vars.Rd @@ -5,6 +5,7 @@ \alias{set_var_types} \alias{set_var_labels} \alias{set_var_units} +\alias{set_var_labels_units} \title{Set variable type, label or units} \usage{ set_var_types(xpdb, .problem = NULL, ..., auto_factor = TRUE, quiet) @@ -12,6 +13,8 @@ set_var_types(xpdb, .problem = NULL, ..., auto_factor = TRUE, quiet) set_var_labels(xpdb, .problem = NULL, ..., quiet) set_var_units(xpdb, .problem = NULL, ..., quiet) + +set_var_labels_units(xpdb, .problem = NULL, info = NULL) } \arguments{ \item{xpdb}{An \code{xpose_data} object.} @@ -25,9 +28,13 @@ type and variable pairs e.g. idv = 'TAD' will assign TAD to the type idv (indepe factor.} \item{quiet}{Logical, if \code{FALSE} messages are printed to the console.} + +\item{info}{A data frame of variable names, labels, and units.} } \value{ An xpose_data object + +A xpose object } \description{ Function designed to change the type, label or unit associated with variables. @@ -45,6 +52,7 @@ Function designed to change the type, label or unit associated with variables. \item evid: Event identifier \item id: Subject identifier \item idv: Independent variable + \item tad: Time after dose \item ipred: Individual model predictions \item mdv: Missing dependent variable \item na: Not attributed @@ -57,7 +65,7 @@ Function designed to change the type, label or unit associated with variables. \examples{ # Change variable type -xpdb_2 <- set_var_types(xpdb_ex_pk, .problem = 1, idv = 'TAD') +xpdb_2 <- set_var_types(xpdb_ex_pk, .problem = 1, catcov = 'DOSE') # Change labels xpdb_2 <- set_var_labels(xpdb_2, .problem = 1, ALAG1 = 'Lag time', CL = 'Clearance', V = 'Volume') @@ -65,6 +73,14 @@ xpdb_2 <- set_var_labels(xpdb_2, .problem = 1, ALAG1 = 'Lag time', CL = 'Clearan # Change units xpdb_2 <- set_var_units(xpdb_2, .problem = 1, ALAG1 = 'h', CL = 'L/h', V = 'L') +labels_units <- data.frame( + col = c('ALAG1', 'CL', 'V'), + label = c('Lag time', 'Clearance', 'Volume'), + units = c('h', 'L/h', 'L') +) + +xpdb_2 <- set_var_labels_units(xpdb_ex_pk, .problem = 1, info = labels_units) + } \seealso{ \code{\link{list_vars}} diff --git a/tests/testthat/test-console_outputs.R b/tests/testthat/test-console_outputs.R index 503e0228..a0dce510 100755 --- a/tests/testthat/test-console_outputs.R +++ b/tests/testthat/test-console_outputs.R @@ -13,7 +13,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.1, 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.1, 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 : data\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 - Time after dose (tad) : TAD\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' # Tests start here -------------------------------------------------------- test_that('Check print.xpose_data returns a proper message', { diff --git a/tests/testthat/test-get_vars.R b/tests/testthat/test-get_vars.R new file mode 100755 index 00000000..c06dd48d --- /dev/null +++ b/tests/testthat/test-get_vars.R @@ -0,0 +1,64 @@ +xp1 <- set_var_types(xpdb_ex_pk, catcov = 'DOSE') +xp1 <- set_var_labels(xp1, .problem = 1, ALAG1 = 'Lag time', CL = 'Clearance') +xp1 <- set_var_units(xp1, .problem = 1, ALAG1 = 'h', CL = 'L/h') +xp2 <- set_var_labels_units( + xpdb_ex_pk, + info = data.frame( + col = c('ALAG1', 'CL', 'V'), + label = c('Lag time', 'Clearance', 'Volume'), + units = c('h', NA, 'L') + ) +) +xp2 <- set_var_labels(xp2, .problem = 1, V = 'Central volume') + +# Tests start here -------------------------------------------------------- +test_that('input is check properly', { + expect_error(get_var_types(), regexp = 'argument \"xpdb\" is missing') + expect_error(get_var_labels(), regexp = 'argument \"xpdb\" is missing') + expect_error(get_var_units(), regexp = 'argument \"xpdb\" is missing') + expect_error(get_var_labels_units(), regexp = 'argument \"xpdb\" is missing') + expect_error(get_var_types(xpdb_ex_pk, .problem = 99), regexp = 'not found in model') + expect_error(get_var_labels(xpdb_ex_pk, .problem = 99), regexp = 'not found in model') + expect_error(get_var_units(xpdb_ex_pk, .problem = 99), regexp = 'not found in model') + expect_error(get_var_labels_units(xpdb_ex_pk, .problem = 99), regexp = 'not found in model') + expect_error(get_var_types(xpdb_ex_pk, .problem = 1, zzz), regexp = 'object \'zzz\' not found') + expect_error(get_var_labels(xpdb_ex_pk, .problem = 1, zzz), regexp = 'object \'zzz\' not found') + expect_error(get_var_units(xpdb_ex_pk, .problem = 1, zzz), regexp = 'object \'zzz\' not found') + expect_error(get_var_labels_units(xpdb_ex_pk, .problem = 99, zzz), regexp = 'object \'zzz\' not found') + +}) + +test_that('get_vars_type works properly', { + expect_true(is.null(get_var_types(xpdb_ex_pk, 'HELLO'))) + expect_type(get_var_types(xpdb_ex_pk, 'ID'), 'character') + expect_equal( + unname(get_var_types(xp1, 'TIME', 'PRED', 'DOSE')), + c('idv', 'pred', 'catcov') + ) +}) + +test_that('get_var_labels works properly', { + expect_true(is.null(get_var_labels(xp1, .problem = 1, 'zzz'))) + expect_true(get_var_labels(xp1, .problem = 1, 'TIME') == 'TIME') + expect_true(all(get_var_labels(xp1, .problem = 1, 'ALAG1', 'CL') %in% c('Lag time', 'Clearance'))) +}) + +test_that('get_var_units works properly', { + expect_true(is.null(get_var_units(xp1, .problem = 1, 'zzz'))) + expect_true(is.na(get_var_units(xp1, .problem = 1, 'TIME'))) + expect_true(all(get_var_units(xp1, .problem = 1, 'ALAG1', 'CL') %in% c('h', 'L/h'))) +}) + +test_that('get_var_labels_units works properly', { + expect_true(is.null(get_var_labels_units(xp2, 'zzz', .problem = 1))) + expect_true(is.null(get_var_labels_units(xp2, 'zzz'))) + expect_true(get_var_labels_units(xp1, 'TIME', .problem = 1) == 'TIME') + expect_true(get_var_labels_units(xp1, 'TIME') == 'TIME') + expect_true(get_var_labels_units(xp2, 'CL') == 'Clearance') + expect_true( + all(get_var_labels_units(xp2, 'ALAG1', 'V') == c('Lag time (h)', 'Volume (L)')) + ) + expect_true( + all(get_var_labels_units(xp2, 'ALAG1', 'V', .problem = 1) == c('Lag time (h)', 'Central volume (L)')) + ) +}) diff --git a/tests/testthat/test-xplot_helpers.R b/tests/testthat/test-xplot_helpers.R index ca4f01c2..56908843 100755 --- a/tests/testthat/test-xplot_helpers.R +++ b/tests/testthat/test-xplot_helpers.R @@ -2,6 +2,7 @@ xpdb_NULL <- xpdb_ex_pk xpdb_NULL$data <- NULL xpdb_NULL$files <- NULL xpdb_NULL <- as.xpdb(xpdb_NULL) +mapping <- aes(x = TIME) # Tests start here -------------------------------------------------------- # test_that('Check check_vars', { @@ -106,3 +107,9 @@ test_that('Check add_facets_var', { expect_equal(add_facet_var(facets = as.formula('OCC~SEX'), variable = 'variable'), as.formula('OCC~SEX+variable')) }) + +test_that('Check get_aes', { + expect_error(get_aes(mapping)) + expect_equal(get_aes(mapping, x), 'TIME') +}) +