R/get_tables.R

In Certara.ModelResults: Generate Diagnostics for Pharmacometric Models Using 'shiny'

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_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 eta skrinkage values xpdb
#'
#' This function returns eta shrinkage values from xpdb object as a \code{data.frame}.
#'
#' @param xpdb Object of class \code{xpose_data}.
#'
#' @examples
#' get_eta_shk(xpdb_NLME$TwCpt_IVBolus_FOCE_ELS)
#'
#'
#' @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 skrinkage values xpdb
#'
#' This function returns eps shrinkage values from xpdb object as a \code{data.frame}.
#'
#' @param xpdb Object of class \code{xpose_data}.
#'
#' @examples
#' get_eps_shk(xpdb_NLME$TwCpt_IVBolus_FOCE_ELS)
#'
#' @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",
                      "se" = "SE",
                      "rse" = "RSE",
                      "rse%" = "RSE%",
                      "label" = "Label",
                      "name" = "Name",
                      "value" = "Value",
                      "fixed" = "Fixed",
                      "shrinkage" = "Shrinkage",
                      "shrinkage%" = "Shrinkage%",
                      "diagonal" = "Diagonal")

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

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

#
# colnamestblmaster <- list(
#                   RetCode = "RetCode",
#                   logLik = "logLik",
#                   `-2LL` = "-2LL",
#                   AIC = "AIC",
#                   BIC = "BIC",
#                   nParm = "nParm",
#                   nObs = "nObs",
#                   nSub = "nSub",
#                   ofv = "ofv",
#                   nobs = "nobs",
#                   nind = "nind",
#                   nparm = "nparm",
#                   name = "name",
#                   label = "label",
#                   value = "value",
#                   se = "se",
#                   rse = "rse",
#                   fixed = "fixed",
#                   diagonal = "diagonal" ,
#                   m = "m",
#                   n = "n",
#                   `2.5% CI` = "2.5% CI",
#                   `97.5% CI` = "97.5% CI",
#                   shrinkage = "shrinkage"
#                   )