From fab83ad590542d21e22c1de27cdd62b20686b159 Mon Sep 17 00:00:00 2001 From: Tami Crawford Date: Wed, 15 May 2019 11:02:28 -0400 Subject: [PATCH] fix package errors, etc --- shinyApp/global.R | 35 ++++--- shinyApp/module-analysisPanel.R | 156 ++++++++++++---------------- shinyApp/module-factorPanel.R | 65 +++++++----- shinyApp/module-loadPanel.R | 175 +++++++++++++------------------- shinyApp/module-statusPanel.R | 39 ++----- shinyApp/newutil.R | 23 ++++- shinyApp/server.R | 100 ++++-------------- shinyApp/ui.R | 52 +++------- shinyApp/www/styles.css | 13 +++ 9 files changed, 265 insertions(+), 393 deletions(-) diff --git a/shinyApp/global.R b/shinyApp/global.R index cc09615..8c7926c 100644 --- a/shinyApp/global.R +++ b/shinyApp/global.R @@ -1,3 +1,18 @@ +#if(!requireNamespace("BiocManager")){ +# install.packages("BiocManager") +#} +#BiocManager::install("phyloseq") +#BiocManager::install("Rhdf5lib") +#BiocManager::install("permute") + +# https://stackoverflow.com/questions/4090169/elegant-way-to-check-for-missing-packages-and-install-them +list.of.packages <- c(#"phyloseq", + "ade4", "dplyr", "stringr", "shiny", + "shinydashboard", + "shinyjs", "DT", "futile.logger") +new.packages <- list.of.packages[!(list.of.packages %in% installed.packages()[,"Package"])] +if(length(new.packages)) install.packages(new.packages) + library(phyloseq) library(ade4) library(dplyr) @@ -6,25 +21,21 @@ library(shiny) library(shinydashboard) library(shinyjs) library(DT) -library(shinywdstar) library(futile.logger) -flog.appender(appender.file("shinywdstar.log")) +ts <- substr(as.character(Sys.time()), 1, 10) +log_filename <- paste0("shinywdstar_",ts,".log") +flog.appender(appender.file(log_filename)) source("newutil.R") source("module-loadPanel.R") source("module-factorPanel.R") -source("module-testsPanel.R") + +#source("module-testsPanel.R") source("module-analysisPanel.R") +source("module-statusPanel.R") distance_choices <- phyloseq::distanceMethodList -data(physeq) - -#other data set -data(phy) -data(phenotypes) - -#physeq <- readRDS("physeq.rds") -#physeq <- readRDS("physeq.rds") -#load("data/physeq.rda") +data(soilrep) +physeq <- soilrep diff --git a/shinyApp/module-analysisPanel.R b/shinyApp/module-analysisPanel.R index d410ec8..08d303b 100644 --- a/shinyApp/module-analysisPanel.R +++ b/shinyApp/module-analysisPanel.R @@ -3,64 +3,68 @@ library(shiny) library(glue) library(DT) library(futile.logger) +library(ggplot2) + +data_controls_box_height <- 210 # UI analysisPanelUI <- function(id) { ns = NS(id) - tagList(uiOutput(ns("analysis"))) -} - -# Server -analysisPanel <- function(input, output, session, computed_details, sampleData, - allDataAvailable, availableFactors, numTests, - testsData, testsDT) { - - numTests <- numTests - allDataAvailable <- allDataAvailable - computed_details <- computed_details - testsData <- testsData - sampleMainFactor <- reactiveVal(NULL) - - selectedFactorChoices <- reactiveVal(NULL) - - data_controls_box_height <- 210 - - data_controls_panel <- reactive({ - ns <- session$ns - fluidRow(div(id="xdata_controls_panel", + tagList( + fluidRow(h1("Please wait for plots to appear, notification is at bottom of screen")), + fluidRow(div(id="xdata_controls_panel", box(width = 4, background = "olive", height = data_controls_box_height, selectInput(ns("distanceMethod"), "Distance", - distance_choices, selected = "jsd")), + distance_choices, selected = "jsd")), box(width = 4, background="olive", height = data_controls_box_height, uiOutput(ns("strataFactor")), - uiOutput(ns("mainFactor"))), - box(id = ns("add_test_box"), width = 4, background= "teal", - height = data_controls_box_height, - actionButton(ns("addTestBtn"), "Add Test"), - numericInput(ns("numPermutations"), "Number of Permutations", - value = 999, min = 1, max = 100000), - if(numTests() > 0) actionButton(ns("runTestsBtn1"), "Run Tests"), - if(numTests() > 0) actionButton(ns("clearTestsBtn"), "Clear Tests"), - if(numTests() > 0) textOutput(ns("testTable2")) - )))}) - - - observeEvent(input$runTestsBtn1, { - show(id = "running-tests", anim = TRUE, animType = "fade") - runTestsAction() - hide(id = "running-tests", anim = TRUE, animType = "fade") - updateTabsetPanel(session, inputId="sidebar", selected="tests") + uiOutput(ns("mainFactorDropdown"))))), + fluidRow( + box(title = "Ordination Plot", width = 6, plotOutput(ns("plot"))), + box(title = "Plot", width = 6, plotOutput(ns("newplot"))))) +} + + +#' Analysis Panel module server-side processing +#' +#' @param input,output,session standard \code{shiny} boilerplate +#' +#' @return list with following components +#' \describe{ +#' \item{globalData}{reactive character indicating x variable selection} +#' } +analysisPanel <- function(input, output, session, + globalData) { + + ns <- session$ns + globalData <- globalData + sampleMainFactor <- reactiveVal(NULL) + selectedFactorChoices <- reactiveVal(NULL) + + observeEvent(input$mainFactor, { + }) + + + availableFactors <- reactive({ + av <- globalData()[["factor_metadata"]] + af <- av %>% + dplyr::filter(ready == TRUE) %>% + pull(name) + af }) # output$mainFactor ---- - output$mainFactor = renderUI({ + output$mainFactorDropdown = renderUI({ af <- availableFactors() if(length(af) > 0) { - selectInput('mainFactor', 'Main factor', af ) + selectInput(ns("mainFactor"), 'Main factor', af ) + } else { + selectInput(ns("mainFactor"), 'Main factor', + c("Missing") ) } }) @@ -68,24 +72,28 @@ analysisPanel <- function(input, output, session, computed_details, sampleData, output$strataFactor = renderUI({ af <- append("None", availableFactors()) if(length(af) > 0) { - selectInput('strataFactor', 'Strata factor', af ) + selectInput(ns('strataFactor'), 'Strata factor', af ) + } else { + selectInput(ns('strataFactor'), 'Strata factor', + c("Missing")) } }) # physeqDataFactor ---- physeqDataFactor <- reactive({ - flog.info(glue("78: physeqDataFactor {input$mainFactor}")) req(input$mainFactor) - flog.info(glue("81: physeqDataFactor {input$mainFactor}")) - physeq <- physeqData() + #physeq <- physeqData() - flog.info(glue("84: physeqDataFactor {input$mainFactor}")) + sd <- globalData()[["sample"]] + q <- sd[ , input$mainFactor] + # save main factor - sampleMainFactor(sample_data(physeq)[[input$mainFactor]]) - flog.info(glue("87: physeqDataFactor {input$mainFactor}")) + sampleMainFactor(q) + #sampleMainFactor(sample_data(physeq)[[input$mainFactor]]) + #soilrep physeq }) @@ -96,55 +104,16 @@ analysisPanel <- function(input, output, session, computed_details, sampleData, physeq <- physeqDataFactor() dist_matrices = distance(physeq, method=c(input$distanceMethod)) }) - observeEvent(input$clearTestsBtn, { - testsDT(NULL) - }) - - # ADD TEST BUTTON ---- - observeEvent(input$addTestBtn, { - req(input$mainFactor) - - flog.info("ADD TEST BUTTON") - aRow <- data_frame(test_id = numTests() + 1, - strata_factor = input$strataFactor, - main_factor = input$mainFactor, - distance = input$distanceMethod, - status = "not run") - - newTable <- bind_rows(testsDT(), aRow) - testsDT(newTable) - }) - - - # analysis tab ---- - output$analysis <- renderUI({ - flog.info("117: analysis render ui") - if(allDataAvailable()) { - ns <- session$ns - flog.info("120: analysis render ui: all data available") - div(data_controls_panel(), - fluidRow( - box(title = "Ordination Plot", width = 6, plotOutput(ns("plot"))), - box(title = "Plot", width = 6, plotOutput(ns("newplot"))))) - } else { - flog.info("analysis render ui: no data available") - div(h1("No data loaded.")) - } - }) # output$plot ---- output$plot <- renderPlot({ - flog.info(glue("analysis : plot {input$mainFactor}")) - flog.info(glue("analysis : plot {is.null(physeqDataFactor())}")) req(physeqDataFactor(), input$mainFactor) - flog.info("analysis : plot B") + withProgress(message = 'Creating ordination plot', value = 0, { physeq <- physeqDataFactor() dist_matrices = distance(physeq, method=c(input$distanceMethod)) - #print(glue::glue("plot_ordination: {input$mainFactor} {input$distanceMethod}")) - flog.info("analysis : plot C") ordination_list = ordinate(physeq, method="MDS", distance = distanceMatrices()) @@ -152,11 +121,12 @@ analysisPanel <- function(input, output, session, computed_details, sampleData, ordination = ordination_list, type = "samples", color = input$mainFactor ) + - theme_minimal() + ggplot2::theme_minimal() flog.info("analysis : plot D") - p <- p + scale_color_discrete(labels = paste(levels(sampleMainFactor()), + p <- p + ggplot2::scale_color_discrete(labels = paste(levels(sampleMainFactor()), table(sampleMainFactor()))) + }) return(p) }) @@ -164,14 +134,12 @@ analysisPanel <- function(input, output, session, computed_details, sampleData, # display new plot ---- output$newplot <- renderPlot({ - flog.info("analysis render ui new plot A checking requirements") req(physeqDataFactor(), input$mainFactor) - flog.info("analysis render ui new plot B requiements met") + withProgress(message = 'Creating plot', value = 0, { physeq <- physeqDataFactor() dist_matrices = distance(physeq, method=c(input$distanceMethod)) - #print(glue::glue("newplot: {input$mainFactor} {input$strataFactor} {input$distanceMethod}")) phy <- physeq jsd.dist = dist_matrices @@ -189,6 +157,8 @@ analysisPanel <- function(input, output, session, computed_details, sampleData, } else { ade4::s.class(jsd.pco$li, sample_data(phy)[[input$mainFactor]]) } + }) + }) outin <- reactiveValues(inputs = NULL) diff --git a/shinyApp/module-factorPanel.R b/shinyApp/module-factorPanel.R index 36ed21c..490bbec 100644 --- a/shinyApp/module-factorPanel.R +++ b/shinyApp/module-factorPanel.R @@ -3,10 +3,9 @@ library(shiny) library(glue) library(readr) library(DT) -library(shinywdstar) library(futile.logger) -source("module-assignFactorLevels.R") +#source("module-assignFactorLevels.R") # UI factorPanelUI <- function(id) { @@ -14,80 +13,87 @@ factorPanelUI <- function(id) { tagList( fluidRow( - column(4, uiOutput(ns("factorDropdown"))), - column(4, assignFactorLevelsUI(id = ns("fp")))), + column(3, uiOutput(ns("factorDropdown"))), + column(9, uiOutput(ns("factorDragAndDrop")))), fluidRow(column(12, DT::dataTableOutput(ns("factorsDataTable"))))) } # Server -factorPanel <- function(input, output, session, computed_details, sdata, gdata) { +factorPanel <- function(input, output, session, globalData) { - computed_details <- computed_details + globalData <- globalData + outin <- reactiveValues(inputs = NULL) selectedFactorChoices <- reactiveVal(NULL) - my_sample_data <- sdata - genomic_data <- gdata - - fp <- callModule(assignFactorLevels, "fp", - selectedFactorChoices, - my_sample_data, genomic_data) - output$result <- renderPrint(str(input$dragvars)) # Drop down containing potential factors output$factorDropdown <- renderUI({ - af <- computed_details() + af <- globalData()[["computed_details"]] if(is.null(af)) { return(p("No factor data available. NO DETAILS")) } ns <- session$ns - #print(str_c("factors: ", str_c(af, collapse = ", "))) selectInput(ns("editFactor"), 'Factor', af %>% pull(name)) }) # Drop down containing potential factors output$factorDragAndDrop <- renderUI({ - af <- computed_details() + + if(is.null(input$editFactor)) { + return(NULL) + } + + af <- globalData()[["computed_details"]] if(is.null(af)) { - return(p("NO DETAILS")) + return(p("a1) NO DETAILS")) } ns <- session$ns - choices <- af %>% pull(name) - #sapply(my_sample_data(), is.factor) - #sapply(my_sample_data(), function(x) {length(levels(x))} ) + print(paste0("SELECTED: ", input$editFactor)) + + fmd <- globalData()[["factor_metadata"]] + fmdthis <- dplyr::filter(fmd, name == input$editFactor) + fchoices <- pull(fmdthis, unique_values) + print(fchoices) + them <- str_split(fchoices, ", ") %>% unlist() + choices <- them dnd <- esquisse::dragulaInput(inputId = ns("dragvars"), - sourceLabel = "SSSLevels", + sourceLabel = "SSSLevels", targetsLabels = c("Level 0", "Level 1"), targetsIds = c("level0", "level1"), choices = choices, badge = TRUE, width = "400px", height = "100px", replace = FALSE) - dnd + dnd }) output$factorsDataTable <- DT::renderDataTable({ - computed_details() + globalData()[["factor_metadata"]] }) - outin <- reactiveValues(inputs = NULL) observeEvent(input$editFactor, { - print(glue("editFactor changed: {input$editFactor}")) - if(!input$editFactor %in% colnames(my_sample_data())) { + mysd <- globalData()[["sample"]] + if(is.null(mysd)) { + return(NULL) + } + print(glue("editFactor changed: [{input$editFactor}]")) + if(!input$editFactor %in% colnames(mysd)) { print("ERROR sample data is not in the correct format") + futile.logger::flog.warn("ERROR sample data not in correct format") + browser() return(NULL) } ##################################### # set the tab based on the type of factor selected - - vals <- my_sample_data() %>% pull(input$editFactor) + vals <- mysd %>% pull(input$editFactor) uvals <- unique(vals) if(is.factor(vals)) { prev <- selectedFactorChoices() @@ -100,6 +106,9 @@ factorPanel <- function(input, output, session, computed_details, sdata, gdata) observeEvent(input$dragvars, { print(glue("dragvars changed: {input$dragvars}")) + # set the data in factors metadata + fmd <- globalData()[["factor_metadata"]] + #fmda <- fmd %>% outin$inputs <- reactiveValuesToList(input) }) diff --git a/shinyApp/module-loadPanel.R b/shinyApp/module-loadPanel.R index afa36c6..b1f0fe9 100644 --- a/shinyApp/module-loadPanel.R +++ b/shinyApp/module-loadPanel.R @@ -4,47 +4,63 @@ library(glue) library(DT) library(futile.logger) -# UI +#' load panel to allow user to load data +#' +#' @param id, character used to specify namespace, see \code{shiny::\link[shiny]{NS}} +#' +#' @return a \code{shiny::\link[shiny]{tagList}} containing UI elements loadPanelUI <- function(id) { ns = NS(id) - tagList(h3("loadPanel"), - actionButton("loadDataBtn", "Load Demo Data Btn"), - uiOutput(ns("loadMenu")), - uiOutput(ns("load"))) + tagList(uiOutput(ns("page"))) } -# Server +#' loadPanel module server-side processing +#' +#' @param input,output,session standard \code{shiny} boilerplate +#' +#' @return list with following components +#' \describe{ +#' \item{genomic}{reactive character indicating x variable selection} +#' \item{sample}{reactive character indicating y variable selection} +#' } loadPanel <- function(input, output, session) { - flog.info("20: loadPanel") - data <- reactiveVal(list(genomic=NULL, sample=NULL)) + ns = session$ns - loadDemoData2 <- reactive({ - flog.info("24:loadDemoData2") + data <- reactiveVal(list(genomic = NULL, + sample = NULL, + orig_factor_data = NULL, + factor_metadata = NULL, + orig_factor_metadata = NULL, + computed_details = NULL + )) - orig <- data() - sdata = read.csv("data/sample_data.csv") - rownames(sdata) <- as.character(sdata$id_full) + physeqToSample <- function(physeq) { + # -- convert the physeq to the same format as sdata + dd <- physeq@sam_data@.Data + names(dd) <- physeq@sam_data@names + dd_df <- data.frame(dd) - asv = read.table("data/raw_count.csv", row.names = 1, sep = ",", check.names = FALSE, header = TRUE) - rcdata = t(asv) + rownames(dd_df) <- physeq@sam_data@row.names + dd_df + } - orig <- data() - orig[["sample"]] <- sdata - orig[["genomic"]] <- rcdata + physeqToRawCount <- function(physeq) { + t(physeq@otu_table) + } - data(orig) - }) - - loadDemoData1 <- reactive({ - flog.info("41:loadDemoData1") - }) + generate_metadata_from_sample_data <- function(sd) { + if(ncol(sd) > 0) { + md <- map_df(colnames(sd), ~ handle_factor(., dplyr::pull(sd, .))) + } else { + NULL + } + } + #this doesn't need to be reactive, it could be a list loadDemoData <- reactive({ - flog.info("46:loadDemoData") - sdata <- physeqToSample(physeq) rcdata <- physeqToRawCount(physeq) @@ -52,6 +68,15 @@ loadPanel <- function(input, output, session) { orig[["sample"]] <- sdata orig[["genomic"]] <- rcdata + md <- generate_metadata_from_sample_data(sdata) + orig[["factor_metadata"]] <- md + orig[["orig_factor_metadata"]] <- md + + avfactors <- md %>% + dplyr::filter(type == "factor") %>% + select(name, ready, description) + + orig[["computed_details"]] <- avfactors data(orig) }) @@ -63,57 +88,30 @@ loadPanel <- function(input, output, session) { style="color: #fff; background-color: #337ab7; border-color: #2e6da4") } - output$loadMenu = renderUI({ - flog.info("67:loadMenu") - div( - p( - #menuItem('Raw Count/CSV', tabName = 'data'), + output$page = renderUI({ + flog.info("67:loadPage") + div( + p( if(allDataAvailable()) { - loadBtn("clearDataBtn", "Clear Data") + loadBtn(ns("clearDataBtn"), "Clear Data") } else { - tagList(p( - loadBtn("xx", "xx"), - loadBtn("loadDemoDataBtn", "Load Demo Data"), - loadBtn("loadDemoDataBtn2", "Load Demo Data 2"))) - }))}) + tagList(actionButton(ns("loadDataBtn"), "Load Phylo Demo Data")) + })) + }) + # data + factorForLoaded <- reactive({ + d <- data() + if (!is.null(d[["sample"]])) { + NULL + } + }) # allDataAvailable ---- allDataAvailable <- reactive({ d <- data() if (!is.null(d[["sample"]]) && !is.null(d[["genomic"]])) { - print("513: ALL AVAILABLE DATA") - flog.info("513: ALL AVAILABLE DATA") - - #???? - sd <- sampleData() - d[["orig_factor_data"]] <- sd - if(ncol(sd) > 0) { - md <- map_df(colnames(sd), - ~ handle_factor(., dplyr::pull(sd, .))) - flog.info("allDataAvailable") - flog.info(md) - - md <- md %>% - mutate(type = map_chr(colnames(sd), ~ class(sd[[.]]))) - - d[["factor_metadata"]] <- md - d[["orig_factor_metadata"]] <- md - - d[["computed_details"]] <- data_frame(name = availableFactors(), - ready = FALSE, - description = "init") - - computed_details(d[["computed_details"]]) - flog.info(d[["computed_details"]]) - } else { - values$factor_metadata = NULL - values$orig_factor_metadata = NULL - d[["factor_metadata"]] <- NULL - d[["orig_factor_metadata"]] <- NULL - } - data(d) return(TRUE) } else { return(FALSE) @@ -140,55 +138,26 @@ loadPanel <- function(input, output, session) { } else { data()[["sample"]] } - }) - - - + }) - # LOAD DEMO DATA BUTTON ---- - ### Load the data then change to the analysis tab + ### Load the data then TO DO: change to the analysis tab observeEvent(input$loadDataBtn, { - flog.info("150:loadDataBtn") - - #show(id = "updating-content", anim = TRUE, animType = "fade") loadDemoData() - - #hide(id = "updating-content", anim = TRUE, animType = "fade") - #updateTabsetPanel(session, inputId = "sidebar", selected = "analysis") - }) - - observeEvent(input$loadDemoDataBtn, { - flog.info("159:loadDemoDataBtn") - print("LOAD") - }) - - observeEvent(input$xx, { - flog.info("166:xx loadDemoDataBtn") - print("LOAD") - }) - - observeEvent(input$loadDemoDataBtn2, { - flog.info("163:loadDemoDataBtn2") }) - # CLEAR DEMO DATA BUTTON ---- observeEvent(input$clearDataBtn, { - flog.info("169: clearDataBtn") - orig <- data() orig[["sample"]] <- NULL orig[["genomic"]] <- NULL - data(orig) - }) + orig[["factor_metadata"]] <- NULL + orig[["orig_factor_metadata"]] <- NULL + orig[["computed_details"]] <- NULL - observe({ - print("181: loadPanel HELLO") - flog.info("181: loadPanel HELLO") + data(orig) }) - return(data) } diff --git a/shinyApp/module-statusPanel.R b/shinyApp/module-statusPanel.R index a93af09..e082718 100644 --- a/shinyApp/module-statusPanel.R +++ b/shinyApp/module-statusPanel.R @@ -1,55 +1,28 @@ -library(dplyr) -library(shiny) -library(glue) -library(readr) -library(DT) -library(shinywdstar) -library(futile.logger) -library(DiagrammeR) - # UI statusPanelUI <- function(id) { ns = NS(id) - tagList( - #grVizOutput('diagram'), - uiOutput(ns("statusPanel"))) + tagList(textOutput(ns("msg"))) } # Server statusPanel <- function(input, output, session, data) { + ns <- session$ns data <- data - spec <- " - digraph { - graph [overlap = true, rankdir = LR] - node [shape = box, fontname = Helvetica, color = blue] - edge [color = gray] - Load; Preprocess; Analysis; Test - Load->Preprocess - Preprocess->Analysis [color = red] - Analysis->Test - }" - - # Drop down containing potential factors - output$statusPanel <- renderUI({ + output$msg <- renderText({ sd <- data()[["sample"]] gd <- data()[["genomic"]] if(is.null(sd) && is.null(gd)) { - return(div("No data loaded.")) + return("No data loaded.") } + sample_msg <- ifelse(is.null(sd),"No sample data", glue("Samples: {nrow(sd)}")) g_msg <- ifelse(is.null(gd),"No genomic data", glue("Genomic: {nrow(gd)}")) - div(str_c(sample_msg, " ", g_msg)) -# , grVizOutput("processGraph") -# , DiagrammeROutput('processGraph', height = "50px", width = "auto") + return(str_c(sample_msg, " ", g_msg)) }) - output$diagram <- renderGrViz({ - grViz(spec) - #grViz("digraph test {A; B; A-> B }") - }) return(NULL) } diff --git a/shinyApp/newutil.R b/shinyApp/newutil.R index b1d4cab..419d44d 100644 --- a/shinyApp/newutil.R +++ b/shinyApp/newutil.R @@ -2,7 +2,6 @@ library(dplyr) library(stringr) library(purrr) - uniq_vals_description <- function(ff1) { ## remove NA's ff <- ff1[!is.na(ff1)] @@ -11,7 +10,6 @@ uniq_vals_description <- function(ff1) { return(str_c("#unique: ", length(uu))) } ss <- str_c(uu, collapse = ",") - flog.info(str_c("uniq_vals_description: ", ss)) if(!length(ss)) { flog.error("nothing in this string") flog.error(uu) @@ -26,7 +24,26 @@ uniq_vals_description <- function(ff1) { update_grouping_factor <- function(nm, f, labels, true_label) { } -handle_factor <- function(nm, f) { +handle_factor <- function(nm, fval) { + + f <- fval + if (is.factor(f)) { + u_vals <- unique(f) + num_unique <- length(u_vals) + ready <- (num_unique == 2) + type <- class(u_vals) + labels <- glue::glue_collapse(levels(f), sep = ", ") + new_df <- data_frame(name = nm, + num_unique = length(levels(f)), + unique_values = labels, + method_applied = "none", + ready = (num_unique == 2), + type = type, + description = "factor", + labels = labels, + true_label = first(levels(f))) + return(new_df) + } u_vals <- unique(f) num_unique <- length(u_vals) diff --git a/shinyApp/server.R b/shinyApp/server.R index c984f1c..8b6995a 100644 --- a/shinyApp/server.R +++ b/shinyApp/server.R @@ -1,8 +1,13 @@ +#' shinyAppServer for WdStar +#' +#' @param input, output, session: standard shiny boilerplate +#' +#' \describe{ +#' +#' +#' } shinyAppServer <- function(input, output, session) { - loadData <- callModule(loadPanel, "loadPanel") - - #genomic_data <- loadData()[["genomic"]] # loaded data values <- reactiveValues(sampleMainFactor = NULL, @@ -36,10 +41,7 @@ shinyAppServer <- function(input, output, session) { }) - cd <- read_csv("cd.csv") - factorPanel <- callModule(factorPanel, - "factorPanel", computed_details, sampleData, cd) load_data <- function() { hide(id = "loading-content", anim = TRUE, animType = "fade") @@ -47,7 +49,6 @@ shinyAppServer <- function(input, output, session) { } load_data() - print("AFTER LOAD DATA") # rawCountData ---- rawCountDataFromFile <- reactive({ @@ -71,21 +72,15 @@ shinyAppServer <- function(input, output, session) { #req(sampleData(), rawCountData()) if( !is.null(values$userPhyseq)) { - #print("return USER physeqData") return(values$userPhyseq) } - ##sdata <- sampleData() - ##asv.t <- rawCountData() sdata <- values$sdata asv.t <- values$rcdata phyloseq( otu_table(asv.t, taxa_are_rows = F), sample_data(sdata)) }) - - - # computeTresFtn ---- computeTresFtn <- function(strata, mainf, dist) { @@ -188,8 +183,8 @@ shinyAppServer <- function(input, output, session) { select(test_id, distance) %>% left_join(w_df, by="test_id") - flog.info(str_c("results: ", nrow(a_df))) - flog.info(a_df) + #flog.info(str_c("results: ", nrow(a_df))) + #flog.info(a_df) if(nrow(a_df) != nrow(w_df)){ browser() } @@ -225,11 +220,8 @@ shinyAppServer <- function(input, output, session) { } }) - # HERE ---- - ### applyFactorNumeric applyFactorNumeric <- function(ft, fmethod) { - flog.info(str_c("applyFactorNumeric: ", ft, " fmethod ", fmethod)) flog.info(str_c("applyFactorNumeric: ", ft, " fmethod ", fmethod)) orig_md <- orig_metadata() md <- metadata() @@ -292,6 +284,8 @@ shinyAppServer <- function(input, output, session) { # availableFactors ---- availableFactors <- reactive({ + print("293: server: AF") + browser() sd <- sampleData() if(!is.null(sd)) { choices <- colnames(sd) @@ -302,74 +296,16 @@ shinyAppServer <- function(input, output, session) { } }) - # allDataAvailable ---- - allDataAvailable <- reactive({ - if (!is.null(sampleData()) && !is.null(rawCountData())) { - #print("513: ALL AVAILABLE DATA") - - sd <- sampleData() - values$orig_factor_data = sd - if(ncol(sd) > 0) { - md <- map_df(colnames(sd), - ~ handle_factor(., dplyr::pull(sd, .))) - flog.info("allDataAvailable") - flog.info(md) - - md <- md %>% - mutate(type = map_chr(colnames(sd), ~ class(sd[[.]]))) - - values$factor_metadata = md - values$orig_factor_metadata = md - - values$computed_details <- data_frame(name = availableFactors(), - ready = FALSE, - description = "init") - - computed_details(values$computed_details) - flog.info(values$computed_details) - } else { - values$factor_metadata = NULL - values$orig_factor_metadata = NULL - } - return(TRUE) - } else { - return(FALSE) - } - }) - - - testsPanel <- callModule(testsPanel, "testsPanel", computed_details, - sampleData, allDataAvailable, numTests, testsData, testsDT) - - analysisPanel <- callModule(analysisPanel, "analysisPanel", computed_details, - sampleData, - allDataAvailable, availableFactors, numTests, testsData, testsDT) - - - output$dataLoaded <- renderText({ - flog.info("350:server dataLoaded") - if (allDataAvailable()) { - flog.info("352:server dataLoaded:data loaded") - "data loaded" - } else {""} - }) - - physeqToSample <- function(physeq) { - # -- convert the physeq to the same format as sdata - dd <- physeq@sam_data@.Data - names(dd) <- physeq@sam_data@names - dd_df <- data.frame(dd) - - rownames(dd_df) <- physeq@sam_data@row.names - dd_df - } - physeqToRawCount <- function(physeq) { - t(physeq@otu_table) - } output$intro <- renderText({ markdown::renderMarkdown('intro.md') }) + globalData <- callModule(loadPanel, "loadPanel") + factorData <- callModule(factorPanel, "factorPanel", globalData) + + analysisPanel <- callModule(analysisPanel, "analysisPanel", globalData) + + statusPanel <- callModule(statusPanel, "statusPanel", globalData) } diff --git a/shinyApp/ui.R b/shinyApp/ui.R index d188471..90e5072 100644 --- a/shinyApp/ui.R +++ b/shinyApp/ui.R @@ -1,41 +1,15 @@ -distance_choices <- phyloseq::distanceMethodList - -# input selection panel -input_selection_panel <- - div(box(fileInput("rawCountFile", "Raw Count File")), - box(fileInput("sampleDataFile", "Sample Data File"))) - -sidebar <- dashboardSidebar( - sidebarMenu(id="sidebar", - menuItem("Introduction", tabName = "intro", icon = icon("home")), - #menuItem('Load data', icon = icon("database"), tabName = 'data', uiOutput("loadMenu")), - menuItem('Load', icon = icon("database"), tabName = 'load') -# , menuItem('Factor', icon = icon("database"), tabName = 'factor'), -# menuItem("Analysis", icon = icon("tasks"), tabName = "analysis" ), -# menuItem('Tests', icon = icon("database"), tabName = 'tests') - )) - - # Shiny app server object ---- -shinyAppUI <- dashboardPage( - - dashboardHeader(title = "Shiny WdStar"), - dashboardSidebar(sidebar), - dashboardBody(id = "dashboard", - shinyjs::useShinyjs(), +shinyAppUI <- + tagList( tags$head(tags$link(rel = 'stylesheet', type = 'text/css', href = 'styles.css')), - - div(id = "loading-content", h1("LOADING...")), - - # some divs to display to show in-progress - hidden(div(id = "updating-content", p("UPDATING...."))), - hidden(div(id = "running-tests", h1("RUNNING TESTS...."))), - - tabItems( - tabItem(tabName = "intro", htmlOutput("intro")), - #tabItem(tabName = "data", input_selection_panel), - tabItem(tabName = "load", loadPanelUI("loadPanel")) -# , tabItem(tabName = "factor", factorPanelUI("factorPanel")), -# tabItem(tabName = "tests", testsPanelUI("testsPanel")), -# tabItem(tabName = "analysis", analysisPanelUI("analysisPanel")) - ))) + tags$head(tags$link(rel = 'stylesheet', type = 'text/css', href = 'styles-dad.css')), + tags$head(tags$link(rel = 'stylesheet', type = 'text/css', href = 'dragula/dragula.min.css')), + navbarPage("WdStar", id = "tabs", inverse = TRUE, + header = div(id = "status-panel", statusPanelUI("statusPanel")) + , tabPanel("Intro", mainPanel(includeMarkdown("intro.md"))) + , tabPanel("Load", loadPanelUI("loadPanel")) +# , tabPanel("Preprocess", factorPanelUI("factorPanel")) + , tabPanel("Analysis", analysisPanelUI("analysisPanel")) +# , tabPanel("Test", testsPanelUI("testsPanel")) + , tabPanel("About", mainPanel(includeMarkdown("about.md"))) + )) diff --git a/shinyApp/www/styles.css b/shinyApp/www/styles.css index a8ee615..2275181 100644 --- a/shinyApp/www/styles.css +++ b/shinyApp/www/styles.css @@ -109,3 +109,16 @@ table.dataTable { color: navy; } .sidebar { background-color: #3C8DBC } +#status-panel, #status-panel1 { + margin-top: -20px; + background-color: #ccccff; +} + +#status-panel h1, #status-panel h3 { + color: #660099; +} + +#status-panel1 h1, #status-panel1 h3 { + color: #660099; +} +