Skip to content

Instantly share code, notes, and snippets.

@jokergoo
Last active March 28, 2022 10:47
Show Gist options
  • Save jokergoo/8412000a7df8313f65f9011111abdd38 to your computer and use it in GitHub Desktop.
Save jokergoo/8412000a7df8313f65f9011111abdd38 to your computer and use it in GitHub Desktop.
library(GetoptLong)
library(shiny)
library(rvest)
library(DT)
html = read_html("https://cran.r-project.org/web/checks/check_summary_by_package.html")
html %>% html_element("table") %>% html_table(header = FALSE) -> tb
tb = as.data.frame(tb)
tb = tb[-1, ]
th = html_children( html %>% html_element("table") )[[1]]
cn = sapply(html_children(th), function(x) {
txt = as.character(x)
txt = gsub("</*th>", "", txt)
txt = gsub("</*a.*?>", "", txt)
txt = gsub("^\\s+|\\s+$", "", txt)
gsub("<br>", " ", txt)
})
cn = gsub("^\\s+|\\s+$", "", cn)
colnames(tb) = cn
rownames(tb) = NULL
tb = tb[, -ncol(tb), drop = FALSE]
nc = ncol(tb)
for(i in 3:(nc-1)) {
tb[, i] = gsub("\\*$", "", tb[, i])
}
stats = apply(tb[, 3:(nc-1)], 2, table)
stats_mat = matrix(nrow = length(stats), ncol = 4)
rownames(stats_mat) = names(stats)
colnames(stats_mat) = c("OK", "NOTE", "WARN", "ERROR")
for(i in seq_along(stats)) {
stats_mat[i, "OK"] = stats[[i]]["OK"]
stats_mat[i, "NOTE"] = stats[[i]]["NOTE"]
stats_mat[i, "WARN"] = stats[[i]]["WARN"]
if("FAIL" %in% names(stats[[i]])) {
stats_mat[i, "ERROR"] = stats[[i]]["ERROR"] + stats[[i]]["FAIL"]
} else {
stats_mat[i, "ERROR"] = stats[[i]]["ERROR"]
}
}
add_status_link = function(status, package, server) {
server = gsub("\\(|\\)", "", server)
server = gsub(" ", "-", server)
server = tolower(server)
server = gsub("new-tk", "new-TK", server)
server = gsub("new-ul", "new-UL", server)
link = paste0("https://www.r-project.org/nosvn/R.check/", server, "/", package, "-00check.html")
qq("<a href='#' onclick='Shiny.setInputValue(\"open_package\", \"@{server}/@{package}\"+\"-\"+Math.random());false;' class='status status-@{status}'>@{status}</a>", collapse = FALSE)
}
for(i in 3:(nc-1)) {
tb[, i] = add_status_link(tb[, i], tb[, 1], cn[i])
}
user = gsub("^(.*?)<(.*)>$", "\\1", tb[, ncol(tb)])
user = gsub("\\s+$", "", user)
email = gsub("^.*?<(.*)>$", "\\1", tb[, ncol(tb)])
email = gsub("\\sat\\s", "@", email)
tb[, ncol(tb)] = qq("<a href='mailto:@{email}'>@{user}</a>", collapse = FALSE)
time = html %>% html_element("p") %>% html_text()
stylish_content = function(content) {
lines = strsplit(content, "\n")[[1]]
is_open = FALSE
for(i in seq_along(lines)) {
if(grepl(" NOTE$", lines[i]) && !grepl("^Status: ", lines[i])) {
lines[i] = paste0("<p class='status-NOTE'>", lines[i], "</p>")
is_open = TRUE
last_class = "status-NOTE"
} else if(grepl(" WARNING$", lines[i]) && !grepl("^Status: ", lines[i])) {
lines[i] = paste0("<p class='status-WARN'>", lines[i], "</p>")
is_open = TRUE
last_class = "status-WARN"
} else if(grepl(" ERROR$", lines[i]) && !grepl("^Status: ", lines[i])) {
lines[i] = paste0("<p class='status-ERROR'>", lines[i], "</p>")
is_open = TRUE
last_class = "status-ERROR"
} else if(grepl(" \\.\\.\\.$", lines[i]) && !grepl("^Status: ", lines[i])) {
lines[i] = paste0("<p class='status-ERROR'>", lines[i], "</p>")
is_open = TRUE
last_class = "status-ERROR"
} else if(grepl(" OK$", lines[i]) && !grepl("^Status: ", lines[i])) {
lines[i] = paste0("<p>", lines[i], "</p>")
is_open = FALSE
last_class = ""
} else if(grepl("DONE$", lines[i])) {
lines[i] = paste0("<p>", lines[i], "</p>")
is_open = FALSE
last_class = ""
} else {
if(is_open) {
lines[i] = paste0("<p class='", last_class, "'>", lines[i], "</p>")
} else {
lines[i] = paste0("<p>", lines[i], "</p>")
}
}
}
paste(c("<div class='check-report'>", lines, "</div>"), collapse = "\n")
}
ui = fluidPage(
tags$style(HTML("
.status-OK {
color:black;
}
.status-WARN {
color:orange;
}
.status-ERROR, .status-FAIL {
color:red;
}
.status-NOTE {
color:blue;
}
.check-report {
font-family: Menlo,Monaco,Consolas,'Courier New',monospace;
border-radius: 4px;
border: 1px solid #CCCCCC;
background-color: #F5F5F5;
display: block;
padding: 9.5px;
margin: 0 0 10px;
font-size: 13px;
line-height: 1;
color: #333;
word-break: break-all;
word-wrap: break-word;
overflow: auto;
}
.check-report .status-NOTE, .check-report .status-WARN, .check-report .status-ERROR, .check-report .status-FAIL {
font-weight: bold;
}
")),
tags$script(HTML("
")),
h1("CRAN Package Check Results"),
tags$p(time),
tabsetPanel(type = "tabs",
tabPanel("Table", dataTableOutput("tb")),
tabPanel("Plot", plotOutput("plot", width = 1000, height = 600))
)
)
server = function(input, output, session) {
output$tb = renderDataTable(tb,
server = TRUE,
escape = FALSE,
rownames = FALSE,
selection = "none",
options = list(ordering = FALSE))
observeEvent(input$open_package, {
path = input$open_package
path = gsub("-\\d\\.\\d+$", "", path)
link = paste0("https://www.r-project.org/nosvn/R.check/", path, "-00check.html")
message(paste0("Fetcing ", link))
oe = try(content <- read_html(link) %>% html_text())
if(inherits(oe, "try-error")) {
stop(qq("Cannot access @{link}"))
}
content = stylish_content(content)
showModal(modalDialog(
title = qq("Check results for @{input$open_package}"),
HTML(qq("<p>Original address: <a href='@{link}'>@{link}</a><p>")),
HTML(content),
easyClose = TRUE,
size = "l"
))
})
output$plot = renderPlot({
par(mar = c(4, 16, 1, 1), las = 1)
barplot(t(stats_mat), horiz = TRUE, col = c("grey", "blue", "orange", "red"))
})
}
shinyApp(ui = ui, server = server)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment