R/get_tables.R

In Certara.DarwinReporter: Data Visualization Utilities for 'pyDarwin' Machine Learning Pharmacometric Model Development

get_table <- function(xpdb, treeSelected, software, col_keys, values, isTableCaption, tableCaption, isTableFooter, tableFooter, digits, align){

  if(treeSelected == "Theta"){
  userTable <- get_theta_table(xpdb, software,  col_keys, values)
  } else if(treeSelected == "Omega"){
    userTable <- get_omega_table(xpdb, software,  col_keys, values)
  } else if(treeSelected == "Overall"){
    userTable <- get_overall_table(xpdb, software, col_keys, values)
  } else if(treeSelected == "Sigma") {
    userTable <- get_sigma_table(xpdb, software,  col_keys, values)
  } else if(treeSelected == "Secondary") {
    userTable <- get_secondary_table(xpdb, software,  col_keys, values)
  } else {
    userTable <- NULL
  }

  if(isTableCaption == TRUE){
    userTable <- metaExpr({
      ..(userTable) %>%
        set_caption(caption = ..(tableCaption))
    })
  }

  if(isTableFooter == TRUE){
    userTable <- metaExpr({
      ..(userTable) %>%
        add_footer_row(values = ..(tableFooter), colwidths = ..(length(col_keys)))
    })
  }

  if(!is.null(userTable)){
  userTable <- metaExpr({
    ..(userTable) %>%
      colformat_double(digits = ..(digits)) %>%
      align(align = ..(align), part = "all") %>%
      set_table_properties(layout = "autofit") %>%
      autofit() %>%
      fontsize(size = 10, part = "all") %>%
      font(fontname = "Times New Roman", part = "all") %>%
      bold(part = "header")
    })
  }

  userTable

}




get_overall_table <- function(xpdb, software, col_keys, values){
  req(values)
  if(software == "NONMEM"){
    userTable <- metaExpr({
      ..(xpdb)$summary %>%
        filter(label %in% c("ofv", "nind", "nobs") & problem == 1) %>%
        select(label, value) %>%
        pivot_wider(names_from = label, values_from = value) %>%
        select(ofv, nobs, nind) %>%
        mutate(Condition = ifelse(length(..(xpdb)$summary$value[..(xpdb)$summary$label == "condn" & ..(xpdb)$summary$problem == 1]) > 0,
                                   as.numeric(..(xpdb)$summary$value[..(xpdb)$summary$label == "condn" & ..(xpdb)$summary$problem == 1]), NA)) %>%
        mutate(nparm = nrow(get_prm(..(xpdb)))) %>%
        mutate(`-2LL` = ifelse(any(grepl("CONTAINS CONSTANT", ..(xpdb)$code$code)),
                               as.numeric(ofv), as.numeric(ofv) + as.numeric(nobs) * log(2 * pi))) %>%
        mutate(ofv = as.numeric(ofv)) %>%
        mutate(AIC = `-2LL` + 2 * nparm) %>%
        mutate(BIC = `-2LL` + log(as.numeric(nobs)) * nparm) %>%
        flextable(col_keys = ..(col_keys)) %>%
        set_header_labels(values = ..(values))
    })
  } else {
    userTable <- metaExpr({
      ..(xpdb) %>%
        get_overallNlme() %>%
        mutate(RetCode = as.integer(RetCode),
               nObs = as.integer(nObs),
               nSub = as.integer(nSub),
               nParm = as.integer(nParm)) %>%
        flextable(col_keys = ..(col_keys)) %>%
        set_header_labels(values = ..(values))
    })
  }
}

get_darwin_overall_table <-
  function(darwin_data, software, col_keys, values) {
    req(values)
    userTable <- metaExpr({
      darwin_data %>%
        summarise_overall_by_key_models() %>%
        flextable(col_keys = ..(col_keys)) %>%
        set_header_labels(values = ..(values))
    })
  }



