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

formulas <- rmdVars$formulas; compounds <- rmdVars$compounds
if (!is.null(formulas) && !is.null(rmdVars$formulasTopMost))
    formulas <- filter(formulas, topMost = rmdVars$formulasTopMost)
if (!is.null(compounds) && !is.null(rmdVars$compoundsTopMost))
    compounds <- filter(compounds, topMost = rmdVars$compoundsTopMost)

Annotation {data-orientation=rows}

feature groups { data-width=300 .fGroups }

compFGroups <- compsClustFGroups <- formFGroups <- componentFGroups <- mfWebFGroups <- character()
if (!is.null(compounds))
    compFGroups <- intersect(groupNames(compounds), rmdVars$groupNames)
if (!is.null(rmdVars$compsCluster))
{
    cl <- clusters(rmdVars$compsCluster)
    compsClustFGroups <- rmdVars$groupNames[rmdVars$groupNames %in% names(cl)]
}
if (rmdVars$includeMFWebLinks != "none")
{
    if (rmdVars$includeMFWebLinks == "compounds")
        mfWebFGroups <- compFGroups
    else if (rmdVars$includeMFWebLinks == "MSMS")
        mfWebFGroups <- rmdVars$groupNames[sapply(rmdVars$groupNames,
                                                  function(grp) any(sapply(peakLists(rmdVars$MSPeakLists),
                                                                           function(pa) !is.null(pa[[grp]]) &&
                                                                               !is.null(pa[[grp]][["MSMS"]]))),
                                                  USE.NAMES = FALSE)]
    mfWebLinks <- sapply(mfWebFGroups, function(grp)
    {
        if (grp %in% compFGroups && is(compounds, "compoundsMF"))
        {
            # make link with used MF settings
            set <- settings(compounds)
        }
        else
            set <- NULL

        return(buildMFLandingURL(set, rmdVars$MSPeakLists[[grp]][["MSMS"]],
                                 rmdVars$gInfo[grp, "mzs"]))
    })
}
if (!is.null(formulas) && "formulas" %in% rmdVars$reportPlots)
    formFGroups <- intersect(groupNames(formulas), rmdVars$groupNames)
if (!is.null(rmdVars$components))
{
    cTable <- componentTable(rmdVars$components)
    componentFGroups <- unique(unlist(sapply(cTable, "[[", "group")))
    componentFGroups <- componentFGroups[componentFGroups %in% rmdVars$groupNames]
}
plotGroups <- unique(c(compFGroups, compsClustFGroups, formFGroups))
allGroups <- unique(c(plotGroups, componentFGroups, mfWebFGroups))

# UNDONE: replace by proper inheritance
isSusp <- isScreening(rmdVars$fGroups)
keepSuspCols <- character()
colsRound5 <- "mz"
if (isSusp)
{
    fGroupsSpecDT <- as.data.table(rmdVars$fGroups, collapseSuspects = NULL)

    isSet <- isFGSet(rmdVars$fGroups)
    keepSuspCols <- c("susp_name", "susp_d_rt", "susp_d_mz", "susp_molNeutralized")

    clR2 <- c("susp_d_rt", "susp_annSimForm", "susp_annSimComp", "susp_annSimBoth", "susp_maxFragMatchesRel")
    clR2 <- getAllSuspCols(clR2, names(fGroupsSpecDT), mergedConsensusNames(rmdVars$fGroups))

    if (length(clR2) > 0)
        fGroupsSpecDT[, (clR2) := lapply(mget(clR2), round, 2)]

    colsRound5 <- c(colsRound5, "susp_d_mz")

    # NOTE: all cols must be same type
    mergeCols <- function(fg, curColNames, parColNames, mergedName, is = isSet)
    {
        if (is)
        {
            for (s in sets(rmdVars$fGroups))
                fg <- mergeCols(fg, paste0(curColNames, "-", s), parColNames, paste0(mergedName, "-", s), FALSE)
            return(fg)
        }

        present <- which(curColNames %in% names(fg))
        if (length(present) == 0)
            return(fg)

        newColName <- paste(mergedName, paste0("(", paste0(parColNames[present], collapse = "/"), ")"))
        keepSuspCols <<- c(keepSuspCols, newColName)

        fg[, (newColName) := do.call(paste, c(mget(curColNames[present]), list(sep = " / ")))]
        return(fg)
    }

    fGroupsSpecDT <- mergeCols(fGroupsSpecDT, c("susp_formRank", "susp_compRank"), c("form", "comp"), "rank")
    fGroupsSpecDT <- mergeCols(fGroupsSpecDT, c("susp_annSimForm", "susp_annSimComp", "susp_annSimBoth"),
                               c("form", "comp", "both"), "annotated sim")
    fGroupsSpecDT <- mergeCols(fGroupsSpecDT, c("susp_maxFrags", "susp_maxFragMatches", "susp_maxFragMatchesRel"),
                               c("suspect", "max matches", "max matches rel"), "fragments")

    keepSuspCols <- c(keepSuspCols, getAllSuspCols("susp_estIDLevel", names(fGroupsSpecDT),
                                                   mergedConsensusNames(rmdVars$fGroups)))

    if (isSet)
        keepSuspCols <- c(keepSuspCols, "susp_sets")
} else
    fGroupsSpecDT <- as.data.table(rmdVars$fGroups)

