CRAN_check_app.R

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)