diff --git a/App/DoseResponse.R b/App/DoseResponse.R new file mode 100644 index 0000000..9adf743 --- /dev/null +++ b/App/DoseResponse.R @@ -0,0 +1,141 @@ +# df +# abs_col +# conc_col +# substance_name_col, +# negative_identifier, +# positive_identifier +# path <- system.file("data", package = "MTT") +# df <- read.csv(paste0(path, "/ExampleData.txt")) +# ic50(df, "abs", "conc", "names", "neg", "pos") + + + +DoseResponseSidebarUI <- function(id) { + tabPanel( + "Dose Response analysis", + textInput(NS(id, "dep"), "dependent Variable", value = "abs"), + textInput(NS(id, "indep"), "independent Variable", value = "conc"), + textInput(NS(id, "substanceNames"), "names colum of dependent Variable", value = "names"), + textInput(NS(id, "negIdentifier"), "identifier for the negative control", value = "neg"), + textInput(NS(id, "posIdentifier"), "identifier for the positive control", value = "pos"), + actionButton(NS(id, "ic50"), "conduct analysis") + ) +} + +DoseResponseUI <- function(id) { + fluidRow( + tags$head( + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js"), + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js"), + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js"), + tags$script(src = "download.js") + ), + h4(strong("Results of test:")), + actionButton(NS(id, "dr_save"), "Add output to result-file"), + actionButton(NS(id, "download_dr"), "Save results"), + checkboxGroupInput(NS(id, "TableSaved"), "Saved results to file", NULL), + tableOutput(NS(id, "dr_result")), + plotOutput(NS(id, "dr_result_plot")), + verbatimTextOutput(NS(id, "dr_error")) + ) +} + +DoseResponseServer <- function(id, data, listResults) { + moduleServer(id, function(input, output, session) { + drFct <- function() { + output$dr_error<- renderText(NULL) + req(is.data.frame(data$df)) + df <- data$df + req(input$dep) + req(input$indep) + dep <- input$dep + indep <- input$indep + req(input$substanceNames) + names <- input$substanceNames + req(input$negIdentifier) + neg <- input$negIdentifier + req(input$posIdentifier) + pos <- input$posIdentifier + err <- NULL + resDF <- NULL + resPlot <- NULL + e <- try({ + stopifnot(get_ast(str2lang(indep)) != "Error") + stopifnot(get_ast(str2lang(dep)) != "Error") + res <- ic50(df, dep, indep, names, neg, pos) + stopifnot(!inherits(res, "errorClass")) + resDF <- lapply(res, function(x) { + if (inherits(x, "errorClass")) { + return(NULL) + } + return(x[[1]]) + }) + resDF <- resDF[!is.null(resDF)] + resDF <- resDF[!sapply(resDF, is.null)] + resDF <- Reduce(rbind, resDF) + resP <- lapply(res, function(x) { + if (inherits(x, "errorClass")) { + return(NULL) + } + return(x[[2]]) + }) + resP <- resP[!is.null(resP)] + resP <- resP[!sapply(resP, is.null)] + resPlot <- resP[[1]] + if (length(resP) >= 2) { + for (i in seq_along(2:length(resP))) { + # if (i %% 4 == 0) { + # resPlot <- resPlot / resP[[i]] + # } else { + resPlot <- resPlot + resP[[i]] + # } + } + } + }) + if (inherits(e, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + output$dr_error <- renderText(err) + } else { + listResults$curr_data <- new("doseResponse", df = resDF, p = resPlot) + listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted dose response analysis") + output$dr_result <- renderTable(resDF, digits = 6) + output$dr_result_plot <- renderPlot(resPlot) + } + } + + observeEvent(input$ic50, { + drFct() + }) + + observeEvent(input$dr_save, { + if(is.null(listResults$curr_name)) return(NULL) + if (!(listResults$curr_name %in% unlist(listResults$all_names)) ) { + listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data + listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name + } + updateCheckboxGroupInput(session, "TableSaved", + choices = listResults$all_names) + }) + + observeEvent(input$download_dr, { + lr <- unlist(listResults$all_names) + indices <- sapply(input$TableSaved, function(x) { + which(x == lr) + }) + req(length(indices) >= 1) + l <- listResults$all_data[indices] + jsString <- createJSString(l) + session$sendCustomMessage(type = "downloadZip", + list(numberOfResults = length(jsString), + FileContent = jsString)) + }) + + }) + + return(listResults) +} + + + + + diff --git a/App/app.R b/App/app.R new file mode 100644 index 0000000..f6ee776 --- /dev/null +++ b/App/app.R @@ -0,0 +1,300 @@ +library(shiny) +library(DT) +library(bslib) +library(broom) +library(utils) +library(ggplot2) +library(base64enc) +library(shinyjs) +library(mgcv) +library(RColorBrewer) +library(tidyr) +library(purrr) +library(agricolae) +library(drc) +library(cowplot) +library(patchwork) +library(httr) +library(readxl) +library(openxlsx) +library(COMELN) +library(openssl) +library(jose) +library(png) +library(ggpmisc) +library(R6) +library(drc) +library(patchwork) + + + +source("check_ast.R") +source("utils.R") +source("plottingInternally.R") +source("lc50.r") +source("correlation.R") +source("visualisation.R") +source("assumption.R") +source("statisticalTests.R") +source("DoseResponse.R") + +ui <- fluidPage( + useShinyjs(), + sidebarLayout( + sidebarPanel( + conditionalPanel( + condition = "input.conditionedPanels == 'Data'", + uiOutput("conditional_data_ui"), + textInput("op", "Operations", value = "var / 1000"), + textInput("new_col", "Name of new variable", value = "var"), + actionButton("mod", "Modify"), + tags$hr(), + textInput("keepVar", "const variable"), + actionButton("pivotLonger", "conversion to long format"), + tags$hr(), + textInput("name", "name column"), + textInput("value", "value column"), + actionButton("pivotWider", "convert to wide format"), + verbatimTextOutput("mod_error"), + tags$hr(), + helpText("Please upload a CSV file.") + ), + conditionalPanel( + condition = "input.conditionedPanels == 'Correlation'", + corrSidebarUI("CORR") + ), + conditionalPanel( + condition = "input.conditionedPanels == 'Visualisation'", + visSidebarUI("VIS") + ), + conditionalPanel( + condition = "input.conditionedPanels == 'Assumption'", + assSidebarUI("ASS") + ), + conditionalPanel( + condition = "input.conditionedPanels == 'Tests'", + testsSidebarUI("TESTS") + ), + conditionalPanel( + condition = "input.conditionedPanels == 'Dose Response analysis'", + DoseResponseSidebarUI("DOSERESPONSE") + ) + ), + mainPanel( + tabsetPanel( + tabPanel( + "Data", + DTOutput("df") + ), + tabPanel( + "Correlation", + corrUI("CORR") + ), + tabPanel( + "Visualisation", + visUI("VIS") + ), + tabPanel( + "Assumption", + assUI("ASS") + ), + tabPanel( + "Tests", + testsUI("TESTS") + ), + tabPanel( + "Dose Response analysis", + DoseResponseUI("DOSERESPONSE") + ), + id = "conditionedPanels" + ) + ) + ) +) + +server <- function(input, output, session) { + dataSet <- reactiveValues(df = NULL) + + output$conditional_data_ui <- renderUI({ + if (Sys.getenv("RUN_MODE") == "BROWSER") { + conditionalPanel( + condition = "input.conditionedPanels == 'Data'", + fileInput("file", "Choose CSV File", + accept = c( + "text/csv", + "text/comma-separated-values,text/plain", + ".csv" + ) + ) + ) + } + }) + + download_file <- reactive({ + file <- COMELN::download(session, "/home/shiny/results") + upload <- function(path) { + stopifnot(is.character(path)) + df <- NULL + df <- try(as.data.frame(read_excel(path, col_names = TRUE)), silent = TRUE) + if (class(df) == "try-error") { + # identify seperator + line <- readLines(path, n = 1) + semicolon <- grepl(";", line) + comma <- grepl(",", line) + tab <- grepl("\t", line) + seperator <- NULL + if (semicolon == TRUE) { + seperator <- ";" + } else if (comma == TRUE) { + seperator <- "," + } else if (tab == TRUE) { + seperator <- "\t" + } else { + return("error") + } + df <- try(read.csv(path, header = TRUE, sep = seperator)) + if (class(df) == "try-error") { + return("error") + } + } else { + f <- function(x) { + options(warn = -1) + x <- as.numeric(x) + options(warn = 0) + x <- x[!is.na(x)] + length(x) > 0 + } + check <- apply(df, 2, f) + conv <- function(a, b) { + if (a == TRUE) { + return(as.numeric(b)) + } + return(b) + } + df <- Map(conv, check, df) + df <- data.frame(df) + } + return(df) + } + df <- NULL + df <- upload(file) + if (is.data.frame(df)) { + var$df <- df + } else { + showNotification("File can not be used. Upload into R failed!", duration = 0) + } + tryCatch( + { + system(paste("rm -r ", file)) + }, + warning = function(warn) { + showNotification(paste("A warning occurred: ", conditionMessage(warn)), duration = 0) + }, + error = function(err) { + showNotification(paste("An error occurred: ", conditionMessage(err)), duration = 0) + } + ) + req(is.data.frame(df)) + return(df) + }) + + + output$df <- renderDT({ + if (Sys.getenv("RUN_MODE") == "BROWSER") { + req(input$file) + df <- try(read.csv(input$file$datapath)) + if (inherits(df, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + showNotification(err) + return(NULL) + } + dataSet$df <- df + req(!is.na(dataSet$df)) + datatable(dataSet$df, options = list(pageLength = 10)) + } else if (Sys.getenv("RUN_MODE") == "SERVER") { + isolate({ + dataSet$df <- download_file() + }) + datatable(dataSet$df, options = list(pageLength = 10)) + } + }) + + observeEvent(input$mod, { + req(!is.null(dataSet$df)) + req(is.data.frame(dataSet$df)) + req(input$op) + req(input$new_col) + dt <- dataSet$df + op <- input$op + new_col <- input$new_col + new <- NULL + err <- NULL + e <- try({ + ast <- get_ast(str2lang(op)) + ast <- ast[[length(ast)]] + }) + if (e == "Error") { + showNotification("Found unallowed function") + return() + } else if (inherits(e, "try-error")) { + showNotification(e) + return() + } + e <- try({ + new <- with(dt, eval(parse(text = op))) + dataSet$df[, new_col] <- new + }) + if (inherits(e, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + } + output$df <- renderDT(dataSet$df) + output$mod_error <- renderText(err) + return(df) + }) + + observeEvent(input$pivotLonger, { + req(!is.null(dataSet$df)) + req(input$keepVar) + err <- NULL + e <- try({ + stopifnot(get_ast(str2lang(input$keepVar)) != "Error") + dataSet$df <- stackDF(dataSet$df, input$keepVar) + }) + if (inherits(e, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + } + output$df <- renderDT(dataSet$df) + output$mod_error <- renderText(err) + return(df) + }) + + observeEvent(input$pivotWider, { + req(!is.null(dataSet$df)) + req(input$name) + req(input$value) + err <- NULL + e <- try({ + stopifnot(get_ast(str2lang(input$value)) != "Error") + stopifnot(get_ast(str2lang(input$name)) != "Error") + dataSet$df <- unstackDF(dataSet$df, input$name, input$value) + }) + if (inherits(e, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + } + output$df <- renderDT(dataSet$df) + output$mod_error <- renderText(err) + return(df) + }) + + listResults <- reactiveValues( + curr_data = NULL, curr_name = NULL, + all_data = list(), all_names = list() + ) + corrServer("CORR", dataSet, listResults) + visServer("VIS", dataSet, listResults) + assServer("ASS", dataSet, listResults) + testsServer("TESTS", dataSet, listResults) + DoseResponseServer("DOSERESPONSE", dataSet, listResults) +} + +shinyApp(ui, server) diff --git a/App/assumption.R b/App/assumption.R new file mode 100644 index 0000000..b63815e --- /dev/null +++ b/App/assumption.R @@ -0,0 +1,231 @@ +assSidebarUI <- function(id) { + tabPanel( + "Assumption", + tags$hr(), + textInput(NS(id, "dep"), "dependent Variable", value = "var1"), + textInput(NS(id, "indep"), "independent Variable", value = "var2"), + tags$hr(), + tags$div(class = "header", checked = NA, + tags$h4(style = "font-weight: bold;", + "Test of normal distribution") + ), + actionButton(NS(id, "shapiro"), "Shapiro test for individual groups"), + tags$hr(), + actionButton(NS(id, "shapiroResiduals"), "Shapiro test for residuals of linear model"), + tags$hr(), + tags$div(class = "header", checked = NA, + tags$h4(style = "font-weight: bold;", + "Test of variance homogenity") + ), + actionButton(NS(id, "levene"), "Levene test"), + selectInput(NS(id, "center"), "Data center of each group: mean or median", + c("Mean" = "mean", + "Median" = "median"), + selectize = FALSE), + tags$hr(), + tags$div(class = "header", checked = NA, + tags$h4(style = "font-weight: bold;", "Visual tests")), + actionButton(NS(id, "DiagnosticPlot"), "diagnostic plots") + ) +} + +assUI <- function(id) { + fluidRow( + tags$head( + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js"), + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js"), + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js"), + tags$script(src = "download.js") + ), + h4(strong("Results of test:")), + verbatimTextOutput(NS(id, "ass_error")), + actionButton(NS(id,"ass_save"), "Add output to result-file"), + actionButton(NS(id, "download_ass"), "Save and exit"), + checkboxGroupInput(NS(id,"TableSaved"), "Saved results to file", NULL), + tableOutput(NS(id, "ass_result")), + plotOutput(NS(id, "DiagnosticPlotRes")) + ) +} + +assServer <- function(id, data, listResults) { + moduleServer(id, function(input, output, session) { + + runShapiro <- function() { + output$ass_error <- renderText(NULL) + req(input$indep) + req(input$dep) + indep <- input$indep + dep <- input$dep + df <- data$df + req(is.data.frame(df)) + check <- TRUE + res <- NULL + temp <- NULL + err <- NULL + if (isTRUE(check)) { + res <- list() + e <- try({ + formula <- as.formula(paste(dep, "~", indep)) + stopifnot(get_ast(formula) != "Error") + dat <- splitData(df, formula) + for (i in unique(dat[, 2])) { + tempDat <- dat[dat[, 2] == i, ] + temp <- broom::tidy(shapiro.test(tempDat[, 1])) + if (!is.null(temp)) { + temp$variable <- i + res[[length(res) + 1]] <- temp + } + } + res <- do.call(rbind, res) + }) + if (!inherits(e, "try-error")) { + listResults$curr_data <- res + listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted shapiro test") + output$curr_result <- renderTable(res, digits = 6) + output$curr_error <- renderText(err) + } else { + err <- conditionMessage(attr(e, "condition")) + output$ass_error <- renderText(err) + } + } + } + observeEvent(input$shapiro, { + runShapiro() + }) + + runShapiroResiduals <- function() { + output$ass_error <- renderText(NULL) + req(input$indep) + indep <- input$indep + req(input$dep) + dep <- input$dep + df <- data$df + req(is.data.frame(df)) + formula <- NULL + err <- NULL + res <- NULL + e <- try({ + formula <- as.formula(paste(dep, "~", indep)) + stopifnot(get_ast(formula) != "Error") + fit <- lm(formula, data = df) + r <- resid(fit) + res <- broom::tidy(shapiro.test(r)) + }) + if (!inherits(e, "try-error")) { + listResults$curr_data <- res + listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted shapiro test") + output$curr_result <- renderTable(res, digits = 6) + output$curr_error <- renderText(err) + } else { + err <- conditionMessage(attr(e, "condition")) + output$ass_error <- renderText(err) + } + } + observeEvent(input$shapiroResiduals, { + runShapiroResiduals() + }) + + runLevene <- function() { + output$ass_error <- renderText(NULL) + req(input$indep) + indep <- input$indep + req(input$dep) + dep <- input$dep + df <- data$df + req(is.data.frame(df)) + formula <- NULL + err <- NULL + fit <- NULL + e <- try({ + formula <- as.formula(paste(dep, "~", indep)) + stopifnot(get_ast(formula) != "Error") + fit <- broom::tidy(car::leveneTest(formula, data = df, center = input$center)) + }) + if (inherits(e, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + output$ass_error <- renderText(err) + } else { + listResults$curr_data <- fit + listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "variance homogenity (levene)") + output$curr_result <- renderTable(fit, digits = 6) + output$curr_error <- renderText(err) + } + } + observeEvent(input$levene, { + runLevene() + }) + + output$ass_result <- renderTable({ + if (!inherits(listResults$curr_data, "diagnosticPlot")) { + return(listResults$curr_data) + } + return(NULL) + }, digits = 6) + + runDiagnosticPlot <- function() { + output$ass_error <- renderText(NULL) + req(input$indep) + indep <- input$indep + req(input$dep) + dep <- input$dep + df <- data$df + req(is.data.frame(df)) + formula <- NULL + err <- NULL + f <- NULL + e <- try({ + formula <- as.formula(paste(dep, "~", indep)) + stopifnot(get_ast(formula) != "Error") + f <- diagnosticPlot(df, formula) + }) + if (inherits(e, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + output$ass_error <- renderText(err) + } else { + listResults$curr_data <- new("diagnosticPlot", p = f) + listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "diagnostic plots") + output$DiagnosticPlotRes <- renderImage({ + list(src = f, + contentType = 'image/png' + )}, + deleteFile = FALSE + ) + output$curr_error <- renderText(err) + } + } + observeEvent(input$DiagnosticPlot, { + runDiagnosticPlot() + }) + + observeEvent(input$ass_save, { + if(is.null(listResults$curr_name)) return(NULL) + if (!(listResults$curr_name %in% unlist(listResults$all_names)) ) { + listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data + listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name + } + updateCheckboxGroupInput(session, "TableSaved", + choices = listResults$all_names) + }) + + observeEvent(input$download_ass, { + lr <- unlist(listResults$all_names) + indices <- sapply(input$TableSaved, function(x) { + which(x == lr) + }) + req(length(indices) >= 1) + l <- listResults$all_data[indices] + jsString <- createJSString(l) + session$sendCustomMessage(type = "downloadZip", + list(numberOfResults = length(jsString), + FileContent = jsString)) + }) + + }) + +return(listResults) +} + + + + + diff --git a/App/check_ast.R b/App/check_ast.R new file mode 100644 index 0000000..a492bd6 --- /dev/null +++ b/App/check_ast.R @@ -0,0 +1,36 @@ +get_ast <- function(inp) { + if (!is.call(inp)) { + return(inp) + } + + inp <- as.list(inp) + + # check if is function + fct <- inp[[1]] + + allowed_fcts <- c( + "-", "+", "*", "/", + "log", "log10", "sqrt", "exp", "^", + "sin", "cos", "tan", "tanh", "sinh", "cosh", "acos", "asin", "atan", + "is.numeric", "is.character", "is.logical", "is.factor", "is.integer", + "as.numeric", "as.character", "as.logical", "as.factor", "as.integer", + ">", "<", "<=", ">=", "==", "!=", + "abs", "ceiling", "floor", "trunc", "round", + "grep", "substr", "sub", "paste", "paste0", + "strsplit", "tolower", "toupper", + "dnorm", "pnorm", "qnorm", "rnorm", "dbinom", + "pbinom", "qbinom", "rbinom", "dpois", + "ppois", "rpois", "dunif", "punif", "qunif", "runif", + "mean", "sd", "median", "quantile", "range", + "sum", "diff", "min", "max", "scale", + "c", "vector", "length", "matrix", "~" + ) + + check <- deparse(fct) + + if ((check %in% allowed_fcts) == FALSE) { + return("Error") + } + + lapply(inp, get_ast) +} diff --git a/App/correlation.R b/App/correlation.R new file mode 100644 index 0000000..7b7d7d9 --- /dev/null +++ b/App/correlation.R @@ -0,0 +1,136 @@ +corrSidebarUI <- function(id) { + tabPanel( + "Correlation", + textInput(NS(id, "dep"), "dependent Variable", value = "var1"), + textInput(NS(id, "indep"), "independent Variable", value = "var2"), + actionButton(NS(id, "pear"), "Pearson correlation"), + actionButton(NS(id, "spear"), "Spearman correlation"), + actionButton(NS(id, "kendall"), "Kendall correlation"), + sliderInput(NS(id, "conflevel"), "Confidence level of the interval", + min = 0, max = 1, value = 0.95 + ), + selectInput( + NS(id, "alt"), "Alternative hypothesis", + c( + "Two sided" = "two.sided", + "Less" = "less", + "Greater" = "greater" + ) + ) + ) +} + +corrUI <- function(id) { + fluidRow( + tags$head( + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js"), + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js"), + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js"), + tags$script(src = "download.js") + ), + h4(strong("Results of test:")), + tableOutput(NS(id, "corr_result")), + verbatimTextOutput(NS(id, "corr_error")), + actionButton(NS(id, "corr_save"), "Add output to result-file"), + actionButton(NS(id, "download_corr"), "Save results"), + checkboxGroupInput(NS(id, "TableSaved"), "Saved results to file", NULL) + ) +} + +corrServer <- function(id, data, listResults) { + moduleServer(id, function(input, output, session) { + corr_fct <- function(method) { + output$corr_error <- renderText(NULL) + req(is.data.frame(data$df)) + df <- data$df + req(input$dep) + req(input$indep) + dep <- input$dep + indep <- input$indep + d <- df + fit <- NULL + err <- NULL + e <- try({ + stopifnot(get_ast(str2lang(indep)) != "Error") + stopifnot(get_ast(str2lang(dep)) != "Error") + fit <- broom::tidy( + cor.test(d[, dep], d[, indep], + method = method, + alternative = input$alt, + conf.level = input$conflevel + ) + ) + }) + if (inherits(e, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + output$corr_error <- renderText(err) + } else { + listResults$curr_data <- fit + listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted test: ", method) + output$corr_result <- renderTable(fit, digits = 6) + } + } + + observeEvent(input$pear, { + corr_fct("pearson") + }) + output$cor_result <- renderTable( + { + listResults$curr_data + }, + digits = 6 + ) + + observeEvent(input$spear, { + corr_fct("spearman") + }) + output$cor_result <- renderTable( + { + listResults$curr_data + }, + digits = 6 + ) + + observeEvent(input$kendall, { + corr_fct("kendall") + }) + output$cor_result <- renderTable( + { # issue: check whether this is required + listResults$curr_data + }, + digits = 6 + ) + + observeEvent(input$corr_save, { + if (is.null(listResults$curr_name)) { + return(NULL) + } + if (!(listResults$curr_name %in% unlist(listResults$all_names))) { + listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data + listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name + } + updateCheckboxGroupInput(session, "TableSaved", + choices = listResults$all_names + ) + }) + + observeEvent(input$download_corr, { + lr <- unlist(listResults$all_names) + indices <- sapply(input$TableSaved, function(x) { + which(x == lr) + }) + req(length(indices) >= 1) + l <- listResults$all_data[indices] + jsString <- createJSString(l) + session$sendCustomMessage( + type = "downloadZip", + list( + numberOfResults = length(jsString), + FileContent = jsString + ) + ) + }) + }) + + return(listResults) +} diff --git a/App/lc50.r b/App/lc50.r new file mode 100644 index 0000000..3f95f3e --- /dev/null +++ b/App/lc50.r @@ -0,0 +1,298 @@ +errorClass <- R6::R6Class("errorClass", + public = list( + error_message = NULL, + object = NULL, + initialize = function(error_message = NULL) { + self$error_message = error_message + }, + isNull = function() { + if(is.null(self$error_message)) { + return(TRUE) + } + return(FALSE) + } + ) +) + +shapenumber <- function (my.number) { + if (is.finite(my.number)) { + my.result <- signif(my.number,3) + } else { + my.result <- NA + } + return (my.result) +} + +#calculates the robust 68th percentile of the residuals +#adapted from Motulsky HJ, Brown RE, BMC Bioinformatics 2006, 7:123 +robust_68_percentile <- function (residuals) { + res <- abs(residuals) + res_sorted <- sort(res) + res_percentiles <- (seq(1:length(res_sorted))/length(res_sorted))*100 + index <- min(which(res_percentiles > 68.25)) + x <- c(res_percentiles[index-1],res_percentiles[index]) + y <- c(res_sorted[index-1],res_sorted[index]) + m <- lm(y~x) + x <- c(68.25) + y <- predict(m, as.data.frame(x)) + return(y) +} + +#calculates the robust standard deviation of the residuals (RSDR) with correction for degrees of freedom +#adapted from Motulsky HJ, Brown RE, BMC Bioinformatics 2006, 7:123 +robust_standard_deviation_residuals <- function(residuals, number_of_coefficients_fitted) { + my_residuals <- as.numeric(residuals) + my_residuals <- na.omit(residuals) + N <- length(my_residuals) #the number of data points fitted + K <- number_of_coefficients_fitted #for ic50, 4 coefficients are fitted + result <- robust_68_percentile(residuals) * N/(N-K) + return (result) +} + +#false discovery rate (FDR) approach, returns a T/F vector for selection of valid data points +#adapted from Motulsky HJ, Brown RE, BMC Bioinformatics 2006, 7:123 +false_discovery_rate <- function(res) { + N <- length(res) + Q <- 0.01 #Q=1% + K <- 4 #number of coefficients in the fitted LL.4 model + R <- robust_standard_deviation_residuals(res,K) #the robust standard deviation of the residuals + id <- seq(1:length(res)) + df <- data.frame(id,res) + df$res_abs <- abs(df$res) + df <- df[order(df$res_abs),] + df$i <- seq(1:N) + df$i_fraction <- df$i / N + df$alpha <- Q*(N-(df$i-1))/N + df$t <- df$res_abs / R + df$P <- dt(df$t, N-K) + df$include <- ifelse(df$P < df$alpha & df$i_fraction >= 0.7, FALSE, TRUE) + df2 <- df[order(df$id), ] + return (df2$include) +} + +check_fit <- function(model, min_conc, max_conc, min_abs, max_abs, substance_name) { + if(model$fit$convergence != TRUE) return(errorClass$new(paste(substance_name, + "Model did not converge"))) + b <- coefficients(model)[1] #Hill coefficient + c <- coefficients(model)[2] #asymptote 1 + d <- coefficients(model)[3] #asymptote 2 + e <- coefficients(model)[4] #IC50 + RSE <- summary(model)$rseMat[1] #residual standard error estimated + Response_lowestdose_predicted <- predict(model, data.frame(concentration = min_conc), se.fit = FALSE)[1] + Response_highestdose_predicted <- predict(model, data.frame(concentration = max_conc), se.fit = FALSE)[1] + Response_difference <- 100 * abs(Response_lowestdose_predicted - Response_highestdose_predicted) + HillCoefficient <- b + IC50_relative <- e + pIC50 <- -log10(e/1000000) + Problems <- "" + if (Response_difference < 25) { + Problems <- paste(Problems, "Response Difference lower than 25%", collapse = " , ") + } else if(IC50_relative > max_conc) { + Problems <- paste(Problems, "IC50 larger than highest measured concentration", collapse = " , ") + } else if(IC50_relative < min_conc) { + Problems <- paste(Problems, "IC50 lower than lowest measured concentration", collapse = " , ") + } + + confidence_interval <- confint(model, parm = c("e"), level = 0.95) + IC50_relative_lower <- confidence_interval[1] + IC50_relative_higher <- confidence_interval[2] + p_value <- noEffect(model)[3] + Response_lowestdose_predicted <- shapenumber(Response_lowestdose_predicted) + Response_highestdose_predicted <- shapenumber(Response_highestdose_predicted) + HillCoefficient <- shapenumber(HillCoefficient) + IC50_relative <- shapenumber(IC50_relative) + IC50_relative_lower <- shapenumber(IC50_relative_lower) + IC50_relative_higher <- shapenumber(IC50_relative_higher) + pIC50 <- shapenumber( -log10(IC50_relative/1000000)) + p_value <- shapenumber(p_value) + ylim_low = 0 + ylim_high = 125 + if (min_abs < ylim_low) ylim_low <- min_abs + if (max_abs > ylim_high) ylim_high <- max_abs + outvar <- data.frame(name = substance_name, + Response_lowestdose_predicted = Response_lowestdose_predicted, + Response_highestdose_predicted = Response_highestdose_predicted, + HillCoefficient = HillCoefficient, + asymptote_one = c, asymptote_two = d, + IC50_relative = IC50_relative, IC50_relative_lower = IC50_relative_lower, + IC50_relative_higher = IC50_relative_higher, pIC50 = pIC50, + RSE = RSE, p_value = p_value, Problems = Problems) + return (outvar) +} + +drawplot <- function(df, abs_col, conc_col, model, valid_points, title, + IC50_relative, IC50_relative_lower, IC50_relative_higher) { + min_conc <- min(df[, conc_col]) + max_conc <- max(df[, conc_col]) + grid <- seq(min_conc, max_conc, 0.1) + plotFct <- (model$curve)[[1]] + res <- plotFct(grid) + data <- data.frame(abs = res, + conc = grid) + data_measured <- data.frame(conc = df[, conc_col], abs = df[, abs_col]) + p <- ggplot() + + geom_boxplot(data = data_measured, aes(x = conc, y = abs*100, group = conc)) + + geom_line(data = data, aes(x = conc, y = abs*100)) + + xlab("Concentration [µM]") + + ylab("Viability [%]") + + ggtitle(title) + + max_conc <- max(df[, conc_col]) + 10 + min_conc <- -10 + xmin <- IC50_relative - IC50_relative_lower + xmax <- IC50_relative + IC50_relative_higher + if (!is.na(xmin) & !is.na(xmax)) { + ymin <- min(df[, abs_col]) * 100 + ymax <- max(df[, abs_col]) * 100 + yrange <- ymax - ymin + butt_height <- yrange * 0.1 + ymedian <- median(df[, abs_col]) * 100 + if (xmin > min_conc && xmax < max_conc ) { + p <- p + geom_errorbarh(aes(xmin = xmin, + xmax = xmax, y = ymedian), + colour = "darkred", end = "butt", height = butt_height) + } else { + p <- p + labs(caption = "Confidence intervall not in conc. range") + + theme(plot.caption = element_text(color = "darkred", face = "italic", size = 7)) + } + } else { + p <- p + labs(caption = "Confidence intervall could not be calculated") + + theme(plot.caption = element_text(color = "darkred", face = "italic", size = 7)) + } + + return(p) +} + +ic50_internal <- function(df, abs, conc, title) { + model <- drm(abs ~ conc, data = df , fct = LL.4(), robust = "median") + valid_points <- false_discovery_rate(residuals(model)) + model <- drm(abs ~ conc, data = df , subset = valid_points, start = model$coefficients, fct = LL.4(), robust = "mean") + res <- check_fit(model, min(df[, conc]), max(df[, conc]), min(df[, abs]), max(df[, abs]), title) + p <- drawplot(df, abs, conc, model, valid_points, title, res$IC50_relative, + res$IC50_relative_lower, res$IC50_relative_higher) + return(list(res, p)) +} + +drawplotOnlyRawData <- function(df, abs_col, conc_col, title) { + min_conc <- min(df[, conc_col]) + max_conc <- max(df[, conc_col]) + data_measured <- data.frame(conc = df[, conc_col], abs = df[, abs_col]) + p <- ggplot() + + geom_boxplot(data = data_measured, aes(x = conc, y = abs*100, group = conc)) + + xlab("Concentration [µM]") + + ylab("Viability [%]") + + ggtitle(title) + return(p) +} + +#' Calculates the ic50 values +#' @export +#' @import drc +#' @import ggplot2 +#' @param df a data.frame which contains all the data +#' @param abs_col the name of the column in df which contains the dependent variable +#' @param conc_col the name of the column in df which contains the different concentrations +#' @param substance_name_col the name of the column in df which contains the different names of the compounds +#' @param negative_identifier a character defining the name to identify the negative control within conc_col +#' @param positive_identifier a character defining the name to identify the positive control within conc_col +#' @return a list is returned containing the ic50 value the fitted plots and other parameters +#' @examples +#' path <- system.file("data", package = "MTT") +#' df <- read.csv(paste0(path, "/ExampleData.txt")) +#' ic50(df, "abs", "conc", "names", "neg", "pos") +ic50 <- function(df, abs_col, conc_col, substance_name_col, negative_identifier, positive_identifier) { + substances <- unique(df$names) + + if(!(negative_identifier %in% substances)) { + return(errorClass$new("the string for the negative control was not found!")) + } + if(!(positive_identifier %in% substances)) { + return(errorClass$new("the string for the positive control was not found!")) + } + substances <- substances[substances != negative_identifier] + substances <- substances[substances != positive_identifier] + if(length(substances) < 1) { + return(errorClass$new("The data for compounds seems to be missing")) + } + if(!is.numeric(df[, abs_col])) { + return(errorClass$new("The absorbance data is not numerical")) + } + temp_conc <- df[, conc_col] + temp_conc[temp_conc == negative_identifier] <- -1 + temp_conc[temp_conc == positive_identifier] <- -2 + temp_conc <- as.numeric(temp_conc) + if(any(is.na(temp_conc))) { + return(errorClass$new("The concentration data cannot be converted to numerical")) + } + df[, conc_col] <- temp_conc + if(!is.numeric(df[, conc_col])) { + return(errorClass$new("The concentration data is not numerical")) + } + neg_mean <- mean(df[df[ , substance_name_col] == negative_identifier, abs_col]) + pos_mean <- mean(df[df[ , substance_name_col] == positive_identifier, abs_col]) + df[, abs_col] <- (df[, abs_col] - pos_mean) / neg_mean + res <- list() + for(i in seq_along(substances)) { + df_temp <- df[df$names == substances[i], ] + m <- tryCatch({ + m <- ic50_internal(df_temp, abs_col, conc_col, substances[i]) + }, + error = function(err) { + retval <- errorClass$new(paste("A warning occurred: ", conditionMessage(err))) + retval$object <- drawplotOnlyRawData(df_temp, abs_col, conc_col, substances[i]) + return(retval) + }) + res[[i]] <- m + } + + return(res) +} + +report_plots <- function(ic50List) { + p3 <- ggdraw() + + draw_line(x = c(0, 1), y = c(0.5, 0.5), color = "black", size = 1) + + theme_void() + for(i in seq_along(ic50List)) { + if(is(ic50List[[i]], "errorClass")) { + p <- ic50List[[i]]$object + p <- p + + annotate("text", x = -Inf, y = -Inf, + hjust = -0.2, vjust = -1, label = ic50List[[i]]$error_message) + #print(p) + #print(p3) + next + } + p1 <- ic50List[[i]][[2]] + a <- ic50List[[i]][[1]] |> t() |> as.data.frame() + a <- data.frame(names = row.names(a), Predicition = a) + a[a$names == "Response_lowestdose_predicted", 1] <- "Response_lowestdose" + a[a$names == "Response_highestdose_predicted", 1] <- "Response_highestdose" + problem <- a[a$names == "Problems", 2] + a <- a[(a$names != "Problems") & (a$names != "name"), ] + p2 <- ggplot(a, aes(x = 0, y = factor(names), label = Prediction)) + + geom_line(size = 0) + + geom_text(position = position_nudge(x = -1.1), hjust = 0, size = 3) + + theme_minimal() + + theme(axis.text.x = element_blank(), + axis.ticks.x = element_blank(), + panel.grid.major.x = element_blank(), + panel.grid.minor.x = element_blank(), + panel.grid.major.y = element_blank(), + panel.grid.minor.y = element_blank(), + axis.title.x = element_blank(), + axis.title.y = element_blank(), + axis.text.y = element_text(hjust = 0, face = "bold"), + axis.line.y = element_line(), + plot.caption = element_text(hjust = 1, face = "italic", colour = "darkred", + size = 7) ) + if(problem != "") { + p2 <- p2 + labs(caption = paste("Note:", as.character(problem)) ) + } + + p <- ggdraw() + + draw_plot(p2, x = 0, y = 0, width = 0.5, height = 0.5) + + draw_plot(p1, x = 0.5, y = 0, width = 0.5, height = 0.5) + #print(p) + #print(p3) + } +} diff --git a/App/plottingInternally.R b/App/plottingInternally.R new file mode 100644 index 0000000..70b5848 --- /dev/null +++ b/App/plottingInternally.R @@ -0,0 +1,302 @@ +annotateDF <- function(p, method, level = 2) { + pB <- ggplot_build(p) + df <- pB$data[[1]] + if (length(unique(df$PANEL)) > 1) { + l <- pB$layout$layout + l <- data.frame(PANEL = l$PANEL, names = l$``) + df$PANEL <- l[match(df$PANEL, l$PANEL), 2] + } + # https://stackoverflow.com/questions/40854225/how-to-identify-the-function-used-by-geom-smooth + formula <- p$layers[[level]]$stat$setup_params( + df, + p$layers[[level]]$stat_params + )$formula + df$interaction <- interaction(df$PANEL, df$group) + + results <- lapply(unique(df$interaction), function(x) { + sub <- df[df$interaction == x, ] + calcParams(sub, formula, method) + }) + df <- Reduce(rbind, results) + return(df) +} + +calcParams <- function(df, formula, method) { + stopifnot(get_ast(formula) != "Error") + if (method == "lm") { + model <- lm(formula, data = df) + r_squared <- summary(model)$r.squared + anova_table <- anova(model) + f_value <- anova_table$`F value`[1] + coefficients <- coef(model) + equation <- paste( + "Y =", round(coefficients[1], 2), "+", + round(coefficients[2], 2), "* X" + ) + p_value <- summary(model)$coefficients[, 4] + p_value <- paste(p_value, collapse = " ") + n <- nrow(df) + annotations <- paste( + "R-squared:", round(r_squared, 2), + "F-value:", round(f_value, 2), "\n", + "Equation:", equation, "\n", + "Sample Size (n):", n, "\n", + "p-values Intercept & x:", round(p_value, 6) + ) + df$annotation <- annotations + df$xPos <- mean(df$x) + df$yPos <- max(df$y) + return(df) + } else if (method == "glm") { + model <- glm(formula, data = df) + r_squared <- with(summary(model), 1 - deviance / null.deviance) + coefficients <- coef(model) + n <- nrow(df) + equation <- paste( + "Y =", round(coefficients[1], 2), "+", + round(coefficients[2], 2), "* X" + ) + p_value <- summary(model)$coefficients[2, 4] + annotations <- paste( + "R-squared:", round(r_squared, 2), + "Sample Size (n):", n, "\n", + "Equation:", equation, "\n", + "p-value:", round(p_value, 6) + ) + df$annotation <- annotations + df$xPos <- mean(df$x) + df$yPos <- max(df$y) + return(df) + } else if (method == "gam") { + model <- gam(formula, data = df) + r_squared <- summary(model)$r.sq + f_value <- summary(model)$p.t + coefficients <- coef(model) + n <- nrow(df) + equation <- paste( + "Y =", round(coefficients[1], 2), "+", + round(coefficients[2], 2), "* X" + ) + p_value <- summary(model)$p.pv + annotations <- paste( + "R-squared:", round(r_squared, 2), + "F-value:", round(f_value, 2), "\n", + "Equation:", equation, + "Sample Size (n):", n, "\n", + "p-value:", round(p_value, 6) + ) + df$annotation <- annotations + df$xPos <- mean(df$x) + df$yPos <- max(df$y) + return(df) + } else if (method == "loess") { + model <- loess(formula, data = df) + fitted_values <- predict(model) + r_squared <- cor(df$y, fitted_values)^2 + n <- nrow(df) + annotations <- paste( + "R-squared:", round(r_squared, 2), + "Sample Size (n):", n + ) + df$annotation <- annotations + df$xPos <- mean(df$x) + df$yPos <- max(df$y) + return(df) + } +} + +addFacet <- function(p, facetVar, facetMode) { + if (facetMode == "facet_wrap") { + return(p + facet_wrap(. ~ .data[[facetVar]], scales = "free")) + } else if (facetMode == "facet_grid") { + return(p + facet_grid(. ~ .data[[facetVar]], scales = "free")) + } +} + +DotplotFct <- function(df, x, y, xLabel, yLabel, + fitMethod, + colourVar, legendTitleColour, + colourTheme, facetMode, facetVar, k = 10) { + # create plot + # ========================================== + aes <- aes(x = .data[[x]], y = .data[[y]]) + aesColour <- NULL + p <- NULL + + if (colourVar != "") { + aesColour <- aes(colour = .data[[colourVar]]) + } + if (colourVar == "") { + p <- ggplot( + data = df, + aes(!!!aes) + ) + + geom_point() + } else { + p <- ggplot( + data = df, + aes(!!!aes, !!!aesColour) + ) + + geom_point() + } + + p <- p + xlab(xLabel) + p <- p + ylab(yLabel) + + if (colourVar != "") { + p <- p + guides(colour = guide_legend(title = legendTitleColour)) + p <- p + scale_color_brewer(palette = colourTheme) + } + + if (facetMode != "none") { + p <- addFacet(p, facetVar, facetMode) + } + + if (fitMethod == "none" || fitMethod == "") { + return(p) + } + + # fit data + # ========================================== + if (fitMethod == "gam") { + p <- p + geom_smooth( + method = fitMethod, + formula = y ~ s(x, bs = "cs", k = k) + ) + } else { + p <- p + geom_smooth(method = fitMethod) + } + + # extract information from fit + # ========================================== + df_original <- df + df <- annotateDF(p, fitMethod) + names(df) <- ifelse(names(df) == "PANEL", "Panel", names(df)) + + # TODO: this is a hack. Find a better way. + if (colourVar != "") { + df$colour_groups <- df_original[, colourVar][match( + df$group, + as.integer(factor(df_original[, colourVar])) + )] + } + # Add annotations to plot + # ========================================== + aes <- aes(x = .data[["x"]], y = .data[["y"]]) + if (colourVar != "") { + aesColour <- aes(colour = .data[["colour_groups"]]) + } + if (fitMethod == "gam") { + p <- ggplot(data = df, aes(!!!aes, !!!aesColour)) + + geom_point() + + geom_smooth( + method = fitMethod, + formula = y ~ s(x, bs = "cs", k = k) + ) + + geom_text( + aes( + x = xPos, y = yPos, + label = annotation + ), + size = 3, + show.legend = FALSE, position = position_dodge(width = .9) + ) + } else { + p <- ggplot(data = df, aes(!!!aes, !!!aesColour)) + + geom_point() + + geom_smooth(method = fitMethod) + + geom_text( + aes( + x = xPos, y = yPos, + label = annotation + ), + size = 3, + show.legend = FALSE, position = position_dodge(width = .9) + ) + } + + # Add labels + # ========================================== + p <- p + xlab(xLabel) + p <- p + ylab(yLabel) + if (length(unique(df$colour)) >= 2) { + p <- p + guides(colour = guide_legend(title = legendTitleColour)) + p <- p + scale_color_brewer(palette = colourTheme) + } + if (facetMode != "none") { + p <- addFacet(p, "Panel", facetMode) + } + + return(p) +} + +BoxplotFct <- function(df, x, y, xLabel, yLabel, + fillVar, legendTitleFill, fillTheme, + colourVar, legendTitleColour, + colourTheme, facetMode, facetVar) { + aes <- aes(x = .data[[x]], y = .data[[y]]) + aesColour <- NULL + aesFill <- NULL + p <- NULL + if (colourVar == "") { + aesColour <- aes() + } else { + aesColour <- aes(colour = .data[[colourVar]]) + } + if (fillVar == "") { + aesFill <- aes() + } else { + aesFill <- aes(fill = .data[[fillVar]]) + } + p <- ggplot() + + geom_boxplot( + data = df, + aes(!!!aes, !!!aesColour, !!!aesFill, + group = interaction( + .data[[x]], + !!!aesColour, !!!aesFill + ) + ) + ) + p <- p + xlab(xLabel) + p <- p + ylab(yLabel) + p <- p + guides(fill = guide_legend(title = legendTitleFill)) + p <- p + guides(colour = guide_legend(title = legendTitleColour)) + p <- p + scale_fill_brewer(palette = fillTheme) + p <- p + scale_color_brewer(palette = colourTheme) + if (facetMode != "none") { + p <- addFacet(p, facetVar, facetMode) + } + return(p) +} + +LineplotFct <- function(df, x, y, xLabel, yLabel, + colourVar, legendTitleColour, + colourTheme, facetMode, facetVar) { + aes <- aes(x = .data[[x]], y = .data[[y]]) + aesColour <- NULL + p <- NULL + if (colourVar == "") { + aesColour <- aes() + } else { + aesColour <- aes(colour = .data[[colourVar]]) + } + p <- ggplot() + + geom_line( + data = df, + aes(!!!aes, !!!aesColour, + group = interaction( + .data[[x]], + !!!aesColour + ) + ) + ) + p <- p + xlab(xLabel) + p <- p + ylab(yLabel) + p <- p + guides(colour = guide_legend(title = legendTitleColour)) + p <- p + scale_color_brewer(palette = colourTheme) + if (facetMode != "none") { + p <- addFacet(p, facetVar, facetMode) + } + return(p) +} diff --git a/App/statisticalTests.R b/App/statisticalTests.R new file mode 100644 index 0000000..d0baae4 --- /dev/null +++ b/App/statisticalTests.R @@ -0,0 +1,281 @@ +testsSidebarUI <- function(id) { + tabPanel( + "Tests", + textInput(NS(id, "dep"), "dependent Variable", value = "var1"), + textInput(NS(id, "indep"), "independent Variable", value = "var2"), + conditionalPanel( + condition = "input.TestsConditionedPanels == 'Two groups'", + sliderInput(NS(id, "confLevel"), "Confidence level of the interval", + min = 0, max = 1, value = 0.95 + ), + selectInput( + NS(id, "altHyp"), "Alternative hypothesis", + c( + "Two sided" = "two.sided", + "Less" = "less", + "Greater" = "greater" + ) + ), + selectInput( + NS(id, "paired"), "Paired or unpaired t-test", + c( + "Unpaired" = "up", + "Paired" = "p" + ) + ), + selectInput( + NS(id, "varEq"), "Are the two variances treated as equal or not?", + c( + "Equal" = "eq", + "Not equal" = "noeq" + ) + ), + actionButton(NS(id, "tTest"), "t test") + ), + conditionalPanel( + condition = "input.TestsConditionedPanels == 'More than two groups'", + actionButton(NS(id, "aovTest"), "anova"), + actionButton(NS(id, "kruskalTest"), "kruskal wallis test"), + ), + conditionalPanel( + selectInput(NS(id, "PostHocTests"), "Choose a Post Hoc test", + choices = c( + "Tukey HSD" = "HSD", "Kruskal Wallis post hoc test" = "kruskalTest", + "Least significant difference test" = "LSD", + "Scheffe post hoc test" = "scheffe", "REGW post hoc test" = "REGW" + ) + ), + condition = "input.TestsConditionedPanels == 'Posthoc tests'", + actionButton(NS(id, "PostHocTest"), "run test"), + sliderInput(NS(id, "pval"), "P-value", + min = 0, max = 0.15, value = 0.05 + ), + selectInput( + NS(id, "design"), "Design", + c( + "Balanced" = "ba", + "Unbalanced" = "ub" + ) + ), + conditionalPanel( + condition = "input.PostHocTests == 'kruskalPHTest' || input.PostHocTests == 'lsdTest'", + selectInput(NS(id, "padj"), "Adjusted p method", + c( + "Holm" = "holm", + "Hommel" = "hommel", + "Hochberg" = "hochberg", + "Bonferroni" = "bonferroni", + "BH" = "BH", + "BY" = "BY", + "fdr" = "fdr" + ), + selectize = FALSE + ) + ) + ) + ) +} + +testsUI <- function(id) { + fluidRow( + tags$head( + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js"), + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js"), + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js"), + tags$script(src = "download.js") + ), + tabsetPanel( + tabPanel( + "Two groups", + br(), + ), + tabPanel( + "More than two groups", + br(), + ), + tabPanel( + "Posthoc tests", + br(), + ), + id = "TestsConditionedPanels" + ), + h4(strong("Results of test:")), + tableOutput(NS(id, "test_result")), + verbatimTextOutput(NS(id, "test_error")), + actionButton(NS(id, "test_save"), "Add output to result-file"), + actionButton(NS(id, "download_test"), "Save results"), + checkboxGroupInput(NS(id, "TableSaved"), "Saved results to file", NULL) + ) +} + +testsServer <- function(id, data, listResults) { + moduleServer(id, function(input, output, session) { + tTest <- function() { + output$test_error <- renderText(NULL) + req(is.data.frame(data$df)) + df <- data$df + req(input$indep) + indep <- input$indep + req(input$dep) + dep <- input$dep + formula <- NULL + err <- NULL + fit <- NULL + e <- try({ + formula <- as.formula(paste(dep, "~", indep)) + stopifnot(get_ast(formula) != "Error") + paired <- FALSE + if (input$paired == "p") { + paired <- TRUE + } + eq <- TRUE + if (input$varEq == "noeq") { + eq <- FALSE + } + fit <- broom::tidy(t.test(formula, + data = df, conf.level = input$confLevel, + alternative = input$alt, paired = paired, var.equal = eq + )) + }) + if (inherits(e, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + output$test_error <- renderText(err) + } else { + listResults$curr_data <- fit + listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted t-test") + output$test_result <- renderTable(fit, digits = 6) + } + } + + observeEvent(input$tTest, { + tTest() + }) + + conductTests <- function(method) { + output$test_error <- renderText(NULL) + req(is.data.frame(data$df)) + df <- data$df + req(input$indep) + indep <- input$indep + req(input$dep) + dep <- input$dep + formula <- NULL + err <- NULL + fit <- NULL + e <- try({ + formula <- as.formula(paste(dep, "~", indep)) + stopifnot(get_ast(formula) != "Error") + }) + if (inherits(e, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + output$test_error <- renderText(err) + } + if (is.null(err)) { + e <- try({ + switch(method, + aov = { + fit <- broom::tidy(aov(formula, data = df)) + }, + kruskal = { + fit <- broom::tidy(kruskal.test(formula, data = df)) + }, + HSD = { + aov_res <- aov(formula, data = df) + bal <- input$design + req(bal) + if (bal == "Balanced") { + bal <- TRUE + } else { + bal <- FALSE + } + fit <- agricolae::HSD.test(aov_res, + trt = indep, + alpha = input$pval, group = TRUE, unbalanced = bal + )$groups + }, + kruskalTest = { + fit <- with(df, kruskal(df[, dep], df[, indep]), + alpha = input$pval, p.adj = input$padj, group = TRUE + )$groups + }, + LSD = { + aov_res <- aov(formula, data = df) + fit <- agricolae::LSD.test(aov_res, + trt = indep, + alpha = input$pval, p.adj = input$padj, group = TRUE + )$groups + }, + scheffe = { + aov_res <- aov(formula, data = df) + fit <- agricolae::scheffe.test(aov_res, trt = indep, alpha = input$pval, group = TRUE)$groups + }, + REGW = { + aov_res <- aov(formula, data = df) + fit <- agricolae::REGW.test(aov_res, trt = indep, alpha = input$pval, group = TRUE)$groups + } + ) + }) + if (inherits(e, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + output$test_error <- renderText(err) + } else if (is.null(fit)) { + output$test_error <- renderText("Result is NULL") + } else { + fit <- cbind(fit, row.names(fit)) + names(fit)[ncol(fit)] <- paste0(indep, collapse = ".") + listResults$curr_data <- fit + listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted: ", method) + output$test_result <- renderTable(fit, digits = 6) + } + } + } + + observeEvent(input$aovTest, { + conductTests("aov") + }) + + observeEvent(input$kruskalTest, { + conductTests("kruskal") + }) + + observeEvent(input$kruskalTest, { + conductTests("kruskal") + }) + + observeEvent(input$PostHocTest, { + conductTests(input$PostHocTests) + }) + + observeEvent(input$test_save, { + if (is.null(listResults$curr_name)) { + return(NULL) + } + if (!(listResults$curr_name %in% unlist(listResults$all_names))) { + listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data + listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name + } + updateCheckboxGroupInput(session, "TableSaved", + choices = listResults$all_names + ) + }) + + observeEvent(input$download_test, { + lr <- unlist(listResults$all_names) + indices <- sapply(input$TableSaved, function(x) { + which(x == lr) + }) + req(length(indices) >= 1) + l <- listResults$all_data[indices] + jsString <- createJSString(l) + session$sendCustomMessage( + type = "downloadZip", + list( + numberOfResults = length(jsString), + FileContent = jsString + ) + ) + }) + }) + + return(listResults) +} diff --git a/App/tests/test_plotting.R b/App/tests/test_plotting.R new file mode 100644 index 0000000..0ca4de6 --- /dev/null +++ b/App/tests/test_plotting.R @@ -0,0 +1,22 @@ +library(tinytest) + +mock_ggplot <- ggplot(data = CO2, aes(x = uptake, y = conc)) + + geom_point() + + geom_smooth() +test_annotateDF <- function() { + df <- annotateDF(mock_ggplot, method = "lm") + expect_equal(nrow(df), 84) + expect_equal(ncol(df), 14) +} +test_annotateDF() + +test_calcParams <- function() { + df <- data.frame(x = 1:10, y = 1:10) + model <- calcParams(df, formula = y ~ x, method = "lm") + a <- model$annotation + r2 <- strsplit(a, split = " ")[[1]][2] + expect_equal(r2, "1") +} +test_calcParams() + +test_dir() \ No newline at end of file diff --git a/App/utils.R b/App/utils.R new file mode 100644 index 0000000..682d0e5 --- /dev/null +++ b/App/utils.R @@ -0,0 +1,128 @@ +DF2String <- function(df) { + resNames <- names(df) + resNames <- paste(resNames, collapse = "\t") + resNames <- paste(resNames, "\n") + res <- apply(df, 1, function(x) { + x <- as.character(x) + x <- paste(x, collapse = "\t") + return(x) + }) + res <- paste0(resNames, "\n", res, collapse = "") + res <- paste0(res, "\n") +} + +setClass("plot", + slots = c( + p = "ANY", + width = "numeric", + height = "numeric", + resolution = "numeric" + ) +) + +setClass("diagnosticPlot", + slots = c( + p = "character" + ) +) + +setClass("doseResponse", + slots = c( + df = "data.frame", + p = "ANY" + ) +) + +createJSString <- function(l) { + jsString <- c() + for (i in seq_along(l)) { + if (inherits(l[[i]], "plot")) { + p <- l[[i]]@p + width <- l[[i]]@width + height <- l[[i]]@height + resolution <- l[[i]]@resolution + fn <- tempfile(fileext = '.png') + ggsave(plot = p, filename = fn, width = width, height = height, dpi = resolution) + jsString <- c(jsString, paste0("data:image/png;base64,", base64enc::base64encode(fn)) ) + unlink(fn) + } else if (inherits(l[[i]], "diagnosticPlot")) { + jsString <- c(jsString, aste0("data:image/png;base64,", base64enc::base64encode(l[[i]]@p)) ) + unlink(l[[i]]@p) + } else if (inherits(l[[i]], "doseResponse")) { + p <- l[[i]]@p + fn <- tempfile(fileext = '.png') + ggsave(plot = p, filename = fn) + jsString <- c(jsString, paste0("data:image/png;base64,", base64enc::base64encode(fn)) ) + unlink(fn) + jsString <- c(jsString, DF2String(l[[i]]@df)) + } else if (inherits(l[[i]], "data.frame")) { + jsString <- c(jsString, DF2String(l[[i]])) + } else if (is.character(l[[i]])) { + jsString <- c(jsString, l[[i]]) + } + } + return(jsString) +} + +stackDF <- function(df, keepCol) { + as.data.frame(pivot_longer(df, cols = -keepCol, + names_to = "name", values_to = "value")) +} + +unstackDF <- function(df, name, value) { + df <- pivot_wider(df, names_from = name, values_from = value) + df <- map(df, simplify) %>% + as.data.frame() + as.data.frame(df) +} + +correctName <- function(name, df) { + name %in% names(df) +} + +changeCharInput <- function(chars) { + nams <- unlist(strsplit(chars, split = ",")) + for (i in 1:length(nams)) { + nams[i] <- gsub(" ", "", nams[i]) + } + nams +} + +combine <- function(new, vec, df, first) { + if (length(vec) == 0) { + return(new) + } + if (correctName(vec[length(vec)], df)) { + if (isTRUE(first)) { + new <- df[, vec[length(vec)]] + first <- FALSE + } else { + new <- interaction(new, df[, vec[length(vec)]]) + } + } + vec <- vec[-length(vec)] + combine(new, vec, df, first) +} + +splitData <- function(df, formula) { + df <- model.frame(formula, data = df) + stopifnot(ncol(df) >= 2) + res <- data.frame(value = df[, 1], interaction = interaction(df[, 2:ncol(df)])) + names(res) <- c("value", interaction = paste0(names(df)[2:ncol(df)], collapse = ".")) + res +} + +diagnosticPlot <- function(df, formula) { + model <- lm(formula, data = df) + f <- tempfile(fileext = ".png") + png(f) + par(mfrow = c(3, 2)) + plot(model, 1) + plot(model, 2) + plot(model, 3) + plot(model, 4) + plot(model, 5) + plot(model, 6) + dev.off() + return(f) +} diff --git a/App/visualisation.R b/App/visualisation.R new file mode 100644 index 0000000..2fd6f99 --- /dev/null +++ b/App/visualisation.R @@ -0,0 +1,267 @@ +visSidebarUI <- function(id) { + tabPanel( + "Visualisation", + textInput(NS(id , "yVar"), "Y variable", value = "y"), + textInput(NS(id, "xVar"), "X variable", value = "x"), + radioButtons(NS(id, "xType"), "Type of x", + choices = c( + factor = "factor", + numeric = "numeric" + ), + selected = "factor" + ), + textInput(NS(id, "xaxisText"), "X axis label", value = "x label"), + textInput(NS(id, "yaxisText"), "Y axis label", value = "y label"), + conditionalPanel( + condition = "input.VisConditionedPanels == 'Scatterplot'", + selectInput(NS(id, "fitMethod"), "Choose a fitting method", + c( + "none" = "none", + "lm" = "lm", + "glm" = "glm", + "gam" = "gam", + "loess" = "loess" + ), + selectize = FALSE + ), + numericInput(NS(id, "k"), "number of knots used by spline for gam", value = 10) + ), + conditionalPanel( + condition = "input.VisConditionedPanels == 'Boxplot'", + textInput(NS(id, "fill"), "Fill variable"), + textInput(NS(id, "legendTitleFill"), "Legend title for fill", value = "Title fill"), + selectInput(NS(id, "themeFill"), "Choose a 'fill' theme", + c( + "BuGn" = "BuGn", + "PuRd" = "PuRd", + "YlOrBr" = "YlOrBr", + "Greens" = "Greens", + "GnBu" = "GnBu", + "Reds" = "Reds", + "Oranges" = "Oranges", + "Greys" = "Greys" + ), + selectize = FALSE + ) + ), + textInput(NS(id, "col"), "Colour variable"), + textInput(NS(id, "legendTitleCol"), "Legend title for colour", value = "Title colour"), + selectInput(NS(id, "theme"), "Choose a 'colour' theme", + c( + "Accent" = "Accent", + "Dark2" = "Dark2", + "Paired" = "Paired", + "Pastel1" = "Pastel1", + "Pastel2" = "Pastel2", + "Set1" = "Set1", + "Set2" = "Set2", + "Set3" = "Set3" + ), + selectize = FALSE + ), + radioButtons(NS(id, "facetMode"), + "Choose Facet Mode:", + choices = c("none", "facet_wrap", "facet_grid") + ), + textInput(NS(id, "facetBy"), "split plot by") + ) +} + +visUI <- function(id) { + fluidRow( + tags$head( + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js"), + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js"), + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js"), + tags$script(src = "download.js"), + ), + br(), + tabsetPanel( + tabPanel("Boxplot", + br(), + actionButton(NS(id, "CreatePlotBox"), "Create plot") + ), + tabPanel("Scatterplot", + br(), + actionButton(NS(id, "CreatePlotScatter"), "Create plot") + ), + tabPanel("Lineplot", + br(), + actionButton(NS(id, "CreatePlotLine"), "Create plot") + ), + id = "VisConditionedPanels" + ), + plotOutput(NS(id, "plotResult")), + actionButton(NS(id, "plotSave"), "Add output to result-file"), + checkboxGroupInput(NS(id, "TableSaved"), "Saved results to file", NULL), + fluidRow( + column(4, + numericInput(NS(id, "widthPlot"), "Width of plot [cm]", value = 10) + ), + column(4, + numericInput(NS(id, "heightPlot"), "Height of plot [cm]", value = 10) + ), + column(4, + numericInput(NS(id, "resPlot"), "Resolution of plot", value = 300) + ), + ), + fluidRow( + column(12, + actionButton(NS(id, "downloadViss"), "Save results") + ) + ) + ) +} + +visServer <- function(id, data, listResults) { + moduleServer(id, function(input, output, session) { + + plotFct <- function(method) { + req(is.data.frame(data$df)) + df <- data$df + req(input$yVar) + req(input$xVar) + x <- input$xVar; y <- input$yVar + colNames <- names(df) + checkX <- x %in% colNames + checkY <- y %in% colNames + if (!checkX) showNotification("X variable not found", duration = 0) + if (!checkY) showNotification("Y variable not found", duration = 0) + req(checkX) + req(checkY) + width <- input$widthPlot + height <- input$heightPlot + resolution <- input$resPlot + if (width <= 0) { + showNotification(paste("width has to be a positive number is changed to 10 cm"), duration = 0) + width <- 10 + } + if (height <= 0) { + showNotification(paste("height has to be a positive number is changed to 10 cm"), duration = 0) + height <- 10 + } + if (width > 100) { + showNotification(paste("width exceeds max value of 100 cm. Is set to 100 cm."), duration = 0) + width <- 100 + } + if (height > 100) { + showNotification(paste("height exceeds max value of 100 cm. Is set to 100 cm."), duration = 0) + height <- 100 + } + col <- input$col + fill <- input$fill + if ( !(fill %in% names(df)) && (fill != "") ) showNotification("fill variable not found", duration = 0) + if ( !(col %in% names(df)) && (col != "") ) showNotification("colour variable not found", duration = 0) + req( (fill %in% names(df)) || (fill == "") ) + req( (col %in% names(df)) || (col == "") ) + fillTitle <- input$legendTitleFill + colTitle <- input$legendTitleCol + xlabel <- input$xaxisText + ylabel <- input$yaxisText + xtype <- input$xType + theme <- input$theme + themeFill <- input$themeFill + facetMode <- input$facetMode + facet <- input$facetBy + fitMethod <- input$fitMethod + + xd <- NULL + if (xtype == "numeric") { + xd <- as.numeric(df[,x]) + } else { + xd <- as.factor(df[,x]) + } + yd <- as.numeric(df[,y]) + if (fitMethod != "none" && !is.null(fitMethod) && xtype != "numeric") { + showNotification("Fit method will be ignored as X variable is not numerical", duration = 0) + fitMethod <- "none" + } + + p <- tryCatch({ + if (method == "box") { + p <- BoxplotFct(df, x, y, xlabel, ylabel, + fill, fillTitle, themeFill, + col, colTitle, theme, + facetMode, facet) + } else if (method == "dot") { + k <- NULL + if (fitMethod == "gam") { + req(input$k) + k <- input$k + if(k <= 0) { + showNotification("k has to be at least 1 and is set to this value") + k <- 1 + } + } + p <- DotplotFct(df, x, y, xlabel, ylabel, + fitMethod, + col, colTitle, theme, + facetMode, facet, k) + } else if (method == "line") { + p <- LineplotFct(df, x, y, xlabel, ylabel, + col, colTitle, theme, + facetMode, facet) + } + }, + warning = function(warn) { + showNotification(paste("A warning occurred: ", conditionMessage(warn)), duration = 0) + }, + error = function(err) { + showNotification(paste("An error occurred: ", conditionMessage(err)), duration = 0) + }) + output$plotResult <- renderPlot(p) + listResults$curr_data <- new("plot", p = p, width = width, height = height, resolution = resolution) + listResults$curr_name <- paste("Plot Nr", + length(listResults$all_names) + 1, paste("Type: ", method)) + } + + observeEvent(input$CreatePlotBox, { + req(is.data.frame(data$df)) + plotFct("box") + }) + output$plotResult <- renderPlot({ + renderPlot(listResults$curr_data) + }) + + observeEvent(input$CreatePlotScatter, { + req(is.data.frame(data$df)) + plotFct("dot") + }) + output$plotResult <- renderPlot({ + renderPlot(listResults$curr_data) + }) + + observeEvent(input$CreatePlotLine, { + req(is.data.frame(data$df)) + plotFct("line") + }) + output$plotResult <- renderPlot({ + renderPlot(listResults$curr_data) + }) + + observeEvent(input$plotSave, { + if(is.null(listResults$curr_name)) return(NULL) + if (!(listResults$curr_name %in% unlist(listResults$all_names)) ) { + listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data + listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name + } + updateCheckboxGroupInput(session, "TableSaved", + choices = listResults$all_names) + }) + + observeEvent(input$downloadViss, { + lr <- unlist(listResults$all_names) + indices <- sapply(input$TableSaved, function(x) { + which(x == lr) + }) + req(length(indices) >= 1) + l <- listResults$all_data[indices] + jsString <- createJSString(l) + session$sendCustomMessage(type = "downloadZip", + list(numberOfResults = length(jsString), + FileContent = jsString)) + }) + + + }) +} diff --git a/App/www/download.js b/App/www/download.js new file mode 100644 index 0000000..cdda255 --- /dev/null +++ b/App/www/download.js @@ -0,0 +1,44 @@ +Shiny.addCustomMessageHandler('downloadZip', function(message) { + var FileContent = message.FileContent; + if( (typeof FileContent) == "string") { + if (FileContent.startsWith("data:image")) { + var fileName = 'file' + (i + 1) + '.png'; + var zip = new JSZip(); + var imageData = atob(FileContent.split(',')[1]); + var byteArray = new Uint8Array(imageData.length); + for (var i = 0; i < imageData.length; i++) { + byteArray[i] = imageData.charCodeAt(i); + } + zip.file(fileName, byteArray, {binary: true}); + zip.generateAsync({type: 'blob'}).then(function(content) { + saveAs(content, 'download.zip'); + }); + } else { + var zipText = new JSZip(); + var fileNameText = 'file' + 1 + '.txt'; + zipText.file(fileNameText, FileContent); + zipText.generateAsync({type: 'blob'}).then(function(content) { + saveAs(content, 'download.zip'); + }); + } + } else { + var zip = new JSZip(); + for (var i in FileContent) { + if (FileContent[i].startsWith("data:image")) { + var fileName = 'file' + (i + 1) + '.png'; + var imageData = atob(FileContent[i].split(',')[1]); + var byteArray = new Uint8Array(imageData.length); + for (var i = 0; i < imageData.length; i++) { + byteArray[i] = imageData.charCodeAt(i); + } + zip.file(fileName, byteArray, {binary: true}); + } else { + var fileName = 'file' + (i + 1) + '.txt'; + zip.file(fileName, FileContent[i]); + } + } + zip.generateAsync({type: 'blob'}).then(function(content) { + saveAs(content, 'download.zip'); + }); + } +}); \ No newline at end of file diff --git a/Finney-BioassayPracticeStatistical-1979.pdf b/Documentation/Finney-BioassayPracticeStatistical-1979.pdf similarity index 100% rename from Finney-BioassayPracticeStatistical-1979.pdf rename to Documentation/Finney-BioassayPracticeStatistical-1979.pdf diff --git a/Meeting.md b/Documentation/Meeting.md similarity index 100% rename from Meeting.md rename to Documentation/Meeting.md diff --git a/Screencast from 27.11.2023 10:16:28.webm b/Documentation/Screencast from 27.11.2023 10:16:28.webm similarity index 100% rename from Screencast from 27.11.2023 10:16:28.webm rename to Documentation/Screencast from 27.11.2023 10:16:28.webm diff --git a/docu.pdf b/Documentation/docu.pdf similarity index 100% rename from docu.pdf rename to Documentation/docu.pdf diff --git a/docu.qmd b/Documentation/docu.qmd similarity index 100% rename from docu.qmd rename to Documentation/docu.qmd diff --git a/bs/.development/deploy.R b/bs/.development/deploy.R new file mode 100644 index 0000000..3cbafb4 --- /dev/null +++ b/bs/.development/deploy.R @@ -0,0 +1,4 @@ +setwd("/home/konrad/Documents/Biostats") + +shinylive::export("./bs/inst/serverless_app/", "docs") +httpuv::runStaticServer("docs/") diff --git a/bs/.development/run_app.R b/bs/.development/run_app.R new file mode 100644 index 0000000..4fca893 --- /dev/null +++ b/bs/.development/run_app.R @@ -0,0 +1,9 @@ +# Run in browser + +# setwd("/home/konrad/Documents/Biostats") +# shinylive::export("./App", "docs", verbose = TRUE) +# httpuv::runStaticServer("docs") + +Sys.setenv(RUN_MODE = "BROWSER") +library(bs) +run_app() diff --git a/bs/DESCRIPTION b/bs/DESCRIPTION new file mode 100644 index 0000000..11804dc --- /dev/null +++ b/bs/DESCRIPTION @@ -0,0 +1,38 @@ +Package: bs +Type: Package +Title: Statistical tools offered as app +Version: 1.0 +Date: 2022-03-24 +Author: Konrad Krämer +Maintainer: +Description: Offers a shiny app to solve data wrangling; visualization and statistical testing tasks. +License: GPL-3 +Imports: + shiny, + DT, + bslib, + broom, + utils, + ggplot2, + base64enc, + shinyjs, + mgcv, + RColorBrewer, + tidyr, + purrr, + agricolae, + drc, + cowplot, + patchwork, + httr, + readxl, + openxlsx, + COMELN, + openssl, + jose, + png, + ggpmisc, + R6, + drc +Encoding: UTF-8 +RoxygenNote: 7.3.2 diff --git a/bs/NAMESPACE b/bs/NAMESPACE new file mode 100644 index 0000000..66c30d8 --- /dev/null +++ b/bs/NAMESPACE @@ -0,0 +1,10 @@ +# Generated by roxygen2: do not edit by hand + +export(ic50) +export(run_app) +import(DT) +import(drc) +import(ggplot2) +import(shiny) +import(shinyjs) +import(COMELN) diff --git a/bs/R/DoseResponse.R b/bs/R/DoseResponse.R new file mode 100644 index 0000000..c59caec --- /dev/null +++ b/bs/R/DoseResponse.R @@ -0,0 +1,147 @@ +# df +# abs_col +# conc_col +# substance_name_col, +# negative_identifier, +# positive_identifier +# path <- system.file("data", package = "MTT") +# df <- read.csv(paste0(path, "/ExampleData.txt")) +# ic50(df, "abs", "conc", "names", "neg", "pos") + + + +DoseResponseSidebarUI <- function(id) { + tabPanel( + "Dose Response analysis", + textInput(NS(id, "dep"), "dependent Variable", value = "abs"), + textInput(NS(id, "indep"), "independent Variable", value = "conc"), + textInput(NS(id, "substanceNames"), "names colum of dependent Variable", value = "names"), + textInput(NS(id, "negIdentifier"), "identifier for the negative control", value = "neg"), + textInput(NS(id, "posIdentifier"), "identifier for the positive control", value = "pos"), + actionButton(NS(id, "ic50"), "conduct analysis") + ) +} + +DoseResponseUI <- function(id) { + fluidRow( + tags$head( + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js"), + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js"), + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js"), + tags$script(src = "download.js") + ), + h4(strong("Results of test:")), + actionButton(NS(id, "dr_save"), "Add output to result-file"), + actionButton(NS(id, "download_dr"), "Save results"), + checkboxGroupInput(NS(id, "TableSaved"), "Saved results to file", NULL), + tableOutput(NS(id, "dr_result")), + plotOutput(NS(id, "dr_result_plot")), + verbatimTextOutput(NS(id, "dr_error")) + ) +} + +DoseResponseServer <- function(id, data, listResults) { + moduleServer(id, function(input, output, session) { + drFct <- function() { + output$dr_error <- renderText(NULL) + req(is.data.frame(data$df)) + df <- data$df + req(input$dep) + req(input$indep) + dep <- input$dep + indep <- input$indep + req(input$substanceNames) + names <- input$substanceNames + req(input$negIdentifier) + neg <- input$negIdentifier + req(input$posIdentifier) + pos <- input$posIdentifier + err <- NULL + resDF <- NULL + resPlot <- NULL + e <- try({ + stopifnot(get_ast(str2lang(indep)) != "Error") + stopifnot(get_ast(str2lang(dep)) != "Error") + res <- ic50(df, dep, indep, names, neg, pos) + stopifnot(!inherits(res, "errorClass")) + resDF <- lapply(res, function(x) { + if (inherits(x, "errorClass")) { + return(NULL) + } + return(x[[1]]) + }) + resDF <- resDF[!is.null(resDF)] + resDF <- resDF[!sapply(resDF, is.null)] + resDF <- Reduce(rbind, resDF) + resP <- lapply(res, function(x) { + if (inherits(x, "errorClass")) { + return(NULL) + } + return(x[[2]]) + }) + resP <- resP[!is.null(resP)] + resP <- resP[!sapply(resP, is.null)] + resPlot <- resP[[1]] + if (length(resP) >= 2) { + for (i in seq_along(2:length(resP))) { + # if (i %% 4 == 0) { + # resPlot <- resPlot / resP[[i]] + # } else { + resPlot <- resPlot + resP[[i]] + # } + } + } + }) + if (inherits(e, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + output$dr_error <- renderText(err) + } else { + listResults$curr_data <- new("doseResponse", df = resDF, p = resPlot) + listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted dose response analysis") + output$dr_result <- renderTable(resDF, digits = 6) + output$dr_result_plot <- renderPlot(resPlot) + } + } + + observeEvent(input$ic50, { + drFct() + }) + + observeEvent(input$dr_save, { + if (is.null(listResults$curr_name)) { + return(NULL) + } + if (!(listResults$curr_name %in% unlist(listResults$all_names))) { + listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data + listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name + } + updateCheckboxGroupInput(session, "TableSaved", + choices = listResults$all_names + ) + }) + + observeEvent(input$download_dr, { + lr <- unlist(listResults$all_names) + indices <- sapply(input$TableSaved, function(x) { + which(x == lr) + }) + req(length(indices) >= 1) + l <- listResults$all_data[indices] + if (Sys.getenv("RUN_MODE") == "BROWSER") { + jsString <- createJSString(l) + session$sendCustomMessage( + type = "downloadZip", + list( + numberOfResults = length(jsString), + 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 + } + }) + }) + + return(listResults) +} diff --git a/bs/R/app.R b/bs/R/app.R new file mode 100644 index 0000000..c9b088a --- /dev/null +++ b/bs/R/app.R @@ -0,0 +1,579 @@ +#' @import shiny +#' @import shinyjs +#' @import DT +#' @export +run_app <- function() { + ui <- fluidPage( + useShinyjs(), + includeScript("www/download.js"), # NOTE: would be better located in inst folder but the serverless version cannot handle this + sidebarLayout( + sidebarPanel( + conditionalPanel( + condition = "input.conditionedPanels == 'Data'", + uiOutput("conditional_data_ui"), + fileInput("file", "Choose CSV File", + accept = c( + "text/csv", + "text/comma-separated-values,text/plain", + ".csv" + ) + ), + textInput("op", "Operations", value = "var / 1000"), + textInput("new_col", "Name of new variable", value = "var"), + actionButton("mod", "Modify"), + tags$hr(), + textInput("keepVar", "const variable"), + actionButton("pivotLonger", "conversion to long format"), + tags$hr(), + textInput("name", "name column"), + textInput("value", "value column"), + actionButton("pivotWider", "convert to wide format"), + verbatimTextOutput("mod_error"), + tags$hr() + ), + conditionalPanel( + condition = "input.conditionedPanels == 'Correlation'", + corrSidebarUI("CORR") + ), + conditionalPanel( + condition = "input.conditionedPanels == 'Visualisation'", + visSidebarUI("VIS") + ), + conditionalPanel( + condition = "input.conditionedPanels == 'Assumption'", + assSidebarUI("ASS") + ), + conditionalPanel( + condition = "input.conditionedPanels == 'Tests'", + testsSidebarUI("TESTS") + ), + conditionalPanel( + condition = "input.conditionedPanels == 'Dose Response analysis'", + DoseResponseSidebarUI("DOSERESPONSE") + ) + ), + mainPanel( + tabsetPanel( + tabPanel( + "Data", + DTOutput("df") + ), + tabPanel( + "Correlation", + corrUI("CORR") + ), + tabPanel( + "Visualisation", + visUI("VIS") + ), + tabPanel( + "Assumption", + assUI("ASS") + ), + tabPanel( + "Tests", + testsUI("TESTS") + ), + tabPanel( + "Dose Response analysis", + DoseResponseUI("DOSERESPONSE") + ), + id = "conditionedPanels" + ) + ) + ) + ) + + server <- function(input, output, session) { + dataSet <- reactiveValues(df = NULL) + + output$conditional_data_ui <- renderUI({ + if (Sys.getenv("RUN_MODE") != "SERVER") { + res <- conditionalPanel( + condition = "input.conditionedPanels == 'Data'", + fileInput("file", "Choose CSV File", + accept = c( + "text/csv", + "text/comma-separated-values,text/plain", + ".csv" + ) + ) + ) + return(res) + } + }) + + download_file <- reactive({ + file <- COMELN::download(session, "/home/shiny/results") + upload <- function(path) { + stopifnot(is.character(path)) + df <- NULL + df <- try(as.data.frame(readxl::read_excel( + path, + col_names = TRUE + )), silent = TRUE) + if (class(df) == "try-error") { + # identify seperator + line <- readLines(path, n = 1) + semicolon <- grepl(";", line) + comma <- grepl(",", line) + tab <- grepl("\t", line) + seperator <- NULL + if (semicolon == TRUE) { + seperator <- ";" + } else if (comma == TRUE) { + seperator <- "," + } else if (tab == TRUE) { + seperator <- "\t" + } else { + return("error") + } + df <- try(read.csv(path, header = TRUE, sep = seperator)) + if (class(df) == "try-error") { + return("error") + } + } else { + f <- function(x) { + options(warn = -1) + x <- as.numeric(x) + options(warn = 0) + x <- x[!is.na(x)] + length(x) > 0 + } + check <- apply(df, 2, f) + conv <- function(a, b) { + if (a == TRUE) { + return(as.numeric(b)) + } + return(b) + } + df <- Map(conv, check, df) + df <- data.frame(df) + } + return(df) + } + df <- NULL + df <- upload(file) + if (is.data.frame(df)) { + var$df <- df + } else { + showNotification("File can not be used. Upload into R failed!", duration = 0) + } + tryCatch( + { + system(paste("rm -r ", file)) + }, + warning = function(warn) { + showNotification(paste("A warning occurred: ", conditionMessage(warn)), duration = 0) + }, + error = function(err) { + showNotification(paste("An error occurred: ", conditionMessage(err)), duration = 0) + } + ) + req(is.data.frame(df)) + return(df) + }) + + + output$df <- renderDT({ + if (Sys.getenv("RUN_MODE") == "SERVER") { + isolate({ + dataSet$df <- download_file() + }) + datatable(dataSet$df, options = list(pageLength = 10)) + } else { + req(input$file) + df <- try(read.csv(input$file$datapath)) + if (inherits(df, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + showNotification(err) + return(NULL) + } + dataSet$df <- df + req(!is.na(dataSet$df)) + datatable(dataSet$df, options = list(pageLength = 10)) + } + }) + + observeEvent(input$mod, { + req(!is.null(dataSet$df)) + req(is.data.frame(dataSet$df)) + req(input$op) + req(input$new_col) + dt <- dataSet$df + op <- input$op + new_col <- input$new_col + new <- NULL + err <- NULL + e <- try({ + ast <- get_ast(str2lang(op)) + ast <- ast[[length(ast)]] + }) + if (e == "Error") { + showNotification("Found unallowed function") + return() + } else if (inherits(e, "try-error")) { + showNotification(e) + return() + } + e <- try({ + new <- with(dt, eval(parse(text = op))) + dataSet$df[, new_col] <- new + }) + if (inherits(e, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + } + output$df <- renderDT(dataSet$df) + output$mod_error <- renderText(err) + return(df) + }) + + observeEvent(input$pivotLonger, { + req(!is.null(dataSet$df)) + req(input$keepVar) + err <- NULL + e <- try({ + stopifnot(get_ast(str2lang(input$keepVar)) != "Error") + dataSet$df <- stackDF(dataSet$df, input$keepVar) + }) + if (inherits(e, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + } + output$df <- renderDT(dataSet$df) + output$mod_error <- renderText(err) + return(df) + }) + + observeEvent(input$pivotWider, { + req(!is.null(dataSet$df)) + req(input$name) + req(input$value) + err <- NULL + e <- try({ + stopifnot(get_ast(str2lang(input$value)) != "Error") + stopifnot(get_ast(str2lang(input$name)) != "Error") + dataSet$df <- unstackDF(dataSet$df, input$name, input$value) + }) + if (inherits(e, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + } + output$df <- renderDT(dataSet$df) + output$mod_error <- renderText(err) + return(df) + }) + + listResults <- reactiveValues( + curr_data = NULL, curr_name = NULL, + all_data = list(), all_names = list() + ) + corrServer("CORR", dataSet, listResults) + visServer("VIS", dataSet, listResults) + assServer("ASS", dataSet, listResults) + testsServer("TESTS", dataSet, listResults) + DoseResponseServer("DOSERESPONSE", dataSet, listResults) + } + + shinyApp(ui, server) +} + +library(shiny) +library(DT) +library(bslib) +library(broom) +library(ggplot2) +library(base64enc) +library(shinyjs) +library(mgcv) +library(RColorBrewer) +library(tidyr) +library(purrr) +library(agricolae) +library(drc) +library(cowplot) +library(MASS) +library(Matrix) +library(shinyjs) + +source("check_ast.R") +source("utils.R") +source("plottingInternally.R") +source("lc50.r") +source("correlation.R") +source("visualisation.R") +source("assumption.R") +source("statisticalTests.R") +source("DoseResponse.R") + +ui <- fluidPage( + useShinyjs(), + includeScript("www/download.js"), # NOTE: would be better located in inst folder but the serverless version cannot handle this + sidebarLayout( + sidebarPanel( + conditionalPanel( + condition = "input.conditionedPanels == 'Data'", + uiOutput("conditional_data_ui"), + fileInput("file", "Choose CSV File", + accept = c( + "text/csv", + "text/comma-separated-values,text/plain", + ".csv" + ) + ), + textInput("op", "Operations", value = "var / 1000"), + textInput("new_col", "Name of new variable", value = "var"), + actionButton("mod", "Modify"), + tags$hr(), + textInput("keepVar", "const variable"), + actionButton("pivotLonger", "conversion to long format"), + tags$hr(), + textInput("name", "name column"), + textInput("value", "value column"), + actionButton("pivotWider", "convert to wide format"), + verbatimTextOutput("mod_error"), + tags$hr() + ), + conditionalPanel( + condition = "input.conditionedPanels == 'Correlation'", + corrSidebarUI("CORR") + ), + conditionalPanel( + condition = "input.conditionedPanels == 'Visualisation'", + visSidebarUI("VIS") + ), + conditionalPanel( + condition = "input.conditionedPanels == 'Assumption'", + assSidebarUI("ASS") + ), + conditionalPanel( + condition = "input.conditionedPanels == 'Tests'", + testsSidebarUI("TESTS") + ), + conditionalPanel( + condition = "input.conditionedPanels == 'Dose Response analysis'", + DoseResponseSidebarUI("DOSERESPONSE") + ) + ), + mainPanel( + tabsetPanel( + tabPanel( + "Data", + DTOutput("df") + ), + tabPanel( + "Correlation", + corrUI("CORR") + ), + tabPanel( + "Visualisation", + visUI("VIS") + ), + tabPanel( + "Assumption", + assUI("ASS") + ), + tabPanel( + "Tests", + testsUI("TESTS") + ), + tabPanel( + "Dose Response analysis", + DoseResponseUI("DOSERESPONSE") + ), + id = "conditionedPanels" + ) + ) + ) +) + +server <- function(input, output, session) { + dataSet <- reactiveValues(df = NULL) + + output$conditional_data_ui <- renderUI({ + if (Sys.getenv("RUN_MODE") != "SERVER") { + res <- conditionalPanel( + condition = "input.conditionedPanels == 'Data'", + fileInput("file", "Choose CSV File", + accept = c( + "text/csv", + "text/comma-separated-values,text/plain", + ".csv" + ) + ) + ) + return(res) + } + }) + + download_file <- reactive({ + file <- COMELN::download(session, "/home/shiny/results") + upload <- function(path) { + stopifnot(is.character(path)) + df <- NULL + df <- try(as.data.frame(readxl::read_excel( + path, + col_names = TRUE + )), silent = TRUE) + if (class(df) == "try-error") { + # identify seperator + line <- readLines(path, n = 1) + semicolon <- grepl(";", line) + comma <- grepl(",", line) + tab <- grepl("\t", line) + seperator <- NULL + if (semicolon == TRUE) { + seperator <- ";" + } else if (comma == TRUE) { + seperator <- "," + } else if (tab == TRUE) { + seperator <- "\t" + } else { + return("error") + } + df <- try(read.csv(path, header = TRUE, sep = seperator)) + if (class(df) == "try-error") { + return("error") + } + } else { + f <- function(x) { + options(warn = -1) + x <- as.numeric(x) + options(warn = 0) + x <- x[!is.na(x)] + length(x) > 0 + } + check <- apply(df, 2, f) + conv <- function(a, b) { + if (a == TRUE) { + return(as.numeric(b)) + } + return(b) + } + df <- Map(conv, check, df) + df <- data.frame(df) + } + return(df) + } + df <- NULL + df <- upload(file) + if (is.data.frame(df)) { + var$df <- df + } else { + showNotification("File can not be used. Upload into R failed!", duration = 0) + } + tryCatch( + { + system(paste("rm -r ", file)) + }, + warning = function(warn) { + showNotification(paste("A warning occurred: ", conditionMessage(warn)), duration = 0) + }, + error = function(err) { + showNotification(paste("An error occurred: ", conditionMessage(err)), duration = 0) + } + ) + req(is.data.frame(df)) + return(df) + }) + + + output$df <- renderDT({ + if (Sys.getenv("RUN_MODE") == "SERVER") { + isolate({ + dataSet$df <- download_file() + }) + datatable(dataSet$df, options = list(pageLength = 10)) + } else { + req(input$file) + df <- try(read.csv(input$file$datapath)) + if (inherits(df, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + showNotification(err) + return(NULL) + } + dataSet$df <- df + req(!is.na(dataSet$df)) + datatable(dataSet$df, options = list(pageLength = 10)) + } + }) + + observeEvent(input$mod, { + req(!is.null(dataSet$df)) + req(is.data.frame(dataSet$df)) + req(input$op) + req(input$new_col) + dt <- dataSet$df + op <- input$op + new_col <- input$new_col + new <- NULL + err <- NULL + e <- try({ + ast <- get_ast(str2lang(op)) + ast <- ast[[length(ast)]] + }) + if (e == "Error") { + showNotification("Found unallowed function") + return() + } else if (inherits(e, "try-error")) { + showNotification(e) + return() + } + e <- try({ + new <- with(dt, eval(parse(text = op))) + dataSet$df[, new_col] <- new + }) + if (inherits(e, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + } + output$df <- renderDT(dataSet$df) + output$mod_error <- renderText(err) + return(df) + }) + + observeEvent(input$pivotLonger, { + req(!is.null(dataSet$df)) + req(input$keepVar) + err <- NULL + e <- try({ + stopifnot(get_ast(str2lang(input$keepVar)) != "Error") + dataSet$df <- stackDF(dataSet$df, input$keepVar) + }) + if (inherits(e, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + } + output$df <- renderDT(dataSet$df) + output$mod_error <- renderText(err) + return(df) + }) + + observeEvent(input$pivotWider, { + req(!is.null(dataSet$df)) + req(input$name) + req(input$value) + err <- NULL + e <- try({ + stopifnot(get_ast(str2lang(input$value)) != "Error") + stopifnot(get_ast(str2lang(input$name)) != "Error") + dataSet$df <- unstackDF(dataSet$df, input$name, input$value) + }) + if (inherits(e, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + } + output$df <- renderDT(dataSet$df) + output$mod_error <- renderText(err) + return(df) + }) + + listResults <- reactiveValues( + curr_data = NULL, curr_name = NULL, + all_data = list(), all_names = list() + ) + corrServer("CORR", dataSet, listResults) + visServer("VIS", dataSet, listResults) + assServer("ASS", dataSet, listResults) + testsServer("TESTS", dataSet, listResults) + DoseResponseServer("DOSERESPONSE", dataSet, listResults) +} + +shinyApp(ui, server) + +# run_app() diff --git a/bs/R/assumption.R b/bs/R/assumption.R new file mode 100644 index 0000000..befcf6d --- /dev/null +++ b/bs/R/assumption.R @@ -0,0 +1,254 @@ +assSidebarUI <- function(id) { + tabPanel( + "Assumption", + tags$hr(), + textInput(NS(id, "dep"), "dependent Variable", value = "var1"), + textInput(NS(id, "indep"), "independent Variable", value = "var2"), + tags$hr(), + tags$div( + class = "header", checked = NA, + tags$h4( + style = "font-weight: bold;", + "Test of normal distribution" + ) + ), + actionButton(NS(id, "shapiro"), "Shapiro test for individual groups"), + tags$hr(), + actionButton(NS(id, "shapiroResiduals"), "Shapiro test for residuals of linear model"), + tags$hr(), + tags$div( + class = "header", checked = NA, + tags$h4( + style = "font-weight: bold;", + "Test of variance homogenity" + ) + ), + actionButton(NS(id, "levene"), "Levene test"), + selectInput(NS(id, "center"), "Data center of each group: mean or median", + c( + "Mean" = "mean", + "Median" = "median" + ), + selectize = FALSE + ), + tags$hr(), + tags$div( + class = "header", checked = NA, + tags$h4(style = "font-weight: bold;", "Visual tests") + ), + actionButton(NS(id, "DiagnosticPlot"), "diagnostic plots") + ) +} + +assUI <- function(id) { + fluidRow( + tags$head( + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js"), + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js"), + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js"), + tags$script(src = "download.js") + ), + h4(strong("Results of test:")), + verbatimTextOutput(NS(id, "ass_error")), + actionButton(NS(id, "ass_save"), "Add output to result-file"), + actionButton(NS(id, "download_ass"), "Save and exit"), + checkboxGroupInput(NS(id, "TableSaved"), "Saved results to file", NULL), + tableOutput(NS(id, "ass_result")), + plotOutput(NS(id, "DiagnosticPlotRes")) + ) +} + +assServer <- function(id, data, listResults) { + moduleServer(id, function(input, output, session) { + runShapiro <- function() { + output$ass_error <- renderText(NULL) + req(input$indep) + req(input$dep) + indep <- input$indep + dep <- input$dep + df <- data$df + req(is.data.frame(df)) + check <- TRUE + res <- NULL + temp <- NULL + err <- NULL + if (isTRUE(check)) { + res <- list() + e <- try({ + formula <- as.formula(paste(dep, "~", indep)) + stopifnot(get_ast(formula) != "Error") + dat <- splitData(df, formula) + for (i in unique(dat[, 2])) { + tempDat <- dat[dat[, 2] == i, ] + temp <- broom::tidy(shapiro.test(tempDat[, 1])) + if (!is.null(temp)) { + temp$variable <- i + res[[length(res) + 1]] <- temp + } + } + res <- do.call(rbind, res) + }) + if (!inherits(e, "try-error")) { + listResults$curr_data <- res + listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted shapiro test") + output$curr_result <- renderTable(res, digits = 6) + output$curr_error <- renderText(err) + } else { + err <- conditionMessage(attr(e, "condition")) + output$ass_error <- renderText(err) + } + } + } + observeEvent(input$shapiro, { + runShapiro() + }) + + runShapiroResiduals <- function() { + output$ass_error <- renderText(NULL) + req(input$indep) + indep <- input$indep + req(input$dep) + dep <- input$dep + df <- data$df + req(is.data.frame(df)) + formula <- NULL + err <- NULL + res <- NULL + e <- try({ + formula <- as.formula(paste(dep, "~", indep)) + stopifnot(get_ast(formula) != "Error") + fit <- lm(formula, data = df) + r <- resid(fit) + res <- broom::tidy(shapiro.test(r)) + }) + if (!inherits(e, "try-error")) { + listResults$curr_data <- res + listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted shapiro test") + output$curr_result <- renderTable(res, digits = 6) + output$curr_error <- renderText(err) + } else { + err <- conditionMessage(attr(e, "condition")) + output$ass_error <- renderText(err) + } + } + observeEvent(input$shapiroResiduals, { + runShapiroResiduals() + }) + + runLevene <- function() { + output$ass_error <- renderText(NULL) + req(input$indep) + indep <- input$indep + req(input$dep) + dep <- input$dep + df <- data$df + req(is.data.frame(df)) + formula <- NULL + err <- NULL + fit <- NULL + e <- try({ + formula <- as.formula(paste(dep, "~", indep)) + stopifnot(get_ast(formula) != "Error") + fit <- broom::tidy(car::leveneTest(formula, data = df, center = input$center)) + }) + if (inherits(e, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + output$ass_error <- renderText(err) + } else { + listResults$curr_data <- fit + listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "variance homogenity (levene)") + output$curr_result <- renderTable(fit, digits = 6) + output$curr_error <- renderText(err) + } + } + observeEvent(input$levene, { + runLevene() + }) + + output$ass_result <- renderTable( + { + if (!inherits(listResults$curr_data, "diagnosticPlot")) { + return(listResults$curr_data) + } + return(NULL) + }, + digits = 6 + ) + + runDiagnosticPlot <- function() { + output$ass_error <- renderText(NULL) + req(input$indep) + indep <- input$indep + req(input$dep) + dep <- input$dep + df <- data$df + req(is.data.frame(df)) + formula <- NULL + err <- NULL + f <- NULL + e <- try({ + formula <- as.formula(paste(dep, "~", indep)) + stopifnot(get_ast(formula) != "Error") + f <- diagnosticPlot(df, formula) + }) + if (inherits(e, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + output$ass_error <- renderText(err) + } else { + listResults$curr_data <- new("diagnosticPlot", p = f) + listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "diagnostic plots") + output$DiagnosticPlotRes <- renderImage( + { + list( + src = f, + contentType = "image/png" + ) + }, + deleteFile = FALSE + ) + output$curr_error <- renderText(err) + } + } + observeEvent(input$DiagnosticPlot, { + runDiagnosticPlot() + }) + + observeEvent(input$ass_save, { + if (is.null(listResults$curr_name)) { + return(NULL) + } + if (!(listResults$curr_name %in% unlist(listResults$all_names))) { + listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data + listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name + } + updateCheckboxGroupInput(session, "TableSaved", + choices = listResults$all_names + ) + }) + + observeEvent(input$download_ass, { + lr <- unlist(listResults$all_names) + indices <- sapply(input$TableSaved, function(x) { + which(x == lr) + }) + req(length(indices) >= 1) + l <- listResults$all_data[indices] + + if (Sys.getenv("RUN_MODE") == "BROWSER") { + jsString <- createJSString(l) + session$sendCustomMessage( + type = "downloadZip", + list( + numberOfResults = length(jsString), + 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 + } + }) + }) + + return(listResults) +} diff --git a/bs/R/check_ast.R b/bs/R/check_ast.R new file mode 100644 index 0000000..a492bd6 --- /dev/null +++ b/bs/R/check_ast.R @@ -0,0 +1,36 @@ +get_ast <- function(inp) { + if (!is.call(inp)) { + return(inp) + } + + inp <- as.list(inp) + + # check if is function + fct <- inp[[1]] + + allowed_fcts <- c( + "-", "+", "*", "/", + "log", "log10", "sqrt", "exp", "^", + "sin", "cos", "tan", "tanh", "sinh", "cosh", "acos", "asin", "atan", + "is.numeric", "is.character", "is.logical", "is.factor", "is.integer", + "as.numeric", "as.character", "as.logical", "as.factor", "as.integer", + ">", "<", "<=", ">=", "==", "!=", + "abs", "ceiling", "floor", "trunc", "round", + "grep", "substr", "sub", "paste", "paste0", + "strsplit", "tolower", "toupper", + "dnorm", "pnorm", "qnorm", "rnorm", "dbinom", + "pbinom", "qbinom", "rbinom", "dpois", + "ppois", "rpois", "dunif", "punif", "qunif", "runif", + "mean", "sd", "median", "quantile", "range", + "sum", "diff", "min", "max", "scale", + "c", "vector", "length", "matrix", "~" + ) + + check <- deparse(fct) + + if ((check %in% allowed_fcts) == FALSE) { + return("Error") + } + + lapply(inp, get_ast) +} diff --git a/bs/R/correlation.R b/bs/R/correlation.R new file mode 100644 index 0000000..2c327bb --- /dev/null +++ b/bs/R/correlation.R @@ -0,0 +1,141 @@ +corrSidebarUI <- function(id) { + tabPanel( + "Correlation", + textInput(NS(id, "dep"), "dependent Variable", value = "var1"), + textInput(NS(id, "indep"), "independent Variable", value = "var2"), + actionButton(NS(id, "pear"), "Pearson correlation"), + actionButton(NS(id, "spear"), "Spearman correlation"), + actionButton(NS(id, "kendall"), "Kendall correlation"), + sliderInput(NS(id, "conflevel"), "Confidence level of the interval", + min = 0, max = 1, value = 0.95 + ), + selectInput( + NS(id, "alt"), "Alternative hypothesis", + c( + "Two sided" = "two.sided", + "Less" = "less", + "Greater" = "greater" + ) + ) + ) +} + +corrUI <- function(id) { + fluidRow( + tags$head( + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js"), + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js"), + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js"), + tags$script(src = "download.js") + ), + h4(strong("Results of test:")), + tableOutput(NS(id, "corr_result")), + verbatimTextOutput(NS(id, "corr_error")), + actionButton(NS(id, "corr_save"), "Add output to result-file"), + actionButton(NS(id, "download_corr"), "Save results"), + checkboxGroupInput(NS(id, "TableSaved"), "Saved results to file", NULL) + ) +} + +corrServer <- function(id, data, listResults) { + moduleServer(id, function(input, output, session) { + corr_fct <- function(method) { + output$corr_error <- renderText(NULL) + req(is.data.frame(data$df)) + df <- data$df + req(input$dep) + req(input$indep) + dep <- input$dep + indep <- input$indep + d <- df + fit <- NULL + err <- NULL + e <- try({ + stopifnot(get_ast(str2lang(indep)) != "Error") + stopifnot(get_ast(str2lang(dep)) != "Error") + fit <- broom::tidy( + cor.test(d[, dep], d[, indep], + method = method, + alternative = input$alt, + conf.level = input$conflevel + ) + ) + }) + if (inherits(e, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + output$corr_error <- renderText(err) + } else { + listResults$curr_data <- fit + listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted test: ", method) + output$corr_result <- renderTable(fit, digits = 6) + } + } + + observeEvent(input$pear, { + corr_fct("pearson") + }) + output$cor_result <- renderTable( + { + listResults$curr_data + }, + digits = 6 + ) + + observeEvent(input$spear, { + corr_fct("spearman") + }) + output$cor_result <- renderTable( + { + listResults$curr_data + }, + digits = 6 + ) + + observeEvent(input$kendall, { + corr_fct("kendall") + }) + output$cor_result <- renderTable( + { # issue: check whether this is required + listResults$curr_data + }, + digits = 6 + ) + + observeEvent(input$corr_save, { + if (is.null(listResults$curr_name)) { + return(NULL) + } + if (!(listResults$curr_name %in% unlist(listResults$all_names))) { + listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data + listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name + } + updateCheckboxGroupInput(session, "TableSaved", + choices = listResults$all_names + ) + }) + + observeEvent(input$download_corr, { + lr <- unlist(listResults$all_names) + indices <- sapply(input$TableSaved, function(x) { + which(x == lr) + }) + req(length(indices) >= 1) + l <- listResults$all_data[indices] + if (Sys.getenv("RUN_MODE") == "BROWSER") { + jsString <- createJSString(l) + session$sendCustomMessage( + type = "downloadZip", + list( + numberOfResults = length(jsString), + 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 + } + }) + }) + + return(listResults) +} diff --git a/bs/R/lc50.r b/bs/R/lc50.r new file mode 100644 index 0000000..3f95f3e --- /dev/null +++ b/bs/R/lc50.r @@ -0,0 +1,298 @@ +errorClass <- R6::R6Class("errorClass", + public = list( + error_message = NULL, + object = NULL, + initialize = function(error_message = NULL) { + self$error_message = error_message + }, + isNull = function() { + if(is.null(self$error_message)) { + return(TRUE) + } + return(FALSE) + } + ) +) + +shapenumber <- function (my.number) { + if (is.finite(my.number)) { + my.result <- signif(my.number,3) + } else { + my.result <- NA + } + return (my.result) +} + +#calculates the robust 68th percentile of the residuals +#adapted from Motulsky HJ, Brown RE, BMC Bioinformatics 2006, 7:123 +robust_68_percentile <- function (residuals) { + res <- abs(residuals) + res_sorted <- sort(res) + res_percentiles <- (seq(1:length(res_sorted))/length(res_sorted))*100 + index <- min(which(res_percentiles > 68.25)) + x <- c(res_percentiles[index-1],res_percentiles[index]) + y <- c(res_sorted[index-1],res_sorted[index]) + m <- lm(y~x) + x <- c(68.25) + y <- predict(m, as.data.frame(x)) + return(y) +} + +#calculates the robust standard deviation of the residuals (RSDR) with correction for degrees of freedom +#adapted from Motulsky HJ, Brown RE, BMC Bioinformatics 2006, 7:123 +robust_standard_deviation_residuals <- function(residuals, number_of_coefficients_fitted) { + my_residuals <- as.numeric(residuals) + my_residuals <- na.omit(residuals) + N <- length(my_residuals) #the number of data points fitted + K <- number_of_coefficients_fitted #for ic50, 4 coefficients are fitted + result <- robust_68_percentile(residuals) * N/(N-K) + return (result) +} + +#false discovery rate (FDR) approach, returns a T/F vector for selection of valid data points +#adapted from Motulsky HJ, Brown RE, BMC Bioinformatics 2006, 7:123 +false_discovery_rate <- function(res) { + N <- length(res) + Q <- 0.01 #Q=1% + K <- 4 #number of coefficients in the fitted LL.4 model + R <- robust_standard_deviation_residuals(res,K) #the robust standard deviation of the residuals + id <- seq(1:length(res)) + df <- data.frame(id,res) + df$res_abs <- abs(df$res) + df <- df[order(df$res_abs),] + df$i <- seq(1:N) + df$i_fraction <- df$i / N + df$alpha <- Q*(N-(df$i-1))/N + df$t <- df$res_abs / R + df$P <- dt(df$t, N-K) + df$include <- ifelse(df$P < df$alpha & df$i_fraction >= 0.7, FALSE, TRUE) + df2 <- df[order(df$id), ] + return (df2$include) +} + +check_fit <- function(model, min_conc, max_conc, min_abs, max_abs, substance_name) { + if(model$fit$convergence != TRUE) return(errorClass$new(paste(substance_name, + "Model did not converge"))) + b <- coefficients(model)[1] #Hill coefficient + c <- coefficients(model)[2] #asymptote 1 + d <- coefficients(model)[3] #asymptote 2 + e <- coefficients(model)[4] #IC50 + RSE <- summary(model)$rseMat[1] #residual standard error estimated + Response_lowestdose_predicted <- predict(model, data.frame(concentration = min_conc), se.fit = FALSE)[1] + Response_highestdose_predicted <- predict(model, data.frame(concentration = max_conc), se.fit = FALSE)[1] + Response_difference <- 100 * abs(Response_lowestdose_predicted - Response_highestdose_predicted) + HillCoefficient <- b + IC50_relative <- e + pIC50 <- -log10(e/1000000) + Problems <- "" + if (Response_difference < 25) { + Problems <- paste(Problems, "Response Difference lower than 25%", collapse = " , ") + } else if(IC50_relative > max_conc) { + Problems <- paste(Problems, "IC50 larger than highest measured concentration", collapse = " , ") + } else if(IC50_relative < min_conc) { + Problems <- paste(Problems, "IC50 lower than lowest measured concentration", collapse = " , ") + } + + confidence_interval <- confint(model, parm = c("e"), level = 0.95) + IC50_relative_lower <- confidence_interval[1] + IC50_relative_higher <- confidence_interval[2] + p_value <- noEffect(model)[3] + Response_lowestdose_predicted <- shapenumber(Response_lowestdose_predicted) + Response_highestdose_predicted <- shapenumber(Response_highestdose_predicted) + HillCoefficient <- shapenumber(HillCoefficient) + IC50_relative <- shapenumber(IC50_relative) + IC50_relative_lower <- shapenumber(IC50_relative_lower) + IC50_relative_higher <- shapenumber(IC50_relative_higher) + pIC50 <- shapenumber( -log10(IC50_relative/1000000)) + p_value <- shapenumber(p_value) + ylim_low = 0 + ylim_high = 125 + if (min_abs < ylim_low) ylim_low <- min_abs + if (max_abs > ylim_high) ylim_high <- max_abs + outvar <- data.frame(name = substance_name, + Response_lowestdose_predicted = Response_lowestdose_predicted, + Response_highestdose_predicted = Response_highestdose_predicted, + HillCoefficient = HillCoefficient, + asymptote_one = c, asymptote_two = d, + IC50_relative = IC50_relative, IC50_relative_lower = IC50_relative_lower, + IC50_relative_higher = IC50_relative_higher, pIC50 = pIC50, + RSE = RSE, p_value = p_value, Problems = Problems) + return (outvar) +} + +drawplot <- function(df, abs_col, conc_col, model, valid_points, title, + IC50_relative, IC50_relative_lower, IC50_relative_higher) { + min_conc <- min(df[, conc_col]) + max_conc <- max(df[, conc_col]) + grid <- seq(min_conc, max_conc, 0.1) + plotFct <- (model$curve)[[1]] + res <- plotFct(grid) + data <- data.frame(abs = res, + conc = grid) + data_measured <- data.frame(conc = df[, conc_col], abs = df[, abs_col]) + p <- ggplot() + + geom_boxplot(data = data_measured, aes(x = conc, y = abs*100, group = conc)) + + geom_line(data = data, aes(x = conc, y = abs*100)) + + xlab("Concentration [µM]") + + ylab("Viability [%]") + + ggtitle(title) + + max_conc <- max(df[, conc_col]) + 10 + min_conc <- -10 + xmin <- IC50_relative - IC50_relative_lower + xmax <- IC50_relative + IC50_relative_higher + if (!is.na(xmin) & !is.na(xmax)) { + ymin <- min(df[, abs_col]) * 100 + ymax <- max(df[, abs_col]) * 100 + yrange <- ymax - ymin + butt_height <- yrange * 0.1 + ymedian <- median(df[, abs_col]) * 100 + if (xmin > min_conc && xmax < max_conc ) { + p <- p + geom_errorbarh(aes(xmin = xmin, + xmax = xmax, y = ymedian), + colour = "darkred", end = "butt", height = butt_height) + } else { + p <- p + labs(caption = "Confidence intervall not in conc. range") + + theme(plot.caption = element_text(color = "darkred", face = "italic", size = 7)) + } + } else { + p <- p + labs(caption = "Confidence intervall could not be calculated") + + theme(plot.caption = element_text(color = "darkred", face = "italic", size = 7)) + } + + return(p) +} + +ic50_internal <- function(df, abs, conc, title) { + model <- drm(abs ~ conc, data = df , fct = LL.4(), robust = "median") + valid_points <- false_discovery_rate(residuals(model)) + model <- drm(abs ~ conc, data = df , subset = valid_points, start = model$coefficients, fct = LL.4(), robust = "mean") + res <- check_fit(model, min(df[, conc]), max(df[, conc]), min(df[, abs]), max(df[, abs]), title) + p <- drawplot(df, abs, conc, model, valid_points, title, res$IC50_relative, + res$IC50_relative_lower, res$IC50_relative_higher) + return(list(res, p)) +} + +drawplotOnlyRawData <- function(df, abs_col, conc_col, title) { + min_conc <- min(df[, conc_col]) + max_conc <- max(df[, conc_col]) + data_measured <- data.frame(conc = df[, conc_col], abs = df[, abs_col]) + p <- ggplot() + + geom_boxplot(data = data_measured, aes(x = conc, y = abs*100, group = conc)) + + xlab("Concentration [µM]") + + ylab("Viability [%]") + + ggtitle(title) + return(p) +} + +#' Calculates the ic50 values +#' @export +#' @import drc +#' @import ggplot2 +#' @param df a data.frame which contains all the data +#' @param abs_col the name of the column in df which contains the dependent variable +#' @param conc_col the name of the column in df which contains the different concentrations +#' @param substance_name_col the name of the column in df which contains the different names of the compounds +#' @param negative_identifier a character defining the name to identify the negative control within conc_col +#' @param positive_identifier a character defining the name to identify the positive control within conc_col +#' @return a list is returned containing the ic50 value the fitted plots and other parameters +#' @examples +#' path <- system.file("data", package = "MTT") +#' df <- read.csv(paste0(path, "/ExampleData.txt")) +#' ic50(df, "abs", "conc", "names", "neg", "pos") +ic50 <- function(df, abs_col, conc_col, substance_name_col, negative_identifier, positive_identifier) { + substances <- unique(df$names) + + if(!(negative_identifier %in% substances)) { + return(errorClass$new("the string for the negative control was not found!")) + } + if(!(positive_identifier %in% substances)) { + return(errorClass$new("the string for the positive control was not found!")) + } + substances <- substances[substances != negative_identifier] + substances <- substances[substances != positive_identifier] + if(length(substances) < 1) { + return(errorClass$new("The data for compounds seems to be missing")) + } + if(!is.numeric(df[, abs_col])) { + return(errorClass$new("The absorbance data is not numerical")) + } + temp_conc <- df[, conc_col] + temp_conc[temp_conc == negative_identifier] <- -1 + temp_conc[temp_conc == positive_identifier] <- -2 + temp_conc <- as.numeric(temp_conc) + if(any(is.na(temp_conc))) { + return(errorClass$new("The concentration data cannot be converted to numerical")) + } + df[, conc_col] <- temp_conc + if(!is.numeric(df[, conc_col])) { + return(errorClass$new("The concentration data is not numerical")) + } + neg_mean <- mean(df[df[ , substance_name_col] == negative_identifier, abs_col]) + pos_mean <- mean(df[df[ , substance_name_col] == positive_identifier, abs_col]) + df[, abs_col] <- (df[, abs_col] - pos_mean) / neg_mean + res <- list() + for(i in seq_along(substances)) { + df_temp <- df[df$names == substances[i], ] + m <- tryCatch({ + m <- ic50_internal(df_temp, abs_col, conc_col, substances[i]) + }, + error = function(err) { + retval <- errorClass$new(paste("A warning occurred: ", conditionMessage(err))) + retval$object <- drawplotOnlyRawData(df_temp, abs_col, conc_col, substances[i]) + return(retval) + }) + res[[i]] <- m + } + + return(res) +} + +report_plots <- function(ic50List) { + p3 <- ggdraw() + + draw_line(x = c(0, 1), y = c(0.5, 0.5), color = "black", size = 1) + + theme_void() + for(i in seq_along(ic50List)) { + if(is(ic50List[[i]], "errorClass")) { + p <- ic50List[[i]]$object + p <- p + + annotate("text", x = -Inf, y = -Inf, + hjust = -0.2, vjust = -1, label = ic50List[[i]]$error_message) + #print(p) + #print(p3) + next + } + p1 <- ic50List[[i]][[2]] + a <- ic50List[[i]][[1]] |> t() |> as.data.frame() + a <- data.frame(names = row.names(a), Predicition = a) + a[a$names == "Response_lowestdose_predicted", 1] <- "Response_lowestdose" + a[a$names == "Response_highestdose_predicted", 1] <- "Response_highestdose" + problem <- a[a$names == "Problems", 2] + a <- a[(a$names != "Problems") & (a$names != "name"), ] + p2 <- ggplot(a, aes(x = 0, y = factor(names), label = Prediction)) + + geom_line(size = 0) + + geom_text(position = position_nudge(x = -1.1), hjust = 0, size = 3) + + theme_minimal() + + theme(axis.text.x = element_blank(), + axis.ticks.x = element_blank(), + panel.grid.major.x = element_blank(), + panel.grid.minor.x = element_blank(), + panel.grid.major.y = element_blank(), + panel.grid.minor.y = element_blank(), + axis.title.x = element_blank(), + axis.title.y = element_blank(), + axis.text.y = element_text(hjust = 0, face = "bold"), + axis.line.y = element_line(), + plot.caption = element_text(hjust = 1, face = "italic", colour = "darkred", + size = 7) ) + if(problem != "") { + p2 <- p2 + labs(caption = paste("Note:", as.character(problem)) ) + } + + p <- ggdraw() + + draw_plot(p2, x = 0, y = 0, width = 0.5, height = 0.5) + + draw_plot(p1, x = 0.5, y = 0, width = 0.5, height = 0.5) + #print(p) + #print(p3) + } +} diff --git a/bs/R/plottingInternally.R b/bs/R/plottingInternally.R new file mode 100644 index 0000000..70b5848 --- /dev/null +++ b/bs/R/plottingInternally.R @@ -0,0 +1,302 @@ +annotateDF <- function(p, method, level = 2) { + pB <- ggplot_build(p) + df <- pB$data[[1]] + if (length(unique(df$PANEL)) > 1) { + l <- pB$layout$layout + l <- data.frame(PANEL = l$PANEL, names = l$``) + df$PANEL <- l[match(df$PANEL, l$PANEL), 2] + } + # https://stackoverflow.com/questions/40854225/how-to-identify-the-function-used-by-geom-smooth + formula <- p$layers[[level]]$stat$setup_params( + df, + p$layers[[level]]$stat_params + )$formula + df$interaction <- interaction(df$PANEL, df$group) + + results <- lapply(unique(df$interaction), function(x) { + sub <- df[df$interaction == x, ] + calcParams(sub, formula, method) + }) + df <- Reduce(rbind, results) + return(df) +} + +calcParams <- function(df, formula, method) { + stopifnot(get_ast(formula) != "Error") + if (method == "lm") { + model <- lm(formula, data = df) + r_squared <- summary(model)$r.squared + anova_table <- anova(model) + f_value <- anova_table$`F value`[1] + coefficients <- coef(model) + equation <- paste( + "Y =", round(coefficients[1], 2), "+", + round(coefficients[2], 2), "* X" + ) + p_value <- summary(model)$coefficients[, 4] + p_value <- paste(p_value, collapse = " ") + n <- nrow(df) + annotations <- paste( + "R-squared:", round(r_squared, 2), + "F-value:", round(f_value, 2), "\n", + "Equation:", equation, "\n", + "Sample Size (n):", n, "\n", + "p-values Intercept & x:", round(p_value, 6) + ) + df$annotation <- annotations + df$xPos <- mean(df$x) + df$yPos <- max(df$y) + return(df) + } else if (method == "glm") { + model <- glm(formula, data = df) + r_squared <- with(summary(model), 1 - deviance / null.deviance) + coefficients <- coef(model) + n <- nrow(df) + equation <- paste( + "Y =", round(coefficients[1], 2), "+", + round(coefficients[2], 2), "* X" + ) + p_value <- summary(model)$coefficients[2, 4] + annotations <- paste( + "R-squared:", round(r_squared, 2), + "Sample Size (n):", n, "\n", + "Equation:", equation, "\n", + "p-value:", round(p_value, 6) + ) + df$annotation <- annotations + df$xPos <- mean(df$x) + df$yPos <- max(df$y) + return(df) + } else if (method == "gam") { + model <- gam(formula, data = df) + r_squared <- summary(model)$r.sq + f_value <- summary(model)$p.t + coefficients <- coef(model) + n <- nrow(df) + equation <- paste( + "Y =", round(coefficients[1], 2), "+", + round(coefficients[2], 2), "* X" + ) + p_value <- summary(model)$p.pv + annotations <- paste( + "R-squared:", round(r_squared, 2), + "F-value:", round(f_value, 2), "\n", + "Equation:", equation, + "Sample Size (n):", n, "\n", + "p-value:", round(p_value, 6) + ) + df$annotation <- annotations + df$xPos <- mean(df$x) + df$yPos <- max(df$y) + return(df) + } else if (method == "loess") { + model <- loess(formula, data = df) + fitted_values <- predict(model) + r_squared <- cor(df$y, fitted_values)^2 + n <- nrow(df) + annotations <- paste( + "R-squared:", round(r_squared, 2), + "Sample Size (n):", n + ) + df$annotation <- annotations + df$xPos <- mean(df$x) + df$yPos <- max(df$y) + return(df) + } +} + +addFacet <- function(p, facetVar, facetMode) { + if (facetMode == "facet_wrap") { + return(p + facet_wrap(. ~ .data[[facetVar]], scales = "free")) + } else if (facetMode == "facet_grid") { + return(p + facet_grid(. ~ .data[[facetVar]], scales = "free")) + } +} + +DotplotFct <- function(df, x, y, xLabel, yLabel, + fitMethod, + colourVar, legendTitleColour, + colourTheme, facetMode, facetVar, k = 10) { + # create plot + # ========================================== + aes <- aes(x = .data[[x]], y = .data[[y]]) + aesColour <- NULL + p <- NULL + + if (colourVar != "") { + aesColour <- aes(colour = .data[[colourVar]]) + } + if (colourVar == "") { + p <- ggplot( + data = df, + aes(!!!aes) + ) + + geom_point() + } else { + p <- ggplot( + data = df, + aes(!!!aes, !!!aesColour) + ) + + geom_point() + } + + p <- p + xlab(xLabel) + p <- p + ylab(yLabel) + + if (colourVar != "") { + p <- p + guides(colour = guide_legend(title = legendTitleColour)) + p <- p + scale_color_brewer(palette = colourTheme) + } + + if (facetMode != "none") { + p <- addFacet(p, facetVar, facetMode) + } + + if (fitMethod == "none" || fitMethod == "") { + return(p) + } + + # fit data + # ========================================== + if (fitMethod == "gam") { + p <- p + geom_smooth( + method = fitMethod, + formula = y ~ s(x, bs = "cs", k = k) + ) + } else { + p <- p + geom_smooth(method = fitMethod) + } + + # extract information from fit + # ========================================== + df_original <- df + df <- annotateDF(p, fitMethod) + names(df) <- ifelse(names(df) == "PANEL", "Panel", names(df)) + + # TODO: this is a hack. Find a better way. + if (colourVar != "") { + df$colour_groups <- df_original[, colourVar][match( + df$group, + as.integer(factor(df_original[, colourVar])) + )] + } + # Add annotations to plot + # ========================================== + aes <- aes(x = .data[["x"]], y = .data[["y"]]) + if (colourVar != "") { + aesColour <- aes(colour = .data[["colour_groups"]]) + } + if (fitMethod == "gam") { + p <- ggplot(data = df, aes(!!!aes, !!!aesColour)) + + geom_point() + + geom_smooth( + method = fitMethod, + formula = y ~ s(x, bs = "cs", k = k) + ) + + geom_text( + aes( + x = xPos, y = yPos, + label = annotation + ), + size = 3, + show.legend = FALSE, position = position_dodge(width = .9) + ) + } else { + p <- ggplot(data = df, aes(!!!aes, !!!aesColour)) + + geom_point() + + geom_smooth(method = fitMethod) + + geom_text( + aes( + x = xPos, y = yPos, + label = annotation + ), + size = 3, + show.legend = FALSE, position = position_dodge(width = .9) + ) + } + + # Add labels + # ========================================== + p <- p + xlab(xLabel) + p <- p + ylab(yLabel) + if (length(unique(df$colour)) >= 2) { + p <- p + guides(colour = guide_legend(title = legendTitleColour)) + p <- p + scale_color_brewer(palette = colourTheme) + } + if (facetMode != "none") { + p <- addFacet(p, "Panel", facetMode) + } + + return(p) +} + +BoxplotFct <- function(df, x, y, xLabel, yLabel, + fillVar, legendTitleFill, fillTheme, + colourVar, legendTitleColour, + colourTheme, facetMode, facetVar) { + aes <- aes(x = .data[[x]], y = .data[[y]]) + aesColour <- NULL + aesFill <- NULL + p <- NULL + if (colourVar == "") { + aesColour <- aes() + } else { + aesColour <- aes(colour = .data[[colourVar]]) + } + if (fillVar == "") { + aesFill <- aes() + } else { + aesFill <- aes(fill = .data[[fillVar]]) + } + p <- ggplot() + + geom_boxplot( + data = df, + aes(!!!aes, !!!aesColour, !!!aesFill, + group = interaction( + .data[[x]], + !!!aesColour, !!!aesFill + ) + ) + ) + p <- p + xlab(xLabel) + p <- p + ylab(yLabel) + p <- p + guides(fill = guide_legend(title = legendTitleFill)) + p <- p + guides(colour = guide_legend(title = legendTitleColour)) + p <- p + scale_fill_brewer(palette = fillTheme) + p <- p + scale_color_brewer(palette = colourTheme) + if (facetMode != "none") { + p <- addFacet(p, facetVar, facetMode) + } + return(p) +} + +LineplotFct <- function(df, x, y, xLabel, yLabel, + colourVar, legendTitleColour, + colourTheme, facetMode, facetVar) { + aes <- aes(x = .data[[x]], y = .data[[y]]) + aesColour <- NULL + p <- NULL + if (colourVar == "") { + aesColour <- aes() + } else { + aesColour <- aes(colour = .data[[colourVar]]) + } + p <- ggplot() + + geom_line( + data = df, + aes(!!!aes, !!!aesColour, + group = interaction( + .data[[x]], + !!!aesColour + ) + ) + ) + p <- p + xlab(xLabel) + p <- p + ylab(yLabel) + p <- p + guides(colour = guide_legend(title = legendTitleColour)) + p <- p + scale_color_brewer(palette = colourTheme) + if (facetMode != "none") { + p <- addFacet(p, facetVar, facetMode) + } + return(p) +} diff --git a/bs/R/statisticalTests.R b/bs/R/statisticalTests.R new file mode 100644 index 0000000..9955707 --- /dev/null +++ b/bs/R/statisticalTests.R @@ -0,0 +1,286 @@ +testsSidebarUI <- function(id) { + tabPanel( + "Tests", + textInput(NS(id, "dep"), "dependent Variable", value = "var1"), + textInput(NS(id, "indep"), "independent Variable", value = "var2"), + conditionalPanel( + condition = "input.TestsConditionedPanels == 'Two groups'", + sliderInput(NS(id, "confLevel"), "Confidence level of the interval", + min = 0, max = 1, value = 0.95 + ), + selectInput( + NS(id, "altHyp"), "Alternative hypothesis", + c( + "Two sided" = "two.sided", + "Less" = "less", + "Greater" = "greater" + ) + ), + selectInput( + NS(id, "paired"), "Paired or unpaired t-test", + c( + "Unpaired" = "up", + "Paired" = "p" + ) + ), + selectInput( + NS(id, "varEq"), "Are the two variances treated as equal or not?", + c( + "Equal" = "eq", + "Not equal" = "noeq" + ) + ), + actionButton(NS(id, "tTest"), "t test") + ), + conditionalPanel( + condition = "input.TestsConditionedPanels == 'More than two groups'", + actionButton(NS(id, "aovTest"), "anova"), + actionButton(NS(id, "kruskalTest"), "kruskal wallis test"), + ), + conditionalPanel( + selectInput(NS(id, "PostHocTests"), "Choose a Post Hoc test", + choices = c( + "Tukey HSD" = "HSD", "Kruskal Wallis post hoc test" = "kruskalTest", + "Least significant difference test" = "LSD", + "Scheffe post hoc test" = "scheffe", "REGW post hoc test" = "REGW" + ) + ), + condition = "input.TestsConditionedPanels == 'Posthoc tests'", + actionButton(NS(id, "PostHocTest"), "run test"), + sliderInput(NS(id, "pval"), "P-value", + min = 0, max = 0.15, value = 0.05 + ), + selectInput( + NS(id, "design"), "Design", + c( + "Balanced" = "ba", + "Unbalanced" = "ub" + ) + ), + conditionalPanel( + condition = "input.PostHocTests == 'kruskalPHTest' || input.PostHocTests == 'lsdTest'", + selectInput(NS(id, "padj"), "Adjusted p method", + c( + "Holm" = "holm", + "Hommel" = "hommel", + "Hochberg" = "hochberg", + "Bonferroni" = "bonferroni", + "BH" = "BH", + "BY" = "BY", + "fdr" = "fdr" + ), + selectize = FALSE + ) + ) + ) + ) +} + +testsUI <- function(id) { + fluidRow( + tags$head( + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js"), + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js"), + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js"), + tags$script(src = "download.js") + ), + tabsetPanel( + tabPanel( + "Two groups", + br(), + ), + tabPanel( + "More than two groups", + br(), + ), + tabPanel( + "Posthoc tests", + br(), + ), + id = "TestsConditionedPanels" + ), + h4(strong("Results of test:")), + tableOutput(NS(id, "test_result")), + verbatimTextOutput(NS(id, "test_error")), + actionButton(NS(id, "test_save"), "Add output to result-file"), + actionButton(NS(id, "download_test"), "Save results"), + checkboxGroupInput(NS(id, "TableSaved"), "Saved results to file", NULL) + ) +} + +testsServer <- function(id, data, listResults) { + moduleServer(id, function(input, output, session) { + tTest <- function() { + output$test_error <- renderText(NULL) + req(is.data.frame(data$df)) + df <- data$df + req(input$indep) + indep <- input$indep + req(input$dep) + dep <- input$dep + formula <- NULL + err <- NULL + fit <- NULL + e <- try({ + formula <- as.formula(paste(dep, "~", indep)) + stopifnot(get_ast(formula) != "Error") + paired <- FALSE + if (input$paired == "p") { + paired <- TRUE + } + eq <- TRUE + if (input$varEq == "noeq") { + eq <- FALSE + } + fit <- broom::tidy(t.test(formula, + data = df, conf.level = input$confLevel, + alternative = input$alt, paired = paired, var.equal = eq + )) + }) + if (inherits(e, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + output$test_error <- renderText(err) + } else { + listResults$curr_data <- fit + listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted t-test") + output$test_result <- renderTable(fit, digits = 6) + } + } + + observeEvent(input$tTest, { + tTest() + }) + + conductTests <- function(method) { + output$test_error <- renderText(NULL) + req(is.data.frame(data$df)) + df <- data$df + req(input$indep) + indep <- input$indep + req(input$dep) + dep <- input$dep + formula <- NULL + err <- NULL + fit <- NULL + e <- try({ + formula <- as.formula(paste(dep, "~", indep)) + stopifnot(get_ast(formula) != "Error") + }) + if (inherits(e, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + output$test_error <- renderText(err) + } + if (is.null(err)) { + e <- try({ + switch(method, + aov = { + fit <- broom::tidy(aov(formula, data = df)) + }, + kruskal = { + fit <- broom::tidy(kruskal.test(formula, data = df)) + }, + HSD = { + aov_res <- aov(formula, data = df) + bal <- input$design + req(bal) + if (bal == "Balanced") { + bal <- TRUE + } else { + bal <- FALSE + } + fit <- agricolae::HSD.test(aov_res, + trt = indep, + alpha = input$pval, group = TRUE, unbalanced = bal + )$groups + }, + kruskalTest = { + fit <- with(df, kruskal(df[, dep], df[, indep]), + alpha = input$pval, p.adj = input$padj, group = TRUE + )$groups + }, + LSD = { + aov_res <- aov(formula, data = df) + fit <- agricolae::LSD.test(aov_res, + trt = indep, + alpha = input$pval, p.adj = input$padj, group = TRUE + )$groups + }, + scheffe = { + aov_res <- aov(formula, data = df) + fit <- agricolae::scheffe.test(aov_res, trt = indep, alpha = input$pval, group = TRUE)$groups + }, + REGW = { + aov_res <- aov(formula, data = df) + fit <- agricolae::REGW.test(aov_res, trt = indep, alpha = input$pval, group = TRUE)$groups + } + ) + }) + if (inherits(e, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + output$test_error <- renderText(err) + } else if (is.null(fit)) { + output$test_error <- renderText("Result is NULL") + } else { + fit <- cbind(fit, row.names(fit)) + names(fit)[ncol(fit)] <- paste0(indep, collapse = ".") + listResults$curr_data <- fit + listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted: ", method) + output$test_result <- renderTable(fit, digits = 6) + } + } + } + + observeEvent(input$aovTest, { + conductTests("aov") + }) + + observeEvent(input$kruskalTest, { + conductTests("kruskal") + }) + + observeEvent(input$kruskalTest, { + conductTests("kruskal") + }) + + observeEvent(input$PostHocTest, { + conductTests(input$PostHocTests) + }) + + observeEvent(input$test_save, { + if (is.null(listResults$curr_name)) { + return(NULL) + } + if (!(listResults$curr_name %in% unlist(listResults$all_names))) { + listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data + listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name + } + updateCheckboxGroupInput(session, "TableSaved", + choices = listResults$all_names + ) + }) + + observeEvent(input$download_test, { + lr <- unlist(listResults$all_names) + indices <- sapply(input$TableSaved, function(x) { + which(x == lr) + }) + req(length(indices) >= 1) + l <- listResults$all_data[indices] + if (Sys.getenv("RUN_MODE") == "BROWSER") { + jsString <- createJSString(l) + session$sendCustomMessage( + type = "downloadZip", + list( + numberOfResults = length(jsString), + 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 + } + }) + }) + + return(listResults) +} diff --git a/bs/R/utils.R b/bs/R/utils.R new file mode 100644 index 0000000..aa27298 --- /dev/null +++ b/bs/R/utils.R @@ -0,0 +1,213 @@ +DF2String <- function(df) { + resNames <- names(df) + resNames <- paste(resNames, collapse = "\t") + resNames <- paste(resNames, "\n") + res <- apply(df, 1, function(x) { + x <- as.character(x) + x <- paste(x, collapse = "\t") + return(x) + }) + res <- paste0(resNames, "\n", res, collapse = "") + res <- paste0(res, "\n") +} + +setClass("plot", + slots = c( + p = "ANY", + width = "numeric", + height = "numeric", + resolution = "numeric" + ) +) + +setClass("diagnosticPlot", + slots = c( + p = "character" + ) +) + +setClass("doseResponse", + slots = c( + df = "data.frame", + p = "ANY" + ) +) + +createExcelFile <- function(l) { + if (length(l) == 0) { + showNotification("Nothing to upload") + return(NULL) + } + + wb <- openxlsx::createWorkbook() + addWorksheet(wb, "Results") + + curr_row <- 1 + plot_files <- c() + # save data to excel file + for (i in seq_along(l)) { + if (inherits(l[[i]], "plot")) { + p <- l[[i]]@p + width <- l[[i]]@width + height <- l[[i]]@height + resolution <- l[[i]]@resolution + fn <- tempfile(fileext = ".png") + ggsave( + plot = p, + filename = fn, width = width, height = height, dpi = resolution + ) + openxlsx::insertImage(wb, "Results", fn, startRow = curr_row) + curr_row <- curr_row + 20 + } else if (inherits(l[[i]], "diagnosticPlot")) { + p <- l[[i]]@p + width <- l[[i]]@width + height <- l[[i]]@height + resolution <- l[[i]]@resolution + fn <- tempfile(fileext = ".png") + ggsave( + plot = p, + filename = fn, width = width, height = height, dpi = resolution + ) + openxlsx::insertImage(wb, "Results", fn, startRow = curr_row) + curr_row <- curr_row + 20 + plot_files <- c(plot_files, l[[i]]@p) + } else if (inherits(l[[i]], "doseResponse")) { + p <- l[[i]]@p + fn <- tempfile(fileext = ".png") + ggsave(plot = p, filename = fn) + jsString <- c(jsString, DF2String(l[[i]]@df)) + openxlsx::insertImage(wb, "Results", fn, startRow = curr_row) + curr_row <- curr_row + 20 + } else if (inherits(l[[i]], "data.frame")) { + openxlsx::writeData(wb, "Results", l[[i]], startRow = curr_row) + curr_row <- curr_row + dim(l[[i]])[1] + 5 + } else if (is.character(l[[i]])) { + openxlsx::writeData(wb, "Results", l[[i]], startRow = curr_row) + curr_row <- curr_row + length(l[[i]])[1] + 5 + } + } + + # create temporary file + file <- function() { + tempfile <- tempfile(tmpdir = "/home/shiny/results", fileext = ".xlsx") + return(tempfile) + } + fn <- file() + + + # save workbook + res <- tryCatch( + expr = { + openxlsx::saveWorkbook(wb, fn) + }, + error = function(e) { + showNotification("Error saving file") + } + ) + + # Clean up + for (f in seq_along(plot_files)) { + unlink(p) + } + + return(fn) +} + +createJSString <- function(l) { + jsString <- c() + for (i in seq_along(l)) { + if (inherits(l[[i]], "plot")) { + p <- l[[i]]@p + width <- l[[i]]@width + height <- l[[i]]@height + resolution <- l[[i]]@resolution + fn <- tempfile(fileext = ".png") + ggsave( + plot = p, + filename = fn, width = width, height = height, dpi = resolution + ) + jsString <- c(jsString, paste0("data:image/png;base64,", base64enc::base64encode(fn))) + unlink(fn) + } else if (inherits(l[[i]], "diagnosticPlot")) { + jsString <- c(jsString, aste0("data:image/png;base64,", base64enc::base64encode(l[[i]]@p))) + unlink(l[[i]]@p) + } else if (inherits(l[[i]], "doseResponse")) { + p <- l[[i]]@p + fn <- tempfile(fileext = ".png") + ggsave(plot = p, filename = fn) + jsString <- c(jsString, paste0("data:image/png;base64,", base64enc::base64encode(fn))) + unlink(fn) + jsString <- c(jsString, DF2String(l[[i]]@df)) + } else if (inherits(l[[i]], "data.frame")) { + jsString <- c(jsString, DF2String(l[[i]])) + } else if (is.character(l[[i]])) { + jsString <- c(jsString, l[[i]]) + } + } + return(jsString) +} + +stackDF <- function(df, keepCol) { + as.data.frame(pivot_longer(df, + cols = -keepCol, + names_to = "name", values_to = "value" + )) +} + +unstackDF <- function(df, name, value) { + df <- pivot_wider(df, names_from = name, values_from = value) + df <- map(df, simplify) %>% + as.data.frame() + as.data.frame(df) +} + +correctName <- function(name, df) { + name %in% names(df) +} + +changeCharInput <- function(chars) { + nams <- unlist(strsplit(chars, split = ",")) + for (i in 1:length(nams)) { + nams[i] <- gsub(" ", "", nams[i]) + } + nams +} + +combine <- function(new, vec, df, first) { + if (length(vec) == 0) { + return(new) + } + if (correctName(vec[length(vec)], df)) { + if (isTRUE(first)) { + new <- df[, vec[length(vec)]] + first <- FALSE + } else { + new <- interaction(new, df[, vec[length(vec)]]) + } + } + vec <- vec[-length(vec)] + combine(new, vec, df, first) +} + +splitData <- function(df, formula) { + df <- model.frame(formula, data = df) + stopifnot(ncol(df) >= 2) + res <- data.frame(value = df[, 1], interaction = interaction(df[, 2:ncol(df)])) + names(res) <- c("value", interaction = paste0(names(df)[2:ncol(df)], collapse = ".")) + res +} + +diagnosticPlot <- function(df, formula) { + model <- lm(formula, data = df) + f <- tempfile(fileext = ".png") + png(f) + par(mfrow = c(3, 2)) + plot(model, 1) + plot(model, 2) + plot(model, 3) + plot(model, 4) + plot(model, 5) + plot(model, 6) + dev.off() + return(f) +} diff --git a/bs/R/visualisation.R b/bs/R/visualisation.R new file mode 100644 index 0000000..f709e80 --- /dev/null +++ b/bs/R/visualisation.R @@ -0,0 +1,294 @@ +visSidebarUI <- function(id) { + tabPanel( + "Visualisation", + textInput(NS(id, "yVar"), "Y variable", value = "y"), + textInput(NS(id, "xVar"), "X variable", value = "x"), + radioButtons(NS(id, "xType"), "Type of x", + choices = c( + factor = "factor", + numeric = "numeric" + ), + selected = "factor" + ), + textInput(NS(id, "xaxisText"), "X axis label", value = "x label"), + textInput(NS(id, "yaxisText"), "Y axis label", value = "y label"), + conditionalPanel( + condition = "input.VisConditionedPanels == 'Scatterplot'", + selectInput(NS(id, "fitMethod"), "Choose a fitting method", + c( + "none" = "none", + "lm" = "lm", + "glm" = "glm", + "gam" = "gam", + "loess" = "loess" + ), + selectize = FALSE + ), + numericInput(NS(id, "k"), "number of knots used by spline for gam", value = 10) + ), + conditionalPanel( + condition = "input.VisConditionedPanels == 'Boxplot'", + textInput(NS(id, "fill"), "Fill variable"), + textInput(NS(id, "legendTitleFill"), "Legend title for fill", value = "Title fill"), + selectInput(NS(id, "themeFill"), "Choose a 'fill' theme", + c( + "BuGn" = "BuGn", + "PuRd" = "PuRd", + "YlOrBr" = "YlOrBr", + "Greens" = "Greens", + "GnBu" = "GnBu", + "Reds" = "Reds", + "Oranges" = "Oranges", + "Greys" = "Greys" + ), + selectize = FALSE + ) + ), + textInput(NS(id, "col"), "Colour variable"), + textInput(NS(id, "legendTitleCol"), "Legend title for colour", value = "Title colour"), + selectInput(NS(id, "theme"), "Choose a 'colour' theme", + c( + "Accent" = "Accent", + "Dark2" = "Dark2", + "Paired" = "Paired", + "Pastel1" = "Pastel1", + "Pastel2" = "Pastel2", + "Set1" = "Set1", + "Set2" = "Set2", + "Set3" = "Set3" + ), + selectize = FALSE + ), + radioButtons(NS(id, "facetMode"), + "Choose Facet Mode:", + choices = c("none", "facet_wrap", "facet_grid") + ), + textInput(NS(id, "facetBy"), "split plot by") + ) +} + +visUI <- function(id) { + fluidRow( + tags$head( + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js"), + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js"), + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js"), + tags$script(src = "download.js"), + ), + br(), + tabsetPanel( + tabPanel( + "Boxplot", + br(), + actionButton(NS(id, "CreatePlotBox"), "Create plot") + ), + tabPanel( + "Scatterplot", + br(), + actionButton(NS(id, "CreatePlotScatter"), "Create plot") + ), + tabPanel( + "Lineplot", + br(), + actionButton(NS(id, "CreatePlotLine"), "Create plot") + ), + id = "VisConditionedPanels" + ), + plotOutput(NS(id, "plotResult")), + actionButton(NS(id, "plotSave"), "Add output to result-file"), + checkboxGroupInput(NS(id, "TableSaved"), "Saved results to file", NULL), + fluidRow( + column( + 4, + numericInput(NS(id, "widthPlot"), "Width of plot [cm]", value = 10) + ), + column( + 4, + numericInput(NS(id, "heightPlot"), "Height of plot [cm]", value = 10) + ), + column( + 4, + numericInput(NS(id, "resPlot"), "Resolution of plot", value = 300) + ), + ), + fluidRow( + column( + 12, + actionButton(NS(id, "downloadViss"), "Save results") + ) + ) + ) +} + +visServer <- function(id, data, listResults) { + moduleServer(id, function(input, output, session) { + plotFct <- function(method) { + req(is.data.frame(data$df)) + df <- data$df + req(input$yVar) + req(input$xVar) + x <- input$xVar + y <- input$yVar + colNames <- names(df) + checkX <- x %in% colNames + checkY <- y %in% colNames + if (!checkX) showNotification("X variable not found", duration = 0) + if (!checkY) showNotification("Y variable not found", duration = 0) + req(checkX) + req(checkY) + width <- input$widthPlot + height <- input$heightPlot + resolution <- input$resPlot + if (width <= 0) { + showNotification(paste("width has to be a positive number is changed to 10 cm"), duration = 0) + width <- 10 + } + if (height <= 0) { + showNotification(paste("height has to be a positive number is changed to 10 cm"), duration = 0) + height <- 10 + } + if (width > 100) { + showNotification(paste("width exceeds max value of 100 cm. Is set to 100 cm."), duration = 0) + width <- 100 + } + if (height > 100) { + showNotification(paste("height exceeds max value of 100 cm. Is set to 100 cm."), duration = 0) + height <- 100 + } + col <- input$col + fill <- input$fill + if (!(fill %in% names(df)) && (fill != "")) showNotification("fill variable not found", duration = 0) + if (!(col %in% names(df)) && (col != "")) showNotification("colour variable not found", duration = 0) + req((fill %in% names(df)) || (fill == "")) + req((col %in% names(df)) || (col == "")) + fillTitle <- input$legendTitleFill + colTitle <- input$legendTitleCol + xlabel <- input$xaxisText + ylabel <- input$yaxisText + xtype <- input$xType + theme <- input$theme + themeFill <- input$themeFill + facetMode <- input$facetMode + facet <- input$facetBy + fitMethod <- input$fitMethod + + xd <- NULL + if (xtype == "numeric") { + xd <- as.numeric(df[, x]) + } else { + xd <- as.factor(df[, x]) + } + yd <- as.numeric(df[, y]) + if (fitMethod != "none" && !is.null(fitMethod) && xtype != "numeric") { + showNotification("Fit method will be ignored as X variable is not numerical", duration = 0) + fitMethod <- "none" + } + + p <- tryCatch( + { + if (method == "box") { + p <- BoxplotFct( + df, x, y, xlabel, ylabel, + fill, fillTitle, themeFill, + col, colTitle, theme, + facetMode, facet + ) + } else if (method == "dot") { + k <- NULL + if (fitMethod == "gam") { + req(input$k) + k <- input$k + if (k <= 0) { + showNotification("k has to be at least 1 and is set to this value") + k <- 1 + } + } + p <- DotplotFct( + df, x, y, xlabel, ylabel, + fitMethod, + col, colTitle, theme, + facetMode, facet, k + ) + } else if (method == "line") { + p <- LineplotFct( + df, x, y, xlabel, ylabel, + col, colTitle, theme, + facetMode, facet + ) + } + }, + warning = function(warn) { + showNotification(paste("A warning occurred: ", conditionMessage(warn)), duration = 0) + }, + error = function(err) { + showNotification(paste("An error occurred: ", conditionMessage(err)), duration = 0) + } + ) + output$plotResult <- renderPlot(p) + listResults$curr_data <- new("plot", p = p, width = width, height = height, resolution = resolution) + listResults$curr_name <- paste( + "Plot Nr", + length(listResults$all_names) + 1, paste("Type: ", method) + ) + } + + observeEvent(input$CreatePlotBox, { + req(is.data.frame(data$df)) + plotFct("box") + }) + output$plotResult <- renderPlot({ + renderPlot(listResults$curr_data) + }) + + observeEvent(input$CreatePlotScatter, { + req(is.data.frame(data$df)) + plotFct("dot") + }) + output$plotResult <- renderPlot({ + renderPlot(listResults$curr_data) + }) + + observeEvent(input$CreatePlotLine, { + req(is.data.frame(data$df)) + plotFct("line") + }) + output$plotResult <- renderPlot({ + renderPlot(listResults$curr_data) + }) + + observeEvent(input$plotSave, { + if (is.null(listResults$curr_name)) { + return(NULL) + } + if (!(listResults$curr_name %in% unlist(listResults$all_names))) { + listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data + listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name + } + updateCheckboxGroupInput(session, "TableSaved", + choices = listResults$all_names + ) + }) + + observeEvent(input$downloadViss, { + lr <- unlist(listResults$all_names) + indices <- sapply(input$TableSaved, function(x) { + which(x == lr) + }) + req(length(indices) >= 1) + l <- listResults$all_data[indices] + if (Sys.getenv("RUN_MODE") == "BROWSER") { + jsString <- createJSString(l) + session$sendCustomMessage( + type = "downloadZip", + list( + numberOfResults = length(jsString), + 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/www/download.js b/bs/R/www/download.js new file mode 100644 index 0000000..cdda255 --- /dev/null +++ b/bs/R/www/download.js @@ -0,0 +1,44 @@ +Shiny.addCustomMessageHandler('downloadZip', function(message) { + var FileContent = message.FileContent; + if( (typeof FileContent) == "string") { + if (FileContent.startsWith("data:image")) { + var fileName = 'file' + (i + 1) + '.png'; + var zip = new JSZip(); + var imageData = atob(FileContent.split(',')[1]); + var byteArray = new Uint8Array(imageData.length); + for (var i = 0; i < imageData.length; i++) { + byteArray[i] = imageData.charCodeAt(i); + } + zip.file(fileName, byteArray, {binary: true}); + zip.generateAsync({type: 'blob'}).then(function(content) { + saveAs(content, 'download.zip'); + }); + } else { + var zipText = new JSZip(); + var fileNameText = 'file' + 1 + '.txt'; + zipText.file(fileNameText, FileContent); + zipText.generateAsync({type: 'blob'}).then(function(content) { + saveAs(content, 'download.zip'); + }); + } + } else { + var zip = new JSZip(); + for (var i in FileContent) { + if (FileContent[i].startsWith("data:image")) { + var fileName = 'file' + (i + 1) + '.png'; + var imageData = atob(FileContent[i].split(',')[1]); + var byteArray = new Uint8Array(imageData.length); + for (var i = 0; i < imageData.length; i++) { + byteArray[i] = imageData.charCodeAt(i); + } + zip.file(fileName, byteArray, {binary: true}); + } else { + var fileName = 'file' + (i + 1) + '.txt'; + zip.file(fileName, FileContent[i]); + } + } + zip.generateAsync({type: 'blob'}).then(function(content) { + saveAs(content, 'download.zip'); + }); + } +}); \ No newline at end of file diff --git a/bs/inst/serverless_app/app.R b/bs/inst/serverless_app/app.R new file mode 100644 index 0000000..d0d0b23 --- /dev/null +++ b/bs/inst/serverless_app/app.R @@ -0,0 +1,295 @@ +library(shiny) +library(DT) +library(bslib) +library(broom) +library(ggplot2) +library(base64enc) +library(shinyjs) +library(mgcv) +library(RColorBrewer) +library(tidyr) +library(purrr) +library(agricolae) +library(drc) +library(cowplot) +library(MASS) +library(Matrix) + +Sys.setenv(RUN_MODE = "BROWSER") +# import bs package + +source("../../R/check_ast.R") +source("../../R/utils.R") +source("../../R/plottingInternally.R") +source("../../R/lc50.r") +source("../../R/correlation.R") +source("../../R/visualisation.R") +source("../../R/assumption.R") +source("../../R/statisticalTests.R") +source("../../R/DoseResponse.R") + +# NOTE: this is the content of ../R/app.R +ui <- fluidPage( + useShinyjs(), + includeScript("inst/www/download.js"), + sidebarLayout( + sidebarPanel( + conditionalPanel( + condition = "input.conditionedPanels == 'Data'", + uiOutput("conditional_data_ui"), + textInput("op", "Operations", value = "var / 1000"), + textInput("new_col", "Name of new variable", value = "var"), + actionButton("mod", "Modify"), + tags$hr(), + textInput("keepVar", "const variable"), + actionButton("pivotLonger", "conversion to long format"), + tags$hr(), + textInput("name", "name column"), + textInput("value", "value column"), + actionButton("pivotWider", "convert to wide format"), + verbatimTextOutput("mod_error"), + tags$hr(), + helpText("Please upload a CSV file.") + ), + conditionalPanel( + condition = "input.conditionedPanels == 'Correlation'", + corrSidebarUI("CORR") + ), + conditionalPanel( + condition = "input.conditionedPanels == 'Visualisation'", + visSidebarUI("VIS") + ), + conditionalPanel( + condition = "input.conditionedPanels == 'Assumption'", + assSidebarUI("ASS") + ), + conditionalPanel( + condition = "input.conditionedPanels == 'Tests'", + testsSidebarUI("TESTS") + ), + conditionalPanel( + condition = "input.conditionedPanels == 'Dose Response analysis'", + DoseResponseSidebarUI("DOSERESPONSE") + ) + ), + mainPanel( + tabsetPanel( + tabPanel( + "Data", + DTOutput("df") + ), + tabPanel( + "Correlation", + corrUI("CORR") + ), + tabPanel( + "Visualisation", + visUI("VIS") + ), + tabPanel( + "Assumption", + assUI("ASS") + ), + tabPanel( + "Tests", + testsUI("TESTS") + ), + tabPanel( + "Dose Response analysis", + DoseResponseUI("DOSERESPONSE") + ), + id = "conditionedPanels" + ) + ) + ) +) + +server <- function(input, output, session) { + dataSet <- reactiveValues(df = NULL) + + output$conditional_data_ui <- renderUI({ + if (Sys.getenv("RUN_MODE") == "BROWSER") { + conditionalPanel( + condition = "input.conditionedPanels == 'Data'", + fileInput("file", "Choose CSV File", + accept = c( + "text/csv", + "text/comma-separated-values,text/plain", + ".csv" + ) + ) + ) + } + }) + + download_file <- reactive({ + file <- download(session, "/home/shiny/results") + upload <- function(path) { + stopifnot(is.character(path)) + df <- NULL + df <- try(as.data.frame(readxl::read_excel( + path, + col_names = TRUE + )), silent = TRUE) + if (class(df) == "try-error") { + # identify seperator + line <- readLines(path, n = 1) + semicolon <- grepl(";", line) + comma <- grepl(",", line) + tab <- grepl("\t", line) + seperator <- NULL + if (semicolon == TRUE) { + seperator <- ";" + } else if (comma == TRUE) { + seperator <- "," + } else if (tab == TRUE) { + seperator <- "\t" + } else { + return("error") + } + df <- try(read.csv(path, header = TRUE, sep = seperator)) + if (class(df) == "try-error") { + return("error") + } + } else { + f <- function(x) { + options(warn = -1) + x <- as.numeric(x) + options(warn = 0) + x <- x[!is.na(x)] + length(x) > 0 + } + check <- apply(df, 2, f) + conv <- function(a, b) { + if (a == TRUE) { + return(as.numeric(b)) + } + return(b) + } + df <- Map(conv, check, df) + df <- data.frame(df) + } + return(df) + } + df <- NULL + df <- upload(file) + if (is.data.frame(df)) { + var$df <- df + } else { + showNotification("File can not be used. Upload into R failed!", duration = 0) + } + tryCatch( + { + system(paste("rm -r ", file)) + }, + warning = function(warn) { + showNotification(paste("A warning occurred: ", conditionMessage(warn)), duration = 0) + }, + error = function(err) { + showNotification(paste("An error occurred: ", conditionMessage(err)), duration = 0) + } + ) + req(is.data.frame(df)) + return(df) + }) + + + output$df <- renderDT({ + if (Sys.getenv("RUN_MODE") == "BROWSER") { + req(input$file) + df <- try(read.csv(input$file$datapath)) + if (inherits(df, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + showNotification(err) + return(NULL) + } + dataSet$df <- df + req(!is.na(dataSet$df)) + datatable(dataSet$df, options = list(pageLength = 10)) + } else if (Sys.getenv("RUN_MODE") == "SERVER") { + isolate({ + dataSet$df <- download_file() + }) + datatable(dataSet$df, options = list(pageLength = 10)) + } + }) + + observeEvent(input$mod, { + req(!is.null(dataSet$df)) + req(is.data.frame(dataSet$df)) + req(input$op) + req(input$new_col) + dt <- dataSet$df + op <- input$op + new_col <- input$new_col + new <- NULL + err <- NULL + e <- try({ + ast <- get_ast(str2lang(op)) + ast <- ast[[length(ast)]] + }) + if (e == "Error") { + showNotification("Found unallowed function") + return() + } else if (inherits(e, "try-error")) { + showNotification(e) + return() + } + e <- try({ + new <- with(dt, eval(parse(text = op))) + dataSet$df[, new_col] <- new + }) + if (inherits(e, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + } + output$df <- renderDT(dataSet$df) + output$mod_error <- renderText(err) + return(df) + }) + + observeEvent(input$pivotLonger, { + req(!is.null(dataSet$df)) + req(input$keepVar) + err <- NULL + e <- try({ + stopifnot(get_ast(str2lang(input$keepVar)) != "Error") + dataSet$df <- stackDF(dataSet$df, input$keepVar) + }) + if (inherits(e, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + } + output$df <- renderDT(dataSet$df) + output$mod_error <- renderText(err) + return(df) + }) + + observeEvent(input$pivotWider, { + req(!is.null(dataSet$df)) + req(input$name) + req(input$value) + err <- NULL + e <- try({ + stopifnot(get_ast(str2lang(input$value)) != "Error") + stopifnot(get_ast(str2lang(input$name)) != "Error") + dataSet$df <- unstackDF(dataSet$df, input$name, input$value) + }) + if (inherits(e, "try-error")) { + err <- conditionMessage(attr(e, "condition")) + } + output$df <- renderDT(dataSet$df) + output$mod_error <- renderText(err) + return(df) + }) + + listResults <- reactiveValues( + curr_data = NULL, curr_name = NULL, + all_data = list(), all_names = list() + ) + corrServer("CORR", dataSet, listResults) + visServer("VIS", dataSet, listResults) + assServer("ASS", dataSet, listResults) + testsServer("TESTS", dataSet, listResults) + DoseResponseServer("DOSERESPONSE", dataSet, listResults) +} + +shinyApp(ui, server) diff --git a/bs/inst/tests/test_plotting.R b/bs/inst/tests/test_plotting.R new file mode 100644 index 0000000..0ca4de6 --- /dev/null +++ b/bs/inst/tests/test_plotting.R @@ -0,0 +1,22 @@ +library(tinytest) + +mock_ggplot <- ggplot(data = CO2, aes(x = uptake, y = conc)) + + geom_point() + + geom_smooth() +test_annotateDF <- function() { + df <- annotateDF(mock_ggplot, method = "lm") + expect_equal(nrow(df), 84) + expect_equal(ncol(df), 14) +} +test_annotateDF() + +test_calcParams <- function() { + df <- data.frame(x = 1:10, y = 1:10) + model <- calcParams(df, formula = y ~ x, method = "lm") + a <- model$annotation + r2 <- strsplit(a, split = " ")[[1]][2] + expect_equal(r2, "1") +} +test_calcParams() + +test_dir() \ No newline at end of file diff --git a/bs/inst/www/download.js b/bs/inst/www/download.js new file mode 100644 index 0000000..cdda255 --- /dev/null +++ b/bs/inst/www/download.js @@ -0,0 +1,44 @@ +Shiny.addCustomMessageHandler('downloadZip', function(message) { + var FileContent = message.FileContent; + if( (typeof FileContent) == "string") { + if (FileContent.startsWith("data:image")) { + var fileName = 'file' + (i + 1) + '.png'; + var zip = new JSZip(); + var imageData = atob(FileContent.split(',')[1]); + var byteArray = new Uint8Array(imageData.length); + for (var i = 0; i < imageData.length; i++) { + byteArray[i] = imageData.charCodeAt(i); + } + zip.file(fileName, byteArray, {binary: true}); + zip.generateAsync({type: 'blob'}).then(function(content) { + saveAs(content, 'download.zip'); + }); + } else { + var zipText = new JSZip(); + var fileNameText = 'file' + 1 + '.txt'; + zipText.file(fileNameText, FileContent); + zipText.generateAsync({type: 'blob'}).then(function(content) { + saveAs(content, 'download.zip'); + }); + } + } else { + var zip = new JSZip(); + for (var i in FileContent) { + if (FileContent[i].startsWith("data:image")) { + var fileName = 'file' + (i + 1) + '.png'; + var imageData = atob(FileContent[i].split(',')[1]); + var byteArray = new Uint8Array(imageData.length); + for (var i = 0; i < imageData.length; i++) { + byteArray[i] = imageData.charCodeAt(i); + } + zip.file(fileName, byteArray, {binary: true}); + } else { + var fileName = 'file' + (i + 1) + '.txt'; + zip.file(fileName, FileContent[i]); + } + } + zip.generateAsync({type: 'blob'}).then(function(content) { + saveAs(content, 'download.zip'); + }); + } +}); \ No newline at end of file diff --git a/bs/man/ic50.Rd b/bs/man/ic50.Rd new file mode 100644 index 0000000..1b8ee60 --- /dev/null +++ b/bs/man/ic50.Rd @@ -0,0 +1,39 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/lc50.r +\name{ic50} +\alias{ic50} +\title{Calculates the ic50 values} +\usage{ +ic50( + df, + abs_col, + conc_col, + substance_name_col, + negative_identifier, + positive_identifier +) +} +\arguments{ +\item{df}{a data.frame which contains all the data} + +\item{abs_col}{the name of the column in df which contains the dependent variable} + +\item{conc_col}{the name of the column in df which contains the different concentrations} + +\item{substance_name_col}{the name of the column in df which contains the different names of the compounds} + +\item{negative_identifier}{a character defining the name to identify the negative control within conc_col} + +\item{positive_identifier}{a character defining the name to identify the positive control within conc_col} +} +\value{ +a list is returned containing the ic50 value the fitted plots and other parameters +} +\description{ +Calculates the ic50 values +} +\examples{ +path <- system.file("data", package = "MTT") +df <- read.csv(paste0(path, "/ExampleData.txt")) +ic50(df, "abs", "conc", "names", "neg", "pos") +} diff --git a/create_bibentry.R b/create_bibentry.R deleted file mode 100644 index a4c0138..0000000 --- a/create_bibentry.R +++ /dev/null @@ -1,13 +0,0 @@ -library(RefManageR) -bib <- c( - bibtype = "book", - key = "Seber1989", - title = "Nonlinear Regression", - author = "Seber, G. A. F. and Wild, C. J", - publisher = "Wiley & Sons", - address = "New York", - pages = "330", - date = "1989" -) -bib_entry <- as.BibEntry(bib) -toBibtex(bib_entry) diff --git a/deploy.R b/deploy.R index cbc4f01..3a60eb5 100644 --- a/deploy.R +++ b/deploy.R @@ -1,7 +1,7 @@ -setwd("/home/konrad/Documents/Biostats") -shinylive::export("./BiostatsGithubPage", "docs", verbose = TRUE) -httpuv::runStaticServer("docs") +shinylive::export("./bs/R/", "docs") +setwd("/home/konrad/Documents/Biostats/docs") +httpuv::runStaticServer(".") -setwd("/home/konrad/Documents/Biostats/BiostatsGithubPage") -source("app.R") -shinyApp(ui, server) +# setwd("/home/konrad/Documents/Biostats/BiostatsGithubPage") +# source("app.R") +# shinyApp(ui, server) diff --git a/installMTT.R b/installMTT.R deleted file mode 100644 index 866fb8a..0000000 --- a/installMTT.R +++ /dev/null @@ -1,2 +0,0 @@ -install.packages("/home/konrad/Documents/GitHub/RProjects/shinychem/MTT", - type = "source", repos = NULL) diff --git a/integrate_app_in_ror.docx b/integrate_app_in_ror.docx deleted file mode 100644 index 3f3adb0..0000000 Binary files a/integrate_app_in_ror.docx and /dev/null differ diff --git a/report.pdf b/report.pdf deleted file mode 100644 index af3dec9..0000000 Binary files a/report.pdf and /dev/null differ diff --git a/report.xlsx b/report.xlsx deleted file mode 100644 index b3e3b0d..0000000 Binary files a/report.xlsx and /dev/null differ diff --git a/test-pdf_creation.R b/test-pdf_creation.R deleted file mode 100644 index 42e9236..0000000 --- a/test-pdf_creation.R +++ /dev/null @@ -1,5 +0,0 @@ -library(MTT) -path <- system.file("data", package = "MTT") -df <- read.csv(paste0(path, "/ExampleData.txt")) -res <- ic50(df, "abs", "conc", "names", "neg", "pos") -report_pdf(res, "blabla", "report.pdf") \ No newline at end of file diff --git a/CO2.csv b/test_data/CO2.csv similarity index 100% rename from CO2.csv rename to test_data/CO2.csv diff --git a/DoseResponse.csv b/test_data/DoseResponse.csv similarity index 100% rename from DoseResponse.csv rename to test_data/DoseResponse.csv diff --git a/banana_quality.csv b/test_data/banana_quality.csv similarity index 100% rename from banana_quality.csv rename to test_data/banana_quality.csv diff --git a/co2.csv b/test_data/co2.csv similarity index 100% rename from co2.csv rename to test_data/co2.csv diff --git a/iris.csv b/test_data/iris.csv similarity index 100% rename from iris.csv rename to test_data/iris.csv diff --git a/lc50_testfile.csv b/test_data/lc50_testfile.csv similarity index 100% rename from lc50_testfile.csv rename to test_data/lc50_testfile.csv diff --git a/test.csv b/test_data/test.csv similarity index 100% rename from test.csv rename to test_data/test.csv diff --git a/testfile.csv b/test_data/testfile.csv similarity index 100% rename from testfile.csv rename to test_data/testfile.csv diff --git a/testfile.xlsx b/test_data/testfile.xlsx similarity index 100% rename from testfile.xlsx rename to test_data/testfile.xlsx diff --git a/winequality-red.csv b/test_data/winequality-red.csv similarity index 100% rename from winequality-red.csv rename to test_data/winequality-red.csv diff --git a/test_excel_creation.R b/test_excel_creation.R deleted file mode 100644 index f48836c..0000000 --- a/test_excel_creation.R +++ /dev/null @@ -1,5 +0,0 @@ -library(MTT) -path <- system.file("data", package = "MTT") -df <- read.csv(paste0(path, "/ExampleData.txt")) -res <- ic50(df, "abs", "conc", "names", "neg", "pos") -save(res, "report.xlsx") \ No newline at end of file