get_secondary_table <- function(xpdb, software, col_keys, values){
  req(values)
  if(software == "NONMEM"){
    stop("Secondary table not available for NONMEM")
  } else {
    userTable <- metaExpr({
      ..(xpdb) %>%
        get_prmNlme() %>%
        filter(type == "sec") %>%
        select(-type,  -diagonal, -n) %>%
        mutate(`rse%` = as.numeric(rse) * 100) %>%
        flextable(col_keys = ..(col_keys)) %>%
        set_header_labels(values = ..(values))
    })
  }
  userTable
}


get_theta_table <- function(xpdb, software, col_keys, values){
  req(values)
  if(software == "NONMEM"){
  userTable <- metaExpr({
    ..(xpdb) %>%
      get_prm() %>%
      filter(type == "the") %>%
      select(-type, -diagonal, -n) %>%
      mutate(m = as.integer(m)) %>%
      mutate(`rse%` = as.numeric(rse) * 100) %>%
      flextable(col_keys = ..(col_keys)) %>%
      set_header_labels(values = ..(values))
  })
  } else {
    userTable <- metaExpr({
      ..(xpdb) %>%
        get_prmNlme() %>%
        filter(type == "the") %>%
        select(-type,  -diagonal, -n) %>%
        mutate(`rse%` = as.numeric(rse) * 100) %>%
        flextable(col_keys = ..(col_keys)) %>%
        set_header_labels(values = ..(values))
    })

  }

  userTable

}

get_omega_table <- function(xpdb, software, col_keys, values){
  req(values)
  if(software == "NONMEM"){
  userTable <- metaExpr({
    ..(xpdb) %>%
      get_prm() %>%
      filter(type == "ome") %>%
      select(-type) %>%
      mutate(`rse%` = as.numeric(rse) * 100) %>%
      mutate(m = as.integer(m)) %>%
      mutate(n = as.integer(n)) %>%
      left_join(get_eta_shk(..(xpdb)), by = c("m", "n")) %>%
      flextable(col_keys = ..(col_keys)) %>%
      set_header_labels(values = ..(values))
  })
  } else {
    userTable <- metaExpr({
      ..(xpdb) %>%
        get_prmNlme() %>%
        filter(type == "ome") %>%
        select(-type) %>%
        mutate(`rse%` = as.numeric(rse) * 100) %>%
        left_join(get_eta_shk(..(xpdb)), by = "label") %>%
        flextable(col_keys = ..(col_keys)) %>%
        set_header_labels(values = ..(values))
    })
  }

  userTable
}


get_sigma_table <- function(xpdb, software, col_keys, values){
  req(values)
  if(software == "NONMEM"){
    userTable <- metaExpr({
      ..(xpdb) %>%
        get_prm() %>%
        filter(type == "sig") %>%
        select(-type) %>%
        mutate(`rse%` = as.numeric(rse) * 100) %>%
        mutate(m = as.integer(m)) %>%
        mutate(n = as.integer(n)) %>%
        left_join(get_eps_shk(..(xpdb)), by = c("m", "n")) %>%
        flextable(col_keys = ..(col_keys)) %>%
        set_header_labels(values = ..(values))
    })
  } else {
    userTable <- metaExpr({
      ..(xpdb) %>%
        get_prmNlme() %>%
        filter(type == "sig") %>%
        select(-type) %>%
        mutate(`rse%` = as.numeric(rse) * 100) %>%
        left_join(get_eps_shk(..(xpdb)), by = "label") %>%
        flextable(col_keys = ..(col_keys)) %>%
        set_header_labels(values = ..(values))
    })
  }

  userTable
}

