inst/app/code/server/s_select.pathway.R

In chemokine/OmicsSBGN: Overlay omics data onto SBGN pathway diagram

output$PrePathways <- DT::renderDataTable({
    tryCatch(
        {
            # print(head(pathways.info))
            output.columns = c("pathway.id"
                            ,"pathway.name"
                            ,"sub.database"
                            ,"database"
                            )
            df <- pathways.info[,output.columns]
        },
        error = function(e) {
            # return a safeError if a parsing error occurs
            stop(safeError(e))
        }
    )
    print(head(df))
    return(df)
})

DemoEnrichMeasureFileTitleText = reactiveVal("")
output$DemoEnrichMeasureFileTitle = renderText({
    DemoEnrichMeasureFileTitleText()
})

demoMeasTable = reactiveVal(data.frame())

output$DemoEnrichMeasureFile <- DT::renderDataTable({
        count.data <- assays(IFNg)$counts
        if.wt = IFNg$group == "wt"
        if.ko = IFNg$group == "ko"
        colnames(count.data)[if.wt] = paste0("wt_",colnames(count.data)[if.wt] )
        colnames(count.data)[if.ko] = paste0("ko_",colnames(count.data)[if.ko] )
        DemoOmicsDataTitleText("Demo Measurement Data: IFNg KO mice dataset")
        demoMeasTable(count.data)
        return(count.data)
    })

output$exampleEnrichData <- downloadHandler(
    filename = function() {
        # downloadNameVector[input$preData]
        "test out"
    },
    content = function(file) {
        write.table(demoMeasTable(), file = file,sep="\t")
    }
)


