Additional features

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)

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, ...)
+}

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))
 

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))
+
 }