get_darwin_table <- function(darwin_data, treeSelected, software, col_keys, values, isTableCaption, tableCaption, isTableFooter, tableFooter, digits, align){
 if (treeSelected == "Key Models") {
  userTable <- get_darwin_overall_table(darwin_data, software,  col_keys, values)
 } else {
  userTable <- NULL
 }

  if (!is.null(userTable)) {
    if (isTableCaption == TRUE) {
      userTable <- metaExpr({
        ..(userTable) %>%
          set_caption(caption = ..(tableCaption))
      })
    }

    if (isTableFooter == TRUE) {
      userTable <- metaExpr({
        ..(userTable) %>%
          add_footer_row(values = ..(tableFooter),
                         colwidths = ..(length(col_keys)))
      })
    }

    userTable <- metaExpr({
      ..(userTable) %>%
        colformat_double(digits = ..(digits)) %>%
        align(align = ..(align), part = "all") %>%
        set_table_properties(layout = "autofit") %>%
        autofit() %>%
        fontsize(size = 10, part = "all") %>%
        font(fontname = "Times New Roman", part = "all") %>%
        bold(part = "header")
    })
  }

  userTable
}

#' Get eta shrinkage values from \code{xpose_data} object
#'
#' This function returns eta shrinkage values from \code{xpose_data} object as a \code{data.frame}.
#'
#' @param xpdb Object of class \code{xpose_data}.
#
#' @return Returns an object of class \code{data.frame}.
#' @export

get_eta_shk <- function(xpdb){

  summary <- xpdb$summary

  software <- summary %>%
    filter(problem == 0 & label == "software") %>%
    select(value)

  etashk <- summary %>%
    filter(problem == 1 & label == "etashk") %>%
    select(value)

  etashk <- unlist(strsplit(etashk[[1]], ", "))


  if(software[[1]] == "nonmem"){
    etashk <- sapply(X = etashk, FUN = strsplit, split = " ")

    etashkdf <- data.frame(matrix(unlist(etashk), nrow=length(etashk), byrow=TRUE))

    etashkdf <- etashkdf %>%
      dplyr::mutate(`shrinkage%` = as.numeric(X1),
                    shrinkage = `shrinkage%` / 100,
                    m = as.integer(gsub("[^[:alnum:]]", " ", X2)),
                    n = m) %>%
      dplyr::select(shrinkage, `shrinkage%`, m, n)
  } else {
    etashkdf <- data.frame(eta = etashk) %>%
      tidyr::separate(col = eta, into = c("label", "shrinkage"), sep = " = ") %>%
      dplyr::mutate(shrinkage = as.numeric(shrinkage),
             `shrinkage%` = shrinkage * 100)
  }

  return(etashkdf)
}


#' Get eps shrinkage values \code{xpose_data} object
#'
#' This function returns eps shrinkage values from \code{xpose_data} object as a \code{data.frame}.
#'
#' @param xpdb Object of class \code{xpose_data}.
#
#' @return Returns an object of class \code{data.frame}.
#' @export

get_eps_shk <- function(xpdb){

  summary <- xpdb$summary

  software <- summary %>%
    dplyr::filter(problem == 0 & label == "software") %>%
    dplyr::select(value)

  epsshk <- summary %>%
    dplyr::filter(problem == 1 & label == "epsshk") %>%
    dplyr::select(value)

  epsshk <- unlist(strsplit(epsshk[[1]], ", "))


  if(software[[1]] == "nonmem"){
    epsshk <- sapply(X = epsshk, FUN = strsplit, split = " ")

    epsshkdf <- data.frame(matrix(unlist(epsshk), nrow=length(epsshk), byrow=TRUE))

    epsshkdf <- epsshkdf %>%
      dplyr::mutate(`shrinkage%` = as.numeric(X1),
                    shrinkage = `shrinkage%` / 100,
                    m = as.integer(gsub("[^[:alnum:]]", " ", X2)),
                    n = m) %>%
      dplyr::select(shrinkage, `shrinkage%`, m, n)
  } else {
    epsshkdf <- data.frame(eps = epsshk) %>%
      tidyr::separate(col = eps, into = c("label", "shrinkage"), sep = " = ") %>%
      dplyr::mutate(shrinkage = as.numeric(shrinkage),
             `shrinkage%` = shrinkage * 100)
  }

  return(epsshkdf)
}

