diff --git a/bs/R/DoseResponse.R b/bs/R/DoseResponse.R index c59caec..6642ec2 100644 --- a/bs/R/DoseResponse.R +++ b/bs/R/DoseResponse.R @@ -127,7 +127,10 @@ DoseResponseServer <- function(id, data, listResults) { }) req(length(indices) >= 1) l <- listResults$all_data[indices] - if (Sys.getenv("RUN_MODE") == "BROWSER") { + if (Sys.getenv("RUN_MODE") == "SERVER") { + excelFile <- createExcelFile(l) + upload(session, excelFile, new_name = "Results.xlsx") # TODO: add possibility for desired file name + } else { jsString <- createJSString(l) session$sendCustomMessage( type = "downloadZip", @@ -136,9 +139,6 @@ DoseResponseServer <- function(id, data, listResults) { FileContent = jsString ) ) - } else if (Sys.getenv("RUN_MODE") == "SERVER") { - excelFile <- createExcelFile(l) - upload(session, excelFile, new_name = "Results.xlsx") # TODO: add possibility for desired file name } }) }) diff --git a/bs/R/assumption.R b/bs/R/assumption.R index befcf6d..ccf5f3b 100644 --- a/bs/R/assumption.R +++ b/bs/R/assumption.R @@ -234,7 +234,10 @@ assServer <- function(id, data, listResults) { req(length(indices) >= 1) l <- listResults$all_data[indices] - if (Sys.getenv("RUN_MODE") == "BROWSER") { + if (Sys.getenv("RUN_MODE") == "SERVER") { + excelFile <- createExcelFile(l) + upload(session, excelFile, new_name = "Results.xlsx") # TODO: add possibility for desired file name + } else { jsString <- createJSString(l) session$sendCustomMessage( type = "downloadZip", @@ -243,9 +246,6 @@ assServer <- function(id, data, listResults) { FileContent = jsString ) ) - } else if (Sys.getenv("RUN_MODE") == "SERVER") { - excelFile <- createExcelFile(l) - upload(session, excelFile, new_name = "Results.xlsx") # TODO: add possibility for desired file name } }) }) diff --git a/bs/R/correlation.R b/bs/R/correlation.R index 2c327bb..fff47c4 100644 --- a/bs/R/correlation.R +++ b/bs/R/correlation.R @@ -121,7 +121,10 @@ corrServer <- function(id, data, listResults) { }) req(length(indices) >= 1) l <- listResults$all_data[indices] - if (Sys.getenv("RUN_MODE") == "BROWSER") { + if (Sys.getenv("RUN_MODE") == "SERVER") { + excelFile <- createExcelFile(l) + upload(session, excelFile, new_name = "Results.xlsx") # TODO: add possibility for desired file name + } else { jsString <- createJSString(l) session$sendCustomMessage( type = "downloadZip", @@ -130,9 +133,6 @@ corrServer <- function(id, data, listResults) { FileContent = jsString ) ) - } else if (Sys.getenv("RUN_MODE") == "SERVER") { - excelFile <- createExcelFile(l) - upload(session, excelFile, new_name = "Results.xlsx") # TODO: add possibility for desired file name } }) }) diff --git a/bs/R/statisticalTests.R b/bs/R/statisticalTests.R index 9955707..a4e9c7b 100644 --- a/bs/R/statisticalTests.R +++ b/bs/R/statisticalTests.R @@ -266,7 +266,10 @@ testsServer <- function(id, data, listResults) { }) req(length(indices) >= 1) l <- listResults$all_data[indices] - if (Sys.getenv("RUN_MODE") == "BROWSER") { + if (Sys.getenv("RUN_MODE") == "SERVER") { + excelFile <- createExcelFile(l) + upload(session, excelFile, new_name = "Results.xlsx") # TODO: add possibility for desired file name + } else { jsString <- createJSString(l) session$sendCustomMessage( type = "downloadZip", @@ -275,9 +278,6 @@ testsServer <- function(id, data, listResults) { FileContent = jsString ) ) - } else if (Sys.getenv("RUN_MODE") == "SERVER") { - excelFile <- createExcelFile(l) - upload(session, excelFile, new_name = "Results.xlsx") # TODO: add possibility for desired file name } }) }) diff --git a/bs/R/visualisation.R b/bs/R/visualisation.R index f709e80..148f08d 100644 --- a/bs/R/visualisation.R +++ b/bs/R/visualisation.R @@ -276,7 +276,10 @@ visServer <- function(id, data, listResults) { }) req(length(indices) >= 1) l <- listResults$all_data[indices] - if (Sys.getenv("RUN_MODE") == "BROWSER") { + if (Sys.getenv("RUN_MODE") == "SERVER") { + excelFile <- createExcelFile(l) + upload(session, excelFile, new_name = "Results.xlsx") # TODO: add possibility for desired file name + } else { jsString <- createJSString(l) session$sendCustomMessage( type = "downloadZip", @@ -285,9 +288,6 @@ visServer <- function(id, data, listResults) { FileContent = jsString ) ) - } else if (Sys.getenv("RUN_MODE") == "SERVER") { - excelFile <- createExcelFile(l) - upload(session, excelFile, new_name = "Results.xlsx") # TODO: add possibility for desired file name } }) }) diff --git a/docs/app.json b/docs/app.json index bc87be4..c893363 100644 --- a/docs/app.json +++ b/docs/app.json @@ -1 +1 @@ -[{"name":"app.R","content":"#' @import shiny\n#' @import shinyjs\n#' @import DT\n#' @export\nrun_app <- function() {\n ui <- fluidPage(\n useShinyjs(),\n includeScript(\"www/download.js\"), # NOTE: would be better located in inst folder but the serverless version cannot handle this\n sidebarLayout(\n sidebarPanel(\n conditionalPanel(\n condition = \"input.conditionedPanels == 'Data'\",\n uiOutput(\"conditional_data_ui\"),\n fileInput(\"file\", \"Choose CSV File\",\n accept = c(\n \"text/csv\",\n \"text/comma-separated-values,text/plain\",\n \".csv\"\n )\n ),\n textInput(\"op\", \"Operations\", value = \"var / 1000\"),\n textInput(\"new_col\", \"Name of new variable\", value = \"var\"),\n actionButton(\"mod\", \"Modify\"),\n tags$hr(),\n textInput(\"keepVar\", \"const variable\"),\n actionButton(\"pivotLonger\", \"conversion to long format\"),\n tags$hr(),\n textInput(\"name\", \"name column\"),\n textInput(\"value\", \"value column\"),\n actionButton(\"pivotWider\", \"convert to wide format\"),\n verbatimTextOutput(\"mod_error\"),\n tags$hr()\n ),\n conditionalPanel(\n condition = \"input.conditionedPanels == 'Correlation'\",\n corrSidebarUI(\"CORR\")\n ),\n conditionalPanel(\n condition = \"input.conditionedPanels == 'Visualisation'\",\n visSidebarUI(\"VIS\")\n ),\n conditionalPanel(\n condition = \"input.conditionedPanels == 'Assumption'\",\n assSidebarUI(\"ASS\")\n ),\n conditionalPanel(\n condition = \"input.conditionedPanels == 'Tests'\",\n testsSidebarUI(\"TESTS\")\n ),\n conditionalPanel(\n condition = \"input.conditionedPanels == 'Dose Response analysis'\",\n DoseResponseSidebarUI(\"DOSERESPONSE\")\n )\n ),\n mainPanel(\n tabsetPanel(\n tabPanel(\n \"Data\",\n DTOutput(\"df\")\n ),\n tabPanel(\n \"Correlation\",\n corrUI(\"CORR\")\n ),\n tabPanel(\n \"Visualisation\",\n visUI(\"VIS\")\n ),\n tabPanel(\n \"Assumption\",\n assUI(\"ASS\")\n ),\n tabPanel(\n \"Tests\",\n testsUI(\"TESTS\")\n ),\n tabPanel(\n \"Dose Response analysis\",\n DoseResponseUI(\"DOSERESPONSE\")\n ),\n id = \"conditionedPanels\"\n )\n )\n )\n )\n\n server <- function(input, output, session) {\n dataSet <- reactiveValues(df = NULL)\n\n output$conditional_data_ui <- renderUI({\n if (Sys.getenv(\"RUN_MODE\") != \"SERVER\") {\n res <- conditionalPanel(\n condition = \"input.conditionedPanels == 'Data'\",\n fileInput(\"file\", \"Choose CSV File\",\n accept = c(\n \"text/csv\",\n \"text/comma-separated-values,text/plain\",\n \".csv\"\n )\n )\n )\n return(res)\n }\n })\n\n download_file <- reactive({\n file <- COMELN::download(session, \"/home/shiny/results\")\n upload <- function(path) {\n stopifnot(is.character(path))\n df <- NULL\n df <- try(as.data.frame(readxl::read_excel(\n path,\n col_names = TRUE\n )), silent = TRUE)\n if (class(df) == \"try-error\") {\n # identify seperator\n line <- readLines(path, n = 1)\n semicolon <- grepl(\";\", line)\n comma <- grepl(\",\", line)\n tab <- grepl(\"\\t\", line)\n seperator <- NULL\n if (semicolon == TRUE) {\n seperator <- \";\"\n } else if (comma == TRUE) {\n seperator <- \",\"\n } else if (tab == TRUE) {\n seperator <- \"\\t\"\n } else {\n return(\"error\")\n }\n df <- try(read.csv(path, header = TRUE, sep = seperator))\n if (class(df) == \"try-error\") {\n return(\"error\")\n }\n } else {\n f <- function(x) {\n options(warn = -1)\n x <- as.numeric(x)\n options(warn = 0)\n x <- x[!is.na(x)]\n length(x) > 0\n }\n check <- apply(df, 2, f)\n conv <- function(a, b) {\n if (a == TRUE) {\n return(as.numeric(b))\n }\n return(b)\n }\n df <- Map(conv, check, df)\n df <- data.frame(df)\n }\n return(df)\n }\n df <- NULL\n df <- upload(file)\n if (is.data.frame(df)) {\n var$df <- df\n } else {\n showNotification(\"File can not be used. Upload into R failed!\", duration = 0)\n }\n tryCatch(\n {\n system(paste(\"rm -r \", file))\n },\n warning = function(warn) {\n showNotification(paste(\"A warning occurred: \", conditionMessage(warn)), duration = 0)\n },\n error = function(err) {\n showNotification(paste(\"An error occurred: \", conditionMessage(err)), duration = 0)\n }\n )\n req(is.data.frame(df))\n return(df)\n })\n\n\n output$df <- renderDT({\n if (Sys.getenv(\"RUN_MODE\") == \"SERVER\") {\n isolate({\n dataSet$df <- download_file()\n })\n datatable(dataSet$df, options = list(pageLength = 10))\n } else {\n req(input$file)\n df <- try(read.csv(input$file$datapath))\n if (inherits(df, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n showNotification(err)\n return(NULL)\n }\n dataSet$df <- df\n req(!is.na(dataSet$df))\n datatable(dataSet$df, options = list(pageLength = 10))\n }\n })\n\n observeEvent(input$mod, {\n req(!is.null(dataSet$df))\n req(is.data.frame(dataSet$df))\n req(input$op)\n req(input$new_col)\n dt <- dataSet$df\n op <- input$op\n new_col <- input$new_col\n new <- NULL\n err <- NULL\n e <- try({\n ast <- get_ast(str2lang(op))\n ast <- ast[[length(ast)]]\n })\n if (e == \"Error\") {\n showNotification(\"Found unallowed function\")\n return()\n } else if (inherits(e, \"try-error\")) {\n showNotification(e)\n return()\n }\n e <- try({\n new <- with(dt, eval(parse(text = op)))\n dataSet$df[, new_col] <- new\n })\n if (inherits(e, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n }\n output$df <- renderDT(dataSet$df)\n output$mod_error <- renderText(err)\n return(df)\n })\n\n observeEvent(input$pivotLonger, {\n req(!is.null(dataSet$df))\n req(input$keepVar)\n err <- NULL\n e <- try({\n stopifnot(get_ast(str2lang(input$keepVar)) != \"Error\")\n dataSet$df <- stackDF(dataSet$df, input$keepVar)\n })\n if (inherits(e, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n }\n output$df <- renderDT(dataSet$df)\n output$mod_error <- renderText(err)\n return(df)\n })\n\n observeEvent(input$pivotWider, {\n req(!is.null(dataSet$df))\n req(input$name)\n req(input$value)\n err <- NULL\n e <- try({\n stopifnot(get_ast(str2lang(input$value)) != \"Error\")\n stopifnot(get_ast(str2lang(input$name)) != \"Error\")\n dataSet$df <- unstackDF(dataSet$df, input$name, input$value)\n })\n if (inherits(e, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n }\n output$df <- renderDT(dataSet$df)\n output$mod_error <- renderText(err)\n return(df)\n })\n\n listResults <- reactiveValues(\n curr_data = NULL, curr_name = NULL,\n all_data = list(), all_names = list()\n )\n corrServer(\"CORR\", dataSet, listResults)\n visServer(\"VIS\", dataSet, listResults)\n assServer(\"ASS\", dataSet, listResults)\n testsServer(\"TESTS\", dataSet, listResults)\n DoseResponseServer(\"DOSERESPONSE\", dataSet, listResults)\n }\n\n shinyApp(ui, server)\n}\n\nlibrary(shiny)\nlibrary(DT)\nlibrary(bslib)\nlibrary(broom)\nlibrary(ggplot2)\nlibrary(base64enc)\nlibrary(shinyjs)\nlibrary(mgcv)\nlibrary(RColorBrewer)\nlibrary(tidyr)\nlibrary(purrr)\nlibrary(agricolae)\nlibrary(drc)\nlibrary(cowplot)\nlibrary(MASS)\nlibrary(Matrix)\nlibrary(shinyjs)\n\nsource(\"check_ast.R\")\nsource(\"utils.R\")\nsource(\"plottingInternally.R\")\nsource(\"lc50.r\")\nsource(\"correlation.R\")\nsource(\"visualisation.R\")\nsource(\"assumption.R\")\nsource(\"statisticalTests.R\")\nsource(\"DoseResponse.R\")\n\nui <- fluidPage(\n useShinyjs(),\n includeScript(\"www/download.js\"), # NOTE: would be better located in inst folder but the serverless version cannot handle this\n sidebarLayout(\n sidebarPanel(\n conditionalPanel(\n condition = \"input.conditionedPanels == 'Data'\",\n uiOutput(\"conditional_data_ui\"),\n fileInput(\"file\", \"Choose CSV File\",\n accept = c(\n \"text/csv\",\n \"text/comma-separated-values,text/plain\",\n \".csv\"\n )\n ),\n textInput(\"op\", \"Operations\", value = \"var / 1000\"),\n textInput(\"new_col\", \"Name of new variable\", value = \"var\"),\n actionButton(\"mod\", \"Modify\"),\n tags$hr(),\n textInput(\"keepVar\", \"const variable\"),\n actionButton(\"pivotLonger\", \"conversion to long format\"),\n tags$hr(),\n textInput(\"name\", \"name column\"),\n textInput(\"value\", \"value column\"),\n actionButton(\"pivotWider\", \"convert to wide format\"),\n verbatimTextOutput(\"mod_error\"),\n tags$hr()\n ),\n conditionalPanel(\n condition = \"input.conditionedPanels == 'Correlation'\",\n corrSidebarUI(\"CORR\")\n ),\n conditionalPanel(\n condition = \"input.conditionedPanels == 'Visualisation'\",\n visSidebarUI(\"VIS\")\n ),\n conditionalPanel(\n condition = \"input.conditionedPanels == 'Assumption'\",\n assSidebarUI(\"ASS\")\n ),\n conditionalPanel(\n condition = \"input.conditionedPanels == 'Tests'\",\n testsSidebarUI(\"TESTS\")\n ),\n conditionalPanel(\n condition = \"input.conditionedPanels == 'Dose Response analysis'\",\n DoseResponseSidebarUI(\"DOSERESPONSE\")\n )\n ),\n mainPanel(\n tabsetPanel(\n tabPanel(\n \"Data\",\n DTOutput(\"df\")\n ),\n tabPanel(\n \"Correlation\",\n corrUI(\"CORR\")\n ),\n tabPanel(\n \"Visualisation\",\n visUI(\"VIS\")\n ),\n tabPanel(\n \"Assumption\",\n assUI(\"ASS\")\n ),\n tabPanel(\n \"Tests\",\n testsUI(\"TESTS\")\n ),\n tabPanel(\n \"Dose Response analysis\",\n DoseResponseUI(\"DOSERESPONSE\")\n ),\n id = \"conditionedPanels\"\n )\n )\n )\n)\n\nserver <- function(input, output, session) {\n dataSet <- reactiveValues(df = NULL)\n\n output$conditional_data_ui <- renderUI({\n if (Sys.getenv(\"RUN_MODE\") != \"SERVER\") {\n res <- conditionalPanel(\n condition = \"input.conditionedPanels == 'Data'\",\n fileInput(\"file\", \"Choose CSV File\",\n accept = c(\n \"text/csv\",\n \"text/comma-separated-values,text/plain\",\n \".csv\"\n )\n )\n )\n return(res)\n }\n })\n\n download_file <- reactive({\n file <- COMELN::download(session, \"/home/shiny/results\")\n upload <- function(path) {\n stopifnot(is.character(path))\n df <- NULL\n df <- try(as.data.frame(readxl::read_excel(\n path,\n col_names = TRUE\n )), silent = TRUE)\n if (class(df) == \"try-error\") {\n # identify seperator\n line <- readLines(path, n = 1)\n semicolon <- grepl(\";\", line)\n comma <- grepl(\",\", line)\n tab <- grepl(\"\\t\", line)\n seperator <- NULL\n if (semicolon == TRUE) {\n seperator <- \";\"\n } else if (comma == TRUE) {\n seperator <- \",\"\n } else if (tab == TRUE) {\n seperator <- \"\\t\"\n } else {\n return(\"error\")\n }\n df <- try(read.csv(path, header = TRUE, sep = seperator))\n if (class(df) == \"try-error\") {\n return(\"error\")\n }\n } else {\n f <- function(x) {\n options(warn = -1)\n x <- as.numeric(x)\n options(warn = 0)\n x <- x[!is.na(x)]\n length(x) > 0\n }\n check <- apply(df, 2, f)\n conv <- function(a, b) {\n if (a == TRUE) {\n return(as.numeric(b))\n }\n return(b)\n }\n df <- Map(conv, check, df)\n df <- data.frame(df)\n }\n return(df)\n }\n df <- NULL\n df <- upload(file)\n if (is.data.frame(df)) {\n var$df <- df\n } else {\n showNotification(\"File can not be used. Upload into R failed!\", duration = 0)\n }\n tryCatch(\n {\n system(paste(\"rm -r \", file))\n },\n warning = function(warn) {\n showNotification(paste(\"A warning occurred: \", conditionMessage(warn)), duration = 0)\n },\n error = function(err) {\n showNotification(paste(\"An error occurred: \", conditionMessage(err)), duration = 0)\n }\n )\n req(is.data.frame(df))\n return(df)\n })\n\n\n output$df <- renderDT({\n if (Sys.getenv(\"RUN_MODE\") == \"SERVER\") {\n isolate({\n dataSet$df <- download_file()\n })\n datatable(dataSet$df, options = list(pageLength = 10))\n } else {\n req(input$file)\n df <- try(read.csv(input$file$datapath))\n if (inherits(df, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n showNotification(err)\n return(NULL)\n }\n dataSet$df <- df\n req(!is.na(dataSet$df))\n datatable(dataSet$df, options = list(pageLength = 10))\n }\n })\n\n observeEvent(input$mod, {\n req(!is.null(dataSet$df))\n req(is.data.frame(dataSet$df))\n req(input$op)\n req(input$new_col)\n dt <- dataSet$df\n op <- input$op\n new_col <- input$new_col\n new <- NULL\n err <- NULL\n e <- try({\n ast <- get_ast(str2lang(op))\n ast <- ast[[length(ast)]]\n })\n if (e == \"Error\") {\n showNotification(\"Found unallowed function\")\n return()\n } else if (inherits(e, \"try-error\")) {\n showNotification(e)\n return()\n }\n e <- try({\n new <- with(dt, eval(parse(text = op)))\n dataSet$df[, new_col] <- new\n })\n if (inherits(e, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n }\n output$df <- renderDT(dataSet$df)\n output$mod_error <- renderText(err)\n return(df)\n })\n\n observeEvent(input$pivotLonger, {\n req(!is.null(dataSet$df))\n req(input$keepVar)\n err <- NULL\n e <- try({\n stopifnot(get_ast(str2lang(input$keepVar)) != \"Error\")\n dataSet$df <- stackDF(dataSet$df, input$keepVar)\n })\n if (inherits(e, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n }\n output$df <- renderDT(dataSet$df)\n output$mod_error <- renderText(err)\n return(df)\n })\n\n observeEvent(input$pivotWider, {\n req(!is.null(dataSet$df))\n req(input$name)\n req(input$value)\n err <- NULL\n e <- try({\n stopifnot(get_ast(str2lang(input$value)) != \"Error\")\n stopifnot(get_ast(str2lang(input$name)) != \"Error\")\n dataSet$df <- unstackDF(dataSet$df, input$name, input$value)\n })\n if (inherits(e, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n }\n output$df <- renderDT(dataSet$df)\n output$mod_error <- renderText(err)\n return(df)\n })\n\n listResults <- reactiveValues(\n curr_data = NULL, curr_name = NULL,\n all_data = list(), all_names = list()\n )\n corrServer(\"CORR\", dataSet, listResults)\n visServer(\"VIS\", dataSet, listResults)\n assServer(\"ASS\", dataSet, listResults)\n testsServer(\"TESTS\", dataSet, listResults)\n DoseResponseServer(\"DOSERESPONSE\", dataSet, listResults)\n}\n\nshinyApp(ui, server)\n\n# run_app()\n","type":"text"},{"name":"DoseResponse.R","content":"# df\n# abs_col\n# conc_col\n# substance_name_col,\n# negative_identifier,\n# positive_identifier\n# path <- system.file(\"data\", package = \"MTT\")\n# df <- read.csv(paste0(path, \"/ExampleData.txt\"))\n# ic50(df, \"abs\", \"conc\", \"names\", \"neg\", \"pos\")\n\n\n\nDoseResponseSidebarUI <- function(id) {\n tabPanel(\n \"Dose Response analysis\",\n textInput(NS(id, \"dep\"), \"dependent Variable\", value = \"abs\"),\n textInput(NS(id, \"indep\"), \"independent Variable\", value = \"conc\"),\n textInput(NS(id, \"substanceNames\"), \"names colum of dependent Variable\", value = \"names\"),\n textInput(NS(id, \"negIdentifier\"), \"identifier for the negative control\", value = \"neg\"),\n textInput(NS(id, \"posIdentifier\"), \"identifier for the positive control\", value = \"pos\"),\n actionButton(NS(id, \"ic50\"), \"conduct analysis\")\n )\n}\n\nDoseResponseUI <- function(id) {\n fluidRow(\n tags$head(\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js\"),\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js\"),\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js\"),\n tags$script(src = \"download.js\")\n ),\n h4(strong(\"Results of test:\")),\n actionButton(NS(id, \"dr_save\"), \"Add output to result-file\"),\n actionButton(NS(id, \"download_dr\"), \"Save results\"),\n checkboxGroupInput(NS(id, \"TableSaved\"), \"Saved results to file\", NULL),\n tableOutput(NS(id, \"dr_result\")),\n plotOutput(NS(id, \"dr_result_plot\")),\n verbatimTextOutput(NS(id, \"dr_error\"))\n )\n}\n\nDoseResponseServer <- function(id, data, listResults) {\n moduleServer(id, function(input, output, session) {\n drFct <- function() {\n output$dr_error <- renderText(NULL)\n req(is.data.frame(data$df))\n df <- data$df\n req(input$dep)\n req(input$indep)\n dep <- input$dep\n indep <- input$indep\n req(input$substanceNames)\n names <- input$substanceNames\n req(input$negIdentifier)\n neg <- input$negIdentifier\n req(input$posIdentifier)\n pos <- input$posIdentifier\n err <- NULL\n resDF <- NULL\n resPlot <- NULL\n e <- try({\n stopifnot(get_ast(str2lang(indep)) != \"Error\")\n stopifnot(get_ast(str2lang(dep)) != \"Error\")\n res <- ic50(df, dep, indep, names, neg, pos)\n stopifnot(!inherits(res, \"errorClass\"))\n resDF <- lapply(res, function(x) {\n if (inherits(x, \"errorClass\")) {\n return(NULL)\n }\n return(x[[1]])\n })\n resDF <- resDF[!is.null(resDF)]\n resDF <- resDF[!sapply(resDF, is.null)]\n resDF <- Reduce(rbind, resDF)\n resP <- lapply(res, function(x) {\n if (inherits(x, \"errorClass\")) {\n return(NULL)\n }\n return(x[[2]])\n })\n resP <- resP[!is.null(resP)]\n resP <- resP[!sapply(resP, is.null)]\n resPlot <- resP[[1]]\n if (length(resP) >= 2) {\n for (i in seq_along(2:length(resP))) {\n # if (i %% 4 == 0) {\n # resPlot <- resPlot / resP[[i]]\n # } else {\n resPlot <- resPlot + resP[[i]]\n # }\n }\n }\n })\n if (inherits(e, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n output$dr_error <- renderText(err)\n } else {\n listResults$curr_data <- new(\"doseResponse\", df = resDF, p = resPlot)\n listResults$curr_name <- paste(\"Test Nr\", length(listResults$all_names) + 1, \"Conducted dose response analysis\")\n output$dr_result <- renderTable(resDF, digits = 6)\n output$dr_result_plot <- renderPlot(resPlot)\n }\n }\n\n observeEvent(input$ic50, {\n drFct()\n })\n\n observeEvent(input$dr_save, {\n if (is.null(listResults$curr_name)) {\n return(NULL)\n }\n if (!(listResults$curr_name %in% unlist(listResults$all_names))) {\n listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data\n listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name\n }\n updateCheckboxGroupInput(session, \"TableSaved\",\n choices = listResults$all_names\n )\n })\n\n observeEvent(input$download_dr, {\n lr <- unlist(listResults$all_names)\n indices <- sapply(input$TableSaved, function(x) {\n which(x == lr)\n })\n req(length(indices) >= 1)\n l <- listResults$all_data[indices]\n if (Sys.getenv(\"RUN_MODE\") == \"BROWSER\") {\n jsString <- createJSString(l)\n session$sendCustomMessage(\n type = \"downloadZip\",\n list(\n numberOfResults = length(jsString),\n FileContent = jsString\n )\n )\n } else if (Sys.getenv(\"RUN_MODE\") == \"SERVER\") {\n excelFile <- createExcelFile(l)\n upload(session, excelFile, new_name = \"Results.xlsx\") # TODO: add possibility for desired file name\n }\n })\n })\n\n return(listResults)\n}\n","type":"text"},{"name":"assumption.R","content":"assSidebarUI <- function(id) {\n tabPanel(\n \"Assumption\",\n tags$hr(),\n textInput(NS(id, \"dep\"), \"dependent Variable\", value = \"var1\"),\n textInput(NS(id, \"indep\"), \"independent Variable\", value = \"var2\"),\n tags$hr(),\n tags$div(\n class = \"header\", checked = NA,\n tags$h4(\n style = \"font-weight: bold;\",\n \"Test of normal distribution\"\n )\n ),\n actionButton(NS(id, \"shapiro\"), \"Shapiro test for individual groups\"),\n tags$hr(),\n actionButton(NS(id, \"shapiroResiduals\"), \"Shapiro test for residuals of linear model\"),\n tags$hr(),\n tags$div(\n class = \"header\", checked = NA,\n tags$h4(\n style = \"font-weight: bold;\",\n \"Test of variance homogenity\"\n )\n ),\n actionButton(NS(id, \"levene\"), \"Levene test\"),\n selectInput(NS(id, \"center\"), \"Data center of each group: mean or median\",\n c(\n \"Mean\" = \"mean\",\n \"Median\" = \"median\"\n ),\n selectize = FALSE\n ),\n tags$hr(),\n tags$div(\n class = \"header\", checked = NA,\n tags$h4(style = \"font-weight: bold;\", \"Visual tests\")\n ),\n actionButton(NS(id, \"DiagnosticPlot\"), \"diagnostic plots\")\n )\n}\n\nassUI <- function(id) {\n fluidRow(\n tags$head(\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js\"),\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js\"),\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js\"),\n tags$script(src = \"download.js\")\n ),\n h4(strong(\"Results of test:\")),\n verbatimTextOutput(NS(id, \"ass_error\")),\n actionButton(NS(id, \"ass_save\"), \"Add output to result-file\"),\n actionButton(NS(id, \"download_ass\"), \"Save and exit\"),\n checkboxGroupInput(NS(id, \"TableSaved\"), \"Saved results to file\", NULL),\n tableOutput(NS(id, \"ass_result\")),\n plotOutput(NS(id, \"DiagnosticPlotRes\"))\n )\n}\n\nassServer <- function(id, data, listResults) {\n moduleServer(id, function(input, output, session) {\n runShapiro <- function() {\n output$ass_error <- renderText(NULL)\n req(input$indep)\n req(input$dep)\n indep <- input$indep\n dep <- input$dep\n df <- data$df\n req(is.data.frame(df))\n check <- TRUE\n res <- NULL\n temp <- NULL\n err <- NULL\n if (isTRUE(check)) {\n res <- list()\n e <- try({\n formula <- as.formula(paste(dep, \"~\", indep))\n stopifnot(get_ast(formula) != \"Error\")\n dat <- splitData(df, formula)\n for (i in unique(dat[, 2])) {\n tempDat <- dat[dat[, 2] == i, ]\n temp <- broom::tidy(shapiro.test(tempDat[, 1]))\n if (!is.null(temp)) {\n temp$variable <- i\n res[[length(res) + 1]] <- temp\n }\n }\n res <- do.call(rbind, res)\n })\n if (!inherits(e, \"try-error\")) {\n listResults$curr_data <- res\n listResults$curr_name <- paste(\"Test Nr\", length(listResults$all_names) + 1, \"Conducted shapiro test\")\n output$curr_result <- renderTable(res, digits = 6)\n output$curr_error <- renderText(err)\n } else {\n err <- conditionMessage(attr(e, \"condition\"))\n output$ass_error <- renderText(err)\n }\n }\n }\n observeEvent(input$shapiro, {\n runShapiro()\n })\n\n runShapiroResiduals <- function() {\n output$ass_error <- renderText(NULL)\n req(input$indep)\n indep <- input$indep\n req(input$dep)\n dep <- input$dep\n df <- data$df\n req(is.data.frame(df))\n formula <- NULL\n err <- NULL\n res <- NULL\n e <- try({\n formula <- as.formula(paste(dep, \"~\", indep))\n stopifnot(get_ast(formula) != \"Error\")\n fit <- lm(formula, data = df)\n r <- resid(fit)\n res <- broom::tidy(shapiro.test(r))\n })\n if (!inherits(e, \"try-error\")) {\n listResults$curr_data <- res\n listResults$curr_name <- paste(\"Test Nr\", length(listResults$all_names) + 1, \"Conducted shapiro test\")\n output$curr_result <- renderTable(res, digits = 6)\n output$curr_error <- renderText(err)\n } else {\n err <- conditionMessage(attr(e, \"condition\"))\n output$ass_error <- renderText(err)\n }\n }\n observeEvent(input$shapiroResiduals, {\n runShapiroResiduals()\n })\n\n runLevene <- function() {\n output$ass_error <- renderText(NULL)\n req(input$indep)\n indep <- input$indep\n req(input$dep)\n dep <- input$dep\n df <- data$df\n req(is.data.frame(df))\n formula <- NULL\n err <- NULL\n fit <- NULL\n e <- try({\n formula <- as.formula(paste(dep, \"~\", indep))\n stopifnot(get_ast(formula) != \"Error\")\n fit <- broom::tidy(car::leveneTest(formula, data = df, center = input$center))\n })\n if (inherits(e, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n output$ass_error <- renderText(err)\n } else {\n listResults$curr_data <- fit\n listResults$curr_name <- paste(\"Test Nr\", length(listResults$all_names) + 1, \"variance homogenity (levene)\")\n output$curr_result <- renderTable(fit, digits = 6)\n output$curr_error <- renderText(err)\n }\n }\n observeEvent(input$levene, {\n runLevene()\n })\n\n output$ass_result <- renderTable(\n {\n if (!inherits(listResults$curr_data, \"diagnosticPlot\")) {\n return(listResults$curr_data)\n }\n return(NULL)\n },\n digits = 6\n )\n\n runDiagnosticPlot <- function() {\n output$ass_error <- renderText(NULL)\n req(input$indep)\n indep <- input$indep\n req(input$dep)\n dep <- input$dep\n df <- data$df\n req(is.data.frame(df))\n formula <- NULL\n err <- NULL\n f <- NULL\n e <- try({\n formula <- as.formula(paste(dep, \"~\", indep))\n stopifnot(get_ast(formula) != \"Error\")\n f <- diagnosticPlot(df, formula)\n })\n if (inherits(e, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n output$ass_error <- renderText(err)\n } else {\n listResults$curr_data <- new(\"diagnosticPlot\", p = f)\n listResults$curr_name <- paste(\"Test Nr\", length(listResults$all_names) + 1, \"diagnostic plots\")\n output$DiagnosticPlotRes <- renderImage(\n {\n list(\n src = f,\n contentType = \"image/png\"\n )\n },\n deleteFile = FALSE\n )\n output$curr_error <- renderText(err)\n }\n }\n observeEvent(input$DiagnosticPlot, {\n runDiagnosticPlot()\n })\n\n observeEvent(input$ass_save, {\n if (is.null(listResults$curr_name)) {\n return(NULL)\n }\n if (!(listResults$curr_name %in% unlist(listResults$all_names))) {\n listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data\n listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name\n }\n updateCheckboxGroupInput(session, \"TableSaved\",\n choices = listResults$all_names\n )\n })\n\n observeEvent(input$download_ass, {\n lr <- unlist(listResults$all_names)\n indices <- sapply(input$TableSaved, function(x) {\n which(x == lr)\n })\n req(length(indices) >= 1)\n l <- listResults$all_data[indices]\n\n if (Sys.getenv(\"RUN_MODE\") == \"BROWSER\") {\n jsString <- createJSString(l)\n session$sendCustomMessage(\n type = \"downloadZip\",\n list(\n numberOfResults = length(jsString),\n FileContent = jsString\n )\n )\n } else if (Sys.getenv(\"RUN_MODE\") == \"SERVER\") {\n excelFile <- createExcelFile(l)\n upload(session, excelFile, new_name = \"Results.xlsx\") # TODO: add possibility for desired file name\n }\n })\n })\n\n return(listResults)\n}\n","type":"text"},{"name":"check_ast.R","content":"get_ast <- function(inp) {\n if (!is.call(inp)) {\n return(inp)\n }\n\n inp <- as.list(inp)\n\n # check if is function\n fct <- inp[[1]]\n\n allowed_fcts <- c(\n \"-\", \"+\", \"*\", \"/\",\n \"log\", \"log10\", \"sqrt\", \"exp\", \"^\",\n \"sin\", \"cos\", \"tan\", \"tanh\", \"sinh\", \"cosh\", \"acos\", \"asin\", \"atan\",\n \"is.numeric\", \"is.character\", \"is.logical\", \"is.factor\", \"is.integer\",\n \"as.numeric\", \"as.character\", \"as.logical\", \"as.factor\", \"as.integer\",\n \">\", \"<\", \"<=\", \">=\", \"==\", \"!=\",\n \"abs\", \"ceiling\", \"floor\", \"trunc\", \"round\",\n \"grep\", \"substr\", \"sub\", \"paste\", \"paste0\",\n \"strsplit\", \"tolower\", \"toupper\",\n \"dnorm\", \"pnorm\", \"qnorm\", \"rnorm\", \"dbinom\",\n \"pbinom\", \"qbinom\", \"rbinom\", \"dpois\",\n \"ppois\", \"rpois\", \"dunif\", \"punif\", \"qunif\", \"runif\",\n \"mean\", \"sd\", \"median\", \"quantile\", \"range\",\n \"sum\", \"diff\", \"min\", \"max\", \"scale\",\n \"c\", \"vector\", \"length\", \"matrix\", \"~\"\n )\n\n check <- deparse(fct)\n\n if ((check %in% allowed_fcts) == FALSE) {\n return(\"Error\")\n }\n\n lapply(inp, get_ast)\n}\n","type":"text"},{"name":"correlation.R","content":"corrSidebarUI <- function(id) {\n tabPanel(\n \"Correlation\",\n textInput(NS(id, \"dep\"), \"dependent Variable\", value = \"var1\"),\n textInput(NS(id, \"indep\"), \"independent Variable\", value = \"var2\"),\n actionButton(NS(id, \"pear\"), \"Pearson correlation\"),\n actionButton(NS(id, \"spear\"), \"Spearman correlation\"),\n actionButton(NS(id, \"kendall\"), \"Kendall correlation\"),\n sliderInput(NS(id, \"conflevel\"), \"Confidence level of the interval\",\n min = 0, max = 1, value = 0.95\n ),\n selectInput(\n NS(id, \"alt\"), \"Alternative hypothesis\",\n c(\n \"Two sided\" = \"two.sided\",\n \"Less\" = \"less\",\n \"Greater\" = \"greater\"\n )\n )\n )\n}\n\ncorrUI <- function(id) {\n fluidRow(\n tags$head(\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js\"),\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js\"),\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js\"),\n tags$script(src = \"download.js\")\n ),\n h4(strong(\"Results of test:\")),\n tableOutput(NS(id, \"corr_result\")),\n verbatimTextOutput(NS(id, \"corr_error\")),\n actionButton(NS(id, \"corr_save\"), \"Add output to result-file\"),\n actionButton(NS(id, \"download_corr\"), \"Save results\"),\n checkboxGroupInput(NS(id, \"TableSaved\"), \"Saved results to file\", NULL)\n )\n}\n\ncorrServer <- function(id, data, listResults) {\n moduleServer(id, function(input, output, session) {\n corr_fct <- function(method) {\n output$corr_error <- renderText(NULL)\n req(is.data.frame(data$df))\n df <- data$df\n req(input$dep)\n req(input$indep)\n dep <- input$dep\n indep <- input$indep\n d <- df\n fit <- NULL\n err <- NULL\n e <- try({\n stopifnot(get_ast(str2lang(indep)) != \"Error\")\n stopifnot(get_ast(str2lang(dep)) != \"Error\")\n fit <- broom::tidy(\n cor.test(d[, dep], d[, indep],\n method = method,\n alternative = input$alt,\n conf.level = input$conflevel\n )\n )\n })\n if (inherits(e, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n output$corr_error <- renderText(err)\n } else {\n listResults$curr_data <- fit\n listResults$curr_name <- paste(\"Test Nr\", length(listResults$all_names) + 1, \"Conducted test: \", method)\n output$corr_result <- renderTable(fit, digits = 6)\n }\n }\n\n observeEvent(input$pear, {\n corr_fct(\"pearson\")\n })\n output$cor_result <- renderTable(\n {\n listResults$curr_data\n },\n digits = 6\n )\n\n observeEvent(input$spear, {\n corr_fct(\"spearman\")\n })\n output$cor_result <- renderTable(\n {\n listResults$curr_data\n },\n digits = 6\n )\n\n observeEvent(input$kendall, {\n corr_fct(\"kendall\")\n })\n output$cor_result <- renderTable(\n { # issue: check whether this is required\n listResults$curr_data\n },\n digits = 6\n )\n\n observeEvent(input$corr_save, {\n if (is.null(listResults$curr_name)) {\n return(NULL)\n }\n if (!(listResults$curr_name %in% unlist(listResults$all_names))) {\n listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data\n listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name\n }\n updateCheckboxGroupInput(session, \"TableSaved\",\n choices = listResults$all_names\n )\n })\n\n observeEvent(input$download_corr, {\n lr <- unlist(listResults$all_names)\n indices <- sapply(input$TableSaved, function(x) {\n which(x == lr)\n })\n req(length(indices) >= 1)\n l <- listResults$all_data[indices]\n if (Sys.getenv(\"RUN_MODE\") == \"BROWSER\") {\n jsString <- createJSString(l)\n session$sendCustomMessage(\n type = \"downloadZip\",\n list(\n numberOfResults = length(jsString),\n FileContent = jsString\n )\n )\n } else if (Sys.getenv(\"RUN_MODE\") == \"SERVER\") {\n excelFile <- createExcelFile(l)\n upload(session, excelFile, new_name = \"Results.xlsx\") # TODO: add possibility for desired file name\n }\n })\n })\n\n return(listResults)\n}\n","type":"text"},{"name":"lc50.r","content":"errorClass <- R6::R6Class(\"errorClass\",\n public = list(\n error_message = NULL,\n object = NULL,\n initialize = function(error_message = NULL) {\n self$error_message = error_message\n },\n isNull = function() {\n if(is.null(self$error_message)) {\n return(TRUE)\n }\n return(FALSE)\n }\n )\n)\n\nshapenumber <- function (my.number) {\n if (is.finite(my.number)) {\n my.result <- signif(my.number,3) \n } else { \n my.result <- NA\n } \n return (my.result)\n}\n\n#calculates the robust 68th percentile of the residuals\n#adapted from Motulsky HJ, Brown RE, BMC Bioinformatics 2006, 7:123\nrobust_68_percentile <- function (residuals) {\n res <- abs(residuals)\n res_sorted <- sort(res)\n res_percentiles <- (seq(1:length(res_sorted))/length(res_sorted))*100\n index <- min(which(res_percentiles > 68.25))\n x <- c(res_percentiles[index-1],res_percentiles[index])\n y <- c(res_sorted[index-1],res_sorted[index])\n m <- lm(y~x)\n x <- c(68.25)\n y <- predict(m, as.data.frame(x))\n return(y)\n}\n\n#calculates the robust standard deviation of the residuals (RSDR) with correction for degrees of freedom\n#adapted from Motulsky HJ, Brown RE, BMC Bioinformatics 2006, 7:123\nrobust_standard_deviation_residuals <- function(residuals, number_of_coefficients_fitted) {\n my_residuals <- as.numeric(residuals)\n my_residuals <- na.omit(residuals)\n N <- length(my_residuals) #the number of data points fitted\n K <- number_of_coefficients_fitted #for ic50, 4 coefficients are fitted\n result <- robust_68_percentile(residuals) * N/(N-K)\n return (result)\n}\n\n#false discovery rate (FDR) approach, returns a T/F vector for selection of valid data points\n#adapted from Motulsky HJ, Brown RE, BMC Bioinformatics 2006, 7:123\nfalse_discovery_rate <- function(res) {\n N <- length(res) \n Q <- 0.01 #Q=1%\n K <- 4 #number of coefficients in the fitted LL.4 model\n R <- robust_standard_deviation_residuals(res,K) #the robust standard deviation of the residuals\n id <- seq(1:length(res))\n df <- data.frame(id,res)\n df$res_abs <- abs(df$res)\n df <- df[order(df$res_abs),] \n df$i <- seq(1:N)\n df$i_fraction <- df$i / N\n df$alpha <- Q*(N-(df$i-1))/N\n df$t <- df$res_abs / R\n df$P <- dt(df$t, N-K)\n df$include <- ifelse(df$P < df$alpha & df$i_fraction >= 0.7, FALSE, TRUE)\n df2 <- df[order(df$id), ]\n return (df2$include)\n}\n\ncheck_fit <- function(model, min_conc, max_conc, min_abs, max_abs, substance_name) {\n if(model$fit$convergence != TRUE) return(errorClass$new(paste(substance_name,\n \"Model did not converge\")))\n b <- coefficients(model)[1] #Hill coefficient\n c <- coefficients(model)[2] #asymptote 1\n d <- coefficients(model)[3] #asymptote 2\n e <- coefficients(model)[4] #IC50\n RSE <- summary(model)$rseMat[1] #residual standard error estimated\n Response_lowestdose_predicted <- predict(model, data.frame(concentration = min_conc), se.fit = FALSE)[1]\n Response_highestdose_predicted <- predict(model, data.frame(concentration = max_conc), se.fit = FALSE)[1]\n Response_difference <- 100 * abs(Response_lowestdose_predicted - Response_highestdose_predicted)\n HillCoefficient <- b\n IC50_relative <- e \n pIC50 <- -log10(e/1000000)\n Problems <- \"\"\n if (Response_difference < 25) {\n Problems <- paste(Problems, \"Response Difference lower than 25%\", collapse = \" , \")\n } else if(IC50_relative > max_conc) {\n Problems <- paste(Problems, \"IC50 larger than highest measured concentration\", collapse = \" , \")\n } else if(IC50_relative < min_conc) {\n Problems <- paste(Problems, \"IC50 lower than lowest measured concentration\", collapse = \" , \")\n } \n \n confidence_interval <- confint(model, parm = c(\"e\"), level = 0.95)\n IC50_relative_lower <- confidence_interval[1] \n IC50_relative_higher <- confidence_interval[2]\n p_value <- noEffect(model)[3]\n Response_lowestdose_predicted <- shapenumber(Response_lowestdose_predicted)\n Response_highestdose_predicted <- shapenumber(Response_highestdose_predicted)\n HillCoefficient <- shapenumber(HillCoefficient) \n IC50_relative <- shapenumber(IC50_relative)\n IC50_relative_lower <- shapenumber(IC50_relative_lower)\n IC50_relative_higher <- shapenumber(IC50_relative_higher)\n pIC50 <- shapenumber( -log10(IC50_relative/1000000))\n p_value <- shapenumber(p_value)\n ylim_low = 0\n ylim_high = 125\n if (min_abs < ylim_low) ylim_low <- min_abs\n if (max_abs > ylim_high) ylim_high <- max_abs\n outvar <- data.frame(name = substance_name, \n Response_lowestdose_predicted = Response_lowestdose_predicted,\n Response_highestdose_predicted = Response_highestdose_predicted, \n HillCoefficient = HillCoefficient, \n asymptote_one = c, asymptote_two = d,\n IC50_relative = IC50_relative, IC50_relative_lower = IC50_relative_lower,\n IC50_relative_higher = IC50_relative_higher, pIC50 = pIC50, \n RSE = RSE, p_value = p_value, Problems = Problems)\n return (outvar)\n}\n\ndrawplot <- function(df, abs_col, conc_col, model, valid_points, title,\n IC50_relative, IC50_relative_lower, IC50_relative_higher) {\n min_conc <- min(df[, conc_col])\n max_conc <- max(df[, conc_col])\n grid <- seq(min_conc, max_conc, 0.1)\n plotFct <- (model$curve)[[1]]\n res <- plotFct(grid)\n data <- data.frame(abs = res,\n conc = grid)\n data_measured <- data.frame(conc = df[, conc_col], abs = df[, abs_col])\n p <- ggplot() +\n geom_boxplot(data = data_measured, aes(x = conc, y = abs*100, group = conc)) +\n geom_line(data = data, aes(x = conc, y = abs*100)) +\n xlab(\"Concentration [µM]\") +\n ylab(\"Viability [%]\") +\n ggtitle(title) \n \n max_conc <- max(df[, conc_col]) + 10\n min_conc <- -10\n xmin <- IC50_relative - IC50_relative_lower\n xmax <- IC50_relative + IC50_relative_higher\n if (!is.na(xmin) & !is.na(xmax)) {\n ymin <- min(df[, abs_col]) * 100\n ymax <- max(df[, abs_col]) * 100\n yrange <- ymax - ymin\n butt_height <- yrange * 0.1\n ymedian <- median(df[, abs_col]) * 100\n if (xmin > min_conc && xmax < max_conc ) {\n p <- p + geom_errorbarh(aes(xmin = xmin,\n xmax = xmax, y = ymedian),\n colour = \"darkred\", end = \"butt\", height = butt_height) \n } else {\n p <- p + labs(caption = \"Confidence intervall not in conc. range\") +\n theme(plot.caption = element_text(color = \"darkred\", face = \"italic\", size = 7))\n } \n } else {\n p <- p + labs(caption = \"Confidence intervall could not be calculated\") +\n theme(plot.caption = element_text(color = \"darkred\", face = \"italic\", size = 7))\n }\n \n return(p)\n}\n\nic50_internal <- function(df, abs, conc, title) {\n model <- drm(abs ~ conc, data = df , fct = LL.4(), robust = \"median\")\n valid_points <- false_discovery_rate(residuals(model))\n model <- drm(abs ~ conc, data = df , subset = valid_points, start = model$coefficients, fct = LL.4(), robust = \"mean\")\n res <- check_fit(model, min(df[, conc]), max(df[, conc]), min(df[, abs]), max(df[, abs]), title)\n p <- drawplot(df, abs, conc, model, valid_points, title, res$IC50_relative,\n res$IC50_relative_lower, res$IC50_relative_higher)\n return(list(res, p))\n}\n\ndrawplotOnlyRawData <- function(df, abs_col, conc_col, title) {\n min_conc <- min(df[, conc_col])\n max_conc <- max(df[, conc_col])\n data_measured <- data.frame(conc = df[, conc_col], abs = df[, abs_col])\n p <- ggplot() +\n geom_boxplot(data = data_measured, aes(x = conc, y = abs*100, group = conc)) +\n xlab(\"Concentration [µM]\") +\n ylab(\"Viability [%]\") +\n ggtitle(title) \n return(p)\n}\n\n#' Calculates the ic50 values\n#' @export\n#' @import drc\n#' @import ggplot2\n#' @param df a data.frame which contains all the data\n#' @param abs_col the name of the column in df which contains the dependent variable\n#' @param conc_col the name of the column in df which contains the different concentrations\n#' @param substance_name_col the name of the column in df which contains the different names of the compounds\n#' @param negative_identifier a character defining the name to identify the negative control within conc_col\n#' @param positive_identifier a character defining the name to identify the positive control within conc_col\n#' @return a list is returned containing the ic50 value the fitted plots and other parameters\n#' @examples\n#' path <- system.file(\"data\", package = \"MTT\")\n#' df <- read.csv(paste0(path, \"/ExampleData.txt\"))\n#' ic50(df, \"abs\", \"conc\", \"names\", \"neg\", \"pos\")\nic50 <- function(df, abs_col, conc_col, substance_name_col, negative_identifier, positive_identifier) {\n substances <- unique(df$names)\n\n if(!(negative_identifier %in% substances)) {\n return(errorClass$new(\"the string for the negative control was not found!\"))\n }\n if(!(positive_identifier %in% substances)) {\n return(errorClass$new(\"the string for the positive control was not found!\"))\n }\n substances <- substances[substances != negative_identifier]\n substances <- substances[substances != positive_identifier] \n if(length(substances) < 1) {\n return(errorClass$new(\"The data for compounds seems to be missing\"))\n }\n if(!is.numeric(df[, abs_col])) {\n return(errorClass$new(\"The absorbance data is not numerical\")) \n }\n temp_conc <- df[, conc_col]\n temp_conc[temp_conc == negative_identifier] <- -1\n temp_conc[temp_conc == positive_identifier] <- -2\n temp_conc <- as.numeric(temp_conc)\n if(any(is.na(temp_conc))) {\n return(errorClass$new(\"The concentration data cannot be converted to numerical\")) \n }\n df[, conc_col] <- temp_conc\n if(!is.numeric(df[, conc_col])) {\n return(errorClass$new(\"The concentration data is not numerical\")) \n }\n neg_mean <- mean(df[df[ , substance_name_col] == negative_identifier, abs_col])\n pos_mean <- mean(df[df[ , substance_name_col] == positive_identifier, abs_col])\n df[, abs_col] <- (df[, abs_col] - pos_mean) / neg_mean\n res <- list()\n for(i in seq_along(substances)) {\n df_temp <- df[df$names == substances[i], ]\n m <- tryCatch({\n m <- ic50_internal(df_temp, abs_col, conc_col, substances[i])\n }, \n error = function(err) {\n retval <- errorClass$new(paste(\"A warning occurred: \", conditionMessage(err)))\n retval$object <- drawplotOnlyRawData(df_temp, abs_col, conc_col, substances[i])\n return(retval)\n })\n res[[i]] <- m\n }\n \n return(res)\n}\n\nreport_plots <- function(ic50List) {\n p3 <- ggdraw() +\n draw_line(x = c(0, 1), y = c(0.5, 0.5), color = \"black\", size = 1) +\n theme_void()\n for(i in seq_along(ic50List)) {\n if(is(ic50List[[i]], \"errorClass\")) {\n p <- ic50List[[i]]$object\n p <- p + \n annotate(\"text\", x = -Inf, y = -Inf,\n hjust = -0.2, vjust = -1, label = ic50List[[i]]$error_message)\n #print(p)\n #print(p3)\n next\n }\n p1 <- ic50List[[i]][[2]]\n a <- ic50List[[i]][[1]] |> t() |> as.data.frame() \n a <- data.frame(names = row.names(a), Predicition = a)\n a[a$names == \"Response_lowestdose_predicted\", 1] <- \"Response_lowestdose\"\n a[a$names == \"Response_highestdose_predicted\", 1] <- \"Response_highestdose\"\n problem <- a[a$names == \"Problems\", 2]\n a <- a[(a$names != \"Problems\") & (a$names != \"name\"), ]\n p2 <- ggplot(a, aes(x = 0, y = factor(names), label = Prediction)) +\n geom_line(size = 0) +\n geom_text(position = position_nudge(x = -1.1), hjust = 0, size = 3) +\n theme_minimal() +\n theme(axis.text.x = element_blank(),\n axis.ticks.x = element_blank(),\n panel.grid.major.x = element_blank(),\n panel.grid.minor.x = element_blank(),\n panel.grid.major.y = element_blank(),\n panel.grid.minor.y = element_blank(),\n axis.title.x = element_blank(),\n axis.title.y = element_blank(),\n axis.text.y = element_text(hjust = 0, face = \"bold\"),\n axis.line.y = element_line(),\n plot.caption = element_text(hjust = 1, face = \"italic\", colour = \"darkred\", \n size = 7) ) \n if(problem != \"\") {\n p2 <- p2 + labs(caption = paste(\"Note:\", as.character(problem)) )\n }\n \n p <- ggdraw() +\n draw_plot(p2, x = 0, y = 0, width = 0.5, height = 0.5) +\n draw_plot(p1, x = 0.5, y = 0, width = 0.5, height = 0.5) \n #print(p)\n #print(p3)\n }\n}\n","type":"text"},{"name":"plottingInternally.R","content":"annotateDF <- function(p, method, level = 2) {\n pB <- ggplot_build(p)\n df <- pB$data[[1]]\n if (length(unique(df$PANEL)) > 1) {\n l <- pB$layout$layout\n l <- data.frame(PANEL = l$PANEL, names = l$``)\n df$PANEL <- l[match(df$PANEL, l$PANEL), 2]\n }\n # https://stackoverflow.com/questions/40854225/how-to-identify-the-function-used-by-geom-smooth\n formula <- p$layers[[level]]$stat$setup_params(\n df,\n p$layers[[level]]$stat_params\n )$formula\n df$interaction <- interaction(df$PANEL, df$group)\n\n results <- lapply(unique(df$interaction), function(x) {\n sub <- df[df$interaction == x, ]\n calcParams(sub, formula, method)\n })\n df <- Reduce(rbind, results)\n return(df)\n}\n\ncalcParams <- function(df, formula, method) {\n stopifnot(get_ast(formula) != \"Error\")\n if (method == \"lm\") {\n model <- lm(formula, data = df)\n r_squared <- summary(model)$r.squared\n anova_table <- anova(model)\n f_value <- anova_table$`F value`[1]\n coefficients <- coef(model)\n equation <- paste(\n \"Y =\", round(coefficients[1], 2), \"+\",\n round(coefficients[2], 2), \"* X\"\n )\n p_value <- summary(model)$coefficients[, 4]\n p_value <- paste(p_value, collapse = \" \")\n n <- nrow(df)\n annotations <- paste(\n \"R-squared:\", round(r_squared, 2),\n \"F-value:\", round(f_value, 2), \"\\n\",\n \"Equation:\", equation, \"\\n\",\n \"Sample Size (n):\", n, \"\\n\",\n \"p-values Intercept & x:\", round(p_value, 6)\n )\n df$annotation <- annotations\n df$xPos <- mean(df$x)\n df$yPos <- max(df$y)\n return(df)\n } else if (method == \"glm\") {\n model <- glm(formula, data = df)\n r_squared <- with(summary(model), 1 - deviance / null.deviance)\n coefficients <- coef(model)\n n <- nrow(df)\n equation <- paste(\n \"Y =\", round(coefficients[1], 2), \"+\",\n round(coefficients[2], 2), \"* X\"\n )\n p_value <- summary(model)$coefficients[2, 4]\n annotations <- paste(\n \"R-squared:\", round(r_squared, 2),\n \"Sample Size (n):\", n, \"\\n\",\n \"Equation:\", equation, \"\\n\",\n \"p-value:\", round(p_value, 6)\n )\n df$annotation <- annotations\n df$xPos <- mean(df$x)\n df$yPos <- max(df$y)\n return(df)\n } else if (method == \"gam\") {\n model <- gam(formula, data = df)\n r_squared <- summary(model)$r.sq\n f_value <- summary(model)$p.t\n coefficients <- coef(model)\n n <- nrow(df)\n equation <- paste(\n \"Y =\", round(coefficients[1], 2), \"+\",\n round(coefficients[2], 2), \"* X\"\n )\n p_value <- summary(model)$p.pv\n annotations <- paste(\n \"R-squared:\", round(r_squared, 2),\n \"F-value:\", round(f_value, 2), \"\\n\",\n \"Equation:\", equation,\n \"Sample Size (n):\", n, \"\\n\",\n \"p-value:\", round(p_value, 6)\n )\n df$annotation <- annotations\n df$xPos <- mean(df$x)\n df$yPos <- max(df$y)\n return(df)\n } else if (method == \"loess\") {\n model <- loess(formula, data = df)\n fitted_values <- predict(model)\n r_squared <- cor(df$y, fitted_values)^2\n n <- nrow(df)\n annotations <- paste(\n \"R-squared:\", round(r_squared, 2),\n \"Sample Size (n):\", n\n )\n df$annotation <- annotations\n df$xPos <- mean(df$x)\n df$yPos <- max(df$y)\n return(df)\n }\n}\n\naddFacet <- function(p, facetVar, facetMode) {\n if (facetMode == \"facet_wrap\") {\n return(p + facet_wrap(. ~ .data[[facetVar]], scales = \"free\"))\n } else if (facetMode == \"facet_grid\") {\n return(p + facet_grid(. ~ .data[[facetVar]], scales = \"free\"))\n }\n}\n\nDotplotFct <- function(df, x, y, xLabel, yLabel,\n fitMethod,\n colourVar, legendTitleColour,\n colourTheme, facetMode, facetVar, k = 10) {\n # create plot\n # ==========================================\n aes <- aes(x = .data[[x]], y = .data[[y]])\n aesColour <- NULL\n p <- NULL\n\n if (colourVar != \"\") {\n aesColour <- aes(colour = .data[[colourVar]])\n }\n if (colourVar == \"\") {\n p <- ggplot(\n data = df,\n aes(!!!aes)\n ) +\n geom_point()\n } else {\n p <- ggplot(\n data = df,\n aes(!!!aes, !!!aesColour)\n ) +\n geom_point()\n }\n\n p <- p + xlab(xLabel)\n p <- p + ylab(yLabel)\n\n if (colourVar != \"\") {\n p <- p + guides(colour = guide_legend(title = legendTitleColour))\n p <- p + scale_color_brewer(palette = colourTheme)\n }\n\n if (facetMode != \"none\") {\n p <- addFacet(p, facetVar, facetMode)\n }\n\n if (fitMethod == \"none\" || fitMethod == \"\") {\n return(p)\n }\n\n # fit data\n # ==========================================\n if (fitMethod == \"gam\") {\n p <- p + geom_smooth(\n method = fitMethod,\n formula = y ~ s(x, bs = \"cs\", k = k)\n )\n } else {\n p <- p + geom_smooth(method = fitMethod)\n }\n\n # extract information from fit\n # ==========================================\n df_original <- df\n df <- annotateDF(p, fitMethod)\n names(df) <- ifelse(names(df) == \"PANEL\", \"Panel\", names(df))\n\n # TODO: this is a hack. Find a better way.\n if (colourVar != \"\") {\n df$colour_groups <- df_original[, colourVar][match(\n df$group,\n as.integer(factor(df_original[, colourVar]))\n )]\n }\n # Add annotations to plot\n # ==========================================\n aes <- aes(x = .data[[\"x\"]], y = .data[[\"y\"]])\n if (colourVar != \"\") {\n aesColour <- aes(colour = .data[[\"colour_groups\"]])\n }\n if (fitMethod == \"gam\") {\n p <- ggplot(data = df, aes(!!!aes, !!!aesColour)) +\n geom_point() +\n geom_smooth(\n method = fitMethod,\n formula = y ~ s(x, bs = \"cs\", k = k)\n ) +\n geom_text(\n aes(\n x = xPos, y = yPos,\n label = annotation\n ),\n size = 3,\n show.legend = FALSE, position = position_dodge(width = .9)\n )\n } else {\n p <- ggplot(data = df, aes(!!!aes, !!!aesColour)) +\n geom_point() +\n geom_smooth(method = fitMethod) +\n geom_text(\n aes(\n x = xPos, y = yPos,\n label = annotation\n ),\n size = 3,\n show.legend = FALSE, position = position_dodge(width = .9)\n )\n }\n\n # Add labels\n # ==========================================\n p <- p + xlab(xLabel)\n p <- p + ylab(yLabel)\n if (length(unique(df$colour)) >= 2) {\n p <- p + guides(colour = guide_legend(title = legendTitleColour))\n p <- p + scale_color_brewer(palette = colourTheme)\n }\n if (facetMode != \"none\") {\n p <- addFacet(p, \"Panel\", facetMode)\n }\n\n return(p)\n}\n\nBoxplotFct <- function(df, x, y, xLabel, yLabel,\n fillVar, legendTitleFill, fillTheme,\n colourVar, legendTitleColour,\n colourTheme, facetMode, facetVar) {\n aes <- aes(x = .data[[x]], y = .data[[y]])\n aesColour <- NULL\n aesFill <- NULL\n p <- NULL\n if (colourVar == \"\") {\n aesColour <- aes()\n } else {\n aesColour <- aes(colour = .data[[colourVar]])\n }\n if (fillVar == \"\") {\n aesFill <- aes()\n } else {\n aesFill <- aes(fill = .data[[fillVar]])\n }\n p <- ggplot() +\n geom_boxplot(\n data = df,\n aes(!!!aes, !!!aesColour, !!!aesFill,\n group = interaction(\n .data[[x]],\n !!!aesColour, !!!aesFill\n )\n )\n )\n p <- p + xlab(xLabel)\n p <- p + ylab(yLabel)\n p <- p + guides(fill = guide_legend(title = legendTitleFill))\n p <- p + guides(colour = guide_legend(title = legendTitleColour))\n p <- p + scale_fill_brewer(palette = fillTheme)\n p <- p + scale_color_brewer(palette = colourTheme)\n if (facetMode != \"none\") {\n p <- addFacet(p, facetVar, facetMode)\n }\n return(p)\n}\n\nLineplotFct <- function(df, x, y, xLabel, yLabel,\n colourVar, legendTitleColour,\n colourTheme, facetMode, facetVar) {\n aes <- aes(x = .data[[x]], y = .data[[y]])\n aesColour <- NULL\n p <- NULL\n if (colourVar == \"\") {\n aesColour <- aes()\n } else {\n aesColour <- aes(colour = .data[[colourVar]])\n }\n p <- ggplot() +\n geom_line(\n data = df,\n aes(!!!aes, !!!aesColour,\n group = interaction(\n .data[[x]],\n !!!aesColour\n )\n )\n )\n p <- p + xlab(xLabel)\n p <- p + ylab(yLabel)\n p <- p + guides(colour = guide_legend(title = legendTitleColour))\n p <- p + scale_color_brewer(palette = colourTheme)\n if (facetMode != \"none\") {\n p <- addFacet(p, facetVar, facetMode)\n }\n return(p)\n}\n","type":"text"},{"name":"statisticalTests.R","content":"testsSidebarUI <- function(id) {\n tabPanel(\n \"Tests\",\n textInput(NS(id, \"dep\"), \"dependent Variable\", value = \"var1\"),\n textInput(NS(id, \"indep\"), \"independent Variable\", value = \"var2\"),\n conditionalPanel(\n condition = \"input.TestsConditionedPanels == 'Two groups'\",\n sliderInput(NS(id, \"confLevel\"), \"Confidence level of the interval\",\n min = 0, max = 1, value = 0.95\n ),\n selectInput(\n NS(id, \"altHyp\"), \"Alternative hypothesis\",\n c(\n \"Two sided\" = \"two.sided\",\n \"Less\" = \"less\",\n \"Greater\" = \"greater\"\n )\n ),\n selectInput(\n NS(id, \"paired\"), \"Paired or unpaired t-test\",\n c(\n \"Unpaired\" = \"up\",\n \"Paired\" = \"p\"\n )\n ),\n selectInput(\n NS(id, \"varEq\"), \"Are the two variances treated as equal or not?\",\n c(\n \"Equal\" = \"eq\",\n \"Not equal\" = \"noeq\"\n )\n ),\n actionButton(NS(id, \"tTest\"), \"t test\")\n ),\n conditionalPanel(\n condition = \"input.TestsConditionedPanels == 'More than two groups'\",\n actionButton(NS(id, \"aovTest\"), \"anova\"),\n actionButton(NS(id, \"kruskalTest\"), \"kruskal wallis test\"),\n ),\n conditionalPanel(\n selectInput(NS(id, \"PostHocTests\"), \"Choose a Post Hoc test\",\n choices = c(\n \"Tukey HSD\" = \"HSD\", \"Kruskal Wallis post hoc test\" = \"kruskalTest\",\n \"Least significant difference test\" = \"LSD\",\n \"Scheffe post hoc test\" = \"scheffe\", \"REGW post hoc test\" = \"REGW\"\n )\n ),\n condition = \"input.TestsConditionedPanels == 'Posthoc tests'\",\n actionButton(NS(id, \"PostHocTest\"), \"run test\"),\n sliderInput(NS(id, \"pval\"), \"P-value\",\n min = 0, max = 0.15, value = 0.05\n ),\n selectInput(\n NS(id, \"design\"), \"Design\",\n c(\n \"Balanced\" = \"ba\",\n \"Unbalanced\" = \"ub\"\n )\n ),\n conditionalPanel(\n condition = \"input.PostHocTests == 'kruskalPHTest' || input.PostHocTests == 'lsdTest'\",\n selectInput(NS(id, \"padj\"), \"Adjusted p method\",\n c(\n \"Holm\" = \"holm\",\n \"Hommel\" = \"hommel\",\n \"Hochberg\" = \"hochberg\",\n \"Bonferroni\" = \"bonferroni\",\n \"BH\" = \"BH\",\n \"BY\" = \"BY\",\n \"fdr\" = \"fdr\"\n ),\n selectize = FALSE\n )\n )\n )\n )\n}\n\ntestsUI <- function(id) {\n fluidRow(\n tags$head(\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js\"),\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js\"),\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js\"),\n tags$script(src = \"download.js\")\n ),\n tabsetPanel(\n tabPanel(\n \"Two groups\",\n br(),\n ),\n tabPanel(\n \"More than two groups\",\n br(),\n ),\n tabPanel(\n \"Posthoc tests\",\n br(),\n ),\n id = \"TestsConditionedPanels\"\n ),\n h4(strong(\"Results of test:\")),\n tableOutput(NS(id, \"test_result\")),\n verbatimTextOutput(NS(id, \"test_error\")),\n actionButton(NS(id, \"test_save\"), \"Add output to result-file\"),\n actionButton(NS(id, \"download_test\"), \"Save results\"),\n checkboxGroupInput(NS(id, \"TableSaved\"), \"Saved results to file\", NULL)\n )\n}\n\ntestsServer <- function(id, data, listResults) {\n moduleServer(id, function(input, output, session) {\n tTest <- function() {\n output$test_error <- renderText(NULL)\n req(is.data.frame(data$df))\n df <- data$df\n req(input$indep)\n indep <- input$indep\n req(input$dep)\n dep <- input$dep\n formula <- NULL\n err <- NULL\n fit <- NULL\n e <- try({\n formula <- as.formula(paste(dep, \"~\", indep))\n stopifnot(get_ast(formula) != \"Error\")\n paired <- FALSE\n if (input$paired == \"p\") {\n paired <- TRUE\n }\n eq <- TRUE\n if (input$varEq == \"noeq\") {\n eq <- FALSE\n }\n fit <- broom::tidy(t.test(formula,\n data = df, conf.level = input$confLevel,\n alternative = input$alt, paired = paired, var.equal = eq\n ))\n })\n if (inherits(e, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n output$test_error <- renderText(err)\n } else {\n listResults$curr_data <- fit\n listResults$curr_name <- paste(\"Test Nr\", length(listResults$all_names) + 1, \"Conducted t-test\")\n output$test_result <- renderTable(fit, digits = 6)\n }\n }\n\n observeEvent(input$tTest, {\n tTest()\n })\n\n conductTests <- function(method) {\n output$test_error <- renderText(NULL)\n req(is.data.frame(data$df))\n df <- data$df\n req(input$indep)\n indep <- input$indep\n req(input$dep)\n dep <- input$dep\n formula <- NULL\n err <- NULL\n fit <- NULL\n e <- try({\n formula <- as.formula(paste(dep, \"~\", indep))\n stopifnot(get_ast(formula) != \"Error\")\n })\n if (inherits(e, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n output$test_error <- renderText(err)\n }\n if (is.null(err)) {\n e <- try({\n switch(method,\n aov = {\n fit <- broom::tidy(aov(formula, data = df))\n },\n kruskal = {\n fit <- broom::tidy(kruskal.test(formula, data = df))\n },\n HSD = {\n aov_res <- aov(formula, data = df)\n bal <- input$design\n req(bal)\n if (bal == \"Balanced\") {\n bal <- TRUE\n } else {\n bal <- FALSE\n }\n fit <- agricolae::HSD.test(aov_res,\n trt = indep,\n alpha = input$pval, group = TRUE, unbalanced = bal\n )$groups\n },\n kruskalTest = {\n fit <- with(df, kruskal(df[, dep], df[, indep]),\n alpha = input$pval, p.adj = input$padj, group = TRUE\n )$groups\n },\n LSD = {\n aov_res <- aov(formula, data = df)\n fit <- agricolae::LSD.test(aov_res,\n trt = indep,\n alpha = input$pval, p.adj = input$padj, group = TRUE\n )$groups\n },\n scheffe = {\n aov_res <- aov(formula, data = df)\n fit <- agricolae::scheffe.test(aov_res, trt = indep, alpha = input$pval, group = TRUE)$groups\n },\n REGW = {\n aov_res <- aov(formula, data = df)\n fit <- agricolae::REGW.test(aov_res, trt = indep, alpha = input$pval, group = TRUE)$groups\n }\n )\n })\n if (inherits(e, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n output$test_error <- renderText(err)\n } else if (is.null(fit)) {\n output$test_error <- renderText(\"Result is NULL\")\n } else {\n fit <- cbind(fit, row.names(fit))\n names(fit)[ncol(fit)] <- paste0(indep, collapse = \".\")\n listResults$curr_data <- fit\n listResults$curr_name <- paste(\"Test Nr\", length(listResults$all_names) + 1, \"Conducted: \", method)\n output$test_result <- renderTable(fit, digits = 6)\n }\n }\n }\n\n observeEvent(input$aovTest, {\n conductTests(\"aov\")\n })\n\n observeEvent(input$kruskalTest, {\n conductTests(\"kruskal\")\n })\n\n observeEvent(input$kruskalTest, {\n conductTests(\"kruskal\")\n })\n\n observeEvent(input$PostHocTest, {\n conductTests(input$PostHocTests)\n })\n\n observeEvent(input$test_save, {\n if (is.null(listResults$curr_name)) {\n return(NULL)\n }\n if (!(listResults$curr_name %in% unlist(listResults$all_names))) {\n listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data\n listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name\n }\n updateCheckboxGroupInput(session, \"TableSaved\",\n choices = listResults$all_names\n )\n })\n\n observeEvent(input$download_test, {\n lr <- unlist(listResults$all_names)\n indices <- sapply(input$TableSaved, function(x) {\n which(x == lr)\n })\n req(length(indices) >= 1)\n l <- listResults$all_data[indices]\n if (Sys.getenv(\"RUN_MODE\") == \"BROWSER\") {\n jsString <- createJSString(l)\n session$sendCustomMessage(\n type = \"downloadZip\",\n list(\n numberOfResults = length(jsString),\n FileContent = jsString\n )\n )\n } else if (Sys.getenv(\"RUN_MODE\") == \"SERVER\") {\n excelFile <- createExcelFile(l)\n upload(session, excelFile, new_name = \"Results.xlsx\") # TODO: add possibility for desired file name\n }\n })\n })\n\n return(listResults)\n}\n","type":"text"},{"name":"utils.R","content":"DF2String <- function(df) {\n resNames <- names(df)\n resNames <- paste(resNames, collapse = \"\\t\")\n resNames <- paste(resNames, \"\\n\")\n res <- apply(df, 1, function(x) {\n x <- as.character(x)\n x <- paste(x, collapse = \"\\t\")\n return(x)\n })\n res <- paste0(resNames, \"\\n\", res, collapse = \"\")\n res <- paste0(res, \"\\n\")\n}\n\nsetClass(\"plot\",\n slots = c(\n p = \"ANY\",\n width = \"numeric\",\n height = \"numeric\",\n resolution = \"numeric\"\n )\n)\n\nsetClass(\"diagnosticPlot\",\n slots = c(\n p = \"character\"\n )\n)\n\nsetClass(\"doseResponse\",\n slots = c(\n df = \"data.frame\",\n p = \"ANY\"\n )\n)\n\ncreateExcelFile <- function(l) {\n if (length(l) == 0) {\n showNotification(\"Nothing to upload\")\n return(NULL)\n }\n\n wb <- openxlsx::createWorkbook()\n addWorksheet(wb, \"Results\")\n\n curr_row <- 1\n plot_files <- c()\n # save data to excel file\n for (i in seq_along(l)) {\n if (inherits(l[[i]], \"plot\")) {\n p <- l[[i]]@p\n width <- l[[i]]@width\n height <- l[[i]]@height\n resolution <- l[[i]]@resolution\n fn <- tempfile(fileext = \".png\")\n ggsave(\n plot = p,\n filename = fn, width = width, height = height, dpi = resolution\n )\n openxlsx::insertImage(wb, \"Results\", fn, startRow = curr_row)\n curr_row <- curr_row + 20\n } else if (inherits(l[[i]], \"diagnosticPlot\")) {\n p <- l[[i]]@p\n width <- l[[i]]@width\n height <- l[[i]]@height\n resolution <- l[[i]]@resolution\n fn <- tempfile(fileext = \".png\")\n ggsave(\n plot = p,\n filename = fn, width = width, height = height, dpi = resolution\n )\n openxlsx::insertImage(wb, \"Results\", fn, startRow = curr_row)\n curr_row <- curr_row + 20\n plot_files <- c(plot_files, l[[i]]@p)\n } else if (inherits(l[[i]], \"doseResponse\")) {\n p <- l[[i]]@p\n fn <- tempfile(fileext = \".png\")\n ggsave(plot = p, filename = fn)\n jsString <- c(jsString, DF2String(l[[i]]@df))\n openxlsx::insertImage(wb, \"Results\", fn, startRow = curr_row)\n curr_row <- curr_row + 20\n } else if (inherits(l[[i]], \"data.frame\")) {\n openxlsx::writeData(wb, \"Results\", l[[i]], startRow = curr_row)\n curr_row <- curr_row + dim(l[[i]])[1] + 5\n } else if (is.character(l[[i]])) {\n openxlsx::writeData(wb, \"Results\", l[[i]], startRow = curr_row)\n curr_row <- curr_row + length(l[[i]])[1] + 5\n }\n }\n\n # create temporary file\n file <- function() {\n tempfile <- tempfile(tmpdir = \"/home/shiny/results\", fileext = \".xlsx\")\n return(tempfile)\n }\n fn <- file()\n\n\n # save workbook\n res <- tryCatch(\n expr = {\n openxlsx::saveWorkbook(wb, fn)\n },\n error = function(e) {\n showNotification(\"Error saving file\")\n }\n )\n\n # Clean up\n for (f in seq_along(plot_files)) {\n unlink(p)\n }\n\n return(fn)\n}\n\ncreateJSString <- function(l) {\n jsString <- c()\n for (i in seq_along(l)) {\n if (inherits(l[[i]], \"plot\")) {\n p <- l[[i]]@p\n width <- l[[i]]@width\n height <- l[[i]]@height\n resolution <- l[[i]]@resolution\n fn <- tempfile(fileext = \".png\")\n ggsave(\n plot = p,\n filename = fn, width = width, height = height, dpi = resolution\n )\n jsString <- c(jsString, paste0(\"data:image/png;base64,\", base64enc::base64encode(fn)))\n unlink(fn)\n } else if (inherits(l[[i]], \"diagnosticPlot\")) {\n jsString <- c(jsString, aste0(\"data:image/png;base64,\", base64enc::base64encode(l[[i]]@p)))\n unlink(l[[i]]@p)\n } else if (inherits(l[[i]], \"doseResponse\")) {\n p <- l[[i]]@p\n fn <- tempfile(fileext = \".png\")\n ggsave(plot = p, filename = fn)\n jsString <- c(jsString, paste0(\"data:image/png;base64,\", base64enc::base64encode(fn)))\n unlink(fn)\n jsString <- c(jsString, DF2String(l[[i]]@df))\n } else if (inherits(l[[i]], \"data.frame\")) {\n jsString <- c(jsString, DF2String(l[[i]]))\n } else if (is.character(l[[i]])) {\n jsString <- c(jsString, l[[i]])\n }\n }\n return(jsString)\n}\n\nstackDF <- function(df, keepCol) {\n as.data.frame(pivot_longer(df,\n cols = -keepCol,\n names_to = \"name\", values_to = \"value\"\n ))\n}\n\nunstackDF <- function(df, name, value) {\n df <- pivot_wider(df, names_from = name, values_from = value)\n df <- map(df, simplify) %>%\n as.data.frame()\n as.data.frame(df)\n}\n\ncorrectName <- function(name, df) {\n name %in% names(df)\n}\n\nchangeCharInput <- function(chars) {\n nams <- unlist(strsplit(chars, split = \",\"))\n for (i in 1:length(nams)) {\n nams[i] <- gsub(\" \", \"\", nams[i])\n }\n nams\n}\n\ncombine <- function(new, vec, df, first) {\n if (length(vec) == 0) {\n return(new)\n }\n if (correctName(vec[length(vec)], df)) {\n if (isTRUE(first)) {\n new <- df[, vec[length(vec)]]\n first <- FALSE\n } else {\n new <- interaction(new, df[, vec[length(vec)]])\n }\n }\n vec <- vec[-length(vec)]\n combine(new, vec, df, first)\n}\n\nsplitData <- function(df, formula) {\n df <- model.frame(formula, data = df)\n stopifnot(ncol(df) >= 2)\n res <- data.frame(value = df[, 1], interaction = interaction(df[, 2:ncol(df)]))\n names(res) <- c(\"value\", interaction = paste0(names(df)[2:ncol(df)], collapse = \".\"))\n res\n}\n\ndiagnosticPlot <- function(df, formula) {\n model <- lm(formula, data = df)\n f <- tempfile(fileext = \".png\")\n png(f)\n par(mfrow = c(3, 2))\n plot(model, 1)\n plot(model, 2)\n plot(model, 3)\n plot(model, 4)\n plot(model, 5)\n plot(model, 6)\n dev.off()\n return(f)\n}\n","type":"text"},{"name":"visualisation.R","content":"visSidebarUI <- function(id) {\n tabPanel(\n \"Visualisation\",\n textInput(NS(id, \"yVar\"), \"Y variable\", value = \"y\"),\n textInput(NS(id, \"xVar\"), \"X variable\", value = \"x\"),\n radioButtons(NS(id, \"xType\"), \"Type of x\",\n choices = c(\n factor = \"factor\",\n numeric = \"numeric\"\n ),\n selected = \"factor\"\n ),\n textInput(NS(id, \"xaxisText\"), \"X axis label\", value = \"x label\"),\n textInput(NS(id, \"yaxisText\"), \"Y axis label\", value = \"y label\"),\n conditionalPanel(\n condition = \"input.VisConditionedPanels == 'Scatterplot'\",\n selectInput(NS(id, \"fitMethod\"), \"Choose a fitting method\",\n c(\n \"none\" = \"none\",\n \"lm\" = \"lm\",\n \"glm\" = \"glm\",\n \"gam\" = \"gam\",\n \"loess\" = \"loess\"\n ),\n selectize = FALSE\n ),\n numericInput(NS(id, \"k\"), \"number of knots used by spline for gam\", value = 10)\n ),\n conditionalPanel(\n condition = \"input.VisConditionedPanels == 'Boxplot'\",\n textInput(NS(id, \"fill\"), \"Fill variable\"),\n textInput(NS(id, \"legendTitleFill\"), \"Legend title for fill\", value = \"Title fill\"),\n selectInput(NS(id, \"themeFill\"), \"Choose a 'fill' theme\",\n c(\n \"BuGn\" = \"BuGn\",\n \"PuRd\" = \"PuRd\",\n \"YlOrBr\" = \"YlOrBr\",\n \"Greens\" = \"Greens\",\n \"GnBu\" = \"GnBu\",\n \"Reds\" = \"Reds\",\n \"Oranges\" = \"Oranges\",\n \"Greys\" = \"Greys\"\n ),\n selectize = FALSE\n )\n ),\n textInput(NS(id, \"col\"), \"Colour variable\"),\n textInput(NS(id, \"legendTitleCol\"), \"Legend title for colour\", value = \"Title colour\"),\n selectInput(NS(id, \"theme\"), \"Choose a 'colour' theme\",\n c(\n \"Accent\" = \"Accent\",\n \"Dark2\" = \"Dark2\",\n \"Paired\" = \"Paired\",\n \"Pastel1\" = \"Pastel1\",\n \"Pastel2\" = \"Pastel2\",\n \"Set1\" = \"Set1\",\n \"Set2\" = \"Set2\",\n \"Set3\" = \"Set3\"\n ),\n selectize = FALSE\n ),\n radioButtons(NS(id, \"facetMode\"),\n \"Choose Facet Mode:\",\n choices = c(\"none\", \"facet_wrap\", \"facet_grid\")\n ),\n textInput(NS(id, \"facetBy\"), \"split plot by\")\n )\n}\n\nvisUI <- function(id) {\n fluidRow(\n tags$head(\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js\"),\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js\"),\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js\"),\n tags$script(src = \"download.js\"),\n ),\n br(),\n tabsetPanel(\n tabPanel(\n \"Boxplot\",\n br(),\n actionButton(NS(id, \"CreatePlotBox\"), \"Create plot\")\n ),\n tabPanel(\n \"Scatterplot\",\n br(),\n actionButton(NS(id, \"CreatePlotScatter\"), \"Create plot\")\n ),\n tabPanel(\n \"Lineplot\",\n br(),\n actionButton(NS(id, \"CreatePlotLine\"), \"Create plot\")\n ),\n id = \"VisConditionedPanels\"\n ),\n plotOutput(NS(id, \"plotResult\")),\n actionButton(NS(id, \"plotSave\"), \"Add output to result-file\"),\n checkboxGroupInput(NS(id, \"TableSaved\"), \"Saved results to file\", NULL),\n fluidRow(\n column(\n 4,\n numericInput(NS(id, \"widthPlot\"), \"Width of plot [cm]\", value = 10)\n ),\n column(\n 4,\n numericInput(NS(id, \"heightPlot\"), \"Height of plot [cm]\", value = 10)\n ),\n column(\n 4,\n numericInput(NS(id, \"resPlot\"), \"Resolution of plot\", value = 300)\n ),\n ),\n fluidRow(\n column(\n 12,\n actionButton(NS(id, \"downloadViss\"), \"Save results\")\n )\n )\n )\n}\n\nvisServer <- function(id, data, listResults) {\n moduleServer(id, function(input, output, session) {\n plotFct <- function(method) {\n req(is.data.frame(data$df))\n df <- data$df\n req(input$yVar)\n req(input$xVar)\n x <- input$xVar\n y <- input$yVar\n colNames <- names(df)\n checkX <- x %in% colNames\n checkY <- y %in% colNames\n if (!checkX) showNotification(\"X variable not found\", duration = 0)\n if (!checkY) showNotification(\"Y variable not found\", duration = 0)\n req(checkX)\n req(checkY)\n width <- input$widthPlot\n height <- input$heightPlot\n resolution <- input$resPlot\n if (width <= 0) {\n showNotification(paste(\"width has to be a positive number is changed to 10 cm\"), duration = 0)\n width <- 10\n }\n if (height <= 0) {\n showNotification(paste(\"height has to be a positive number is changed to 10 cm\"), duration = 0)\n height <- 10\n }\n if (width > 100) {\n showNotification(paste(\"width exceeds max value of 100 cm. Is set to 100 cm.\"), duration = 0)\n width <- 100\n }\n if (height > 100) {\n showNotification(paste(\"height exceeds max value of 100 cm. Is set to 100 cm.\"), duration = 0)\n height <- 100\n }\n col <- input$col\n fill <- input$fill\n if (!(fill %in% names(df)) && (fill != \"\")) showNotification(\"fill variable not found\", duration = 0)\n if (!(col %in% names(df)) && (col != \"\")) showNotification(\"colour variable not found\", duration = 0)\n req((fill %in% names(df)) || (fill == \"\"))\n req((col %in% names(df)) || (col == \"\"))\n fillTitle <- input$legendTitleFill\n colTitle <- input$legendTitleCol\n xlabel <- input$xaxisText\n ylabel <- input$yaxisText\n xtype <- input$xType\n theme <- input$theme\n themeFill <- input$themeFill\n facetMode <- input$facetMode\n facet <- input$facetBy\n fitMethod <- input$fitMethod\n\n xd <- NULL\n if (xtype == \"numeric\") {\n xd <- as.numeric(df[, x])\n } else {\n xd <- as.factor(df[, x])\n }\n yd <- as.numeric(df[, y])\n if (fitMethod != \"none\" && !is.null(fitMethod) && xtype != \"numeric\") {\n showNotification(\"Fit method will be ignored as X variable is not numerical\", duration = 0)\n fitMethod <- \"none\"\n }\n\n p <- tryCatch(\n {\n if (method == \"box\") {\n p <- BoxplotFct(\n df, x, y, xlabel, ylabel,\n fill, fillTitle, themeFill,\n col, colTitle, theme,\n facetMode, facet\n )\n } else if (method == \"dot\") {\n k <- NULL\n if (fitMethod == \"gam\") {\n req(input$k)\n k <- input$k\n if (k <= 0) {\n showNotification(\"k has to be at least 1 and is set to this value\")\n k <- 1\n }\n }\n p <- DotplotFct(\n df, x, y, xlabel, ylabel,\n fitMethod,\n col, colTitle, theme,\n facetMode, facet, k\n )\n } else if (method == \"line\") {\n p <- LineplotFct(\n df, x, y, xlabel, ylabel,\n col, colTitle, theme,\n facetMode, facet\n )\n }\n },\n warning = function(warn) {\n showNotification(paste(\"A warning occurred: \", conditionMessage(warn)), duration = 0)\n },\n error = function(err) {\n showNotification(paste(\"An error occurred: \", conditionMessage(err)), duration = 0)\n }\n )\n output$plotResult <- renderPlot(p)\n listResults$curr_data <- new(\"plot\", p = p, width = width, height = height, resolution = resolution)\n listResults$curr_name <- paste(\n \"Plot Nr\",\n length(listResults$all_names) + 1, paste(\"Type: \", method)\n )\n }\n\n observeEvent(input$CreatePlotBox, {\n req(is.data.frame(data$df))\n plotFct(\"box\")\n })\n output$plotResult <- renderPlot({\n renderPlot(listResults$curr_data)\n })\n\n observeEvent(input$CreatePlotScatter, {\n req(is.data.frame(data$df))\n plotFct(\"dot\")\n })\n output$plotResult <- renderPlot({\n renderPlot(listResults$curr_data)\n })\n\n observeEvent(input$CreatePlotLine, {\n req(is.data.frame(data$df))\n plotFct(\"line\")\n })\n output$plotResult <- renderPlot({\n renderPlot(listResults$curr_data)\n })\n\n observeEvent(input$plotSave, {\n if (is.null(listResults$curr_name)) {\n return(NULL)\n }\n if (!(listResults$curr_name %in% unlist(listResults$all_names))) {\n listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data\n listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name\n }\n updateCheckboxGroupInput(session, \"TableSaved\",\n choices = listResults$all_names\n )\n })\n\n observeEvent(input$downloadViss, {\n lr <- unlist(listResults$all_names)\n indices <- sapply(input$TableSaved, function(x) {\n which(x == lr)\n })\n req(length(indices) >= 1)\n l <- listResults$all_data[indices]\n if (Sys.getenv(\"RUN_MODE\") == \"BROWSER\") {\n jsString <- createJSString(l)\n session$sendCustomMessage(\n type = \"downloadZip\",\n list(\n numberOfResults = length(jsString),\n FileContent = jsString\n )\n )\n } else if (Sys.getenv(\"RUN_MODE\") == \"SERVER\") {\n excelFile <- createExcelFile(l)\n upload(session, excelFile, new_name = \"Results.xlsx\") # TODO: add possibility for desired file name\n }\n })\n })\n}\n","type":"text"},{"name":"www/download.js","content":"Shiny.addCustomMessageHandler('downloadZip', function(message) {\n var FileContent = message.FileContent;\n if( (typeof FileContent) == \"string\") {\n if (FileContent.startsWith(\"data:image\")) {\n var fileName = 'file' + (i + 1) + '.png'; \n var zip = new JSZip();\n var imageData = atob(FileContent.split(',')[1]);\n var byteArray = new Uint8Array(imageData.length);\n for (var i = 0; i < imageData.length; i++) {\n byteArray[i] = imageData.charCodeAt(i);\n }\n zip.file(fileName, byteArray, {binary: true});\n zip.generateAsync({type: 'blob'}).then(function(content) {\n saveAs(content, 'download.zip');\n });\n } else {\n var zipText = new JSZip();\n var fileNameText = 'file' + 1 + '.txt'; \n zipText.file(fileNameText, FileContent);\n zipText.generateAsync({type: 'blob'}).then(function(content) {\n saveAs(content, 'download.zip');\n });\n }\n } else {\n var zip = new JSZip();\n for (var i in FileContent) {\n if (FileContent[i].startsWith(\"data:image\")) {\n var fileName = 'file' + (i + 1) + '.png'; \n var imageData = atob(FileContent[i].split(',')[1]);\n var byteArray = new Uint8Array(imageData.length);\n for (var i = 0; i < imageData.length; i++) {\n byteArray[i] = imageData.charCodeAt(i);\n }\n zip.file(fileName, byteArray, {binary: true});\n } else {\n var fileName = 'file' + (i + 1) + '.txt'; \n zip.file(fileName, FileContent[i]); \n }\n }\n zip.generateAsync({type: 'blob'}).then(function(content) {\n saveAs(content, 'download.zip');\n });\n }\n});","type":"text"}] +[{"name":"app.R","content":"#' @import shiny\n#' @import shinyjs\n#' @import DT\n#' @export\nrun_app <- function() {\n ui <- fluidPage(\n useShinyjs(),\n includeScript(\"www/download.js\"), # NOTE: would be better located in inst folder but the serverless version cannot handle this\n sidebarLayout(\n sidebarPanel(\n conditionalPanel(\n condition = \"input.conditionedPanels == 'Data'\",\n uiOutput(\"conditional_data_ui\"),\n fileInput(\"file\", \"Choose CSV File\",\n accept = c(\n \"text/csv\",\n \"text/comma-separated-values,text/plain\",\n \".csv\"\n )\n ),\n textInput(\"op\", \"Operations\", value = \"var / 1000\"),\n textInput(\"new_col\", \"Name of new variable\", value = \"var\"),\n actionButton(\"mod\", \"Modify\"),\n tags$hr(),\n textInput(\"keepVar\", \"const variable\"),\n actionButton(\"pivotLonger\", \"conversion to long format\"),\n tags$hr(),\n textInput(\"name\", \"name column\"),\n textInput(\"value\", \"value column\"),\n actionButton(\"pivotWider\", \"convert to wide format\"),\n verbatimTextOutput(\"mod_error\"),\n tags$hr()\n ),\n conditionalPanel(\n condition = \"input.conditionedPanels == 'Correlation'\",\n corrSidebarUI(\"CORR\")\n ),\n conditionalPanel(\n condition = \"input.conditionedPanels == 'Visualisation'\",\n visSidebarUI(\"VIS\")\n ),\n conditionalPanel(\n condition = \"input.conditionedPanels == 'Assumption'\",\n assSidebarUI(\"ASS\")\n ),\n conditionalPanel(\n condition = \"input.conditionedPanels == 'Tests'\",\n testsSidebarUI(\"TESTS\")\n ),\n conditionalPanel(\n condition = \"input.conditionedPanels == 'Dose Response analysis'\",\n DoseResponseSidebarUI(\"DOSERESPONSE\")\n )\n ),\n mainPanel(\n tabsetPanel(\n tabPanel(\n \"Data\",\n DTOutput(\"df\")\n ),\n tabPanel(\n \"Correlation\",\n corrUI(\"CORR\")\n ),\n tabPanel(\n \"Visualisation\",\n visUI(\"VIS\")\n ),\n tabPanel(\n \"Assumption\",\n assUI(\"ASS\")\n ),\n tabPanel(\n \"Tests\",\n testsUI(\"TESTS\")\n ),\n tabPanel(\n \"Dose Response analysis\",\n DoseResponseUI(\"DOSERESPONSE\")\n ),\n id = \"conditionedPanels\"\n )\n )\n )\n )\n\n server <- function(input, output, session) {\n dataSet <- reactiveValues(df = NULL)\n\n output$conditional_data_ui <- renderUI({\n if (Sys.getenv(\"RUN_MODE\") != \"SERVER\") {\n res <- conditionalPanel(\n condition = \"input.conditionedPanels == 'Data'\",\n fileInput(\"file\", \"Choose CSV File\",\n accept = c(\n \"text/csv\",\n \"text/comma-separated-values,text/plain\",\n \".csv\"\n )\n )\n )\n return(res)\n }\n })\n\n download_file <- reactive({\n file <- COMELN::download(session, \"/home/shiny/results\")\n upload <- function(path) {\n stopifnot(is.character(path))\n df <- NULL\n df <- try(as.data.frame(readxl::read_excel(\n path,\n col_names = TRUE\n )), silent = TRUE)\n if (class(df) == \"try-error\") {\n # identify seperator\n line <- readLines(path, n = 1)\n semicolon <- grepl(\";\", line)\n comma <- grepl(\",\", line)\n tab <- grepl(\"\\t\", line)\n seperator <- NULL\n if (semicolon == TRUE) {\n seperator <- \";\"\n } else if (comma == TRUE) {\n seperator <- \",\"\n } else if (tab == TRUE) {\n seperator <- \"\\t\"\n } else {\n return(\"error\")\n }\n df <- try(read.csv(path, header = TRUE, sep = seperator))\n if (class(df) == \"try-error\") {\n return(\"error\")\n }\n } else {\n f <- function(x) {\n options(warn = -1)\n x <- as.numeric(x)\n options(warn = 0)\n x <- x[!is.na(x)]\n length(x) > 0\n }\n check <- apply(df, 2, f)\n conv <- function(a, b) {\n if (a == TRUE) {\n return(as.numeric(b))\n }\n return(b)\n }\n df <- Map(conv, check, df)\n df <- data.frame(df)\n }\n return(df)\n }\n df <- NULL\n df <- upload(file)\n if (is.data.frame(df)) {\n var$df <- df\n } else {\n showNotification(\"File can not be used. Upload into R failed!\", duration = 0)\n }\n tryCatch(\n {\n system(paste(\"rm -r \", file))\n },\n warning = function(warn) {\n showNotification(paste(\"A warning occurred: \", conditionMessage(warn)), duration = 0)\n },\n error = function(err) {\n showNotification(paste(\"An error occurred: \", conditionMessage(err)), duration = 0)\n }\n )\n req(is.data.frame(df))\n return(df)\n })\n\n\n output$df <- renderDT({\n if (Sys.getenv(\"RUN_MODE\") == \"SERVER\") {\n isolate({\n dataSet$df <- download_file()\n })\n datatable(dataSet$df, options = list(pageLength = 10))\n } else {\n req(input$file)\n df <- try(read.csv(input$file$datapath))\n if (inherits(df, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n showNotification(err)\n return(NULL)\n }\n dataSet$df <- df\n req(!is.na(dataSet$df))\n datatable(dataSet$df, options = list(pageLength = 10))\n }\n })\n\n observeEvent(input$mod, {\n req(!is.null(dataSet$df))\n req(is.data.frame(dataSet$df))\n req(input$op)\n req(input$new_col)\n dt <- dataSet$df\n op <- input$op\n new_col <- input$new_col\n new <- NULL\n err <- NULL\n e <- try({\n ast <- get_ast(str2lang(op))\n ast <- ast[[length(ast)]]\n })\n if (e == \"Error\") {\n showNotification(\"Found unallowed function\")\n return()\n } else if (inherits(e, \"try-error\")) {\n showNotification(e)\n return()\n }\n e <- try({\n new <- with(dt, eval(parse(text = op)))\n dataSet$df[, new_col] <- new\n })\n if (inherits(e, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n }\n output$df <- renderDT(dataSet$df)\n output$mod_error <- renderText(err)\n return(df)\n })\n\n observeEvent(input$pivotLonger, {\n req(!is.null(dataSet$df))\n req(input$keepVar)\n err <- NULL\n e <- try({\n stopifnot(get_ast(str2lang(input$keepVar)) != \"Error\")\n dataSet$df <- stackDF(dataSet$df, input$keepVar)\n })\n if (inherits(e, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n }\n output$df <- renderDT(dataSet$df)\n output$mod_error <- renderText(err)\n return(df)\n })\n\n observeEvent(input$pivotWider, {\n req(!is.null(dataSet$df))\n req(input$name)\n req(input$value)\n err <- NULL\n e <- try({\n stopifnot(get_ast(str2lang(input$value)) != \"Error\")\n stopifnot(get_ast(str2lang(input$name)) != \"Error\")\n dataSet$df <- unstackDF(dataSet$df, input$name, input$value)\n })\n if (inherits(e, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n }\n output$df <- renderDT(dataSet$df)\n output$mod_error <- renderText(err)\n return(df)\n })\n\n listResults <- reactiveValues(\n curr_data = NULL, curr_name = NULL,\n all_data = list(), all_names = list()\n )\n corrServer(\"CORR\", dataSet, listResults)\n visServer(\"VIS\", dataSet, listResults)\n assServer(\"ASS\", dataSet, listResults)\n testsServer(\"TESTS\", dataSet, listResults)\n DoseResponseServer(\"DOSERESPONSE\", dataSet, listResults)\n }\n\n shinyApp(ui, server)\n}\n\nlibrary(shiny)\nlibrary(DT)\nlibrary(bslib)\nlibrary(broom)\nlibrary(ggplot2)\nlibrary(base64enc)\nlibrary(shinyjs)\nlibrary(mgcv)\nlibrary(RColorBrewer)\nlibrary(tidyr)\nlibrary(purrr)\nlibrary(agricolae)\nlibrary(drc)\nlibrary(cowplot)\nlibrary(MASS)\nlibrary(Matrix)\nlibrary(shinyjs)\n\nsource(\"check_ast.R\")\nsource(\"utils.R\")\nsource(\"plottingInternally.R\")\nsource(\"lc50.r\")\nsource(\"correlation.R\")\nsource(\"visualisation.R\")\nsource(\"assumption.R\")\nsource(\"statisticalTests.R\")\nsource(\"DoseResponse.R\")\n\nui <- fluidPage(\n useShinyjs(),\n includeScript(\"www/download.js\"), # NOTE: would be better located in inst folder but the serverless version cannot handle this\n sidebarLayout(\n sidebarPanel(\n conditionalPanel(\n condition = \"input.conditionedPanels == 'Data'\",\n uiOutput(\"conditional_data_ui\"),\n fileInput(\"file\", \"Choose CSV File\",\n accept = c(\n \"text/csv\",\n \"text/comma-separated-values,text/plain\",\n \".csv\"\n )\n ),\n textInput(\"op\", \"Operations\", value = \"var / 1000\"),\n textInput(\"new_col\", \"Name of new variable\", value = \"var\"),\n actionButton(\"mod\", \"Modify\"),\n tags$hr(),\n textInput(\"keepVar\", \"const variable\"),\n actionButton(\"pivotLonger\", \"conversion to long format\"),\n tags$hr(),\n textInput(\"name\", \"name column\"),\n textInput(\"value\", \"value column\"),\n actionButton(\"pivotWider\", \"convert to wide format\"),\n verbatimTextOutput(\"mod_error\"),\n tags$hr()\n ),\n conditionalPanel(\n condition = \"input.conditionedPanels == 'Correlation'\",\n corrSidebarUI(\"CORR\")\n ),\n conditionalPanel(\n condition = \"input.conditionedPanels == 'Visualisation'\",\n visSidebarUI(\"VIS\")\n ),\n conditionalPanel(\n condition = \"input.conditionedPanels == 'Assumption'\",\n assSidebarUI(\"ASS\")\n ),\n conditionalPanel(\n condition = \"input.conditionedPanels == 'Tests'\",\n testsSidebarUI(\"TESTS\")\n ),\n conditionalPanel(\n condition = \"input.conditionedPanels == 'Dose Response analysis'\",\n DoseResponseSidebarUI(\"DOSERESPONSE\")\n )\n ),\n mainPanel(\n tabsetPanel(\n tabPanel(\n \"Data\",\n DTOutput(\"df\")\n ),\n tabPanel(\n \"Correlation\",\n corrUI(\"CORR\")\n ),\n tabPanel(\n \"Visualisation\",\n visUI(\"VIS\")\n ),\n tabPanel(\n \"Assumption\",\n assUI(\"ASS\")\n ),\n tabPanel(\n \"Tests\",\n testsUI(\"TESTS\")\n ),\n tabPanel(\n \"Dose Response analysis\",\n DoseResponseUI(\"DOSERESPONSE\")\n ),\n id = \"conditionedPanels\"\n )\n )\n )\n)\n\nserver <- function(input, output, session) {\n dataSet <- reactiveValues(df = NULL)\n\n output$conditional_data_ui <- renderUI({\n if (Sys.getenv(\"RUN_MODE\") != \"SERVER\") {\n res <- conditionalPanel(\n condition = \"input.conditionedPanels == 'Data'\",\n fileInput(\"file\", \"Choose CSV File\",\n accept = c(\n \"text/csv\",\n \"text/comma-separated-values,text/plain\",\n \".csv\"\n )\n )\n )\n return(res)\n }\n })\n\n download_file <- reactive({\n file <- COMELN::download(session, \"/home/shiny/results\")\n upload <- function(path) {\n stopifnot(is.character(path))\n df <- NULL\n df <- try(as.data.frame(readxl::read_excel(\n path,\n col_names = TRUE\n )), silent = TRUE)\n if (class(df) == \"try-error\") {\n # identify seperator\n line <- readLines(path, n = 1)\n semicolon <- grepl(\";\", line)\n comma <- grepl(\",\", line)\n tab <- grepl(\"\\t\", line)\n seperator <- NULL\n if (semicolon == TRUE) {\n seperator <- \";\"\n } else if (comma == TRUE) {\n seperator <- \",\"\n } else if (tab == TRUE) {\n seperator <- \"\\t\"\n } else {\n return(\"error\")\n }\n df <- try(read.csv(path, header = TRUE, sep = seperator))\n if (class(df) == \"try-error\") {\n return(\"error\")\n }\n } else {\n f <- function(x) {\n options(warn = -1)\n x <- as.numeric(x)\n options(warn = 0)\n x <- x[!is.na(x)]\n length(x) > 0\n }\n check <- apply(df, 2, f)\n conv <- function(a, b) {\n if (a == TRUE) {\n return(as.numeric(b))\n }\n return(b)\n }\n df <- Map(conv, check, df)\n df <- data.frame(df)\n }\n return(df)\n }\n df <- NULL\n df <- upload(file)\n if (is.data.frame(df)) {\n var$df <- df\n } else {\n showNotification(\"File can not be used. Upload into R failed!\", duration = 0)\n }\n tryCatch(\n {\n system(paste(\"rm -r \", file))\n },\n warning = function(warn) {\n showNotification(paste(\"A warning occurred: \", conditionMessage(warn)), duration = 0)\n },\n error = function(err) {\n showNotification(paste(\"An error occurred: \", conditionMessage(err)), duration = 0)\n }\n )\n req(is.data.frame(df))\n return(df)\n })\n\n\n output$df <- renderDT({\n if (Sys.getenv(\"RUN_MODE\") == \"SERVER\") {\n isolate({\n dataSet$df <- download_file()\n })\n datatable(dataSet$df, options = list(pageLength = 10))\n } else {\n req(input$file)\n df <- try(read.csv(input$file$datapath))\n if (inherits(df, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n showNotification(err)\n return(NULL)\n }\n dataSet$df <- df\n req(!is.na(dataSet$df))\n datatable(dataSet$df, options = list(pageLength = 10))\n }\n })\n\n observeEvent(input$mod, {\n req(!is.null(dataSet$df))\n req(is.data.frame(dataSet$df))\n req(input$op)\n req(input$new_col)\n dt <- dataSet$df\n op <- input$op\n new_col <- input$new_col\n new <- NULL\n err <- NULL\n e <- try({\n ast <- get_ast(str2lang(op))\n ast <- ast[[length(ast)]]\n })\n if (e == \"Error\") {\n showNotification(\"Found unallowed function\")\n return()\n } else if (inherits(e, \"try-error\")) {\n showNotification(e)\n return()\n }\n e <- try({\n new <- with(dt, eval(parse(text = op)))\n dataSet$df[, new_col] <- new\n })\n if (inherits(e, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n }\n output$df <- renderDT(dataSet$df)\n output$mod_error <- renderText(err)\n return(df)\n })\n\n observeEvent(input$pivotLonger, {\n req(!is.null(dataSet$df))\n req(input$keepVar)\n err <- NULL\n e <- try({\n stopifnot(get_ast(str2lang(input$keepVar)) != \"Error\")\n dataSet$df <- stackDF(dataSet$df, input$keepVar)\n })\n if (inherits(e, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n }\n output$df <- renderDT(dataSet$df)\n output$mod_error <- renderText(err)\n return(df)\n })\n\n observeEvent(input$pivotWider, {\n req(!is.null(dataSet$df))\n req(input$name)\n req(input$value)\n err <- NULL\n e <- try({\n stopifnot(get_ast(str2lang(input$value)) != \"Error\")\n stopifnot(get_ast(str2lang(input$name)) != \"Error\")\n dataSet$df <- unstackDF(dataSet$df, input$name, input$value)\n })\n if (inherits(e, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n }\n output$df <- renderDT(dataSet$df)\n output$mod_error <- renderText(err)\n return(df)\n })\n\n listResults <- reactiveValues(\n curr_data = NULL, curr_name = NULL,\n all_data = list(), all_names = list()\n )\n corrServer(\"CORR\", dataSet, listResults)\n visServer(\"VIS\", dataSet, listResults)\n assServer(\"ASS\", dataSet, listResults)\n testsServer(\"TESTS\", dataSet, listResults)\n DoseResponseServer(\"DOSERESPONSE\", dataSet, listResults)\n}\n\nshinyApp(ui, server)\n\n# run_app()\n","type":"text"},{"name":"DoseResponse.R","content":"# df\n# abs_col\n# conc_col\n# substance_name_col,\n# negative_identifier,\n# positive_identifier\n# path <- system.file(\"data\", package = \"MTT\")\n# df <- read.csv(paste0(path, \"/ExampleData.txt\"))\n# ic50(df, \"abs\", \"conc\", \"names\", \"neg\", \"pos\")\n\n\n\nDoseResponseSidebarUI <- function(id) {\n tabPanel(\n \"Dose Response analysis\",\n textInput(NS(id, \"dep\"), \"dependent Variable\", value = \"abs\"),\n textInput(NS(id, \"indep\"), \"independent Variable\", value = \"conc\"),\n textInput(NS(id, \"substanceNames\"), \"names colum of dependent Variable\", value = \"names\"),\n textInput(NS(id, \"negIdentifier\"), \"identifier for the negative control\", value = \"neg\"),\n textInput(NS(id, \"posIdentifier\"), \"identifier for the positive control\", value = \"pos\"),\n actionButton(NS(id, \"ic50\"), \"conduct analysis\")\n )\n}\n\nDoseResponseUI <- function(id) {\n fluidRow(\n tags$head(\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js\"),\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js\"),\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js\"),\n tags$script(src = \"download.js\")\n ),\n h4(strong(\"Results of test:\")),\n actionButton(NS(id, \"dr_save\"), \"Add output to result-file\"),\n actionButton(NS(id, \"download_dr\"), \"Save results\"),\n checkboxGroupInput(NS(id, \"TableSaved\"), \"Saved results to file\", NULL),\n tableOutput(NS(id, \"dr_result\")),\n plotOutput(NS(id, \"dr_result_plot\")),\n verbatimTextOutput(NS(id, \"dr_error\"))\n )\n}\n\nDoseResponseServer <- function(id, data, listResults) {\n moduleServer(id, function(input, output, session) {\n drFct <- function() {\n output$dr_error <- renderText(NULL)\n req(is.data.frame(data$df))\n df <- data$df\n req(input$dep)\n req(input$indep)\n dep <- input$dep\n indep <- input$indep\n req(input$substanceNames)\n names <- input$substanceNames\n req(input$negIdentifier)\n neg <- input$negIdentifier\n req(input$posIdentifier)\n pos <- input$posIdentifier\n err <- NULL\n resDF <- NULL\n resPlot <- NULL\n e <- try({\n stopifnot(get_ast(str2lang(indep)) != \"Error\")\n stopifnot(get_ast(str2lang(dep)) != \"Error\")\n res <- ic50(df, dep, indep, names, neg, pos)\n stopifnot(!inherits(res, \"errorClass\"))\n resDF <- lapply(res, function(x) {\n if (inherits(x, \"errorClass\")) {\n return(NULL)\n }\n return(x[[1]])\n })\n resDF <- resDF[!is.null(resDF)]\n resDF <- resDF[!sapply(resDF, is.null)]\n resDF <- Reduce(rbind, resDF)\n resP <- lapply(res, function(x) {\n if (inherits(x, \"errorClass\")) {\n return(NULL)\n }\n return(x[[2]])\n })\n resP <- resP[!is.null(resP)]\n resP <- resP[!sapply(resP, is.null)]\n resPlot <- resP[[1]]\n if (length(resP) >= 2) {\n for (i in seq_along(2:length(resP))) {\n # if (i %% 4 == 0) {\n # resPlot <- resPlot / resP[[i]]\n # } else {\n resPlot <- resPlot + resP[[i]]\n # }\n }\n }\n })\n if (inherits(e, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n output$dr_error <- renderText(err)\n } else {\n listResults$curr_data <- new(\"doseResponse\", df = resDF, p = resPlot)\n listResults$curr_name <- paste(\"Test Nr\", length(listResults$all_names) + 1, \"Conducted dose response analysis\")\n output$dr_result <- renderTable(resDF, digits = 6)\n output$dr_result_plot <- renderPlot(resPlot)\n }\n }\n\n observeEvent(input$ic50, {\n drFct()\n })\n\n observeEvent(input$dr_save, {\n if (is.null(listResults$curr_name)) {\n return(NULL)\n }\n if (!(listResults$curr_name %in% unlist(listResults$all_names))) {\n listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data\n listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name\n }\n updateCheckboxGroupInput(session, \"TableSaved\",\n choices = listResults$all_names\n )\n })\n\n observeEvent(input$download_dr, {\n lr <- unlist(listResults$all_names)\n indices <- sapply(input$TableSaved, function(x) {\n which(x == lr)\n })\n req(length(indices) >= 1)\n l <- listResults$all_data[indices]\n if (Sys.getenv(\"RUN_MODE\") == \"SERVER\") {\n excelFile <- createExcelFile(l)\n upload(session, excelFile, new_name = \"Results.xlsx\") # TODO: add possibility for desired file name\n } else {\n jsString <- createJSString(l)\n session$sendCustomMessage(\n type = \"downloadZip\",\n list(\n numberOfResults = length(jsString),\n FileContent = jsString\n )\n )\n }\n })\n })\n\n return(listResults)\n}\n","type":"text"},{"name":"assumption.R","content":"assSidebarUI <- function(id) {\n tabPanel(\n \"Assumption\",\n tags$hr(),\n textInput(NS(id, \"dep\"), \"dependent Variable\", value = \"var1\"),\n textInput(NS(id, \"indep\"), \"independent Variable\", value = \"var2\"),\n tags$hr(),\n tags$div(\n class = \"header\", checked = NA,\n tags$h4(\n style = \"font-weight: bold;\",\n \"Test of normal distribution\"\n )\n ),\n actionButton(NS(id, \"shapiro\"), \"Shapiro test for individual groups\"),\n tags$hr(),\n actionButton(NS(id, \"shapiroResiduals\"), \"Shapiro test for residuals of linear model\"),\n tags$hr(),\n tags$div(\n class = \"header\", checked = NA,\n tags$h4(\n style = \"font-weight: bold;\",\n \"Test of variance homogenity\"\n )\n ),\n actionButton(NS(id, \"levene\"), \"Levene test\"),\n selectInput(NS(id, \"center\"), \"Data center of each group: mean or median\",\n c(\n \"Mean\" = \"mean\",\n \"Median\" = \"median\"\n ),\n selectize = FALSE\n ),\n tags$hr(),\n tags$div(\n class = \"header\", checked = NA,\n tags$h4(style = \"font-weight: bold;\", \"Visual tests\")\n ),\n actionButton(NS(id, \"DiagnosticPlot\"), \"diagnostic plots\")\n )\n}\n\nassUI <- function(id) {\n fluidRow(\n tags$head(\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js\"),\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js\"),\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js\"),\n tags$script(src = \"download.js\")\n ),\n h4(strong(\"Results of test:\")),\n verbatimTextOutput(NS(id, \"ass_error\")),\n actionButton(NS(id, \"ass_save\"), \"Add output to result-file\"),\n actionButton(NS(id, \"download_ass\"), \"Save and exit\"),\n checkboxGroupInput(NS(id, \"TableSaved\"), \"Saved results to file\", NULL),\n tableOutput(NS(id, \"ass_result\")),\n plotOutput(NS(id, \"DiagnosticPlotRes\"))\n )\n}\n\nassServer <- function(id, data, listResults) {\n moduleServer(id, function(input, output, session) {\n runShapiro <- function() {\n output$ass_error <- renderText(NULL)\n req(input$indep)\n req(input$dep)\n indep <- input$indep\n dep <- input$dep\n df <- data$df\n req(is.data.frame(df))\n check <- TRUE\n res <- NULL\n temp <- NULL\n err <- NULL\n if (isTRUE(check)) {\n res <- list()\n e <- try({\n formula <- as.formula(paste(dep, \"~\", indep))\n stopifnot(get_ast(formula) != \"Error\")\n dat <- splitData(df, formula)\n for (i in unique(dat[, 2])) {\n tempDat <- dat[dat[, 2] == i, ]\n temp <- broom::tidy(shapiro.test(tempDat[, 1]))\n if (!is.null(temp)) {\n temp$variable <- i\n res[[length(res) + 1]] <- temp\n }\n }\n res <- do.call(rbind, res)\n })\n if (!inherits(e, \"try-error\")) {\n listResults$curr_data <- res\n listResults$curr_name <- paste(\"Test Nr\", length(listResults$all_names) + 1, \"Conducted shapiro test\")\n output$curr_result <- renderTable(res, digits = 6)\n output$curr_error <- renderText(err)\n } else {\n err <- conditionMessage(attr(e, \"condition\"))\n output$ass_error <- renderText(err)\n }\n }\n }\n observeEvent(input$shapiro, {\n runShapiro()\n })\n\n runShapiroResiduals <- function() {\n output$ass_error <- renderText(NULL)\n req(input$indep)\n indep <- input$indep\n req(input$dep)\n dep <- input$dep\n df <- data$df\n req(is.data.frame(df))\n formula <- NULL\n err <- NULL\n res <- NULL\n e <- try({\n formula <- as.formula(paste(dep, \"~\", indep))\n stopifnot(get_ast(formula) != \"Error\")\n fit <- lm(formula, data = df)\n r <- resid(fit)\n res <- broom::tidy(shapiro.test(r))\n })\n if (!inherits(e, \"try-error\")) {\n listResults$curr_data <- res\n listResults$curr_name <- paste(\"Test Nr\", length(listResults$all_names) + 1, \"Conducted shapiro test\")\n output$curr_result <- renderTable(res, digits = 6)\n output$curr_error <- renderText(err)\n } else {\n err <- conditionMessage(attr(e, \"condition\"))\n output$ass_error <- renderText(err)\n }\n }\n observeEvent(input$shapiroResiduals, {\n runShapiroResiduals()\n })\n\n runLevene <- function() {\n output$ass_error <- renderText(NULL)\n req(input$indep)\n indep <- input$indep\n req(input$dep)\n dep <- input$dep\n df <- data$df\n req(is.data.frame(df))\n formula <- NULL\n err <- NULL\n fit <- NULL\n e <- try({\n formula <- as.formula(paste(dep, \"~\", indep))\n stopifnot(get_ast(formula) != \"Error\")\n fit <- broom::tidy(car::leveneTest(formula, data = df, center = input$center))\n })\n if (inherits(e, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n output$ass_error <- renderText(err)\n } else {\n listResults$curr_data <- fit\n listResults$curr_name <- paste(\"Test Nr\", length(listResults$all_names) + 1, \"variance homogenity (levene)\")\n output$curr_result <- renderTable(fit, digits = 6)\n output$curr_error <- renderText(err)\n }\n }\n observeEvent(input$levene, {\n runLevene()\n })\n\n output$ass_result <- renderTable(\n {\n if (!inherits(listResults$curr_data, \"diagnosticPlot\")) {\n return(listResults$curr_data)\n }\n return(NULL)\n },\n digits = 6\n )\n\n runDiagnosticPlot <- function() {\n output$ass_error <- renderText(NULL)\n req(input$indep)\n indep <- input$indep\n req(input$dep)\n dep <- input$dep\n df <- data$df\n req(is.data.frame(df))\n formula <- NULL\n err <- NULL\n f <- NULL\n e <- try({\n formula <- as.formula(paste(dep, \"~\", indep))\n stopifnot(get_ast(formula) != \"Error\")\n f <- diagnosticPlot(df, formula)\n })\n if (inherits(e, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n output$ass_error <- renderText(err)\n } else {\n listResults$curr_data <- new(\"diagnosticPlot\", p = f)\n listResults$curr_name <- paste(\"Test Nr\", length(listResults$all_names) + 1, \"diagnostic plots\")\n output$DiagnosticPlotRes <- renderImage(\n {\n list(\n src = f,\n contentType = \"image/png\"\n )\n },\n deleteFile = FALSE\n )\n output$curr_error <- renderText(err)\n }\n }\n observeEvent(input$DiagnosticPlot, {\n runDiagnosticPlot()\n })\n\n observeEvent(input$ass_save, {\n if (is.null(listResults$curr_name)) {\n return(NULL)\n }\n if (!(listResults$curr_name %in% unlist(listResults$all_names))) {\n listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data\n listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name\n }\n updateCheckboxGroupInput(session, \"TableSaved\",\n choices = listResults$all_names\n )\n })\n\n observeEvent(input$download_ass, {\n lr <- unlist(listResults$all_names)\n indices <- sapply(input$TableSaved, function(x) {\n which(x == lr)\n })\n req(length(indices) >= 1)\n l <- listResults$all_data[indices]\n\n if (Sys.getenv(\"RUN_MODE\") == \"SERVER\") {\n excelFile <- createExcelFile(l)\n upload(session, excelFile, new_name = \"Results.xlsx\") # TODO: add possibility for desired file name\n } else {\n jsString <- createJSString(l)\n session$sendCustomMessage(\n type = \"downloadZip\",\n list(\n numberOfResults = length(jsString),\n FileContent = jsString\n )\n )\n }\n })\n })\n\n return(listResults)\n}\n","type":"text"},{"name":"check_ast.R","content":"get_ast <- function(inp) {\n if (!is.call(inp)) {\n return(inp)\n }\n\n inp <- as.list(inp)\n\n # check if is function\n fct <- inp[[1]]\n\n allowed_fcts <- c(\n \"-\", \"+\", \"*\", \"/\",\n \"log\", \"log10\", \"sqrt\", \"exp\", \"^\",\n \"sin\", \"cos\", \"tan\", \"tanh\", \"sinh\", \"cosh\", \"acos\", \"asin\", \"atan\",\n \"is.numeric\", \"is.character\", \"is.logical\", \"is.factor\", \"is.integer\",\n \"as.numeric\", \"as.character\", \"as.logical\", \"as.factor\", \"as.integer\",\n \">\", \"<\", \"<=\", \">=\", \"==\", \"!=\",\n \"abs\", \"ceiling\", \"floor\", \"trunc\", \"round\",\n \"grep\", \"substr\", \"sub\", \"paste\", \"paste0\",\n \"strsplit\", \"tolower\", \"toupper\",\n \"dnorm\", \"pnorm\", \"qnorm\", \"rnorm\", \"dbinom\",\n \"pbinom\", \"qbinom\", \"rbinom\", \"dpois\",\n \"ppois\", \"rpois\", \"dunif\", \"punif\", \"qunif\", \"runif\",\n \"mean\", \"sd\", \"median\", \"quantile\", \"range\",\n \"sum\", \"diff\", \"min\", \"max\", \"scale\",\n \"c\", \"vector\", \"length\", \"matrix\", \"~\"\n )\n\n check <- deparse(fct)\n\n if ((check %in% allowed_fcts) == FALSE) {\n return(\"Error\")\n }\n\n lapply(inp, get_ast)\n}\n","type":"text"},{"name":"correlation.R","content":"corrSidebarUI <- function(id) {\n tabPanel(\n \"Correlation\",\n textInput(NS(id, \"dep\"), \"dependent Variable\", value = \"var1\"),\n textInput(NS(id, \"indep\"), \"independent Variable\", value = \"var2\"),\n actionButton(NS(id, \"pear\"), \"Pearson correlation\"),\n actionButton(NS(id, \"spear\"), \"Spearman correlation\"),\n actionButton(NS(id, \"kendall\"), \"Kendall correlation\"),\n sliderInput(NS(id, \"conflevel\"), \"Confidence level of the interval\",\n min = 0, max = 1, value = 0.95\n ),\n selectInput(\n NS(id, \"alt\"), \"Alternative hypothesis\",\n c(\n \"Two sided\" = \"two.sided\",\n \"Less\" = \"less\",\n \"Greater\" = \"greater\"\n )\n )\n )\n}\n\ncorrUI <- function(id) {\n fluidRow(\n tags$head(\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js\"),\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js\"),\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js\"),\n tags$script(src = \"download.js\")\n ),\n h4(strong(\"Results of test:\")),\n tableOutput(NS(id, \"corr_result\")),\n verbatimTextOutput(NS(id, \"corr_error\")),\n actionButton(NS(id, \"corr_save\"), \"Add output to result-file\"),\n actionButton(NS(id, \"download_corr\"), \"Save results\"),\n checkboxGroupInput(NS(id, \"TableSaved\"), \"Saved results to file\", NULL)\n )\n}\n\ncorrServer <- function(id, data, listResults) {\n moduleServer(id, function(input, output, session) {\n corr_fct <- function(method) {\n output$corr_error <- renderText(NULL)\n req(is.data.frame(data$df))\n df <- data$df\n req(input$dep)\n req(input$indep)\n dep <- input$dep\n indep <- input$indep\n d <- df\n fit <- NULL\n err <- NULL\n e <- try({\n stopifnot(get_ast(str2lang(indep)) != \"Error\")\n stopifnot(get_ast(str2lang(dep)) != \"Error\")\n fit <- broom::tidy(\n cor.test(d[, dep], d[, indep],\n method = method,\n alternative = input$alt,\n conf.level = input$conflevel\n )\n )\n })\n if (inherits(e, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n output$corr_error <- renderText(err)\n } else {\n listResults$curr_data <- fit\n listResults$curr_name <- paste(\"Test Nr\", length(listResults$all_names) + 1, \"Conducted test: \", method)\n output$corr_result <- renderTable(fit, digits = 6)\n }\n }\n\n observeEvent(input$pear, {\n corr_fct(\"pearson\")\n })\n output$cor_result <- renderTable(\n {\n listResults$curr_data\n },\n digits = 6\n )\n\n observeEvent(input$spear, {\n corr_fct(\"spearman\")\n })\n output$cor_result <- renderTable(\n {\n listResults$curr_data\n },\n digits = 6\n )\n\n observeEvent(input$kendall, {\n corr_fct(\"kendall\")\n })\n output$cor_result <- renderTable(\n { # issue: check whether this is required\n listResults$curr_data\n },\n digits = 6\n )\n\n observeEvent(input$corr_save, {\n if (is.null(listResults$curr_name)) {\n return(NULL)\n }\n if (!(listResults$curr_name %in% unlist(listResults$all_names))) {\n listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data\n listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name\n }\n updateCheckboxGroupInput(session, \"TableSaved\",\n choices = listResults$all_names\n )\n })\n\n observeEvent(input$download_corr, {\n lr <- unlist(listResults$all_names)\n indices <- sapply(input$TableSaved, function(x) {\n which(x == lr)\n })\n req(length(indices) >= 1)\n l <- listResults$all_data[indices]\n if (Sys.getenv(\"RUN_MODE\") == \"SERVER\") {\n excelFile <- createExcelFile(l)\n upload(session, excelFile, new_name = \"Results.xlsx\") # TODO: add possibility for desired file name\n } else {\n jsString <- createJSString(l)\n session$sendCustomMessage(\n type = \"downloadZip\",\n list(\n numberOfResults = length(jsString),\n FileContent = jsString\n )\n )\n }\n })\n })\n\n return(listResults)\n}\n","type":"text"},{"name":"lc50.r","content":"errorClass <- R6::R6Class(\"errorClass\",\n public = list(\n error_message = NULL,\n object = NULL,\n initialize = function(error_message = NULL) {\n self$error_message = error_message\n },\n isNull = function() {\n if(is.null(self$error_message)) {\n return(TRUE)\n }\n return(FALSE)\n }\n )\n)\n\nshapenumber <- function (my.number) {\n if (is.finite(my.number)) {\n my.result <- signif(my.number,3) \n } else { \n my.result <- NA\n } \n return (my.result)\n}\n\n#calculates the robust 68th percentile of the residuals\n#adapted from Motulsky HJ, Brown RE, BMC Bioinformatics 2006, 7:123\nrobust_68_percentile <- function (residuals) {\n res <- abs(residuals)\n res_sorted <- sort(res)\n res_percentiles <- (seq(1:length(res_sorted))/length(res_sorted))*100\n index <- min(which(res_percentiles > 68.25))\n x <- c(res_percentiles[index-1],res_percentiles[index])\n y <- c(res_sorted[index-1],res_sorted[index])\n m <- lm(y~x)\n x <- c(68.25)\n y <- predict(m, as.data.frame(x))\n return(y)\n}\n\n#calculates the robust standard deviation of the residuals (RSDR) with correction for degrees of freedom\n#adapted from Motulsky HJ, Brown RE, BMC Bioinformatics 2006, 7:123\nrobust_standard_deviation_residuals <- function(residuals, number_of_coefficients_fitted) {\n my_residuals <- as.numeric(residuals)\n my_residuals <- na.omit(residuals)\n N <- length(my_residuals) #the number of data points fitted\n K <- number_of_coefficients_fitted #for ic50, 4 coefficients are fitted\n result <- robust_68_percentile(residuals) * N/(N-K)\n return (result)\n}\n\n#false discovery rate (FDR) approach, returns a T/F vector for selection of valid data points\n#adapted from Motulsky HJ, Brown RE, BMC Bioinformatics 2006, 7:123\nfalse_discovery_rate <- function(res) {\n N <- length(res) \n Q <- 0.01 #Q=1%\n K <- 4 #number of coefficients in the fitted LL.4 model\n R <- robust_standard_deviation_residuals(res,K) #the robust standard deviation of the residuals\n id <- seq(1:length(res))\n df <- data.frame(id,res)\n df$res_abs <- abs(df$res)\n df <- df[order(df$res_abs),] \n df$i <- seq(1:N)\n df$i_fraction <- df$i / N\n df$alpha <- Q*(N-(df$i-1))/N\n df$t <- df$res_abs / R\n df$P <- dt(df$t, N-K)\n df$include <- ifelse(df$P < df$alpha & df$i_fraction >= 0.7, FALSE, TRUE)\n df2 <- df[order(df$id), ]\n return (df2$include)\n}\n\ncheck_fit <- function(model, min_conc, max_conc, min_abs, max_abs, substance_name) {\n if(model$fit$convergence != TRUE) return(errorClass$new(paste(substance_name,\n \"Model did not converge\")))\n b <- coefficients(model)[1] #Hill coefficient\n c <- coefficients(model)[2] #asymptote 1\n d <- coefficients(model)[3] #asymptote 2\n e <- coefficients(model)[4] #IC50\n RSE <- summary(model)$rseMat[1] #residual standard error estimated\n Response_lowestdose_predicted <- predict(model, data.frame(concentration = min_conc), se.fit = FALSE)[1]\n Response_highestdose_predicted <- predict(model, data.frame(concentration = max_conc), se.fit = FALSE)[1]\n Response_difference <- 100 * abs(Response_lowestdose_predicted - Response_highestdose_predicted)\n HillCoefficient <- b\n IC50_relative <- e \n pIC50 <- -log10(e/1000000)\n Problems <- \"\"\n if (Response_difference < 25) {\n Problems <- paste(Problems, \"Response Difference lower than 25%\", collapse = \" , \")\n } else if(IC50_relative > max_conc) {\n Problems <- paste(Problems, \"IC50 larger than highest measured concentration\", collapse = \" , \")\n } else if(IC50_relative < min_conc) {\n Problems <- paste(Problems, \"IC50 lower than lowest measured concentration\", collapse = \" , \")\n } \n \n confidence_interval <- confint(model, parm = c(\"e\"), level = 0.95)\n IC50_relative_lower <- confidence_interval[1] \n IC50_relative_higher <- confidence_interval[2]\n p_value <- noEffect(model)[3]\n Response_lowestdose_predicted <- shapenumber(Response_lowestdose_predicted)\n Response_highestdose_predicted <- shapenumber(Response_highestdose_predicted)\n HillCoefficient <- shapenumber(HillCoefficient) \n IC50_relative <- shapenumber(IC50_relative)\n IC50_relative_lower <- shapenumber(IC50_relative_lower)\n IC50_relative_higher <- shapenumber(IC50_relative_higher)\n pIC50 <- shapenumber( -log10(IC50_relative/1000000))\n p_value <- shapenumber(p_value)\n ylim_low = 0\n ylim_high = 125\n if (min_abs < ylim_low) ylim_low <- min_abs\n if (max_abs > ylim_high) ylim_high <- max_abs\n outvar <- data.frame(name = substance_name, \n Response_lowestdose_predicted = Response_lowestdose_predicted,\n Response_highestdose_predicted = Response_highestdose_predicted, \n HillCoefficient = HillCoefficient, \n asymptote_one = c, asymptote_two = d,\n IC50_relative = IC50_relative, IC50_relative_lower = IC50_relative_lower,\n IC50_relative_higher = IC50_relative_higher, pIC50 = pIC50, \n RSE = RSE, p_value = p_value, Problems = Problems)\n return (outvar)\n}\n\ndrawplot <- function(df, abs_col, conc_col, model, valid_points, title,\n IC50_relative, IC50_relative_lower, IC50_relative_higher) {\n min_conc <- min(df[, conc_col])\n max_conc <- max(df[, conc_col])\n grid <- seq(min_conc, max_conc, 0.1)\n plotFct <- (model$curve)[[1]]\n res <- plotFct(grid)\n data <- data.frame(abs = res,\n conc = grid)\n data_measured <- data.frame(conc = df[, conc_col], abs = df[, abs_col])\n p <- ggplot() +\n geom_boxplot(data = data_measured, aes(x = conc, y = abs*100, group = conc)) +\n geom_line(data = data, aes(x = conc, y = abs*100)) +\n xlab(\"Concentration [µM]\") +\n ylab(\"Viability [%]\") +\n ggtitle(title) \n \n max_conc <- max(df[, conc_col]) + 10\n min_conc <- -10\n xmin <- IC50_relative - IC50_relative_lower\n xmax <- IC50_relative + IC50_relative_higher\n if (!is.na(xmin) & !is.na(xmax)) {\n ymin <- min(df[, abs_col]) * 100\n ymax <- max(df[, abs_col]) * 100\n yrange <- ymax - ymin\n butt_height <- yrange * 0.1\n ymedian <- median(df[, abs_col]) * 100\n if (xmin > min_conc && xmax < max_conc ) {\n p <- p + geom_errorbarh(aes(xmin = xmin,\n xmax = xmax, y = ymedian),\n colour = \"darkred\", end = \"butt\", height = butt_height) \n } else {\n p <- p + labs(caption = \"Confidence intervall not in conc. range\") +\n theme(plot.caption = element_text(color = \"darkred\", face = \"italic\", size = 7))\n } \n } else {\n p <- p + labs(caption = \"Confidence intervall could not be calculated\") +\n theme(plot.caption = element_text(color = \"darkred\", face = \"italic\", size = 7))\n }\n \n return(p)\n}\n\nic50_internal <- function(df, abs, conc, title) {\n model <- drm(abs ~ conc, data = df , fct = LL.4(), robust = \"median\")\n valid_points <- false_discovery_rate(residuals(model))\n model <- drm(abs ~ conc, data = df , subset = valid_points, start = model$coefficients, fct = LL.4(), robust = \"mean\")\n res <- check_fit(model, min(df[, conc]), max(df[, conc]), min(df[, abs]), max(df[, abs]), title)\n p <- drawplot(df, abs, conc, model, valid_points, title, res$IC50_relative,\n res$IC50_relative_lower, res$IC50_relative_higher)\n return(list(res, p))\n}\n\ndrawplotOnlyRawData <- function(df, abs_col, conc_col, title) {\n min_conc <- min(df[, conc_col])\n max_conc <- max(df[, conc_col])\n data_measured <- data.frame(conc = df[, conc_col], abs = df[, abs_col])\n p <- ggplot() +\n geom_boxplot(data = data_measured, aes(x = conc, y = abs*100, group = conc)) +\n xlab(\"Concentration [µM]\") +\n ylab(\"Viability [%]\") +\n ggtitle(title) \n return(p)\n}\n\n#' Calculates the ic50 values\n#' @export\n#' @import drc\n#' @import ggplot2\n#' @param df a data.frame which contains all the data\n#' @param abs_col the name of the column in df which contains the dependent variable\n#' @param conc_col the name of the column in df which contains the different concentrations\n#' @param substance_name_col the name of the column in df which contains the different names of the compounds\n#' @param negative_identifier a character defining the name to identify the negative control within conc_col\n#' @param positive_identifier a character defining the name to identify the positive control within conc_col\n#' @return a list is returned containing the ic50 value the fitted plots and other parameters\n#' @examples\n#' path <- system.file(\"data\", package = \"MTT\")\n#' df <- read.csv(paste0(path, \"/ExampleData.txt\"))\n#' ic50(df, \"abs\", \"conc\", \"names\", \"neg\", \"pos\")\nic50 <- function(df, abs_col, conc_col, substance_name_col, negative_identifier, positive_identifier) {\n substances <- unique(df$names)\n\n if(!(negative_identifier %in% substances)) {\n return(errorClass$new(\"the string for the negative control was not found!\"))\n }\n if(!(positive_identifier %in% substances)) {\n return(errorClass$new(\"the string for the positive control was not found!\"))\n }\n substances <- substances[substances != negative_identifier]\n substances <- substances[substances != positive_identifier] \n if(length(substances) < 1) {\n return(errorClass$new(\"The data for compounds seems to be missing\"))\n }\n if(!is.numeric(df[, abs_col])) {\n return(errorClass$new(\"The absorbance data is not numerical\")) \n }\n temp_conc <- df[, conc_col]\n temp_conc[temp_conc == negative_identifier] <- -1\n temp_conc[temp_conc == positive_identifier] <- -2\n temp_conc <- as.numeric(temp_conc)\n if(any(is.na(temp_conc))) {\n return(errorClass$new(\"The concentration data cannot be converted to numerical\")) \n }\n df[, conc_col] <- temp_conc\n if(!is.numeric(df[, conc_col])) {\n return(errorClass$new(\"The concentration data is not numerical\")) \n }\n neg_mean <- mean(df[df[ , substance_name_col] == negative_identifier, abs_col])\n pos_mean <- mean(df[df[ , substance_name_col] == positive_identifier, abs_col])\n df[, abs_col] <- (df[, abs_col] - pos_mean) / neg_mean\n res <- list()\n for(i in seq_along(substances)) {\n df_temp <- df[df$names == substances[i], ]\n m <- tryCatch({\n m <- ic50_internal(df_temp, abs_col, conc_col, substances[i])\n }, \n error = function(err) {\n retval <- errorClass$new(paste(\"A warning occurred: \", conditionMessage(err)))\n retval$object <- drawplotOnlyRawData(df_temp, abs_col, conc_col, substances[i])\n return(retval)\n })\n res[[i]] <- m\n }\n \n return(res)\n}\n\nreport_plots <- function(ic50List) {\n p3 <- ggdraw() +\n draw_line(x = c(0, 1), y = c(0.5, 0.5), color = \"black\", size = 1) +\n theme_void()\n for(i in seq_along(ic50List)) {\n if(is(ic50List[[i]], \"errorClass\")) {\n p <- ic50List[[i]]$object\n p <- p + \n annotate(\"text\", x = -Inf, y = -Inf,\n hjust = -0.2, vjust = -1, label = ic50List[[i]]$error_message)\n #print(p)\n #print(p3)\n next\n }\n p1 <- ic50List[[i]][[2]]\n a <- ic50List[[i]][[1]] |> t() |> as.data.frame() \n a <- data.frame(names = row.names(a), Predicition = a)\n a[a$names == \"Response_lowestdose_predicted\", 1] <- \"Response_lowestdose\"\n a[a$names == \"Response_highestdose_predicted\", 1] <- \"Response_highestdose\"\n problem <- a[a$names == \"Problems\", 2]\n a <- a[(a$names != \"Problems\") & (a$names != \"name\"), ]\n p2 <- ggplot(a, aes(x = 0, y = factor(names), label = Prediction)) +\n geom_line(size = 0) +\n geom_text(position = position_nudge(x = -1.1), hjust = 0, size = 3) +\n theme_minimal() +\n theme(axis.text.x = element_blank(),\n axis.ticks.x = element_blank(),\n panel.grid.major.x = element_blank(),\n panel.grid.minor.x = element_blank(),\n panel.grid.major.y = element_blank(),\n panel.grid.minor.y = element_blank(),\n axis.title.x = element_blank(),\n axis.title.y = element_blank(),\n axis.text.y = element_text(hjust = 0, face = \"bold\"),\n axis.line.y = element_line(),\n plot.caption = element_text(hjust = 1, face = \"italic\", colour = \"darkred\", \n size = 7) ) \n if(problem != \"\") {\n p2 <- p2 + labs(caption = paste(\"Note:\", as.character(problem)) )\n }\n \n p <- ggdraw() +\n draw_plot(p2, x = 0, y = 0, width = 0.5, height = 0.5) +\n draw_plot(p1, x = 0.5, y = 0, width = 0.5, height = 0.5) \n #print(p)\n #print(p3)\n }\n}\n","type":"text"},{"name":"plottingInternally.R","content":"annotateDF <- function(p, method, level = 2) {\n pB <- ggplot_build(p)\n df <- pB$data[[1]]\n if (length(unique(df$PANEL)) > 1) {\n l <- pB$layout$layout\n l <- data.frame(PANEL = l$PANEL, names = l$``)\n df$PANEL <- l[match(df$PANEL, l$PANEL), 2]\n }\n # https://stackoverflow.com/questions/40854225/how-to-identify-the-function-used-by-geom-smooth\n formula <- p$layers[[level]]$stat$setup_params(\n df,\n p$layers[[level]]$stat_params\n )$formula\n df$interaction <- interaction(df$PANEL, df$group)\n\n results <- lapply(unique(df$interaction), function(x) {\n sub <- df[df$interaction == x, ]\n calcParams(sub, formula, method)\n })\n df <- Reduce(rbind, results)\n return(df)\n}\n\ncalcParams <- function(df, formula, method) {\n stopifnot(get_ast(formula) != \"Error\")\n if (method == \"lm\") {\n model <- lm(formula, data = df)\n r_squared <- summary(model)$r.squared\n anova_table <- anova(model)\n f_value <- anova_table$`F value`[1]\n coefficients <- coef(model)\n equation <- paste(\n \"Y =\", round(coefficients[1], 2), \"+\",\n round(coefficients[2], 2), \"* X\"\n )\n p_value <- summary(model)$coefficients[, 4]\n p_value <- paste(p_value, collapse = \" \")\n n <- nrow(df)\n annotations <- paste(\n \"R-squared:\", round(r_squared, 2),\n \"F-value:\", round(f_value, 2), \"\\n\",\n \"Equation:\", equation, \"\\n\",\n \"Sample Size (n):\", n, \"\\n\",\n \"p-values Intercept & x:\", round(p_value, 6)\n )\n df$annotation <- annotations\n df$xPos <- mean(df$x)\n df$yPos <- max(df$y)\n return(df)\n } else if (method == \"glm\") {\n model <- glm(formula, data = df)\n r_squared <- with(summary(model), 1 - deviance / null.deviance)\n coefficients <- coef(model)\n n <- nrow(df)\n equation <- paste(\n \"Y =\", round(coefficients[1], 2), \"+\",\n round(coefficients[2], 2), \"* X\"\n )\n p_value <- summary(model)$coefficients[2, 4]\n annotations <- paste(\n \"R-squared:\", round(r_squared, 2),\n \"Sample Size (n):\", n, \"\\n\",\n \"Equation:\", equation, \"\\n\",\n \"p-value:\", round(p_value, 6)\n )\n df$annotation <- annotations\n df$xPos <- mean(df$x)\n df$yPos <- max(df$y)\n return(df)\n } else if (method == \"gam\") {\n model <- gam(formula, data = df)\n r_squared <- summary(model)$r.sq\n f_value <- summary(model)$p.t\n coefficients <- coef(model)\n n <- nrow(df)\n equation <- paste(\n \"Y =\", round(coefficients[1], 2), \"+\",\n round(coefficients[2], 2), \"* X\"\n )\n p_value <- summary(model)$p.pv\n annotations <- paste(\n \"R-squared:\", round(r_squared, 2),\n \"F-value:\", round(f_value, 2), \"\\n\",\n \"Equation:\", equation,\n \"Sample Size (n):\", n, \"\\n\",\n \"p-value:\", round(p_value, 6)\n )\n df$annotation <- annotations\n df$xPos <- mean(df$x)\n df$yPos <- max(df$y)\n return(df)\n } else if (method == \"loess\") {\n model <- loess(formula, data = df)\n fitted_values <- predict(model)\n r_squared <- cor(df$y, fitted_values)^2\n n <- nrow(df)\n annotations <- paste(\n \"R-squared:\", round(r_squared, 2),\n \"Sample Size (n):\", n\n )\n df$annotation <- annotations\n df$xPos <- mean(df$x)\n df$yPos <- max(df$y)\n return(df)\n }\n}\n\naddFacet <- function(p, facetVar, facetMode) {\n if (facetMode == \"facet_wrap\") {\n return(p + facet_wrap(. ~ .data[[facetVar]], scales = \"free\"))\n } else if (facetMode == \"facet_grid\") {\n return(p + facet_grid(. ~ .data[[facetVar]], scales = \"free\"))\n }\n}\n\nDotplotFct <- function(df, x, y, xLabel, yLabel,\n fitMethod,\n colourVar, legendTitleColour,\n colourTheme, facetMode, facetVar, k = 10) {\n # create plot\n # ==========================================\n aes <- aes(x = .data[[x]], y = .data[[y]])\n aesColour <- NULL\n p <- NULL\n\n if (colourVar != \"\") {\n aesColour <- aes(colour = .data[[colourVar]])\n }\n if (colourVar == \"\") {\n p <- ggplot(\n data = df,\n aes(!!!aes)\n ) +\n geom_point()\n } else {\n p <- ggplot(\n data = df,\n aes(!!!aes, !!!aesColour)\n ) +\n geom_point()\n }\n\n p <- p + xlab(xLabel)\n p <- p + ylab(yLabel)\n\n if (colourVar != \"\") {\n p <- p + guides(colour = guide_legend(title = legendTitleColour))\n p <- p + scale_color_brewer(palette = colourTheme)\n }\n\n if (facetMode != \"none\") {\n p <- addFacet(p, facetVar, facetMode)\n }\n\n if (fitMethod == \"none\" || fitMethod == \"\") {\n return(p)\n }\n\n # fit data\n # ==========================================\n if (fitMethod == \"gam\") {\n p <- p + geom_smooth(\n method = fitMethod,\n formula = y ~ s(x, bs = \"cs\", k = k)\n )\n } else {\n p <- p + geom_smooth(method = fitMethod)\n }\n\n # extract information from fit\n # ==========================================\n df_original <- df\n df <- annotateDF(p, fitMethod)\n names(df) <- ifelse(names(df) == \"PANEL\", \"Panel\", names(df))\n\n # TODO: this is a hack. Find a better way.\n if (colourVar != \"\") {\n df$colour_groups <- df_original[, colourVar][match(\n df$group,\n as.integer(factor(df_original[, colourVar]))\n )]\n }\n # Add annotations to plot\n # ==========================================\n aes <- aes(x = .data[[\"x\"]], y = .data[[\"y\"]])\n if (colourVar != \"\") {\n aesColour <- aes(colour = .data[[\"colour_groups\"]])\n }\n if (fitMethod == \"gam\") {\n p <- ggplot(data = df, aes(!!!aes, !!!aesColour)) +\n geom_point() +\n geom_smooth(\n method = fitMethod,\n formula = y ~ s(x, bs = \"cs\", k = k)\n ) +\n geom_text(\n aes(\n x = xPos, y = yPos,\n label = annotation\n ),\n size = 3,\n show.legend = FALSE, position = position_dodge(width = .9)\n )\n } else {\n p <- ggplot(data = df, aes(!!!aes, !!!aesColour)) +\n geom_point() +\n geom_smooth(method = fitMethod) +\n geom_text(\n aes(\n x = xPos, y = yPos,\n label = annotation\n ),\n size = 3,\n show.legend = FALSE, position = position_dodge(width = .9)\n )\n }\n\n # Add labels\n # ==========================================\n p <- p + xlab(xLabel)\n p <- p + ylab(yLabel)\n if (length(unique(df$colour)) >= 2) {\n p <- p + guides(colour = guide_legend(title = legendTitleColour))\n p <- p + scale_color_brewer(palette = colourTheme)\n }\n if (facetMode != \"none\") {\n p <- addFacet(p, \"Panel\", facetMode)\n }\n\n return(p)\n}\n\nBoxplotFct <- function(df, x, y, xLabel, yLabel,\n fillVar, legendTitleFill, fillTheme,\n colourVar, legendTitleColour,\n colourTheme, facetMode, facetVar) {\n aes <- aes(x = .data[[x]], y = .data[[y]])\n aesColour <- NULL\n aesFill <- NULL\n p <- NULL\n if (colourVar == \"\") {\n aesColour <- aes()\n } else {\n aesColour <- aes(colour = .data[[colourVar]])\n }\n if (fillVar == \"\") {\n aesFill <- aes()\n } else {\n aesFill <- aes(fill = .data[[fillVar]])\n }\n p <- ggplot() +\n geom_boxplot(\n data = df,\n aes(!!!aes, !!!aesColour, !!!aesFill,\n group = interaction(\n .data[[x]],\n !!!aesColour, !!!aesFill\n )\n )\n )\n p <- p + xlab(xLabel)\n p <- p + ylab(yLabel)\n p <- p + guides(fill = guide_legend(title = legendTitleFill))\n p <- p + guides(colour = guide_legend(title = legendTitleColour))\n p <- p + scale_fill_brewer(palette = fillTheme)\n p <- p + scale_color_brewer(palette = colourTheme)\n if (facetMode != \"none\") {\n p <- addFacet(p, facetVar, facetMode)\n }\n return(p)\n}\n\nLineplotFct <- function(df, x, y, xLabel, yLabel,\n colourVar, legendTitleColour,\n colourTheme, facetMode, facetVar) {\n aes <- aes(x = .data[[x]], y = .data[[y]])\n aesColour <- NULL\n p <- NULL\n if (colourVar == \"\") {\n aesColour <- aes()\n } else {\n aesColour <- aes(colour = .data[[colourVar]])\n }\n p <- ggplot() +\n geom_line(\n data = df,\n aes(!!!aes, !!!aesColour,\n group = interaction(\n .data[[x]],\n !!!aesColour\n )\n )\n )\n p <- p + xlab(xLabel)\n p <- p + ylab(yLabel)\n p <- p + guides(colour = guide_legend(title = legendTitleColour))\n p <- p + scale_color_brewer(palette = colourTheme)\n if (facetMode != \"none\") {\n p <- addFacet(p, facetVar, facetMode)\n }\n return(p)\n}\n","type":"text"},{"name":"statisticalTests.R","content":"testsSidebarUI <- function(id) {\n tabPanel(\n \"Tests\",\n textInput(NS(id, \"dep\"), \"dependent Variable\", value = \"var1\"),\n textInput(NS(id, \"indep\"), \"independent Variable\", value = \"var2\"),\n conditionalPanel(\n condition = \"input.TestsConditionedPanels == 'Two groups'\",\n sliderInput(NS(id, \"confLevel\"), \"Confidence level of the interval\",\n min = 0, max = 1, value = 0.95\n ),\n selectInput(\n NS(id, \"altHyp\"), \"Alternative hypothesis\",\n c(\n \"Two sided\" = \"two.sided\",\n \"Less\" = \"less\",\n \"Greater\" = \"greater\"\n )\n ),\n selectInput(\n NS(id, \"paired\"), \"Paired or unpaired t-test\",\n c(\n \"Unpaired\" = \"up\",\n \"Paired\" = \"p\"\n )\n ),\n selectInput(\n NS(id, \"varEq\"), \"Are the two variances treated as equal or not?\",\n c(\n \"Equal\" = \"eq\",\n \"Not equal\" = \"noeq\"\n )\n ),\n actionButton(NS(id, \"tTest\"), \"t test\")\n ),\n conditionalPanel(\n condition = \"input.TestsConditionedPanels == 'More than two groups'\",\n actionButton(NS(id, \"aovTest\"), \"anova\"),\n actionButton(NS(id, \"kruskalTest\"), \"kruskal wallis test\"),\n ),\n conditionalPanel(\n selectInput(NS(id, \"PostHocTests\"), \"Choose a Post Hoc test\",\n choices = c(\n \"Tukey HSD\" = \"HSD\", \"Kruskal Wallis post hoc test\" = \"kruskalTest\",\n \"Least significant difference test\" = \"LSD\",\n \"Scheffe post hoc test\" = \"scheffe\", \"REGW post hoc test\" = \"REGW\"\n )\n ),\n condition = \"input.TestsConditionedPanels == 'Posthoc tests'\",\n actionButton(NS(id, \"PostHocTest\"), \"run test\"),\n sliderInput(NS(id, \"pval\"), \"P-value\",\n min = 0, max = 0.15, value = 0.05\n ),\n selectInput(\n NS(id, \"design\"), \"Design\",\n c(\n \"Balanced\" = \"ba\",\n \"Unbalanced\" = \"ub\"\n )\n ),\n conditionalPanel(\n condition = \"input.PostHocTests == 'kruskalPHTest' || input.PostHocTests == 'lsdTest'\",\n selectInput(NS(id, \"padj\"), \"Adjusted p method\",\n c(\n \"Holm\" = \"holm\",\n \"Hommel\" = \"hommel\",\n \"Hochberg\" = \"hochberg\",\n \"Bonferroni\" = \"bonferroni\",\n \"BH\" = \"BH\",\n \"BY\" = \"BY\",\n \"fdr\" = \"fdr\"\n ),\n selectize = FALSE\n )\n )\n )\n )\n}\n\ntestsUI <- function(id) {\n fluidRow(\n tags$head(\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js\"),\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js\"),\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js\"),\n tags$script(src = \"download.js\")\n ),\n tabsetPanel(\n tabPanel(\n \"Two groups\",\n br(),\n ),\n tabPanel(\n \"More than two groups\",\n br(),\n ),\n tabPanel(\n \"Posthoc tests\",\n br(),\n ),\n id = \"TestsConditionedPanels\"\n ),\n h4(strong(\"Results of test:\")),\n tableOutput(NS(id, \"test_result\")),\n verbatimTextOutput(NS(id, \"test_error\")),\n actionButton(NS(id, \"test_save\"), \"Add output to result-file\"),\n actionButton(NS(id, \"download_test\"), \"Save results\"),\n checkboxGroupInput(NS(id, \"TableSaved\"), \"Saved results to file\", NULL)\n )\n}\n\ntestsServer <- function(id, data, listResults) {\n moduleServer(id, function(input, output, session) {\n tTest <- function() {\n output$test_error <- renderText(NULL)\n req(is.data.frame(data$df))\n df <- data$df\n req(input$indep)\n indep <- input$indep\n req(input$dep)\n dep <- input$dep\n formula <- NULL\n err <- NULL\n fit <- NULL\n e <- try({\n formula <- as.formula(paste(dep, \"~\", indep))\n stopifnot(get_ast(formula) != \"Error\")\n paired <- FALSE\n if (input$paired == \"p\") {\n paired <- TRUE\n }\n eq <- TRUE\n if (input$varEq == \"noeq\") {\n eq <- FALSE\n }\n fit <- broom::tidy(t.test(formula,\n data = df, conf.level = input$confLevel,\n alternative = input$alt, paired = paired, var.equal = eq\n ))\n })\n if (inherits(e, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n output$test_error <- renderText(err)\n } else {\n listResults$curr_data <- fit\n listResults$curr_name <- paste(\"Test Nr\", length(listResults$all_names) + 1, \"Conducted t-test\")\n output$test_result <- renderTable(fit, digits = 6)\n }\n }\n\n observeEvent(input$tTest, {\n tTest()\n })\n\n conductTests <- function(method) {\n output$test_error <- renderText(NULL)\n req(is.data.frame(data$df))\n df <- data$df\n req(input$indep)\n indep <- input$indep\n req(input$dep)\n dep <- input$dep\n formula <- NULL\n err <- NULL\n fit <- NULL\n e <- try({\n formula <- as.formula(paste(dep, \"~\", indep))\n stopifnot(get_ast(formula) != \"Error\")\n })\n if (inherits(e, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n output$test_error <- renderText(err)\n }\n if (is.null(err)) {\n e <- try({\n switch(method,\n aov = {\n fit <- broom::tidy(aov(formula, data = df))\n },\n kruskal = {\n fit <- broom::tidy(kruskal.test(formula, data = df))\n },\n HSD = {\n aov_res <- aov(formula, data = df)\n bal <- input$design\n req(bal)\n if (bal == \"Balanced\") {\n bal <- TRUE\n } else {\n bal <- FALSE\n }\n fit <- agricolae::HSD.test(aov_res,\n trt = indep,\n alpha = input$pval, group = TRUE, unbalanced = bal\n )$groups\n },\n kruskalTest = {\n fit <- with(df, kruskal(df[, dep], df[, indep]),\n alpha = input$pval, p.adj = input$padj, group = TRUE\n )$groups\n },\n LSD = {\n aov_res <- aov(formula, data = df)\n fit <- agricolae::LSD.test(aov_res,\n trt = indep,\n alpha = input$pval, p.adj = input$padj, group = TRUE\n )$groups\n },\n scheffe = {\n aov_res <- aov(formula, data = df)\n fit <- agricolae::scheffe.test(aov_res, trt = indep, alpha = input$pval, group = TRUE)$groups\n },\n REGW = {\n aov_res <- aov(formula, data = df)\n fit <- agricolae::REGW.test(aov_res, trt = indep, alpha = input$pval, group = TRUE)$groups\n }\n )\n })\n if (inherits(e, \"try-error\")) {\n err <- conditionMessage(attr(e, \"condition\"))\n output$test_error <- renderText(err)\n } else if (is.null(fit)) {\n output$test_error <- renderText(\"Result is NULL\")\n } else {\n fit <- cbind(fit, row.names(fit))\n names(fit)[ncol(fit)] <- paste0(indep, collapse = \".\")\n listResults$curr_data <- fit\n listResults$curr_name <- paste(\"Test Nr\", length(listResults$all_names) + 1, \"Conducted: \", method)\n output$test_result <- renderTable(fit, digits = 6)\n }\n }\n }\n\n observeEvent(input$aovTest, {\n conductTests(\"aov\")\n })\n\n observeEvent(input$kruskalTest, {\n conductTests(\"kruskal\")\n })\n\n observeEvent(input$kruskalTest, {\n conductTests(\"kruskal\")\n })\n\n observeEvent(input$PostHocTest, {\n conductTests(input$PostHocTests)\n })\n\n observeEvent(input$test_save, {\n if (is.null(listResults$curr_name)) {\n return(NULL)\n }\n if (!(listResults$curr_name %in% unlist(listResults$all_names))) {\n listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data\n listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name\n }\n updateCheckboxGroupInput(session, \"TableSaved\",\n choices = listResults$all_names\n )\n })\n\n observeEvent(input$download_test, {\n lr <- unlist(listResults$all_names)\n indices <- sapply(input$TableSaved, function(x) {\n which(x == lr)\n })\n req(length(indices) >= 1)\n l <- listResults$all_data[indices]\n if (Sys.getenv(\"RUN_MODE\") == \"SERVER\") {\n excelFile <- createExcelFile(l)\n upload(session, excelFile, new_name = \"Results.xlsx\") # TODO: add possibility for desired file name\n } else {\n jsString <- createJSString(l)\n session$sendCustomMessage(\n type = \"downloadZip\",\n list(\n numberOfResults = length(jsString),\n FileContent = jsString\n )\n )\n }\n })\n })\n\n return(listResults)\n}\n","type":"text"},{"name":"utils.R","content":"DF2String <- function(df) {\n resNames <- names(df)\n resNames <- paste(resNames, collapse = \"\\t\")\n resNames <- paste(resNames, \"\\n\")\n res <- apply(df, 1, function(x) {\n x <- as.character(x)\n x <- paste(x, collapse = \"\\t\")\n return(x)\n })\n res <- paste0(resNames, \"\\n\", res, collapse = \"\")\n res <- paste0(res, \"\\n\")\n}\n\nsetClass(\"plot\",\n slots = c(\n p = \"ANY\",\n width = \"numeric\",\n height = \"numeric\",\n resolution = \"numeric\"\n )\n)\n\nsetClass(\"diagnosticPlot\",\n slots = c(\n p = \"character\"\n )\n)\n\nsetClass(\"doseResponse\",\n slots = c(\n df = \"data.frame\",\n p = \"ANY\"\n )\n)\n\ncreateExcelFile <- function(l) {\n if (length(l) == 0) {\n showNotification(\"Nothing to upload\")\n return(NULL)\n }\n\n wb <- openxlsx::createWorkbook()\n addWorksheet(wb, \"Results\")\n\n curr_row <- 1\n plot_files <- c()\n # save data to excel file\n for (i in seq_along(l)) {\n if (inherits(l[[i]], \"plot\")) {\n p <- l[[i]]@p\n width <- l[[i]]@width\n height <- l[[i]]@height\n resolution <- l[[i]]@resolution\n fn <- tempfile(fileext = \".png\")\n ggsave(\n plot = p,\n filename = fn, width = width, height = height, dpi = resolution\n )\n openxlsx::insertImage(wb, \"Results\", fn, startRow = curr_row)\n curr_row <- curr_row + 20\n } else if (inherits(l[[i]], \"diagnosticPlot\")) {\n p <- l[[i]]@p\n width <- l[[i]]@width\n height <- l[[i]]@height\n resolution <- l[[i]]@resolution\n fn <- tempfile(fileext = \".png\")\n ggsave(\n plot = p,\n filename = fn, width = width, height = height, dpi = resolution\n )\n openxlsx::insertImage(wb, \"Results\", fn, startRow = curr_row)\n curr_row <- curr_row + 20\n plot_files <- c(plot_files, l[[i]]@p)\n } else if (inherits(l[[i]], \"doseResponse\")) {\n p <- l[[i]]@p\n fn <- tempfile(fileext = \".png\")\n ggsave(plot = p, filename = fn)\n jsString <- c(jsString, DF2String(l[[i]]@df))\n openxlsx::insertImage(wb, \"Results\", fn, startRow = curr_row)\n curr_row <- curr_row + 20\n } else if (inherits(l[[i]], \"data.frame\")) {\n openxlsx::writeData(wb, \"Results\", l[[i]], startRow = curr_row)\n curr_row <- curr_row + dim(l[[i]])[1] + 5\n } else if (is.character(l[[i]])) {\n openxlsx::writeData(wb, \"Results\", l[[i]], startRow = curr_row)\n curr_row <- curr_row + length(l[[i]])[1] + 5\n }\n }\n\n # create temporary file\n file <- function() {\n tempfile <- tempfile(tmpdir = \"/home/shiny/results\", fileext = \".xlsx\")\n return(tempfile)\n }\n fn <- file()\n\n\n # save workbook\n res <- tryCatch(\n expr = {\n openxlsx::saveWorkbook(wb, fn)\n },\n error = function(e) {\n showNotification(\"Error saving file\")\n }\n )\n\n # Clean up\n for (f in seq_along(plot_files)) {\n unlink(p)\n }\n\n return(fn)\n}\n\ncreateJSString <- function(l) {\n jsString <- c()\n for (i in seq_along(l)) {\n if (inherits(l[[i]], \"plot\")) {\n p <- l[[i]]@p\n width <- l[[i]]@width\n height <- l[[i]]@height\n resolution <- l[[i]]@resolution\n fn <- tempfile(fileext = \".png\")\n ggsave(\n plot = p,\n filename = fn, width = width, height = height, dpi = resolution\n )\n jsString <- c(jsString, paste0(\"data:image/png;base64,\", base64enc::base64encode(fn)))\n unlink(fn)\n } else if (inherits(l[[i]], \"diagnosticPlot\")) {\n jsString <- c(jsString, aste0(\"data:image/png;base64,\", base64enc::base64encode(l[[i]]@p)))\n unlink(l[[i]]@p)\n } else if (inherits(l[[i]], \"doseResponse\")) {\n p <- l[[i]]@p\n fn <- tempfile(fileext = \".png\")\n ggsave(plot = p, filename = fn)\n jsString <- c(jsString, paste0(\"data:image/png;base64,\", base64enc::base64encode(fn)))\n unlink(fn)\n jsString <- c(jsString, DF2String(l[[i]]@df))\n } else if (inherits(l[[i]], \"data.frame\")) {\n jsString <- c(jsString, DF2String(l[[i]]))\n } else if (is.character(l[[i]])) {\n jsString <- c(jsString, l[[i]])\n }\n }\n return(jsString)\n}\n\nstackDF <- function(df, keepCol) {\n as.data.frame(pivot_longer(df,\n cols = -keepCol,\n names_to = \"name\", values_to = \"value\"\n ))\n}\n\nunstackDF <- function(df, name, value) {\n df <- pivot_wider(df, names_from = name, values_from = value)\n df <- map(df, simplify) %>%\n as.data.frame()\n as.data.frame(df)\n}\n\ncorrectName <- function(name, df) {\n name %in% names(df)\n}\n\nchangeCharInput <- function(chars) {\n nams <- unlist(strsplit(chars, split = \",\"))\n for (i in 1:length(nams)) {\n nams[i] <- gsub(\" \", \"\", nams[i])\n }\n nams\n}\n\ncombine <- function(new, vec, df, first) {\n if (length(vec) == 0) {\n return(new)\n }\n if (correctName(vec[length(vec)], df)) {\n if (isTRUE(first)) {\n new <- df[, vec[length(vec)]]\n first <- FALSE\n } else {\n new <- interaction(new, df[, vec[length(vec)]])\n }\n }\n vec <- vec[-length(vec)]\n combine(new, vec, df, first)\n}\n\nsplitData <- function(df, formula) {\n df <- model.frame(formula, data = df)\n stopifnot(ncol(df) >= 2)\n res <- data.frame(value = df[, 1], interaction = interaction(df[, 2:ncol(df)]))\n names(res) <- c(\"value\", interaction = paste0(names(df)[2:ncol(df)], collapse = \".\"))\n res\n}\n\ndiagnosticPlot <- function(df, formula) {\n model <- lm(formula, data = df)\n f <- tempfile(fileext = \".png\")\n png(f)\n par(mfrow = c(3, 2))\n plot(model, 1)\n plot(model, 2)\n plot(model, 3)\n plot(model, 4)\n plot(model, 5)\n plot(model, 6)\n dev.off()\n return(f)\n}\n","type":"text"},{"name":"visualisation.R","content":"visSidebarUI <- function(id) {\n tabPanel(\n \"Visualisation\",\n textInput(NS(id, \"yVar\"), \"Y variable\", value = \"y\"),\n textInput(NS(id, \"xVar\"), \"X variable\", value = \"x\"),\n radioButtons(NS(id, \"xType\"), \"Type of x\",\n choices = c(\n factor = \"factor\",\n numeric = \"numeric\"\n ),\n selected = \"factor\"\n ),\n textInput(NS(id, \"xaxisText\"), \"X axis label\", value = \"x label\"),\n textInput(NS(id, \"yaxisText\"), \"Y axis label\", value = \"y label\"),\n conditionalPanel(\n condition = \"input.VisConditionedPanels == 'Scatterplot'\",\n selectInput(NS(id, \"fitMethod\"), \"Choose a fitting method\",\n c(\n \"none\" = \"none\",\n \"lm\" = \"lm\",\n \"glm\" = \"glm\",\n \"gam\" = \"gam\",\n \"loess\" = \"loess\"\n ),\n selectize = FALSE\n ),\n numericInput(NS(id, \"k\"), \"number of knots used by spline for gam\", value = 10)\n ),\n conditionalPanel(\n condition = \"input.VisConditionedPanels == 'Boxplot'\",\n textInput(NS(id, \"fill\"), \"Fill variable\"),\n textInput(NS(id, \"legendTitleFill\"), \"Legend title for fill\", value = \"Title fill\"),\n selectInput(NS(id, \"themeFill\"), \"Choose a 'fill' theme\",\n c(\n \"BuGn\" = \"BuGn\",\n \"PuRd\" = \"PuRd\",\n \"YlOrBr\" = \"YlOrBr\",\n \"Greens\" = \"Greens\",\n \"GnBu\" = \"GnBu\",\n \"Reds\" = \"Reds\",\n \"Oranges\" = \"Oranges\",\n \"Greys\" = \"Greys\"\n ),\n selectize = FALSE\n )\n ),\n textInput(NS(id, \"col\"), \"Colour variable\"),\n textInput(NS(id, \"legendTitleCol\"), \"Legend title for colour\", value = \"Title colour\"),\n selectInput(NS(id, \"theme\"), \"Choose a 'colour' theme\",\n c(\n \"Accent\" = \"Accent\",\n \"Dark2\" = \"Dark2\",\n \"Paired\" = \"Paired\",\n \"Pastel1\" = \"Pastel1\",\n \"Pastel2\" = \"Pastel2\",\n \"Set1\" = \"Set1\",\n \"Set2\" = \"Set2\",\n \"Set3\" = \"Set3\"\n ),\n selectize = FALSE\n ),\n radioButtons(NS(id, \"facetMode\"),\n \"Choose Facet Mode:\",\n choices = c(\"none\", \"facet_wrap\", \"facet_grid\")\n ),\n textInput(NS(id, \"facetBy\"), \"split plot by\")\n )\n}\n\nvisUI <- function(id) {\n fluidRow(\n tags$head(\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js\"),\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js\"),\n tags$script(src = \"https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js\"),\n tags$script(src = \"download.js\"),\n ),\n br(),\n tabsetPanel(\n tabPanel(\n \"Boxplot\",\n br(),\n actionButton(NS(id, \"CreatePlotBox\"), \"Create plot\")\n ),\n tabPanel(\n \"Scatterplot\",\n br(),\n actionButton(NS(id, \"CreatePlotScatter\"), \"Create plot\")\n ),\n tabPanel(\n \"Lineplot\",\n br(),\n actionButton(NS(id, \"CreatePlotLine\"), \"Create plot\")\n ),\n id = \"VisConditionedPanels\"\n ),\n plotOutput(NS(id, \"plotResult\")),\n actionButton(NS(id, \"plotSave\"), \"Add output to result-file\"),\n checkboxGroupInput(NS(id, \"TableSaved\"), \"Saved results to file\", NULL),\n fluidRow(\n column(\n 4,\n numericInput(NS(id, \"widthPlot\"), \"Width of plot [cm]\", value = 10)\n ),\n column(\n 4,\n numericInput(NS(id, \"heightPlot\"), \"Height of plot [cm]\", value = 10)\n ),\n column(\n 4,\n numericInput(NS(id, \"resPlot\"), \"Resolution of plot\", value = 300)\n ),\n ),\n fluidRow(\n column(\n 12,\n actionButton(NS(id, \"downloadViss\"), \"Save results\")\n )\n )\n )\n}\n\nvisServer <- function(id, data, listResults) {\n moduleServer(id, function(input, output, session) {\n plotFct <- function(method) {\n req(is.data.frame(data$df))\n df <- data$df\n req(input$yVar)\n req(input$xVar)\n x <- input$xVar\n y <- input$yVar\n colNames <- names(df)\n checkX <- x %in% colNames\n checkY <- y %in% colNames\n if (!checkX) showNotification(\"X variable not found\", duration = 0)\n if (!checkY) showNotification(\"Y variable not found\", duration = 0)\n req(checkX)\n req(checkY)\n width <- input$widthPlot\n height <- input$heightPlot\n resolution <- input$resPlot\n if (width <= 0) {\n showNotification(paste(\"width has to be a positive number is changed to 10 cm\"), duration = 0)\n width <- 10\n }\n if (height <= 0) {\n showNotification(paste(\"height has to be a positive number is changed to 10 cm\"), duration = 0)\n height <- 10\n }\n if (width > 100) {\n showNotification(paste(\"width exceeds max value of 100 cm. Is set to 100 cm.\"), duration = 0)\n width <- 100\n }\n if (height > 100) {\n showNotification(paste(\"height exceeds max value of 100 cm. Is set to 100 cm.\"), duration = 0)\n height <- 100\n }\n col <- input$col\n fill <- input$fill\n if (!(fill %in% names(df)) && (fill != \"\")) showNotification(\"fill variable not found\", duration = 0)\n if (!(col %in% names(df)) && (col != \"\")) showNotification(\"colour variable not found\", duration = 0)\n req((fill %in% names(df)) || (fill == \"\"))\n req((col %in% names(df)) || (col == \"\"))\n fillTitle <- input$legendTitleFill\n colTitle <- input$legendTitleCol\n xlabel <- input$xaxisText\n ylabel <- input$yaxisText\n xtype <- input$xType\n theme <- input$theme\n themeFill <- input$themeFill\n facetMode <- input$facetMode\n facet <- input$facetBy\n fitMethod <- input$fitMethod\n\n xd <- NULL\n if (xtype == \"numeric\") {\n xd <- as.numeric(df[, x])\n } else {\n xd <- as.factor(df[, x])\n }\n yd <- as.numeric(df[, y])\n if (fitMethod != \"none\" && !is.null(fitMethod) && xtype != \"numeric\") {\n showNotification(\"Fit method will be ignored as X variable is not numerical\", duration = 0)\n fitMethod <- \"none\"\n }\n\n p <- tryCatch(\n {\n if (method == \"box\") {\n p <- BoxplotFct(\n df, x, y, xlabel, ylabel,\n fill, fillTitle, themeFill,\n col, colTitle, theme,\n facetMode, facet\n )\n } else if (method == \"dot\") {\n k <- NULL\n if (fitMethod == \"gam\") {\n req(input$k)\n k <- input$k\n if (k <= 0) {\n showNotification(\"k has to be at least 1 and is set to this value\")\n k <- 1\n }\n }\n p <- DotplotFct(\n df, x, y, xlabel, ylabel,\n fitMethod,\n col, colTitle, theme,\n facetMode, facet, k\n )\n } else if (method == \"line\") {\n p <- LineplotFct(\n df, x, y, xlabel, ylabel,\n col, colTitle, theme,\n facetMode, facet\n )\n }\n },\n warning = function(warn) {\n showNotification(paste(\"A warning occurred: \", conditionMessage(warn)), duration = 0)\n },\n error = function(err) {\n showNotification(paste(\"An error occurred: \", conditionMessage(err)), duration = 0)\n }\n )\n output$plotResult <- renderPlot(p)\n listResults$curr_data <- new(\"plot\", p = p, width = width, height = height, resolution = resolution)\n listResults$curr_name <- paste(\n \"Plot Nr\",\n length(listResults$all_names) + 1, paste(\"Type: \", method)\n )\n }\n\n observeEvent(input$CreatePlotBox, {\n req(is.data.frame(data$df))\n plotFct(\"box\")\n })\n output$plotResult <- renderPlot({\n renderPlot(listResults$curr_data)\n })\n\n observeEvent(input$CreatePlotScatter, {\n req(is.data.frame(data$df))\n plotFct(\"dot\")\n })\n output$plotResult <- renderPlot({\n renderPlot(listResults$curr_data)\n })\n\n observeEvent(input$CreatePlotLine, {\n req(is.data.frame(data$df))\n plotFct(\"line\")\n })\n output$plotResult <- renderPlot({\n renderPlot(listResults$curr_data)\n })\n\n observeEvent(input$plotSave, {\n if (is.null(listResults$curr_name)) {\n return(NULL)\n }\n if (!(listResults$curr_name %in% unlist(listResults$all_names))) {\n listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data\n listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name\n }\n updateCheckboxGroupInput(session, \"TableSaved\",\n choices = listResults$all_names\n )\n })\n\n observeEvent(input$downloadViss, {\n lr <- unlist(listResults$all_names)\n indices <- sapply(input$TableSaved, function(x) {\n which(x == lr)\n })\n req(length(indices) >= 1)\n l <- listResults$all_data[indices]\n if (Sys.getenv(\"RUN_MODE\") == \"SERVER\") {\n excelFile <- createExcelFile(l)\n upload(session, excelFile, new_name = \"Results.xlsx\") # TODO: add possibility for desired file name\n } else {\n jsString <- createJSString(l)\n session$sendCustomMessage(\n type = \"downloadZip\",\n list(\n numberOfResults = length(jsString),\n FileContent = jsString\n )\n )\n }\n })\n })\n}\n","type":"text"},{"name":"www/download.js","content":"Shiny.addCustomMessageHandler('downloadZip', function(message) {\n var FileContent = message.FileContent;\n if( (typeof FileContent) == \"string\") {\n if (FileContent.startsWith(\"data:image\")) {\n var fileName = 'file' + (i + 1) + '.png'; \n var zip = new JSZip();\n var imageData = atob(FileContent.split(',')[1]);\n var byteArray = new Uint8Array(imageData.length);\n for (var i = 0; i < imageData.length; i++) {\n byteArray[i] = imageData.charCodeAt(i);\n }\n zip.file(fileName, byteArray, {binary: true});\n zip.generateAsync({type: 'blob'}).then(function(content) {\n saveAs(content, 'download.zip');\n });\n } else {\n var zipText = new JSZip();\n var fileNameText = 'file' + 1 + '.txt'; \n zipText.file(fileNameText, FileContent);\n zipText.generateAsync({type: 'blob'}).then(function(content) {\n saveAs(content, 'download.zip');\n });\n }\n } else {\n var zip = new JSZip();\n for (var i in FileContent) {\n if (FileContent[i].startsWith(\"data:image\")) {\n var fileName = 'file' + (i + 1) + '.png'; \n var imageData = atob(FileContent[i].split(',')[1]);\n var byteArray = new Uint8Array(imageData.length);\n for (var i = 0; i < imageData.length; i++) {\n byteArray[i] = imageData.charCodeAt(i);\n }\n zip.file(fileName, byteArray, {binary: true});\n } else {\n var fileName = 'file' + (i + 1) + '.txt'; \n zip.file(fileName, FileContent[i]); \n }\n }\n zip.generateAsync({type: 'blob'}).then(function(content) {\n saveAs(content, 'download.zip');\n });\n }\n});","type":"text"}]