# sync objects components <- rmdVars$components[, intersect(names(rmdVars$fGroups), groupNames(rmdVars$components))] components <- delete(components, i = !componentInfo(components)$parent_group %chin% names(rmdVars$fGroups)) cInfo <- componentInfo(components) if (isScreening(rmdVars$fGroups)) { suspTbl <- as.data.table(rmdVars$fGroups, collapseSuspects = NULL) suspTbl <- suspTbl[, grepl("^susp_|group", names(suspTbl)), with = FALSE] setnames(suspTbl, sub("^susp_", "", names(suspTbl))) } plotPathFull <- getPlotPath(FALSE) if (length(components) > 0) { message("Generating parent plots...") prog <- openProgBar(0, nrow(cInfo)) makeStructPlot <- function(SMI, out) { mol <- getMoleculesFromSMILES(SMI, emptyIfFails = TRUE)[[1]] withr::with_png(out, width = 1.5, height = 1.5, units = "in", res = 72, bg = NA, code = { withr::with_par(list(mar = rep(0, 4)), plot(getRCDKStructurePlot(mol, 150, 150))) }) } plotIntMainArgs <- list(average = TRUE, normalize = TRUE) if (isFGSet(rmdVars$fGroups)) { plotIntMainArgs <- c(plotIntMainArgs, list(sets = TRUE)) } else { plotIntMainArgs <- c(plotIntMainArgs, list(col = "black")) } parentPlots <- setNames(Map(split(cInfo, seq_len(nrow(cInfo))), seq_len(nrow(cInfo)), f = function(parentRow, i) { grpi <- match(parentRow$parent_group, names(rmdVars$fGroups)) plots <- list() fg <- rmdVars$fGroups[, parentRow$parent_group] plots[["int"]] <- file.path(plotPathFull, sprintf("int-parent_%s.png", parentRow$name)) makeCachedPlot(plots[["int"]], "plotInt", c(list(fg), plotIntMainArgs), 3.3, 3.3, bg = NA, cacheDB = rmdVars$cacheDB) if (!is.null(parentRow[["parent_SMILES"]])) { plots[["struct"]] <- file.path(plotPathFull, sprintf("struct-parent_%s.png", parentRow$name)) makeStructPlot(parentRow$parent_SMILES, plots[["struct"]]) } setTxtProgressBar(prog, i) return(plots) }), cInfo$name) message("Generating TP plots...") prog <- openProgBar(0, length(components)) cmpTab <- as.data.table(components) cmpTab[, cmpInd := seq_len(.N), by = "name"] # isFGScrAnnotated <- isScreening(rmdVars$fGroups) && screenInfo(rmdVars$fGroups)[[""]] TPPlotName <- function(cmp, i) paste0(cmp, "_", i) TPPlots <- setNames(Map(split(cmpTab, seq_len(nrow(cmpTab))), seq_len(nrow(cmpTab)), f = function(ctRow, i) { grpi <- match(ctRow$group, names(rmdVars$fGroups)) plots <- list() fg <- rmdVars$fGroups[, ctRow$group] plots[["int"]] <- file.path(plotPathFull, sprintf("int-TP_%s-%d.png", ctRow$name, ctRow$cmpInd)) makeCachedPlot(plots[["int"]], "plotInt", c(list(fg), plotIntMainArgs), 3.3, 3.3, bg = NA, cacheDB = rmdVars$cacheDB) SMI <- ctRow[["SMILES"]] if (!is.null(SMI)) { plots[["struct"]] <- file.path(plotPathFull, sprintf("struct-TP_%s-%d.png", ctRow$name, ctRow$cmpInd)) makeStructPlot(SMI, plots[["struct"]]) } if (!is.null(rmdVars[["MSPeakLists"]])) { # try to plot a mirror spectrum: use compounds if possible, otherwise try formulas or finally peak lists plSpecArgs <- list() if (isScreening(rmdVars$fGroups)) { suspParRow <- suspTbl[name == ctRow$parent_name & group == ctRow$parent_group] suspTPRow <- suspTbl[name == ctRow$TP_name & group == ctRow$group] if (!is.null(rmdVars[["compounds"]]) && !is.null(suspTbl[["compRank"]]) && all(c(ctRow$parent_group, ctRow$group) %chin% groupNames(rmdVars$compounds)) && nrow(suspTPRow) == 1 && !is.na(suspParRow$compRank) && !is.na(suspTPRow$compRank)) { plSpecArgs <- list(obj = rmdVars$compounds, formulas = rmdVars[["formulas"]], index = c(suspParRow$compRank, suspTPRow$compRank), MSPeakLists = rmdVars$MSPeakLists, plotStruct = FALSE) } else if (!is.null(rmdVars[["formulas"]]) && !is.null(suspTbl[["formRank"]]) && all(c(ctRow$parent_group, ctRow$group) %chin% groupNames(rmdVars$formulas)) && nrow(suspTPRow) == 1 && !is.na(suspParRow$formRank) && !is.na(suspTPRow$formRank) && !is.null(rmdVars$MSPeakLists[[ctRow$parent_group]][["MSMS"]]) && !is.null(rmdVars$MSPeakLists[[ctRow$group]][["MSMS"]])) { plSpecArgs <- list(obj = rmdVars$formulas, index = c(suspParRow$formRank, suspTPRow$formRank), MSPeakLists = rmdVars$MSPeakLists) } } if (length(plSpecArgs) == 0 && !is.null(rmdVars$MSPeakLists[[ctRow$parent_group]][["MSMS"]]) && !is.null(rmdVars$MSPeakLists[[ctRow$group]][["MSMS"]])) { # no formulas/compounds, try peak lists plSpecArgs <- list(obj = rmdVars$MSPeakLists, MSLevel = 2) } if (length(plSpecArgs) > 0) { plots[["spec"]] <- file.path(plotPathFull, sprintf("spec-sim_%s-%d.png", ctRow$name, ctRow$cmpInd)) makeCachedPlot(plots[["spec"]], "plotSpectrum", c(plSpecArgs, list(groupName = c(ctRow$parent_group, ctRow$group), specSimParams = rmdVars$specSimParams, title = "")), 5, 4.5, bg = NA, cacheDB = rmdVars$cacheDB) } } setTxtProgressBar(prog, i) return(plots) }), TPPlotName(cmpTab$name, cmpTab$cmpInd)) prepPlots <- function(pl) { ap <- unlist(allPlots); ap <- ap[nzchar(ap)] if (rmdVars$optimizePng && length(ap > 0)) optimizePngPlots(ap) if (rmdVars$selfContained) pl <- rapply(pl, function(ap) sapply(ap, function(p) if (nzchar(p)) knitr::image_uri(p) else ""), how = "replace") return(pl) } parentPlots <- prepPlots(parentPlots); TPPlots <- prepPlots(TPPlots) }
makeTPTab <- function(cr, cols) { allCols <- unique(unlist(lapply(cols, function(cl) grep(paste0("^", cl), names(cr), value = TRUE)))) roundCols <- function(t) t[, (names(t)) := lapply(.SD, function(x) if (is.double(x)) round(x, 2) else x)] if (!isTRUE(all.equal(cols, allCols, check.attributes = FALSE))) { sets <- unique(sub(".+\\-(.+)$", "\\1", allCols[grepl("-", allCols, fixed = TRUE)])) # NOTE: " " (a space) results in an unnamed column ret <- rbindlist(lapply(c(" ", sets), function(s) { takeCols <- if (s == " ") cols else paste0(cols, "-", s) whCols <- which(takeCols %in% names(cr)) if (length(whCols) == 0) return(data.table()) t <- cr[, takeCols[whCols], with = FALSE] setnames(t, cols[whCols]) t <- roundCols(t) t[, set := s] setcolorder(t, "set") return(t) }), fill = TRUE) ret <- transpose(ret, keep.names = " ", make.names = "set") } else { ret <- roundCols(cr[, cols, with = FALSE]) ret <- setnames(transpose(ret, keep.names = " "), 2, "value") } return(knitr::kable(ret, "html", escape = FALSE) %>% kableExtra::kable_styling(font_size = 11) %>% kableExtra::scroll_box(extra_css = "overflow-x: auto;")) } chromPlotStyle <- "width: auto; height: 250px;" parentsDT <- copy(cInfo) parentsDT <- parentsDT[, intersect(c("name", "parent_name", "parent_group", "parent_formula", "parent_CID"), names(cInfo)), with = FALSE] parentsDT[, compInd := seq_len(.N)] setnames(parentsDT, "name", "component") setnames(parentsDT, sub("^parent_", "", names(parentsDT))) if (!is.null(parentsDT[["formula"]])) parentsDT[, formula := subscriptFormulaHTML(formula)] if (!is.null(parentsDT[["CID"]])) parentsDT[, CID := makeDBIdentLink("pubchem", CID)] if (isScreening(rmdVars$fGroups)) { cols <- c("group", "name", "estIDLevel", "sets") parentsDT <- merge(parentsDT, suspTbl[, intersect(cols, names(suspTbl)), with = FALSE], by = c("group", "name"), all.x = TRUE, sort = FALSE) } parentsDT[, component := paste0(sapply(component, function(cmp) { if (is.null(parentPlots[[cmp]][["struct"]])) "" else imgTags(parentPlots[[cmp]][["struct"]]) }), "<br>", component, " (", name, ")")] parentsDT[, name := NULL] parentsDT[, show := { sprintf("<button onclick=\"showTPs('%s', %d);\" style=\"padding: 0px 3px 0px 3px\">Show</button>", compInd, match(cInfo$parent_group, names(rmdVars$fGroups))) }] setcolorder(parentsDT, c("compInd", "show", "component")) DT::datatable(parentsDT, extensions = "Buttons", fillContainer = TRUE, options = list(paging = FALSE, pageLength = -1, scrollX = TRUE, scrollY = "300px", dom = "tip", deferRender = TRUE, initComplete = DT::JS("function(settings, json)", "{ setTimeout(initTPs, 25); }"), order = list(list(0, "asc")), columnDefs = list(list(visible = FALSE, targets = 0), list(className = "dt-center", targets = (seq_len(ncol(parentsDT)))-1))), escape = FALSE, rownames = FALSE, elementId = "parentsTable")
parentsPlotsDT <- data.table(compInd = parentsDT$compInd) parentsPlotsDT[, EIC := imgTags(chromPaths[match(cInfo$parent_group, names(rmdVars$fGroups))], style = chromPlotStyle)] parentsPlotsDT[, "profile" := imgTags(sapply(parentPlots[cInfo$name], "[[", "int"))] DT::datatable(parentsPlotsDT, options = list(paging = FALSE, pageLength = -1, scrollX = TRUE, scrollY = "300px", dom = "t", # hide column header, thanks to https://stackoverflow.com/a/54325384 headerCallback = DT::JS("function(thead, data, start, end, display)", "{ $(thead).remove(); }"), order = list(list(0, "asc")), language = list(zeroRecords = "No parent selected"), columnDefs = list(list(visible = FALSE, targets = 0), list(className = "dt-center", targets = (seq_len(ncol(parentsPlotsDT)))-1))), escape = FALSE, rownames = FALSE, elementId = "parentsPlotsTable") %>% DT::formatStyle(seq_along(parentsPlotsDT), backgroundColor = "white")
cTable <- componentTable(components) TPsDT <- rbindlist(Map(cTable, seq_along(cTable), names(cTable), f = function(cmp, cInd, cName) { ret <- data.table(compInd = cInd, "#" = seq_len(nrow(cmp))) splitCmp <- split(cmp, seq_len(nrow(cmp))) trCols <- intersect(c("formula", "retDir", "TP_retDir", "retDiff", "mzDiff", "formulaDiff", "set", "CID", "SMILES", "molNeutralized", "similarity", "mergedBy", "coverage"), names(cmp)) ret[, TP := mapply(splitCmp, seq_len(nrow(cmp)), FUN = function(cr, ci) { tpInfo <- cr[, c("TP_name", "group", trCols), with = FALSE] if (rmdVars$retMin) tpInfo[, retDiff := retDiff / 60] for (col in c("retDiff", "similarity", "coverage")) { if (!is.null(tpInfo[[col]])) set(tpInfo, j = col, value = round(tpInfo[[col]], 2)) } tpInfo[, mzDiff := round(mzDiff, 5)] setnames(tpInfo, "TP_name", "name") if (!is.null(tpInfo[["retDir"]]) && !is.null(tpInfo[["TP_retDir"]])) { tpInfo[, "retDir (predicted/actual)" := paste0(TP_retDir, "/", retDir)] tpInfo[, c("retDir", "TP_retDir") := NULL] } if (!is.null(tpInfo[["formula"]])) tpInfo[, formula := subscriptFormulaHTML(formula)] if (!is.null(tpInfo[["formulaDiff"]])) tpInfo[, formulaDiff := subscriptFormulaHTML(formulaDiff)] if (!is.null(tpInfo[["CID"]])) tpInfo[, CID := makeDBIdentLink("pubchem", CID)] tp <- makeInfoBox(paste0(names(tpInfo), ": ", tpInfo, collapse = "<br>")) if (!is.null(TPPlots[[TPPlotName(cName, ci)]][["struct"]])) tp <- paste0(imgTags(TPPlots[[TPPlotName(cName, ci)]][["struct"]]), "<br>", tp) return(tp) })] ret[, EIC := imgTags(chromPaths[match(cmp$group, names(rmdVars$fGroups))], style = chromPlotStyle)] if (isScreening(rmdVars$fGroups)) { suspCols <- c("formRank", "compRank", "annSimBoth", "estIDLevel") if (any(sapply(suspCols, grepl, names(suspTbl)))) { ret[, screening := sapply(splitCmp, function(cr) { sr <- suspTbl[name == cr$TP_name & group == cr$group] if (nrow(sr) > 0) makeTPTab(sr, suspCols) else "" })] } } if (any(grepl("^(specSimilarity|fragmentMatches|neutralLossMatches)", names(cmp)))) { ret[, similarity := sapply(splitCmp, function(cr) { simt <- makeTPTab(cr, c("specSimilarity", "specSimilarityPrec", "specSimilarityBoth", "fragmentMatches", "neutralLossMatches")) return(simt) })] } ret[, spectrum := mapply(splitCmp, seq_along(splitCmp), FUN = function(cr, ci) { if (!is.null(TPPlots[[TPPlotName(cName, ci)]][["spec"]])) return(imgTags(TPPlots[[TPPlotName(cName, ci)]][["spec"]])) return("") })] if (!any(nzchar(ret$spectrum))) set(ret, j = "spectrum", value = NULL) ret[, "intensity profile" := mapply(splitCmp, seq_along(splitCmp), FUN = function(cr, ci) { return(imgTags(TPPlots[[TPPlotName(cName, ci)]][["int"]])) })] return(ret) }), fill = TRUE) # fill: spectrum can be absent depending on candidate DT::datatable(TPsDT, options = list(scrollX = TRUE, scrollY = "600px", deferRender = TRUE, dom = "Blrtp", pageLength = 25, autoWidth = FALSE, ordering = FALSE, language = list(zeroRecords = "No parent selected"), columnDefs = list(list(visible = FALSE, targets = 0), list(className = "dt-center", targets = (seq_len(ncol(TPsDT)))-1)), buttons = list(list(extend = "colvis", background = FALSE, columns = seq(3, ncol(TPsDT)-1)))), rownames = FALSE, escape = FALSE, elementId = "TPsTable")
rmdText <- ""
rmdText <- sapply(seq_len(nrow(cInfo)), function(i) { DOMID <- paste0('TPGraph_', i) TPInd <- match(cInfo$parent_name[i], parents(rmdVars$TPs)$name, nomatch = NA) if (is.na(TPInd)) sprintf("<div id='%s'></div>", DOMID) else glue::glue("\n{ ticks } {{r}}\n", "gr <- plotGraph(rmdVars$TPs, which = { TPInd }, components = components, structuresMax = rmdVars$TPGraphStructuresMax)\n", "gr$elementId <- '{ DOMID }'\n", "gr\n", "{ ticks }\n\n", ticks = "```", TPInd = TPInd, DOMID = DOMID) }) rmdText <- if (length(rmdText) > 0) paste0(knitr::knit(text = rmdText), collapse = "\n") else ""
r if (nzchar(rmdText)) rmdText
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.