In rickhelmus/patRoon: Workflows for Mass-Spectrometry Based Non-Target Analysis

Transformation Products {data-orientation=rows}

# 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)
}

Parents { data-width=200 .parents }

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

Selected parent { data-width=100 }

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

{.tabset}

Transformation Products { .TPsClass }

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

Transformation Pathway

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