create_col_labels <- function(cols, reactiveTblCols){

  ui <- tagList()
  for(i in seq_along(cols)){
    col <- cols[[i]]

    col_val <- switch(col,
                      "logLik" = "LL",
                      "ofv" = "OFV",
                      "nobs" = "nObs",
                      "nind" = "nSub",
                      "nparm" = "nParm",
                      "Condition" = "Condition Number",
                      "RetCode" = "Return Code",
                      "se" = "SE",
                      "rse" = "RSE",
                      "rse%" = "RSE%",
                      "label" = "Label",
                      "name" = "Name",
                      "value" = "Value",
                      "fixed" = "Fixed",
                      "shrinkage" = "Shrinkage",
                      "shrinkage%" = "Shrinkage%",
                      "diagonal" = "Diagonal",
                      "model_name" = "Model Name",
                      "iteration" = "Iteration",
                      "run_dir" = "Run Directory",
                      "fitness" = "Fitness",
                      "penalty_ntheta" = "Penalty nTheta",
                      "penalty_nomega" = "Penalty nOmega",
                      "penalty_nsigma" = "Penalty nSigma",
                      "penalty_corr" = "Penalty Correlation",
                      "penalty_condition" = "Penalty Condition > 1000",
                      "penalty_covar" = "Penalty Covariance",
                      "penalty_success" = "Penalty Convergence",
                      "penalty_r" = "Penalty R",
                      "penalty_python" = "Penalty Python")

    if(is.null(col_val)){
      col_val <- col
    }

    ui[[col]] <- tagList(
      div(style = "display:inline-block; padding-left: 5px;",
          textInput(col, label = col,
                    value = ifelse(is.null(reactiveTblCols[[col]]),
                                                      col_val, reactiveTblCols[[col]]) ,
                    width = "125px")
      )
    )
  }
  return(ui)
}





colsOverallNONMEM <-
  c("Condition", "ofv", "-2LL", "AIC", "BIC",  "nparm" , "nobs", "nind")

colsOverallDarwinNONMEM <-
  c(
    "iteration",
    "model_name",
    "fitness",
    "ofv",
    "-2LL",
    "AIC",
    "BIC",
    "Condition",
    "run_dir",
    "penalty_ntheta",
    "penalty_nomega",
    "penalty_nsigma",
    "penalty_corr",
    "penalty_condition",
    "penalty_success",
    "penalty_r",
    "penalty_python",
    "nparm" ,
    "nobs",
    "nind"
  )
colsOverallDarwinNLME <-
  c(
    "iteration",
    "model_name",
    "fitness",
    "ofv",
    "-2LL",
    "AIC",
    "BIC",
    "Condition",
    "RetCode",
    "run_dir",
    "penalty_ntheta",
    "penalty_nomega",
    "penalty_nsigma",
    "penalty_corr",
    "penalty_covar",
    "penalty_condition",
    "penalty_success",
    "penalty_r",
    "penalty_python",
    "nParm" ,
    "nObs",
    "nSub"
  )

colsOverallNLME <-
  c("RetCode",
    "Condition",
    "logLik",
    "-2LL",
    "AIC",
    "BIC",
    "nParm",
    "nObs",
    "nSub")

colsPrmNONMEM <-
  c(
    "name",
    "label",
    "value",
    "se",
    "rse",
    "rse%",
    "fixed",
    "diagonal",
    "m",
    "n",
    "shrinkage%",
    "shrinkage"
  )

colsPrmNLME <-
  c(
    "name",
    "label",
    "value",
    "se",
    "rse",
    "rse%",
    "fixed",
    "diagonal" ,
    "m",
    "n",
    "2.5% CI",
    "97.5% CI",
    "shrinkage%",
    "shrinkage"
  )