In DLMtool/DLMtool: Data-Limited Methods Toolkit

knitr::opts_chunk$set(echo = TRUE)

# havingIP <- function() {
#   if (.Platform$OS.type == "windows") {
#     ipmessage <- system("ipconfig", intern = TRUE)
#   } else {
#     ipmessage <- system("ifconfig", intern = TRUE)
#   }
#   validIP <- "((25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)[.]){3}(25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)"
#   any(grep(validIP, ipmessage))
# }
# 
# # if (havingIP() & enableSearch) {
# #   cat('<link rel="stylesheet" type="text/css" href="http://cdn.datatables.net/1.10.5/css/jquery.dataTables.min.css">')
# #   cat('<script src="http://code.jquery.com/jquery-2.1.2.min.js"></script>')
# #   cat('<script src="http://cdn.datatables.net/1.10.5/js/jquery.dataTables.min.js"></script>')
# # }

suppressMessages(library(dplyr))
suppressMessages(library(knitr))
suppressMessages(library(kableExtra))

Plimits <- lapply(runPM, function(x) x@Caption) %>% unlist()
chk <- grepl("<", Plimits)
if (sum(chk)) {
  ind <- which(chk)  
  for (x in ind)
    Plimits[x] <- gsub("<", "\\\\<", Plimits[x])
}
if (length(Plimits)>1)
  cat("## Minimum Performance Criteria\n")
if (length(Plimits)==1)
    cat("## Minimum Performance Criterion\n")

cat("### Management Procedures must have at least an", Prob, "probability of meeting all Performance Limits \n")
for (xx in 1:length(Plimits)) {
  # cat("#### ", xx, ": ", Plimits[xx], " \n\n", sep="")
  cat(xx, ": ", Plimits[xx], " \n\n", sep="")
}

if (output_format == "html_document") format <- 'html'
if (output_format != "html_document") {
  full_width <- FALSE
  format <- 'latex'
}

# htmlDF1 <- df %>% dplyr::filter(!is.na(url)) %>% dplyr::mutate(
#   prob = cell_spec(prob, format, color = ifelse(prob < Prob, "red", "green")),
#     MP = cell_spec(MP, format, color = ifelse(min < Prob, "red", "green"), link=url)
#   )
# # custom MPs (no url)
# htmlDF2 <- df %>% dplyr::filter(is.na(url)) %>% dplyr::mutate(
#   prob = cell_spec(prob, format, color = ifelse(prob < Prob, "red", "green")),
#     MP = cell_spec(MP, format, color = ifelse(min < Prob, "red", "green"))
#   )
htmlDF <- df # bind_rows(htmlDF1, htmlDF2)

TabDF <- tidyr::spread(htmlDF, PM, prob)
# if (format!='latex') TabDF <- cbind(data.frame("#"=1:nMPs), TabDF)

TabDF <- TabDF %>% dplyr::arrange(desc(min), desc(Feasible))
ind <- which(TabDF$min >= Prob)

# TabDF$url <- NULL
# TabDF$X. <- NULL

# TabDF$Feasible <- factor(TabDF$Feasible)
if (all(is.na(TabDF$Feasible))) TabDF$Feasible <- NULL

MPwithurl <- !is.na(TabDF$url) 
fail.ind <- TabDF$min <Prob 
TabDF$MP[!fail.ind&MPwithurl] <- 
  paste0("<a href='", TabDF$url[!fail.ind&MPwithurl],"' style='color: #008000'>", TabDF$MP[!fail.ind&MPwithurl],"</a>")
TabDF$MP[fail.ind&MPwithurl] <- 
  paste0("<a href='", TabDF$url[fail.ind&MPwithurl],"' style='color: #FF0000'>", TabDF$MP[fail.ind&MPwithurl],"</a>")

TabDF$url <- NULL
# TabDF$Type <- as.factor(TabDF$Type)

cnames <- colnames(TabDF)
cind <- which(cnames == "Type")
cnames <- cnames[(cind+1):length(cnames)]

DT::datatable(TabDF, escape=FALSE, filter='top', 
  extensions = c('Buttons', 'Responsive'), 
  class = 'cell-border stripe', 
  options = list(
    dom = 'Blfrtip',
      buttons = list('copy', 'print'),
    columnDefs = list(list(targets = 2, visible = FALSE)),
    lengthMenu = list(c(10,20, 50, 100, -1), list('10', '20', '50','100', 'All')),
    pageLength = 20, 
    autoWidth = auto_width)) %>%
  DT::formatStyle(2, target="row", 
                  color = DT::styleInterval(cuts=c(0, Prob*0.999), values=c("black", "red", "green"))) %>%
  DT::formatStyle(cnames, color = DT::styleInterval(cuts=c(-1, Prob*0.999), values=c("black", "red", "green"))) 

# Tab <- TabDF %>% kable(format = format, escape = FALSE,  align="llllcccclll") %>%
#   kableExtra::kable_styling(bootstrap_options = c("striped", "hover", "condensed", "responsive"),
#                 full_width = full_width, position="float_left", font_size = font_size)
# if (format == "latex") {
#   Tab <- Tab %>%
#     column_spec(1, width = "2em") %>%
#     column_spec(2, width = "5em")
# }
# Tab %>% kableExtra::row_spec(ind, bold = TRUE)