fGroupsSpecDT <- fGroupsSpecDT[group %in% allGroups]
if (rmdVars$retMin)
    fGroupsSpecDT[, ret := ret / 60]

if (!is.null(fGroupsSpecDT[["neutralMass"]]))
    colsRound5 <- c(colsRound5, "neutralMass")

fGroupsSpecDT[, ret := round(ret, 2)]
fGroupsSpecDT[, (colsRound5) := lapply(mget(colsRound5), round, 5)]

fGroupsSpecDT <- fGroupsSpecDT[, intersect(c("group", "ret", "mz", "adduct", "neutralMass", keepSuspCols),
                                           names(fGroupsSpecDT)), with = FALSE]
fGroupsSpecDT[, groupInd := match(group, names(rmdVars$fGroups))]

showButton <- function(title, jsFunc, ...)
{
    args <- paste0("'", unlist(list(...)), "'", collapse = ", ")
    sprintf("<button onclick=\"%s(%s);\" style=\"padding: 0px 3px 0px 3px\">%s</button>", jsFunc, args, title)
}
maybeAddButton <- function(g, subGroups, ...) if (g %in% subGroups) showButton(...) else "^"

compButtons <- sapply(fGroupsSpecDT$group, function(g) maybeAddButton(g, compFGroups, "compounds", "showAnnotation",
                                                                      match(g, names(rmdVars$fGroups)), "compounds"))
compCLButtons <- sapply(fGroupsSpecDT$group, function(g) maybeAddButton(g, compsClustFGroups,
                                                                        "compounds clust", "showCompoundsCluster",
                                                                        match(g, names(rmdVars$fGroups))))
formButtons <- sapply(fGroupsSpecDT$group, function(g) maybeAddButton(g, formFGroups, "formulas",
                                                                      "showAnnotation", match(g, names(rmdVars$fGroups)),
                                                                      "formulas"))
mfWebButtons <- sapply(fGroupsSpecDT$group, function(g) maybeAddButton(g, mfWebFGroups, "MetFrag web",
                                                                       "window.open", mfWebLinks[g],
                                                                       "_blank"))

sp <- paste0(rep("&nbsp;", 4), collapse = "")
buttons <- paste(compButtons, compCLButtons, formButtons, mfWebButtons, sep = sp)
buttons <- gsub("\\^(&nbsp;)*", "", buttons) # remove placeholder (^) with accompanying spaces
fGroupsSpecDT[, show := buttons]
setcolorder(fGroupsSpecDT, c("groupInd", "group", "ret", "mz", "show"))

if (!is.null(rmdVars$components))
{
    annCols <- c("isogroup", "isonr", "charge", "ppm", # RAMClustR
                 "isotopes", "adnr", "adduct_rule", "adduct_charge", "adduct_nmol", "M_adduct", # CAMERA
                 "adduct_ion", # RC/CAMERA
                 "hsnr", "rGroup", # nontarget
                 "TP_name") # TPs

    fGroupsSpecDT[, components := sapply(group, function(grp)
    {
        cmps <- findFGroup(rmdVars$components, grp)
        if (length(cmps) == 0)
            return("")

        return(wrapStr(paste0(sapply(cmps, function(cmpi)
        {
            cline <- cTable[[cmpi]][group == grp]
            if (nrow(cline) > 1) # some components like NT/TP may have >1 row per fGroup
            {
                if (!is.null(cline[["rGroup"]])) # NT
                    cline[, rGroup := paste0(rGroup, collapse = "/")]
                cline <- cline[1]
            }
            cline <- cline[, sapply(cline, function(x) !is.na(x) && nzchar(x),
                                    USE.NAMES = FALSE), with = FALSE]
            annColsPresent <- annCols[annCols %in% names(cline)]
            cname <- names(rmdVars$components)[cmpi]

            if (length(annColsPresent) > 0)
            {
                cline <- cline[, annColsPresent, with = FALSE]
                for (j in seq_along(cline))
                {
                    if (is.numeric(cline[[j]]))
                        set(cline, 1L, j, round(cline[[j]], 5))
                }
                ann <- paste0(sprintf("%s: %s", names(cline), cline), collapse = ", ")
                return(sprintf("%s (%s)", cname, ann))
            }
            return(cname)
        }), collapse = ", "), width = 50, sep = "<br>"))
    }, USE.NAMES = FALSE)]
}

