Merge pull request #370 from ggPMXdevelopment/369-parameter-table-for…

…-monolix-2013r1

369 parameter table for monolix 2013r1

NAMESPACE

@@ -38,7 +38,6 @@ export(pk_occ)
 export(pk_pd)
 export(plot_names)
 export(plot_pmx)
-export(plot_pmx_gpar_real)
 export(plots)
 export(pmx)
 export(pmxOptions)

R/plot-base.R

@@ -1,3 +1,14 @@
+#' The ggPMX base plot function
+#'
+#'
+#' This function should be called internally by other plots to set
+#' general settings like , smoothing, add band, labelling, theming,...
+#' @param x object of pmx_gpar type
+#' @param dx plot
+#' @param ... ignored parameters
+#' @import ggplot2
+#' @family plot_pmx
+#' @return ggplot2 object
 #' @export
 plot_pmx.pmx_gpar <- function(x, dx, ...) {
   extra <- list(...)
@@ -8,21 +19,10 @@ plot_pmx.pmx_gpar <- function(x, dx, ...) {
   }
 }
 
-#' The ggPMX base plot function
-#'
-#'
-#' This function should be called internally by other plots to set
-#' general settings like , smoothing, add band, labelling, theming,...
-#' @param gpar object of pmx_gpar type
-#' @param p plot
-#' @param bloq_cens bloq censored column name
-#' @import ggplot2
-#' @family plot_pmx
-#' @return ggplot2 object
-#' @export
-plot_pmx_gpar_real <- function(gpar, p, bloq_cens) {
+plot_pmx_gpar_real <- function(gpar, p, bloq_cens, ...) {
   assert_that(is_pmx_gpar(gpar))
   assert_that(is_ggplot(p))
+  if (length(list(...)) != 0) stop("plot_pmx.pmx_gpar requires 3 arguments", call.=FALSE)
   with(gpar, {
     assert_that(is_list_or_null(smooth))
     assert_that(is_list_or_null(band))

R/plot-vpc.R

@@ -223,8 +223,10 @@ pmx_vpc_rug <-
            linewidth = 1,
            alpha = 0.7,
            size) {
-    lifecycle::deprecate_soft("1.2.9", "pmx_vpc_rug(size)", I("use `linewidth=` instead of `size=`"))
-    if (!missing(size)) linewidth <- size
+    if (!missing(size)){
+      lifecycle::deprecate_soft("1.2.9", "pmx_vpc_rug(size)", I("use `linewidth=` instead of `size=`"))
+      linewidth <- size
+    }
     if (show) {
       structure(
         list(
@@ -541,19 +543,19 @@ vpc.plot <- function(x) {
 #'
 
 pmx_vpc <- function(
-  type = c("percentile", "scatter"),
-  idv = "TIME",
-  obs = pmx_vpc_obs(),
-  pi = pmx_vpc_pi(),
-  ci = pmx_vpc_ci(),
-  rug = pmx_vpc_rug(),
-  bin = pmx_vpc_bin(),
-  labels = NULL,
-  facets = NULL,
-  is.legend = TRUE,
-  is.footnote= TRUE,
-  dname = NULL,
-  ...) {
+                    type = c("percentile", "scatter"),
+                    idv = "TIME",
+                    obs = pmx_vpc_obs(),
+                    pi = pmx_vpc_pi(),
+                    ci = pmx_vpc_ci(),
+                    rug = pmx_vpc_rug(),
+                    bin = pmx_vpc_bin(),
+                    labels = NULL,
+                    facets = NULL,
+                    is.legend = TRUE,
+                    is.footnote= TRUE,
+                    dname = NULL,
+                    ...) {
   type <- match.arg(type)
   ## check args here
 

R/pmx-reader.R

@@ -456,24 +456,30 @@ read_mlx18_pred <- function(path, x, ...) {
 #' @return data.table object
 #' @importFrom utils read.table
 #' @import data.table
-
 read_mlx_par_est <- function(path, x, ...) {
   sep <- ifelse(exists("sep", x), x$sep, ";")
-  xx <- setDT(read.table(path, sep = sep, header = TRUE))
-  if ("names" %in% names(x)) {
-    # This handles the case where the
-    nam <- x[["names"]]
-    do_more <- FALSE
-    if (length(nam) > ncol(xx)) {
-      nam <- nam[seq(1, ncol(xx))]
-    }
-    setnames(xx, seq_along(nam), nam)
-    if (do_more) {
-      nam <- x[["names"]]
-      nam <- nam[-seq(1, ncol(xx))]
-      xx <- xx[, (nam) := NA]
-    }
-  }
+  xx <- as.data.frame(read.table(path, sep = sep, header = TRUE))
+  val <- names(xx)[1]
+  names <- vapply(names(xx), function(v) {
+    if (val == v) return("PARAM")
+    if (grepl("^par", v, ignore.case=TRUE)) return("VALUE")
+    if (grepl("(^value|^val)", v, ignore.case=TRUE)) return("VALUE")
+    if (grepl("^r[.]?s[.]?e[.]?", v, ignore.case=TRUE)) return("RSE")
+    if (grepl("^s[.]?e[.]?", v, ignore.case=TRUE)) return("SE")
+    if (grepl("^pval", v, ignore.case=TRUE)) return("PVALUE")
+    v
+  }, character(1), USE.NAMES=TRUE)
+  names(xx) <- names
+
+  vals <- intersect(c("PARAM", "VALUE", "SE", "RSE", "PVALUE"), names(xx))
+  ensure <- setdiff(c("PARAM", "VALUE"), vals)
+  if (length(ensure) > 0) {
+    stop("cannot determine the following column name types: '",
+         paste(ensure, collapse="', '"), "'",
+         call.=FALSE)
+  }
+  xx <- xx[,vals]
+  xx <- setDT(xx)
   xx
 }
 

tests/testthat/test-2023table.R

@@ -0,0 +1,18 @@
+test_that("Monolix 2023 tables read in correctly (Issue #369)", {
+  skip_if_not(file.exists(test_path("warfarin_PD_project.zip")))
+  .path <- normalizePath(test_path("warfarin_PD_project.zip"))
+
+  withr::with_tempdir({
+
+    unzip(.path)
+
+     ctr <- pmx_mlxtran("warfarin_PD_project.mlxtran")
+
+    p_ctr <- ctr %>% param_table(return_table = TRUE)
+
+    Names <- c("PARAM", "VALUE", "SE", "RSE")
+
+    expect_equal(names(p_ctr), Names)
+
+  })
+})

tests/testthat/test-reader.R

@@ -268,48 +268,16 @@ test_that("read_mlx_par_est: params: path, x; result: identical class and struct
   ipath <- file.path(reader_help$wd, "estimates.txt")
   x <- NULL
   x$sep <- ";"
-  x$names <- c("params", "parameter", "s.e._lin", "r.s.e._lin", "pvalues_lin")
   r <- read_mlx_par_est(ipath, x)
-
-  expect_identical(
-    names(r),
-    c("params", "parameter", "s.e._lin", "r.s.e._lin", "pvalues_lin")
-  )
+  expect_identical(c("PARAM", "VALUE", "SE", "RSE", "PVALUE"), names(r))
   expect_true(inherits(r, "data.frame"))
 })
 
-test_that("read_mlx_par_est: params: path, x$name is vector; result: identical structure", {
-  ipath <- file.path(reader_help$wd, "estimates.txt")
-  x <- NULL
-  x$sep <- ";"
-  x$names <- c("parameter name", "parameter", "SE._lin", "RSE_lin", "pValues_lin")
-  r <- read_mlx_par_est(ipath, x)
-
-  expect_identical(
-    names(r),
-    c("parameter name", "parameter", "SE._lin", "RSE_lin", "pValues_lin")
-  )
-})
-
-test_that("read_mlx_par_est: params: path, x$name is NULL; result: identical structure", {
-  ipath <- file.path(reader_help$wd, "estimates.txt")
-  x <- NULL
-  x$sep <- ";"
-  x$names <- NULL
-  r <- read_mlx_par_est(ipath, x)
-
-  expect_identical(
-    names(r),
-    c("X", "parameter", "s.e._lin", "r.s.e._lin", "pvalues_lin")
-  )
-})
-
 test_that("read_mlx_par_est: params: path is NULL, x;
           result: error", {
   ipath <- NULL
   x <- NULL
   x$sep <- ";"
-  x$names <- c("params", "parameter", "s.e._lin", "r.s.e._lin", "pvalues_lin")
 
   expect_error(
     read_mlx_par_est(ipath, x)
@@ -320,7 +288,6 @@ test_that("read_mlx_par_est: params: path, x is '' ; result: error", {
   ipath <- file.path(reader_help$wd, "estimates.txt")
   x <- NULL
   x$sep <- ""
-  x$names <- c("params", "parameter", "s.e._lin", "r.s.e._lin", "pvalues_lin")
 
   expect_error(read_mlx_par_est(ipath, x))
 })