In pnolain/popkinr: Shiny applications for pharmacometrics

knitr::opts_chunk$set(echo = FALSE, warning = FALSE, message = FALSE)

run <- params$run
grp_names <- groups(params$run$tables$pmxploitab)
group_cols <- plyr::mapvalues(as.character(grp_names), run$model$covariates$column, run$model$covariates$name,
                              warn_missing = FALSE)

qc <- run %>% quality_criteria(prediction = params$prediction,
                               log_data = params$log_data,
                               alpha = params$alpha)

Info

filters <- attr(run$tables$pmxploitab, "filters")

has_filters <- !is.null(filters)
n_obs <- run$info$number_of_observations
n_filtered_rows <- nrow(run$tables$pmxploitab)

filter_text <- ifelse(has_filters & (n_filtered_rows != n_obs),
                      sprintf("%s (filtered from %s)", n_filtered_rows, n_obs),
                      n_obs)

Number of observations: r filter_text

r if(has_filters) {"Filters:"}

if(has_filters)
  knitr::kable(tibble(condition = as.character(filters)), align = "c")

Standard QC

qc_cols <- intersect(colnames(qc), c("n_observations", "standard", group_cols))

qc_s <- qc %>% select(one_of(qc_cols)) %>% unnest(standard) %>% rename("Maximal Error" = max_err,
                                                               "Absolute Average Fold Error" = aafe)

knitr::kable(qc_s, align = "c")

Bias (Mean Prediction Error)

qc_cols <- intersect(colnames(qc), c("n_observations", "bias", group_cols))

qc_b <- qc %>% select(one_of(qc_cols)) %>% unnest(bias)

ci <- (1 - as.numeric(params$alpha)) * 100

dots <- setNames(c("value", "ci_low", "ci_up", "relative_value"),
                 nm = c("MPE (absolute)", paste(ci, "% CI (lower bound)"), paste(ci, "% CI (upper bound)"), "MPE (%)"))

qc_b <- qc_b %>% rename(!!!dots) %>% 
  mutate(`MPE (%)` = `MPE (%)` * 100)

knitr::kable(qc_b, align = "c")

Precision (Root Mean Square Error)

qc_cols <- intersect(colnames(qc), c("n_observations", "precision", group_cols))

qc_p <- qc %>% select(one_of(qc_cols)) %>% unnest(precision)

ci <- (1 - as.numeric(params$alpha)) * 100

dots <- setNames(c("value", "ci_low", "ci_up", "relative_value"),
                 nm = c("RMSE (absolute)", paste(ci, "% CI (lower bound)"), paste(ci, "% CI (upper bound)"), "RMSE (%)"))

qc_p <- qc_p %>% rename(!!!dots) %>% 
  mutate(`RMSE (%)` = `RMSE (%)` * 100)

knitr::kable(qc_p, align = "c")

Student's t-Test

Observations vs Predictions; paired, two-sided

qc_cols <- intersect(colnames(qc), c("n_observations", "t_test_obs", group_cols))

qc_t_o <- qc %>% 
  select(one_of(qc_cols))  %>%
  mutate(t_test_obs = map(t_test_obs, broom::tidy)) %>%
  unnest(t_test_obs) %>%
  select(-method, -alternative)

knitr::kable(qc_t_o)

Residuals vs zero; paired, two-sided

qc_cols <- intersect(colnames(qc), c("n_observations", "t_test_res", group_cols))

qc_t_r <-qc %>%
  select(one_of(qc_cols)) %>% 
  filter(!map_lgl(t_test_res, is.null))%>%
  unnest(t_test_res) %>%
  mutate(t.test = map(t.test, broom::tidy)) %>%
  unnest(t.test) %>%
  select(-method, -alternative)

knitr::kable(qc_t_r)

Correlation test

Observations vs Predictions

qc_cols <- intersect(colnames(qc), c("n_observations", "correlation_test", group_cols))

qc_c <- qc %>%
  select(one_of(qc_cols)) %>%
  mutate(correlation_test = map(correlation_test, broom::tidy)) %>%
  unnest(correlation_test) %>%
  select(-method, -alternative)


knitr::kable(qc_c)

Linear regression

$$Prediction = Intercept + Slope * Observation$$

qc_cols <- intersect(colnames(qc), c("n_observations", "linear_regression", group_cols))

qc_l <- qc %>%
  select(one_of(qc_cols)) %>% 
  mutate(linear_regression = map(linear_regression, tidy)) %>%
  unnest(linear_regression) %>%
  mutate(term = plyr::revalue(term, c("observations" = "slope")))

knitr::kable(qc_l, align = "c")