ISTDs <- internalStandards(rmdVars$fGroups)
if (nrow(ISTDs) > 0)
{
    ISTDs <- ISTDs[group %chin% allGroups]
    fGroupsSpecDT[, "Internal standard" := sapply(group, function(grp)
    {
        ISTDNames <- ISTDs[group == grp]$name
        return(if (length(ISTDNames) == 0) "" else paste0(ISTDNames, collapse = ", "))
    })]
}

dtOpts <- list(paging = FALSE, pageLength = -1, scrollX = TRUE, scrollY = "200px",
               dom = "frtip",
               initComplete = DT::JS("function(settings, json)",
                                     "{ setTimeout(initAnnotation, 25); }"),
               order = list(list(1, "asc")),
               columnDefs = list(list(visible = FALSE, targets = 0),
                                 list(className = "dt-nowrap", targets = 4),
                                 list(className = "dt-center",
                                      targets = (seq_len(ncol(fGroupsSpecDT))[-5])-1)))

selCols <- ncol(fGroupsSpecDT) > 5 # selectable columns if >5 columns
if (selCols)
{
    dtOpts <- c(dtOpts, list(buttons = list(list(extend = "colvis", background = FALSE,
                                                 columns = seq(5, ncol(fGroupsSpecDT)-1),
                                                 collectionLayout = "three-column"))))
    dtOpts$dom <- paste0("B", dtOpts$dom)
}

dtArgs <- list(fGroupsSpecDT, escape = FALSE, rownames = FALSE, elementId = "fGroupsTable",
               options = dtOpts)
if (selCols)
    dtArgs <- c(dtArgs, list(extensions = "Buttons"))

do.call(DT::datatable, dtArgs)

EIC { data-width=100 }

Push a show button to view annotation data for a feature group.

# Generate all plots in advance, since having many code chunks will cause a lot of overhead.

message("Generating spectra...")
prog <- openProgBar(0, length(plotGroups))

plotPathFull <- getPlotPath(FALSE)
plotPathLink <- getPlotPath(TRUE)