output$introUploadMeasurement = renderText({
    introUploadMeasurementText()
})
introUploadMeasurementText = reactiveVal("Please upload a file containing measurement table. 
                                         Row names are molecule IDs;
                                         Column names are sample IDs
                                         ")

UploadedMeasu = reactiveVal(data.frame())

output$UploadedEnrichMeasureFile <- DT::renderDataTable({
    req(input$uploadDataForEnrich)
    introUploadMeasurementText("")
    tryCatch(
        {
            # print(head(pathways.info))
            df <- read.table(input$uploadDataForEnrich$datapath,
                           header = input$headerMeasure,
                           sep = input$sepMeasure,
                           as.is = TRUE,
                           quote = input$quoteMeasure)
        },
        error = function(e) {
            # return a safeError if a parsing error occurs
            stop(safeError(e))
        }
    )
    # print("uploaded tigle 111 is")
    # print(UploadedEnrichMeasureFileTitleText())
    # UploadedEnrichMeasureFileTitleText("Uploaded Measurement table")
    UploadedMeasu(df)
    return(df)
})

chooserInput <- function(inputId, leftLabel, rightLabel, leftChoices, rightChoices,
                         size = 5, multiple = FALSE) {
    
    leftChoices <- lapply(leftChoices, tags$option)
    rightChoices <- lapply(rightChoices, tags$option)
    
    if (multiple)
        multiple <- "multiple"
    else
        multiple <- NULL
    
    tagList(
        singleton(tags$head(
            tags$script(src="chooser-binding.js"),
            tags$style(type="text/css",
                       HTML(".chooser-container { display: inline-block; }")
            )
        )),
        div(id=inputId, class="chooser",
            div(class="chooser-container chooser-left-container",
                tags$p(leftLabel),
                tags$select(class="left", size=size, multiple=multiple, leftChoices)
            ),
            div(class="chooser-container chooser-center-container",
                icon("arrow-circle-o-right", "right-arrow fa-3x"),
                tags$br(),
                icon("arrow-circle-o-left", "left-arrow fa-3x")
            ),
            div(class="chooser-container chooser-right-container",
                tags$p(rightLabel),
                tags$select(class="right", size=size, multiple=multiple, rightChoices)
            )
        )
    )
}

registerInputHandler("shinyjsexamples.chooser"
    ,function(data, ...) {
        if (is.null(data))
            NULL
        else
            list(left=as.character(data$left), right=as.character(data$right))
    }
    ,force = TRUE
)

output$selectGroupInfo = renderText({
    selectGroupInfoText()
})
selectGroupInfoText = reactiveVal("Sample group information can be selected after measurement table is uploaded")



output$selectGroup = renderUI({
    req(input$uploadDataForEnrich)
    userMeasure = UploadedMeasu()
    all.samples = colnames(userMeasure)
    if(all.samples[1] == "wt_727"){
        wt.samples = all.samples[grepl("wt",all.samples)]
        ko.samples = all.samples[grepl("ko",all.samples)]
    }else{
        wt.samples = all.samples
        ko.samples = c()
    }
    print(wt.samples)
    print(ko.samples)
    selectGroupInfoText("")
    tagList(
        chooserInput(inputId = "groups"
                     ,leftLabel = "Group 1 (Reference)"
                     ,rightLabel = "Group 2 (Treatment)"
                     ,leftChoices = wt.samples
                     ,rightChoices = ko.samples
                     ,size = 10, multiple = TRUE
        )
        # ,h3("Uploaded measurement table:", id = "UploadedEnrichMeasureFileTitle")
        # ,tags$head(tags$style("#UploadedEnrichMeasureFileTitle{color: DodgerBlue;
        #                  font-size: 20px;
        #                  font-style: italic;
        #                  }"
        #                 )
        #             )
    )
})
sigPaths = eventReactive(
    input$RunEnrich
    ,{
        print("generating mol list")
        mol.to.pathway <- get.mol.list(
            database = "pathwayCommons"
            ,mol.list.ID.type = input$OmicsIdTypeMeasure
            ,org = input$orgMeasure
            ,cpd.or.gene = "gene"
            ,output.pathway.name = TRUE
        )
        print(mol.to.pathway[[1]])
        userMeasure = UploadedMeasu()
        degs <- gage(exprs = userMeasure
                   ,gsets = mol.to.pathway
                   ,ref = which(colnames(userMeasure) %in% input$groups$left)
                   ,samp = which(colnames(userMeasure) %in% input$groups$right)
                   ,compare = "as.group"
                   )
        introEnrichResultText("Click on the cells to select pathways. Selected pathways will show up in the dashboard on the left.")
        print(head(degs$greater)[,c(1,4:5)])
        print(head(degs$less))
        return(degs)
    }
)

EnrichResultTitleText = reactiveVal("")
output$EnrichResultTitle = renderText({
    EnrichResultTitleText()
})
EnrichResultTitleLessText = reactiveVal("")
output$EnrichResultTitleLess = renderText({
    EnrichResultTitleLessText()
})
EnrichResultTitleGreaterText = reactiveVal("")
output$EnrichResultTitleGreater = renderText({
    EnrichResultTitleGreaterText()
})

introEnrichResultText = reactiveVal("Click 'Run enrichment analysis to run pathway enrichment analysis.'")
output$introEnrichResult = renderText({
    print("printing intro enrichment result")
    print(
        introEnrichResultText()
    )
    introEnrichResultText()
})

output$EnrichResultTableLess <- DT::renderDataTable({
    selectedCols = c("stat.mean","p.val","q.val", "set.size" )
    lessPaths = sigPaths()$less[,selectedCols]
    # EnrichResultTitleText("Pathway enrichment analysis result")
    # EnrichResultTitleLessText("Less in reference")
    return(lessPaths)
})
output$EnrichResultTableGreater <- DT::renderDataTable({
    selectedCols = c("stat.mean","p.val","q.val", "set.size" )
    greaterPaths = sigPaths()$greater[,selectedCols]
    EnrichResultTitleGreaterText("Greater in reference")
    return(greaterPaths)
})


selectedPathFromEnrich = reactiveVal(data.frame())
selectedPathFromEnrichGreater = reactiveVal(data.frame())
selectedPathFromEnrichLess = reactiveVal(data.frame())
output$selectedPathFromEnrichOut = renderTable({
    selectedPathFromEnrich()
})
observeEvent(input$EnrichResultTableLess_rows_selected, {
    print("selected less")
    print(input$EnrichResultTableLess_rows_selected)
    selectedLess = row.names(sigPaths()$less)[input$EnrichResultTableLess_rows_selected]
    selectedLess = do.call(rbind, strsplit(selectedLess,"::"))[,1]
    selectedLess = as.data.frame(selectedLess,stringsAsFactors = FALSE)
    colnames(selectedLess) = c("Selected pathways")
    selectedPathFromEnrichLess(selectedLess)
    
    selectedAll = rbind(selectedPathFromEnrichLess()
                        ,selectedPathFromEnrichGreater()
                        )
    selectedAll = unique(selectedAll)
    selectedPathFromEnrich(selectedAll)
})

observeEvent(input$EnrichResultTableGreater_rows_selected, {
    print("selected greater")
    print(input$EnrichResultTableGreater_rows_selected)
    selectedGreater = row.names(sigPaths()$greater)[input$EnrichResultTableGreater_rows_selected]
    selectedGreater = do.call(rbind, strsplit(selectedGreater,"::"))[,1]
    selectedGreater = as.data.frame(selectedGreater)
    colnames(selectedGreater) = c("Selected pathways")
    selectedPathFromEnrichGreater(selectedGreater)
    
    selectedAll = rbind(selectedPathFromEnrichLess()
                        ,selectedPathFromEnrichGreater()
                        )
    selectedAll = unique(selectedAll)
    selectedPathFromEnrich(selectedAll)
})





sbgn.info = reactiveVal(list())

observeEvent(
    input$uploadSBGN
    ,{
    print(input$uploadSBGN)
    SBGN.full.path = input$uploadSBGN$datapath
    sbgn.dir = tempdir()
    # sbgn.file.name = "uploaded.sbgn"
    sbgn.file.name = input$uploadSBGN$name
    print(sbgn.file.name)
    new.file = paste0(sbgn.dir,"/",sbgn.file.name)
    print(new.file)
    print(SBGN.full.path)
    file.remove(new.file)
    file.copy(SBGN.full.path,new.file)
    sbgn.content = readChar(new.file,nchars = 100)
    print(sbgn.content)
    sbgn.info(list(
        server.sbgn = sbgn.file.name
        ,input.sbgn = input$uploadSBGN$name
        ,sbgn.dir = sbgn.dir
    ))
    return("")
})
output$inputSBGN <- renderText({
    sbgn.info()$input.sbgn
})
output$sbgnDir <- renderText({
    sbgn.info()$sbgn.dir
})


output$upSBGN <- renderText({
    sbgn.info()$input.sbgn
})
output$upSbgnDir <- renderText({
    sbgn.info()$sbgn.dir
})


output$selectedPrePathwayText = renderText({
    paste0("Selected pre-generated pathway is: ",input$pathway.id)
})


output$exampleSBGN <- downloadHandler(
    filename = function() {
        # downloadNameVector[input$preData]
        "example.sbgn"
    },
    content = function(file) {
        sbgn.xml.out = sbgn.xmls[["http___identifiers.org_panther.pathway_P00001.sbgn"]]
        print(sbgn.xml.out)
        writeChar( object = sbgn.xml.out
                  , con = file
                  ,nchars = nchar(sbgn.xml.out))
    }
)


output$exampleIdMapping <- downloadHandler(
    filename = function() {
        # downloadNameVector[input$preData]
        "example.sbgn"
    },
    content = function(file) {
        write.table(hsa_ENTREZID_pathwayCommons
                    ,file = file
                    ,row.names = FALSE
                    ,sep="\t")
    }
)