diff --git a/TRUE b/TRUE new file mode 100644 index 0000000..e69de29 diff --git a/app/DoseResponse.R b/app/DoseResponse.R index e1ec8d5..c156520 100644 --- a/app/DoseResponse.R +++ b/app/DoseResponse.R @@ -1,5 +1,3 @@ -# TODO: add everywhere the ? documentation. -# In an analogous way to the DoseResponse tab DoseResponseSidebarUI <- function(id) { tabPanel( "Dose Response analysis", @@ -18,9 +16,9 @@ DoseResponseSidebarUI <- function(id) { verbatimTextOutput(NS(id, "applied_filter")) ), br(), - uiOutput(NS(id, "substanceNames")), - uiOutput(NS(id, "negIdentifier")), - uiOutput(NS(id, "posIdentifier")), + uiOutput(NS(id, "substanceNamesUI")), + uiOutput(NS(id, "negIdentifierUI")), + uiOutput(NS(id, "posIdentifierUI")), actionButton(NS(id, "ic50"), "Conduct analysis") ) ) @@ -53,7 +51,6 @@ DoseResponseUI <- function(id) { DoseResponseServer <- function(id, data, listResults) { moduleServer(id, function(input, output, session) { - r_vals <- reactiveValues( plots = NULL, names = NULL, # For dropdown_plots @@ -63,7 +60,7 @@ DoseResponseServer <- function(id, data, listResults) { ) # Render names, conc and abs column - output[["substanceNames"]] <- renderUI({ + output[["substanceNamesUI"]] <- renderUI({ req(!is.null(data$df)) req(is.data.frame(data$df)) colnames <- names(data$df) @@ -84,7 +81,7 @@ DoseResponseServer <- function(id, data, listResults) { ) }) - output[["negIdentifier"]] <- renderUI({ + output[["negIdentifierUI"]] <- renderUI({ req(!is.null(data$df)) req(is.data.frame(data$df)) req(input$`substanceNames`) @@ -101,13 +98,13 @@ DoseResponseServer <- function(id, data, listResults) { selectInput( inputId = paste0("DOSERESPONSE-negIdentifier"), label = "Name of the negative control", - choices = choices[1:length( choices)], + choices = choices[1:length(choices)], selected = NULL ) ) }) - output[["posIdentifier"]] <- renderUI({ + output[["posIdentifierUI"]] <- renderUI({ req(!is.null(data$df)) req(is.data.frame(data$df)) req(input$`substanceNames`) @@ -124,7 +121,7 @@ DoseResponseServer <- function(id, data, listResults) { selectInput( inputId = paste0("DOSERESPONSE-posIdentifier"), label = "Name of the positive control", - choices = choices[1:length( choices)], + choices = choices[1:length(choices)], selected = NULL ) ) @@ -195,14 +192,18 @@ DoseResponseServer <- function(id, data, listResults) { FormulaEditorUI("FO"), easyClose = TRUE, size = "l", - footer = NULL + footer = tagList( + modalButton("Close") + ) )) }) # display current formula observe({ req(!is.null(data$formula)) - output$formula <- renderText({deparse(data$formula)}) + output$formula <- renderText({ + deparse(data$formula) + }) }) drFct <- function() { @@ -266,6 +267,10 @@ DoseResponseServer <- function(id, data, listResults) { listResults$counter <- listResults$counter + 1 new_result_name <- paste0("DoseResponseNr", listResults$counter) listResults$all_data[[new_result_name]] <- new("doseResponse", df = resDF, p = resPlot) + + exportTestValues( + doseresponse_res = listResults$curr_data + ) } } @@ -347,7 +352,6 @@ DoseResponseServer <- function(id, data, listResults) { r_vals$currentPageOverview <- r_vals$currentPageOverview - 1 } }) - }) return(listResults) diff --git a/app/MainApp.R b/app/MainApp.R index b9d2302..9e4da1d 100644 --- a/app/MainApp.R +++ b/app/MainApp.R @@ -1,15 +1,475 @@ app <- function() { ui <- fluidPage( - # useShinyjs(), - # includeScript("www/download.js"), - # tags$head( - # tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js"), - # tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js"), - # tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js") - # ), + useShinyjs(), + includeScript(system.file("www/download.js", package = "bs")), + tags$head( + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js"), + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js"), + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js") + ), + sidebarLayout( + sidebarPanel( + div( + conditionalPanel( + condition = "input.conditionedPanels == 'Data'", + div( + style = "position: relative", + actionButton( + "data_docu", + label = NULL, + icon = icon("question-circle") + ) + ), + conditionalPanel( + condition = "input.conditionedPanels == 'Data'", + fileInput("file", "Choose CSV File", + accept = c( + "text/csv", + "text/comma-separated-values,text/plain", + ".csv" + ) + ) + ), + tags$hr() + ), + conditionalPanel( + condition = "input.conditionedPanels == 'DataWrangling'", + div( + style = "position: relative", + actionButton( + "datawrangling_docu", + label = NULL, + icon = icon("question-circle") + ) + ), + OperatorEditorSidebar("OP") + ), + conditionalPanel( + condition = "input.conditionedPanels == 'Visualisation'", + div( + style = "position: relative;", + actionButton( + "visualization_docu", + label = NULL, + icon = icon("question-circle") + ) + ), + visSidebarUI("VIS") + ), + conditionalPanel( + condition = "input.conditionedPanels == 'Assumption'", + div( + style = "position: relative", + actionButton( + "ass_docu", + label = NULL, + icon = icon("question-circle") + ) + ), + assSidebarUI("ASS") + ), + conditionalPanel( + condition = "input.conditionedPanels == 'Correlation'", + div( + style = "position: relative", + actionButton( + "corr_docu", + label = NULL, + icon = icon("question-circle") + ) + ), + corrSidebarUI("CORR") + ), + conditionalPanel( + condition = "input.conditionedPanels == 'Tests'", + div( + style = "position: relative", + actionButton( + "test_docu", + label = NULL, + icon = icon("question-circle") + ) + ), + testsSidebarUI("TESTS") + ), + conditionalPanel( + condition = "input.conditionedPanels == 'Dose Response analysis'", + div( + style = "position: relative;", + actionButton( + "doseresponse_docu", + label = NULL, + icon = icon("question-circle") + ) + ), + DoseResponseSidebarUI("DOSERESPONSE") + ) + ) + ), + mainPanel( + tabsetPanel( + tabPanel( + "Data", + DTOutput("df") + ), + tabPanel( + "DataWrangling", + OperatorEditorUI("OP") + ), + tabPanel( + "Visualisation", + visUI("VIS") + ), + tabPanel( + "Assumption", + assUI("ASS") + ), + tabPanel( + "Correlation", + corrUI("CORR") + ), + tabPanel( + "Tests", + testsUI("TESTS") + ), + tabPanel( + "Dose Response analysis", + DoseResponseUI("DOSERESPONSE") + ), + id = "conditionedPanels" + ), + uiOutput("Results") + ) + ) ) server <- function(input, output, session) { + dataSet <- reactiveValues( + df = NULL, formula = NULL, + backup_df = NULL, filter_col = NULL, filter_group = NULL + ) + + listResults <- reactiveValues( + curr_data = NULL, curr_name = NULL, + all_data = list(), all_names = list(), + counter = 0 + ) + + # docu data + observeEvent(input[["data_docu"]], { + showModal(modalDialog( + title = "Example Dataframe", + includeHTML("www/data.html"), + easyClose = TRUE, + footer = NULL + )) + }) + observeEvent(input[["datawrangling_docu"]], { + showModal(modalDialog( + title = "Data wrangling", + includeHTML("www/operations.html"), + easyClose = TRUE, + footer = NULL + )) + }) + observeEvent(input[["corr_docu"]], { + showModal(modalDialog( + title = "Correlation", + includeHTML("www/data.html"), + easyClose = TRUE, + footer = NULL + )) + }) + observeEvent(input[["ass_docu"]], { + showModal(modalDialog( + title = "Testing assumptions", + includeHTML("www/assumptions.html"), + easyClose = TRUE, + footer = NULL + )) + }) + observeEvent(input[["test_docu"]], { + showModal(modalDialog( + title = "Statistical tests", + includeHTML("www/tests.html"), + easyClose = TRUE, + footer = NULL + )) + }) + # docu dose response + observeEvent(input[["doseresponse_docu"]], { + showModal(modalDialog( + title = "Doseresponse analysis", + includeHTML("www/doseresponse.html"), + easyClose = TRUE, + footer = NULL + )) + }) + # docu visualisation + observeEvent(input[["visualization_docu"]], { + showModal(modalDialog( + title = "Visualization", + includeHTML("www/visualization1.html"), + br(), + renderImage( + { + list( + src = "www/DocuPlot.jpg", + contentType = "image/jpg", + width = 650, + height = 500, + alt = "Basic Plot" + ) + }, + deleteFile = FALSE + ), + br(), + br(), + br(), + br(), + br(), + includeHTML("www/visualization2.html"), + easyClose = TRUE, + footer = NULL, + size = "l" + )) + }) + # docu formula editor + observeEvent(input[["FO-formula_docu"]], { + showModal(modalDialog( + title = "Defining the formula", + includeHTML(system.file("www/formula.html", package = "bs")), + easyClose = TRUE, + footer = NULL, + size = "l" + )) + }) + # docu split by group + observeEvent(input[["SG-split_docu"]], { + showModal(modalDialog( + title = "Subsetting the dataset", + includeHTML(system.file("www/SplitData.html", package = "bs")), + easyClose = TRUE, + footer = NULL, + size = "l" + )) + }) + + output$conditional_data_ui <- renderUI({ + if (Sys.getenv("RUN_MODE") != "SERVER") { + res <- conditionalPanel( + condition = "input.conditionedPanels == 'Data'", + fileInput("file", "Choose CSV File", + accept = c( + "text/csv", + "text/comma-separated-values,text/plain", + ".csv" + ) + ) + ) + return(res) + } + }) + + download_file <- reactive({ + file <- download(session, "/home/shiny/results") # NOTE: from COMELN + df <- NULL + df <- readData(file) + if (!is.data.frame(df)) { + showNotification("File can not be used. Upload into R failed!", duration = 0) + } + tryCatch( + { + unlink(file) + }, + warning = function(warn) { + showNotification(paste("A warning occurred: ", conditionMessage(warn)), duration = 0) + }, + error = function(err) { + showNotification(paste("An error occurred: ", conditionMessage(err)), duration = 0) + } + ) + req(is.data.frame(df)) + return(df) + }) + + output$df <- renderDT({ + if (Sys.getenv("RUN_MODE") == "SERVER") { + res <- try({ + download_file() + }) + if (inherits(res, "try-error")) { + stop(attributes(res)$condition) + } else { + res <- create_r_names(res) + dataSet$df <- res + } + datatable(dataSet$df, options = list(pageLength = 10)) + } else { + req(input$file) + df <- try(readData(input$file$datapath)) + if (inherits(df, "try-error")) { + err <- conditionMessage(attr(df, "condition")) + showNotification(err) + return(NULL) + } + df <- create_r_names(df) + dataSet$df <- df + req(!is.na(dataSet$df)) + datatable(dataSet$df, options = list(pageLength = 10)) + } + }) + + observe({ + req(!is.null(dataSet$df)) + req(is.data.frame(dataSet$df)) + output$df <- renderDT( + datatable(dataSet$df, options = list(pageLength = 10)) + ) + }) + + OperationEditorServer("OP", dataSet, listResults) + corrServer("CORR", dataSet, listResults) + visServer("VIS", dataSet, listResults) + assServer("ASS", dataSet, listResults) + testsServer("TESTS", dataSet, listResults) + DoseResponseServer("DOSERESPONSE", dataSet, listResults) + FormulaEditorServer("FO", dataSet) + SplitByGroupServer("SG", dataSet) + + # Render results list + output$Results <- renderUI({ + if (input$conditionedPanels == "DataWrangling" || input$conditionedPanels == "Dose Response analysis") { + return( + div( + class = "var-box-output", + h3(strong("The results are displayed in the other tabs")) + ) + ) + } + res <- listResults$all_data |> rev() + if (length(res) == 0) { + return() + } + res_ui_list <- lapply(names(res), function(name) { + temp <- res[[name]] + if (is.vector(temp)) { + div( + class = "var-box-output", + div( + class = "var-box-name", + name + ), + verbatimTextOutput(paste0("res_", name)), + actionButton(paste0("remove_res_", name), "Remove", class = "btn-danger") + ) + } else if (is.data.frame(temp)) { + div( + class = "var-box-output", + div( + class = "var-box-name", + name + ), + DTOutput(paste0("res_", name)), + actionButton(paste0("remove_res_", name), "Remove", class = "btn-danger") + ) + } else if (inherits(temp, "plot")) { + div( + class = "var-box-output", + div( + class = "var-box-name", + name + ), + plotOutput(paste0("res_", name), width = "100%", height = "800px"), + actionButton(paste0("remove_res_", name), "Remove", class = "btn-danger") + ) + } else { + div( + class = "var-box-output", + div( + class = "var-box-name", + name + ), + verbatimTextOutput(paste0("res_", name)), + actionButton(paste0("remove_res_", name), "Remove", class = "btn-danger") + ) + } + }) + download_stuff <- div( + class = "var-box-output", + h3(strong("Results")), + p("The following list contains the results"), + actionButton("download", "Save and exit"), + textInput("user_filename", "Set filename", value = "") + ) + do.call(tagList, list(download_stuff, res_ui_list)) + }) + + # Show results + observe({ + if (length(listResults$all_data) == 0) { + return() + } + res <- listResults$all_data + res_ui_list <- lapply(names(res), function(name) { + observeEvent(res[[name]], { + temp <- res[[name]] + if (is.vector(temp)) { + output[[paste0("res_", name)]] <- renderPrint(temp) + } else if (is.data.frame(temp)) { + output[[paste0("res_", name)]] <- renderDT(temp) + } else if (inherits(temp, "plot")) { + output[[paste0("res_", name)]] <- renderPlot(temp@p) + } else if (inherits(temp, "doseResponse")) { + message <- "Dose Response Analysis. Too large to display." + output[[paste0("res_", name)]] <- renderPrint(message) + } else { + output[[paste0("res_", name)]] <- renderPrint(temp) + } + }) + }) + do.call(tagList, res_ui_list) + }) + + # Observe remove buttons + observe({ + if (length(listResults$all_data) == 0) { + return() + } + current_list <- listResults$all_data + lapply(names(current_list), function(name) { + observeEvent(input[[paste0("remove_res_", name)]], + { + current_list <- listResults$all_data + current_list[[name]] <- NULL + listResults$all_data <- current_list + }, + ignoreInit = TRUE + ) + }) + }) + + observeEvent(input$download, { + print_noti(is_valid_filename(input$user_filename), "Defined filename is not valid") + print_noti(length(listResults$all_data) > 0, "No results to save") + l <- listResults$all_data + if (Sys.getenv("RUN_MODE") == "SERVER") { + print_noti(check_filename_for_server(input$user_filename), "Defined filename does not have xlsx as extension") + excelFile <- createExcelFile(l) + upload(session, excelFile, new_name = input$user_filename) + } else { + print_noti(check_filename_for_serverless(input$user_filename), "Defined filename does not have zip as extension") + jsString <- createJSString(l) + session$sendCustomMessage( + type = "downloadZip", + list( + numberOfResults = length(jsString), + FileContent = jsString, + Filename = input$user_filename + ) + ) + } + }) } return(list(ui = ui, server = server)) diff --git a/app/app.R b/app/app.R index 396648c..b508f34 100644 --- a/app/app.R +++ b/app/app.R @@ -17,8 +17,10 @@ library(shinyjs) library(equatiomatic) library(car) - files <- list.files(".") + files <- list.files(".", full.names = TRUE) + files <- files[!(basename(files) %in% c("app.R", "www"))] lapply(files, source) Sys.setenv(RUN_MODE = "BROWSER") app <- app() - shiny::runApp(app$ui, app$server) + shiny::shinyApp(app$ui, app$server) + diff --git a/app/statisticalTests.R b/app/statisticalTests.R index cc6b821..2a5f2ff 100644 --- a/app/statisticalTests.R +++ b/app/statisticalTests.R @@ -64,7 +64,7 @@ testsSidebarUI <- function(id) { "Unbalanced" = "ub" ) ), - uiOutput(NS(id, "padj")) + uiOutput(NS(id, "padjUI")) ) ) } @@ -91,9 +91,8 @@ testsUI <- function(id) { testsServer <- function(id, data, listResults) { moduleServer(id, function(input, output, session) { - # Render p adjustment methods - output[["padj"]] <- renderUI({ + output[["padjUI"]] <- renderUI({ if (input$PostHocTests == "kruskalTest" || input$PostHocTests == "LSD") { return( selectInput(NS(id, "padj"), "Adjusted p method", @@ -246,55 +245,58 @@ testsServer <- function(id, data, listResults) { output$test_error <- renderText(err) } if (is.null(err)) { - e <- try({ - switch(method, - aov = { - fit <- broom::tidy(aov(formula, data = df)) - }, - kruskal = { - fit <- broom::tidy(kruskal.test(formula, data = df)) # Keep here the restriction for respone ~ predictor - }, - HSD = { - check_formula(formula) - aov_res <- aov(formula, data = df) - bal <- input$design - req(bal) - if (bal == "Balanced") { - bal <- TRUE - } else { - bal <- FALSE + e <- try( + { + switch(method, + aov = { + fit <- broom::tidy(aov(formula, data = df)) + }, + kruskal = { + fit <- broom::tidy(kruskal.test(formula, data = df)) # Keep here the restriction for respone ~ predictor + }, + HSD = { + check_formula(formula) + aov_res <- aov(formula, data = df) + bal <- input$design + req(bal) + if (bal == "Balanced") { + bal <- TRUE + } else { + bal <- FALSE + } + fit <- agricolae::HSD.test(aov_res, + trt = indep, + alpha = input$pval, group = TRUE, unbalanced = bal + )$groups + }, + kruskalTest = { + check_formula(formula) + fit <- with(df, kruskal(df[, dep], df[, indep]), + alpha = input$pval, p.adj = input$padj, group = TRUE + )$groups + }, + LSD = { + check_formula(formula) + aov_res <- aov(formula, data = df) + fit <- agricolae::LSD.test(aov_res, + trt = indep, + alpha = input$pval, p.adj = input$padj, group = TRUE + )$groups + }, + scheffe = { + check_formula(formula) + aov_res <- aov(formula, data = df) + fit <- agricolae::scheffe.test(aov_res, trt = indep, alpha = input$pval, group = TRUE)$groups + }, + REGW = { + check_formula(formula) + aov_res <- aov(formula, data = df) + fit <- agricolae::REGW.test(aov_res, trt = indep, alpha = input$pval, group = TRUE)$groups } - fit <- agricolae::HSD.test(aov_res, - trt = indep, - alpha = input$pval, group = TRUE, unbalanced = bal - )$groups - }, - kruskalTest = { - check_formula(formula) - fit <- with(df, kruskal(df[, dep], df[, indep]), - alpha = input$pval, p.adj = input$padj, group = TRUE - )$groups - }, - LSD = { - check_formula(formula) - aov_res <- aov(formula, data = df) - fit <- agricolae::LSD.test(aov_res, - trt = indep, - alpha = input$pval, p.adj = input$padj, group = TRUE - )$groups - }, - scheffe = { - check_formula(formula) - aov_res <- aov(formula, data = df) - fit <- agricolae::scheffe.test(aov_res, trt = indep, alpha = input$pval, group = TRUE)$groups - }, - REGW = { - check_formula(formula) - aov_res <- aov(formula, data = df) - fit <- agricolae::REGW.test(aov_res, trt = indep, alpha = input$pval, group = TRUE)$groups - } - ) - }, silent = TRUE) + ) + }, + silent = TRUE + ) if (inherits(e, "try-error")) { err <- conditionMessage(attr(e, "condition")) err <- paste0(err, "\n", "Test did not run successfully") @@ -328,7 +330,6 @@ testsServer <- function(id, data, listResults) { observeEvent(input$PostHocTest, { conductTests(input$PostHocTests) }) - }) return(listResults) diff --git a/app/utils.R b/app/utils.R index 420277c..fb089f0 100644 --- a/app/utils.R +++ b/app/utils.R @@ -496,6 +496,9 @@ check_filename_for_serverless <- function(filename) { # Split list of plots into panels of 9 plots create_plot_pages <- function(plotList) { n_full_pages <- floor(length(plotList) / 9) + if (n_full_pages == 0) { + return(list(cowplot::plot_grid(plotlist = plotList))) + } n_plots_last_page <- length(plotList) %% 9 res <- list() i <- 1 @@ -507,7 +510,7 @@ create_plot_pages <- function(plotList) { } } res[[i + 1]] <- plotList[(n_full_pages * 9 + 1): - (n_full_pages * 9 + n_plots_last_page)] + (n_full_pages * 9 + n_plots_last_page)] lapply(res, function(x) { cowplot::plot_grid(plotlist = x) }) diff --git a/deploy_serverless_app.R b/deploy_serverless_app.R index b14a306..2495f77 100644 --- a/deploy_serverless_app.R +++ b/deploy_serverless_app.R @@ -1,5 +1,8 @@ -# files <- list.files("/home/konrad/Documents/Biostats/bs/R/", pattern = ".R", full.names = TRUE) -# file.copy(files, "/home/konrad/Documents/Biostats/app/", overwrite = TRUE) +files <- list.files("/home/konrad/Documents/Biostats/bs/R/", pattern = ".R", full.names = TRUE) +file.copy(files, "/home/konrad/Documents/Biostats/app/", overwrite = TRUE) +# Replace the upload field +# Copy folder www +# replace system.files with www folder paths file.create("/home/konrad/Documents/Biostats/app/app.R", overwrite = TRUE) con <- file("/home/konrad/Documents/Biostats/app/app.R") @@ -23,11 +26,12 @@ code <- function() { library(shinyjs) library(equatiomatic) library(car) - files <- list.files(".") + files <- list.files(".", full.names = TRUE) + files <- files[!(basename(files) %in% c("app.R", "www"))] lapply(files, source) Sys.setenv(RUN_MODE = "BROWSER") app <- app() - shiny::runApp(app$ui, app$server) + shiny::shinyApp(app$ui, app$server) } code <- body(code) |> deparse() code <- code[2:(length(code) - 1)]