allPlots <- setNames(lapply(seq_along(plotGroups), function(i)
{
    grp <- plotGroups[i]
    grpi <- match(grp, names(rmdVars$fGroups))
    grpPlots <- list()

    if (grp %in% compFGroups)
    {
        cTable <- compounds[[grp]]
        compsSeq <- seq_len(nrow(cTable))
        grpPlots[["compoundScores"]] <- sapply(compsSeq, function(compi)
        {
            ret <- file.path(plotPathFull, sprintf("compscore_%d_%d.png", grpi, compi))
            makeCachedPlot(ret, "plotScores", list(compounds, compi, grp, rmdVars$compoundsNormalizeScores,
                                                   rmdVars$compoundsExclNormScores, rmdVars$compoundsOnlyUsedScorings),
                           4.5, 4.5, bg = NA, cacheDB = rmdVars$cacheDB)
            return(ret)
        })

        grpPlots[["compoundSpectra"]] <- sapply(compsSeq, function(compi)
        {
            ret <- file.path(plotPathFull, sprintf("compspec_%d_%d.png", grpi, compi))
            makeCachedPlot(ret, "plotSpectrum", list(compounds, compi,  grp, rmdVars$MSPeakLists,
                                                     formulas, FALSE),
                           7, 4.5, bg = NA, cacheDB = rmdVars$cacheDB)
            return(ret)
        })

        grpPlots[["compoundStructs"]] <- sapply(compsSeq, function(compi)
        {
            ret <- file.path(plotPathFull, sprintf("compstruct_%d_%d.png", grpi, compi))
            makeCachedPlot(ret, "plotStructure", list(compounds, compi, grp, width = 150, height = 150),
                           3, 3, bg = NA, cacheDB = rmdVars$cacheDB)
            return(ret)
        })
    }

    if (grp %in% compsClustFGroups)
    {
        plotf <- file.path(plotPathFull, sprintf("dendro_%d.png", grpi))
        makeCachedPlot(plotf, "plot", list(rmdVars$compsCluster, groupName = grp), 8, 4.5, cacheDB = rmdVars$cacheDB)
        grpPlots[["compClustDendro"]] <- plotf

        ct <- cutClusters(rmdVars$compsCluster)[[grp]]
        grpPlots[["compClustMCS"]] <- sapply(seq_along(unique(ct)), function(cli)
        {
            ret <- file.path(plotPathFull, sprintf("mcs_%d_%d.png", grpi, cli))
            makeCachedPlot(ret, "plotStructure", list(rmdVars$compsCluster, grp, cli, 100, 100),
                           3, 3, cacheDB = rmdVars$cacheDB)
            return(ret)
        })
    }

    if (grp %in% formFGroups)
    {
        fTable <- formulas[[grp]]
        formsSeq <- seq_len(nrow(fTable))

        grpPlots[["formulaScores"]] <- sapply(formsSeq, function(formi)
        {
            ret <- file.path(plotPathFull, sprintf("formscore_%d_%i.png", grpi, formi))
            makeCachedPlot(ret, "plotScores", list(formulas, formi, grp,
                                                   normalizeScores = rmdVars$formulasNormalizeScores,
                                                   excludeNormScores = rmdVars$formulasExclNormScores),
                           4.5, 4.5, bg = NA, cacheDB = rmdVars$cacheDB)
            return(ret)
        })

        grpPlots[["formulaSpecs"]] <- sapply(formsSeq, function(formi)
        {
            anPList <- annotatedPeakList(formulas, formi, grp,
                                         MSPeakLists = rmdVars$MSPeakLists, onlyAnnotated = TRUE)
            if (is.null(anPList))
                return("") # No MS/MS data available

            ret <- file.path(plotPathFull, sprintf("formspec_%d_%d.png", grpi, formi))
            makeCachedPlot(ret, "plotSpectrum", list(formulas, formi, grp, MSPeakLists = rmdVars$MSPeakLists),
                           6, 4.5, cacheDB = rmdVars$cacheDB)
            return(ret)
        })
    }

    setTxtProgressBar(prog, i)

    return(grpPlots)
}), plotGroups)
close(prog)

ap <- unlist(allPlots); ap <- ap[nzchar(ap)]
if (rmdVars$optimizePng && length(ap > 0))
    optimizePngPlots(ap)

if (rmdVars$selfContained)
    allPlots <- rapply(allPlots, function(ap) sapply(ap, function(p) if (nzchar(p)) knitr::image_uri(p) else ""), how = "replace")

{ .annotationClass .compounds }

compoundsDT <- rbindlist(lapply(compFGroups, function(grp)
{
    ct <- compounds[[grp]]

    infoTexts <- sapply(seq_len(nrow(ct)), function(compi)
    {
        it <- paste0(getCompInfoList(ct, compi, mergedConsensusNames(compounds), TRUE), collapse = "<br>")
        if (isSusp)
        {
            # insert suspect names (if any)
            tbl <- as.data.table(rmdVars$fGroups, collapseSuspects = NULL)[group == grp]
            if (!is.null(tbl[["susp_compRank"]]) && any(tbl$susp_compRank == compi, na.rm = TRUE))
                it <- paste(paste("<strong>Suspect(s):</strong>", paste0(tbl[susp_compRank == compi]$susp_name, collapse = ", ")),
                             it, sep = "<br>")
        }
        return(it)
    })
    infoTexts <- makeInfoBox(infoTexts)

    fiTables <- sapply(seq_len(nrow(ct)), function(compi)
    {
        apl <- annotatedPeakList(compounds, index = compi, groupName = grp,
                                 MSPeakLists = rmdVars$MSPeakLists, formulas = formulas,
                                 onlyAnnotated = TRUE)

        if (is.null(apl) || nrow(apl) == 0)
            return("<div align=\"center\">No annotation available.</div>")

        apl[, ion_formula := subscriptFormulaHTML(ion_formula)]
        apl[, neutral_loss := subscriptFormulaHTML(neutral_loss)]

        knitr::kable(apl, "html", escape = FALSE) %>%
                           kableExtra::kable_styling(font_size = 11) %>%
                           kableExtra::scroll_box(extra_css = "overflow: auto; height: 125px;")
    })

    return(data.table(group = match(grp, names(rmdVars$fGroups)),
                      "#" = seq_len(nrow(ct)),
                      compound = paste0(imgTags(allPlots[[grp]]$compoundStructs), "<br>", infoTexts),
                      spectrum = paste0(imgTags(allPlots[[grp]]$compoundSpectra), "<br>", fiTables),
                      scores = imgTags(allPlots[[grp]]$compoundScores)))
}))

