diff --git a/Direct_Test_App.R b/Direct_Test_App.R new file mode 100644 index 0000000..6abc64e --- /dev/null +++ b/Direct_Test_App.R @@ -0,0 +1,32 @@ +library(shiny) +library(DT) +library(bslib) +library(broom) +library(ggplot2) +library(base64enc) +library(shinyjs) +library(mgcv) +library(RColorBrewer) +library(tidyr) +library(purrr) +library(agricolae) +library(drc) +library(cowplot) +library(MASS) +library(Matrix) +library(shinyjs) +library(equatiomatic) +library(openxlsx) +library(car) +library(cowplot) +library(COMELN) +library(httr) +library(jose) +library(openssl) +Sys.setenv(RUN_MODE = "BROWSER") +setwd("bs/R") +files <- list.files(".") +lapply(files, source) +app <- app() +shiny::shinyApp(app$ui, app$server) + diff --git a/Rplots.pdf b/Rplots.pdf new file mode 100644 index 0000000..ea3bb1c Binary files /dev/null and b/Rplots.pdf differ diff --git a/bs/.development/remove_buttons.R b/bs/.development/remove_buttons.R new file mode 100644 index 0000000..c62235b --- /dev/null +++ b/bs/.development/remove_buttons.R @@ -0,0 +1,55 @@ +library(shiny) + +ui <- fluidPage( + titlePanel("Dynamic List with Remove Buttons"), + sidebarLayout( + sidebarPanel( + numericInput("num_input", "Enter a number:", value = 0), + actionButton("add_btn", "Add to List") + ), + mainPanel( + uiOutput("dynamic_list") + ) + ) +) + +server <- function(input, output, session) { + listValues <- reactiveVal(list()) + observeEvent(input$add_btn, { + current_list <- listValues() + new_item_name <- paste0("item_", length(current_list) + 1) + current_list[[new_item_name]] <- input$num_input + listValues(current_list) + }) + + # Dynamically render the list UI + output$dynamic_list <- renderUI({ + current_list <- listValues() + if (length(current_list) == 0) { + return("No items in the list.") + } + # Create UI elements for each item in the list + tagList(lapply(names(current_list), function(name) { + div( + style = "margin-bottom: 10px;", + span(paste(name, ":", current_list[[name]]), style = "margin-right: 10px;"), + actionButton(name, "Remove", class = "btn-danger btn-sm") + ) + })) + }) + + # Observe and handle remove buttons dynamically + observe({ + current_list <- listValues() + lapply(names(current_list), function(name) { + observeEvent(input[[name]], { + current_list <- listValues() + current_list[[name]] <- NULL # Remove the item + listValues(current_list) + }, ignoreInit = TRUE) + }) + }) +} + +shinyApp(ui, server) + diff --git a/bs/DESCRIPTION b/bs/DESCRIPTION index 6c2b5a6..ba9a74e 100644 --- a/bs/DESCRIPTION +++ b/bs/DESCRIPTION @@ -29,7 +29,6 @@ Imports: equatiomatic, openxlsx, car, - cowplot, COMELN, httr, jose, diff --git a/bs/R/DoseResponse.R b/bs/R/DoseResponse.R index 415a871..e1ec8d5 100644 --- a/bs/R/DoseResponse.R +++ b/bs/R/DoseResponse.R @@ -28,17 +28,6 @@ DoseResponseSidebarUI <- function(id) { DoseResponseUI <- function(id) { fluidRow( - 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"), - tags$script(src = "download.js") - ), - h4(strong("Results of test:")), - actionButton(NS(id, "dr_save"), "Add output to result-file"), - actionButton(NS(id, "download_dr"), "Save results"), - textInput(NS(id, "user_filename"), "Set filename", value = ""), - checkboxGroupInput(NS(id, "TableSaved"), "Saved results to file", NULL), tabsetPanel( id = NS(id, "results_tabs"), tabPanel( @@ -58,8 +47,7 @@ DoseResponseUI <- function(id) { actionButton(NS(id, "previousPage"), "Previous plot"), actionButton(NS(id, "nextPage"), "Next plot") ) - ), - verbatimTextOutput(NS(id, "dr_error")) + ) ) } @@ -218,7 +206,6 @@ DoseResponseServer <- function(id, data, listResults) { }) drFct <- function() { - output$dr_error <- renderText(NULL) req(is.data.frame(data$df)) df <- data$df req(input$substanceNames) @@ -270,11 +257,15 @@ DoseResponseServer <- function(id, data, listResults) { }) if (inherits(e, "try-error")) { err <- conditionMessage(attr(e, "condition")) - output$dr_error <- renderText(err) + print_noti(FALSE, err) } else { listResults$curr_data <- new("doseResponse", df = resDF, p = resPlot) listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted dose response analysis") output$dr_result <- renderTable(resDF, digits = 6) + + listResults$counter <- listResults$counter + 1 + new_result_name <- paste0("DoseResponseNr", listResults$counter) + listResults$all_data[[new_result_name]] <- new("doseResponse", df = resDF, p = resPlot) } } @@ -357,45 +348,6 @@ DoseResponseServer <- function(id, data, listResults) { } }) - # Download results - observeEvent(input$dr_save, { - if (is.null(listResults$curr_name)) { - return(NULL) - } - if (!(listResults$curr_name %in% unlist(listResults$all_names))) { - listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data - listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name - } - updateCheckboxGroupInput(session, "TableSaved", - choices = listResults$all_names - ) - }) - - observeEvent(input$download_dr, { - print_noti(is_valid_filename(input$user_filename), "Defined filename is not valid") - lr <- unlist(listResults$all_names) - indices <- sapply(input$TableSaved, function(x) { - which(x == lr) - }) - req(length(indices) >= 1) - l <- listResults$all_data[indices] - 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(listResults) diff --git a/bs/R/MainApp.R b/bs/R/MainApp.R index 90f5af4..8cb3d1d 100644 --- a/bs/R/MainApp.R +++ b/bs/R/MainApp.R @@ -3,6 +3,11 @@ app <- function() { ui <- fluidPage( 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( @@ -124,7 +129,8 @@ app <- function() { DoseResponseUI("DOSERESPONSE") ), id = "conditionedPanels" - ) + ), + uiOutput("Results") ) ) ) @@ -135,6 +141,12 @@ app <- function() { 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( @@ -303,10 +315,6 @@ app <- function() { ) }) - listResults <- reactiveValues( - curr_data = NULL, curr_name = NULL, - all_data = list(), all_names = list() - ) OperationEditorServer("OP", dataSet, listResults) corrServer("CORR", dataSet, listResults) visServer("VIS", dataSet, listResults) @@ -315,6 +323,123 @@ app <- function() { 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() + 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( + br(), + h4("Results"), + actionButton("download", "Save and exit"), + textInput("user_filename", "Set filename", value = "") + ) + + do.call(tagList, list(download_stuff, res_ui_list)) + }) + + # Show results + observe({ + 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({ + 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/bs/R/OperationsModule.R b/bs/R/OperationsModule.R index 4ea6be8..71fd431 100644 --- a/bs/R/OperationsModule.R +++ b/bs/R/OperationsModule.R @@ -1,6 +1,3 @@ - -# TODO: store original dataset. Add option to reset dataset - OperatorEditorSidebar <- function(id) { ui <- fluidPage( tags$head( @@ -92,6 +89,8 @@ OperatorEditorSidebar <- function(id) { actionButton(NS(id, "min"), "Min", class = "add-button", title = "Find the smallest number (e.g., Min(c(1, 2, 3)) gives 1)"), actionButton(NS(id, "max"), "Max", class = "add-button", title = "Find the largest number (e.g., Max(c(1, 2, 3)) gives 3)"), actionButton(NS(id, "c"), "concatenate", class = "add-button", title = "Combine values into a list (e.g., c(1, 2, 3) gives [1, 2, 3])"), + actionButton(NS(id, "seq"), "sequence", class = "add-button", title = "Create a sequence of elements (e.g. seq(1, 10, 0.1) which creates a sequence starting from 1 to 10 in steps of 0.1)."), + actionButton(NS(id, "df"), "DataFrame", class = "add-button", title = "Create a table (e.g. DataFrame(Variable1, Variable2))"), actionButton(NS(id, "get_elem"), "get one element", class = "add-button", title = "Extract one element from a variable. This can either be ColName or a tabular dataset. In case it is a ColName the syntax is get_elem(ColName, idx) where idx is an integer number e.g. 1. In case one specific element of a dataset should be retrieved the syntax is get_elem(df, idx_row, idx_col). Again idx_row and idx_col have to be integers. The first one specifies the row number and the second one the column number."), actionButton(NS(id, "get_rows"), "get_rows", class = "add-button", @@ -103,8 +102,8 @@ OperatorEditorSidebar <- function(id) { ), div( h3("String Functions"), - actionButton(NS(id, "paste"), "paste", class = "add-button", title = "Join pieces of text (e.g., paste('Hello', 'World') gives 'Hello World')"), - actionButton(NS(id, "paste0"), "paste0", class = "add-button", title = "Join pieces of text without spaces (e.g., paste0('Hello', 'World') gives 'HelloWorld')"), + actionButton(NS(id, "paste"), "paste", class = "add-button", title = "Join pieces of text (e.g., paste('Hello', 'World') gives 'Hello World')."), + actionButton(NS(id, "paste0"), "paste0", class = "add-button", title = "Join pieces of text without spaces (e.g., paste0('Hello', 'World') gives 'HelloWorld'). This is very practical if you want to join two columns e.g. paste0(ColName1, ColName2)"), actionButton(NS(id, "tolower"), "tolower", class = "add-button", title = "Convert text to lowercase (e.g., tolower('Hello') gives 'hello')"), actionButton(NS(id, "toupper"), "toupper", class = "add-button", title = "Convert text to uppercase (e.g., toupper('hello') gives 'HELLO')"), class = "boxed-output" @@ -243,10 +242,6 @@ OperatorEditorUI <- function(id) { ) ), uiOutput(NS(id, "head")), - actionButton(NS(id, "save"), "Add output to result-file"), - actionButton(NS(id, "download"), "Save results"), - textInput(NS(id, "user_filename"), "Set filename", value = ""), - checkboxGroupInput(NS(id, "TableSaved"), "Saved results to file", NULL), uiOutput(NS(id, "intermediate_results")) ) } @@ -462,6 +457,9 @@ OperationEditorServer <- function(id, data, listResults) { exportTestValues( iv_list = r_vals$intermediate_vars ) + listResults$counter <- listResults$counter + 1 + new_name <- paste0(var_name, listResults$counter) + listResults$all_data[[new_name]] <- new } }) @@ -516,12 +514,9 @@ OperationEditorServer <- function(id, data, listResults) { output$head <- renderTable(head(r_vals$df, 10)) r_vals$counter_id <- r_vals$counter_id + 1 - listResults$curr_data <- data$df - listResults$curr_name <- paste( - "Dataset Changes Nr", - length(listResults$all_names) + 1, - "Conducted test: ", input$editable_code - ) + listResults$counter <- listResults$counter + 1 + new_name <- paste0("Dataset", listResults$counter) + listResults$all_data[[new_name]] <- data$df }) observeEvent(input$add, { @@ -759,6 +754,16 @@ OperationEditorServer <- function(id, data, listResults) { updated_text <- paste(current_text, "c(", sep = " ") updateTextAreaInput(session, "editable_code", value = updated_text) }) + observeEvent(input$seq, { + current_text <- input$editable_code + updated_text <- paste(current_text, "seq(", sep = " ") + updateTextAreaInput(session, "editable_code", value = updated_text) + }) + observeEvent(input$df, { + current_text <- input$editable_code + updated_text <- paste(current_text, "DataFrame(", sep = " ") + updateTextAreaInput(session, "editable_code", value = updated_text) + }) observeEvent(input$as_char, { current_text <- input$editable_code updated_text <- paste(current_text, "as.char(", sep = " ") @@ -855,44 +860,5 @@ OperationEditorServer <- function(id, data, listResults) { updateTextAreaInput(session, "editable_code", value = updated_text) }) - observeEvent(input$save, { - if (is.null(listResults$curr_name)) { - return(NULL) - } - if (!(listResults$curr_name %in% unlist(listResults$all_names))) { - listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data - listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name - } - updateCheckboxGroupInput(session, "TableSaved", - choices = listResults$all_names - ) - }) - - observeEvent(input$download, { - print_noti(is_valid_filename(input$user_filename), "Defined filename is not valid") - lr <- unlist(listResults$all_names) - indices <- sapply(input$TableSaved, function(x) { - which(x == lr) - }) - req(length(indices) >= 1) - l <- listResults$all_data[indices] - 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 - ) - ) - } - }) - }) } diff --git a/bs/R/assumption.R b/bs/R/assumption.R index cc21e10..634d6f1 100644 --- a/bs/R/assumption.R +++ b/bs/R/assumption.R @@ -56,22 +56,7 @@ assSidebarUI <- function(id) { } assUI <- function(id) { - fluidRow( - 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"), - tags$script(src = "download.js") - ), - h4(strong("Results of test:")), - verbatimTextOutput(NS(id, "ass_error")), - actionButton(NS(id, "ass_save"), "Add output to result-file"), - actionButton(NS(id, "download_ass"), "Save and exit"), - textInput(NS(id, "user_filename"), "Set filename", value = ""), - checkboxGroupInput(NS(id, "TableSaved"), "Saved results to file", NULL), - tableOutput(NS(id, "ass_result")), - plotOutput(NS(id, "DiagnosticPlotRes"), width = "100%", height = "1000px") - ) + fluidRow() } assServer <- function(id, data, listResults) { @@ -127,7 +112,7 @@ assServer <- function(id, data, listResults) { data$filter_group <- NULL }) - output$open_formula_editor_corr <- renderUI({ # TODO: change to unique identifier probably via [["open_formula_editor"]] + output$open_formula_editor_corr <- renderUI({ actionButton(NS(id, "open_formula_editor"), "Open formula editor", title = "Open the formula editor to create or modify a formula", @@ -154,7 +139,6 @@ assServer <- function(id, data, listResults) { }) runShapiro <- function() { - output$ass_error <- renderText(NULL) df <- data$df req(is.data.frame(df)) req(!is.null(data$formula)) @@ -177,18 +161,20 @@ assServer <- function(id, data, listResults) { } } res <- do.call(rbind, res) - }) + }, silent = TRUE) if (!inherits(e, "try-error")) { exportTestValues( assumption_res = res ) - listResults$curr_data <- res - listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted shapiro test") - output$curr_result <- renderTable(res, digits = 6) + listResults$counter <- listResults$counter + 1 + new_name <- paste0( + "ShapiroDataNr", listResults$counter + ) + listResults$all_data[[new_name]] <- res output$curr_error <- renderText(err) } else { err <- conditionMessage(attr(e, "condition")) - output$ass_error <- renderText(err) + print_noti(FALSE, err) } } } @@ -197,7 +183,6 @@ assServer <- function(id, data, listResults) { }) runShapiroResiduals <- function() { - output$ass_error <- renderText(NULL) df <- data$df req(is.data.frame(df)) req(!is.null(data$formula)) @@ -209,18 +194,20 @@ assServer <- function(id, data, listResults) { r <- resid(fit) res <- broom::tidy(shapiro.test(r)) res$`Residuals normal distributed` <- res$p.value > 0.05 - }) + }, silent = TRUE) if (!inherits(e, "try-error")) { exportTestValues( assumption_res = res ) - listResults$curr_data <- res - listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted shapiro test") - output$curr_result <- renderTable(res, digits = 6) + listResults$counter <- listResults$counter + 1 + new_name <- paste0( + "ShaprioResidualsNr", listResults$counter + ) + listResults$all_data[[new_name]] <- res output$curr_error <- renderText(err) } else { err <- conditionMessage(attr(e, "condition")) - output$ass_error <- renderText(err) + print_noti(FALSE, err) } } observeEvent(input$shapiroResiduals, { @@ -228,7 +215,6 @@ assServer <- function(id, data, listResults) { }) runLevene <- function() { - output$ass_error <- renderText(NULL) df <- data$df req(is.data.frame(df)) req(!is.null(data$formula)) @@ -238,17 +224,19 @@ assServer <- function(id, data, listResults) { e <- try({ fit <- broom::tidy(car::leveneTest(formula, data = df, center = input$center)) fit$`Variance homogenity` <- fit$p.value > 0.05 - }) + }, silent = TRUE) if (inherits(e, "try-error")) { err <- conditionMessage(attr(e, "condition")) - output$ass_error <- renderText(err) + print_noti(FALSE, err) } else { exportTestValues( assumption_res = fit ) - listResults$curr_data <- fit - listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "variance homogenity (levene)") - output$curr_result <- renderTable(fit, digits = 6) + listResults$counter <- listResults$counter + 1 + new_name <- paste0( + "LeveneTestNr", listResults$counter + ) + listResults$all_data[[new_name]] <- fit output$curr_error <- renderText(err) } } @@ -256,18 +244,7 @@ assServer <- function(id, data, listResults) { runLevene() }) - output$ass_result <- renderTable( - { - if (!inherits(listResults$curr_data, "plot")) { - return(listResults$curr_data) - } - return(NULL) - }, - digits = 6 - ) - runDiagnosticPlot <- function() { - output$ass_error <- renderText(NULL) df <- data$df req(is.data.frame(df)) req(!is.null(data$formula)) @@ -276,16 +253,18 @@ assServer <- function(id, data, listResults) { p <- NULL e <- try({ p <- diagnosticPlots(df, formula) - }) + }, silent = TRUE) if (inherits(e, "try-error")) { err <- conditionMessage(attr(e, "condition")) - output$ass_error <- renderText(err) + print_noti(FALSE, err) } else { exportTestValues( assumption_res = p ) - listResults$curr_data <- new("plot", p = p, width = 15, height = 15, resolution = 600) - listResults$curr_name <- paste("Plot Nr", length(listResults$all_names) + 1, "diagnostic plots") + listResults$counter <- listResults$counter + 1 + new_result_name <- paste0("DiagnosticPlotNr", listResults$counter) + listResults$all_data[[new_result_name]] <- + new("plot", p = p, width = 15, height = 15, resolution = 600) output$DiagnosticPlotRes <- renderPlot(p) output$curr_error <- renderText(err) } @@ -294,44 +273,6 @@ assServer <- function(id, data, listResults) { runDiagnosticPlot() }) - observeEvent(input$ass_save, { - if (is.null(listResults$curr_name)) { - return(NULL) - } - if (!(listResults$curr_name %in% unlist(listResults$all_names))) { - listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data - listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name - } - updateCheckboxGroupInput(session, "TableSaved", - choices = listResults$all_names - ) - }) - - observeEvent(input$download_ass, { - print_noti(is_valid_filename(input$user_filename), "Defined filename is not valid") - lr <- unlist(listResults$all_names) - indices <- sapply(input$TableSaved, function(x) { - which(x == lr) - }) - req(length(indices) >= 1) - l <- listResults$all_data[indices] - 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(listResults) diff --git a/bs/R/check_ast.R b/bs/R/check_ast.R index ebbda38..6f01938 100644 --- a/bs/R/check_ast.R +++ b/bs/R/check_ast.R @@ -12,7 +12,7 @@ allowed_fcts <- function() { "ppois", "rpois", "dunif", "punif", "qunif", "runif", "Mean", "SD", "Median", "quantile", "range", "Sum", "diff", "Min", "Max", "scale", - "c", "vector", "length", "matrix", "~", + "c", "seq", "DataFrame", "vector", "length", "matrix", "~", "get_rows", "get_cols", "get_elem", "as.char", "as.int", "as.real", "as.fact" ) diff --git a/bs/R/correlation.R b/bs/R/correlation.R index cb17eb3..2ee0c9b 100644 --- a/bs/R/correlation.R +++ b/bs/R/correlation.R @@ -38,21 +38,7 @@ corrSidebarUI <- function(id) { } corrUI <- function(id) { - fluidRow( - 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"), - tags$script(src = "download.js") - ), - h4(strong("Results of test:")), - tableOutput(NS(id, "corr_result")), - verbatimTextOutput(NS(id, "corr_error")), - actionButton(NS(id, "corr_save"), "Add output to result-file"), - actionButton(NS(id, "download_corr"), "Save results"), - textInput(NS(id, "user_filename"), "Set filename", value = ""), - checkboxGroupInput(NS(id, "TableSaved"), "Saved results to file", NULL) - ) + fluidRow() } corrServer <- function(id, data, listResults) { @@ -138,14 +124,13 @@ corrServer <- function(id, data, listResults) { }) corr_fct <- function(method) { - output$corr_error <- renderText(NULL) req(is.data.frame(data$df)) req(!is.null(data$formula)) f <- as.character(data$formula) dep <- f[2] indep <- f[3] d <- data$df - e <- tryCatch({ + tryCatch({ check_ast(str2lang(indep), colnames(df)) # NOTE: check_ast throws error check_ast(str2lang(dep), colnames(df)) fit <- withCallingHandlers( @@ -164,14 +149,16 @@ corrServer <- function(id, data, listResults) { exportTestValues( correlation_res = fit ) - listResults$curr_data <- fit - listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted test: ", method) - output$corr_result <- renderTable(fit, digits = 6) + listResults$counter <- listResults$counter + 1 + new_name <- paste0( + "Correlation", method, "NR", listResults$counter + ) + listResults$all_data[[new_name]] <- fit }, error = function(err) { err <- err$message showNotification(err) - output$corr_error <- renderText(err) + print_noti(FALSE, err) } ) } @@ -179,71 +166,15 @@ corrServer <- function(id, data, listResults) { observeEvent(input$pear, { corr_fct("pearson") }) - output$cor_result <- renderTable( - { - listResults$curr_data - }, - digits = 6 - ) observeEvent(input$spear, { corr_fct("spearman") }) - output$cor_result <- renderTable( - { - listResults$curr_data - }, - digits = 6 - ) observeEvent(input$kendall, { corr_fct("kendall") }) - output$cor_result <- renderTable( - { # issue: check whether this is required - listResults$curr_data - }, - digits = 6 - ) - - observeEvent(input$corr_save, { - if (is.null(listResults$curr_name)) { - return(NULL) - } - if (!(listResults$curr_name %in% unlist(listResults$all_names))) { - listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data - listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name - } - updateCheckboxGroupInput(session, "TableSaved", - choices = listResults$all_names - ) - }) - observeEvent(input$download_corr, { - print_noti(is_valid_filename(input$user_filename), "Defined filename is not valid") - lr <- unlist(listResults$all_names) - indices <- sapply(input$TableSaved, function(x) { - which(x == lr) - }) - req(length(indices) >= 1) - l <- listResults$all_data[indices] - 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(listResults) diff --git a/bs/R/statisticalTests.R b/bs/R/statisticalTests.R index 3553bc6..cc6b821 100644 --- a/bs/R/statisticalTests.R +++ b/bs/R/statisticalTests.R @@ -71,12 +71,6 @@ testsSidebarUI <- function(id) { testsUI <- function(id) { fluidRow( - 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"), - tags$script(src = "download.js") - ), tabsetPanel( tabPanel( "Two groups", @@ -91,14 +85,7 @@ testsUI <- function(id) { br(), ), id = "TestsConditionedPanels" - ), - h4(strong("Results of test:")), - tableOutput(NS(id, "test_result")), - verbatimTextOutput(NS(id, "test_error")), - actionButton(NS(id, "test_save"), "Add output to result-file"), - actionButton(NS(id, "download_test"), "Save results"), - textInput(NS(id, "user_filename"), "Set filename", value = ""), - checkboxGroupInput(NS(id, "TableSaved"), "Saved results to file", NULL) + ) ) } @@ -205,7 +192,6 @@ testsServer <- function(id, data, listResults) { }) tTest <- function() { - output$test_error <- renderText(NULL) req(is.data.frame(data$df)) df <- data$df req(!is.null(data$formula)) @@ -224,14 +210,16 @@ testsServer <- function(id, data, listResults) { }) if (inherits(e, "try-error")) { err <- conditionMessage(attr(e, "condition")) - output$test_error <- renderText(err) + print_noti(FALSE, err) } else { - listResults$curr_data <- fit + listResults$counter <- listResults$counter + 1 + new_name <- paste0( + "TTestNr", listResults$counter + ) + listResults$all_data[[new_name]] <- fit exportTestValues( tests_res = fit ) - listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted t-test") - output$test_result <- renderTable(fit, digits = 6) } } @@ -240,7 +228,6 @@ testsServer <- function(id, data, listResults) { }) conductTests <- function(method) { - output$test_error <- renderText(NULL) req(is.data.frame(data$df)) df <- data$df req(!is.null(data$formula)) @@ -311,19 +298,21 @@ testsServer <- function(id, data, listResults) { if (inherits(e, "try-error")) { err <- conditionMessage(attr(e, "condition")) err <- paste0(err, "\n", "Test did not run successfully") - output$test_error <- renderText(err) + print_noti(FALSE, err) } else if (is.null(fit)) { err <- paste0(err, "\n", "Test did not run successfully") - output$test_error <- renderText("Result is NULL") + print_noti(FALSE, err) } else { fit <- cbind(fit, row.names(fit)) names(fit)[ncol(fit)] <- paste0(indep, collapse = ".") exportTestValues( tests_res = fit ) - listResults$curr_data <- fit - listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted: ", method) - output$test_result <- renderTable(fit, digits = 6) + listResults$counter <- listResults$counter + 1 + new_name <- paste0( + "Test_", method, "Nr", listResults$counter + ) + listResults$all_data[[new_name]] <- fit } } } @@ -336,52 +325,10 @@ testsServer <- function(id, data, listResults) { conductTests("kruskal") }) - observeEvent(input$kruskalTest, { - conductTests("kruskal") - }) - observeEvent(input$PostHocTest, { conductTests(input$PostHocTests) }) - observeEvent(input$test_save, { - if (is.null(listResults$curr_name)) { - return(NULL) - } - if (!(listResults$curr_name %in% unlist(listResults$all_names))) { - listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data - listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name - } - updateCheckboxGroupInput(session, "TableSaved", - choices = listResults$all_names - ) - }) - - observeEvent(input$download_test, { - print_noti(is_valid_filename(input$user_filename), "Defined filename is not valid") - lr <- unlist(listResults$all_names) - indices <- sapply(input$TableSaved, function(x) { - which(x == lr) - }) - req(length(indices) >= 1) - l <- listResults$all_data[indices] - 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(listResults) diff --git a/bs/R/utils.R b/bs/R/utils.R index 5e261d1..420277c 100644 --- a/bs/R/utils.R +++ b/bs/R/utils.R @@ -190,8 +190,12 @@ createJSString <- function(l) { } else if (inherits(l[[i]], "doseResponse")) { p <- l[[i]]@p fn <- tempfile(fileext = ".png") - ggsave(plot = p, filename = fn) - jsString <- c(jsString, paste0("data:image/png;base64,", base64enc::base64encode(fn))) + for (idx in seq_len(length(p))) { + fn <- tempfile(fileext = ".png") + ggsave(plot = p[[idx]], filename = fn) + jsString <- c(jsString, paste0("data:image/png;base64,", base64enc::base64encode(fn))) + unlink(fn) + } unlink(fn) jsString <- c(jsString, DF2String(l[[i]]@df)) } else if (inherits(l[[i]], "data.frame")) { @@ -508,3 +512,35 @@ create_plot_pages <- function(plotList) { cowplot::plot_grid(plotlist = x) }) } + +# internal dataframe function +elongate_col <- function(col, l) { + times <- l / length(col) + if (floor(times) == times) { + return(rep(col, times)) + } else { + res <- rep(col, floor(times)) + remaining_elems <- l %% length(col) + res <- c(res, col[1:remaining_elems]) + return(res) + } +} + +DataFrame <- function(...) { + columns <- list(...) + s <- substitute(list(...)) + args <- as.list(s[-1]) + args <- lapply(args, function(x) { + make.names(deparse(x)) + }) + sapply(columns, function(x) { + if (length(x) == 0) stop("Found empty column") + }) + rows <- max(sapply(columns, length)) + columns <- lapply(columns, function(col) { + elongate_col(col, rows) + }) + df <- do.call(cbind, columns) |> as.data.frame() + names(df) <- args + return(df) +} diff --git a/bs/R/visualisation.R b/bs/R/visualisation.R index 3a89cef..a4bdff4 100644 --- a/bs/R/visualisation.R +++ b/bs/R/visualisation.R @@ -75,12 +75,6 @@ visSidebarUI <- function(id) { visUI <- function(id) { fluidRow( - 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"), - tags$script(src = "download.js"), - ), br(), tabsetPanel( tabPanel( @@ -100,8 +94,6 @@ visUI <- function(id) { ), id = "VisConditionedPanels" ), - actionButton(NS(id, "plotSave"), "Add output to result-file"), - checkboxGroupInput(NS(id, "TableSaved"), "Saved results to file", NULL), fluidRow( column( 4, @@ -115,16 +107,6 @@ visUI <- function(id) { 4, numericInput(NS(id, "resPlot"), "Resolution of plot", value = 300) ), - ), - fluidRow( - column( - 12, - actionButton(NS(id, "downloadViss"), "Save results"), - textInput(NS(id, "user_filename"), "Set filename", value = "") - ) - ), - plotOutput( - NS(id, "plotResult") ) ) } @@ -484,75 +466,25 @@ visServer <- function(id, data, listResults) { exportTestValues( plot = p ) - output$plotResult <- renderPlot(p) - listResults$curr_data <- new("plot", p = p, width = width, height = height, resolution = resolution) - listResults$curr_name <- paste( - "Plot Nr", - length(listResults$all_names) + 1, paste("Type: ", method) - ) + listResults$counter <- listResults$counter + 1 + new_result_name <- paste0("PlotNr", listResults$counter) + listResults$all_data[[new_result_name]] <- new("plot", p = p, width = width, height = height, resolution = resolution) } observeEvent(input$CreatePlotBox, { req(is.data.frame(data$df)) plotFct("box") }) - output$plotResult <- renderPlot({ - renderPlot(listResults$curr_data) - }) observeEvent(input$CreatePlotScatter, { req(is.data.frame(data$df)) plotFct("dot") }) - output$plotResult <- renderPlot({ - renderPlot(listResults$curr_data) - }) observeEvent(input$CreatePlotLine, { req(is.data.frame(data$df)) plotFct("line") }) - output$plotResult <- renderPlot({ - renderPlot(listResults$curr_data) - }) - observeEvent(input$plotSave, { - if (is.null(listResults$curr_name)) { - return(NULL) - } - if (!(listResults$curr_name %in% unlist(listResults$all_names))) { - listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data - listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name - } - updateCheckboxGroupInput(session, "TableSaved", - choices = listResults$all_names - ) - }) - - observeEvent(input$downloadViss, { - print_noti(is_valid_filename(input$user_filename), "Defined filename is not valid") - lr <- unlist(listResults$all_names) - indices <- sapply(input$TableSaved, function(x) { - which(x == lr) - }) - req(length(indices) >= 1) - l <- listResults$all_data[indices] - 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 - ) - ) - } - }) }) } diff --git a/glm/DESCRIPTION b/glm/DESCRIPTION new file mode 100644 index 0000000..cd440cb --- /dev/null +++ b/glm/DESCRIPTION @@ -0,0 +1,14 @@ +Package: glm +Type: Package +Title: biostats +Version: 1.0 +Date: 2022-03-24 +Author: Konrad Krämer +Maintainer: +Description: Offers the backend for generalized linear models used in Biostats shiny app. +License: GPL-3 +Imports: + broom, + ggplot2 +Encoding: UTF-8 + diff --git a/glm/NAMESPACE b/glm/NAMESPACE new file mode 100644 index 0000000..e69de29 diff --git a/glm/R/CheckAssumptions.R b/glm/R/CheckAssumptions.R new file mode 100644 index 0000000..e69de29 diff --git a/glm/R/CreateModel.R b/glm/R/CreateModel.R new file mode 100644 index 0000000..5f26592 --- /dev/null +++ b/glm/R/CreateModel.R @@ -0,0 +1,4 @@ +glm_internal <- function(formula, family, data) { + +} + diff --git a/glm/R/Tests.R b/glm/R/Tests.R new file mode 100644 index 0000000..e69de29