DT::datatable(compoundsDT, options = list(scrollX = TRUE, scrollY = "600px", deferRender = TRUE,
                                          dom = "lrtp", pageLength = 25, autoWidth = TRUE,
                                          ordering = FALSE,
                                          columnDefs = list(list(visible = FALSE, targets = 0))),
              rownames = FALSE, escape = FALSE, elementId = "compoundsTable")

{ .annotationClass .formulas }

formulasDT <- rbindlist(lapply(formFGroups, function(grp)
{
    ft <- formulas[[grp]]

    infoTexts <- sapply(seq_len(nrow(ft)), function(formi)
    {
        it <- paste0(getFormInfoList(ft, formi, mergedConsensusNames(formulas), TRUE), collapse = "<br>")
        if (isSusp)
        {
            # insert suspect names (if any)
            tbl <- as.data.table(rmdVars$fGroups, collapseSuspects = NULL)[group == grp]
            if (!is.null(tbl[["susp_formRank"]]) && any(tbl$susp_formRank == formi, na.rm = TRUE))
                it <- paste(paste("<strong>Suspect(s):</strong>", paste0(tbl[susp_formRank == formi]$susp_name, collapse = ", ")),
                             it, sep = "<br>")
        }
        return(it)
    })

    infoTexts <- makeInfoBox(infoTexts)

    fiTables <- sapply(seq_len(nrow(ft)), function(formi)
    {
        apl <- annotatedPeakList(formulas, index = formi, groupName = grp, MSPeakLists = rmdVars$MSPeakLists,
                                 onlyAnnotated = TRUE)
        if (is.null(apl) || nrow(apl) == 0)
            return("<div align=\"center\">No annotation available.</div>")

        apl[, ion_formula := subscriptFormulaHTML(ion_formula)]
        apl[, neutral_loss := subscriptFormulaHTML(neutral_loss)]

        knitr::kable(apl, "html", escape = FALSE) %>%
            kableExtra::kable_styling(font_size = 11) %>%
            kableExtra::scroll_box(extra_css = "overflow: auto; height: 125px;")
    })

    ret <- data.table(group = match(grp, names(rmdVars$fGroups)),
                      neutral_formula = subscriptFormulaHTML(ft$neutral_formula),
                      spectrum = paste0(imgTags(allPlots[[grp]]$formulaSpecs), "<br>", fiTables),
                      scores = paste0(imgTags(allPlots[[grp]]$formulaScores), "<br>", infoTexts))

    return(ret)
}))

DT::datatable(formulasDT, options = list(scrollX = TRUE, scrollY = "600px", deferRender = TRUE,
                                         dom = "lrtp", pageLength = 25, autoWidth = TRUE,
                                         ordering = FALSE,
                                         columnDefs = list(list(visible = FALSE, targets = 0))),
              rownames = FALSE, escape = FALSE, elementId = "formulasTable")

rmdTexts <- vector("character", length = length(compsClustFGroups))

message("Generating compounds cluster layout... ", appendLF = FALSE)
# prog <- openProgBar(0, length(plotGroups))
compClustTempl <- readAllFile(system.file("templates", "comp-cluster.Rmd", package = "patRoon"))

cutcl <- cutClusters(rmdVars$compsCluster)
for (i in seq_along(compsClustFGroups))
{
    grp <- compsClustFGroups[i]
    grpi <- match(grp, names(rmdVars$fGroups))

    ct <- cutcl[[grp]]
    rmdTexts[i] <-
        paste0(glue::glue(compClustTempl,
                          grpi = grpi,
                          grp = grp,
                          dendro = allPlots[[grp]]$compClustDendro,
                          mcs = paste0(sprintf("![](%s)", allPlots[[grp]]$compClustMCS),
                                       collapse = "\n")),
               collapse = "\n")
}

rmdText <- paste0(rmdTexts, collapse = "\n")
message("Done!")