started developing the biostats app as static website

BiostatsGithubPage/BiostatsGithubPage.Rproj

@@ -0,0 +1,13 @@
+Version: 1.0
+
+RestoreWorkspace: Default
+SaveWorkspace: Default
+AlwaysSaveHistory: Default
+
+EnableCodeIndexing: Yes
+UseSpacesForTab: Yes
+NumSpacesForTab: 2
+Encoding: UTF-8
+
+RnwWeave: Sweave
+LaTeX: pdfLaTeX

BiostatsGithubPage/app.R

@@ -0,0 +1,64 @@
+library(shiny)
+
+ui <- fluidPage(
+  titlePanel("Custom Message Handler Demo with Download"),
+  mainPanel(
+    textInput("user_message", "Enter your message:"),
+    actionButton("trigger_button", "Trigger Custom Message Handler"),
+    tags$head(
+      tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js")
+    ),
+    tags$script(
+      "
+      Shiny.addCustomMessageHandler('updateField', function(message) {
+        console.log(message.message);
+        var result = message.message;
+        $('#output').append(result + '<br>');
+      });
+      
+      Shiny.addCustomMessageHandler('downloadText', function(message) {
+        var text = message.text;
+        var filename = message.file;
+        var element = document.createElement('a');
+        element.setAttribute('href', 'data:text/plain;charset=utf-8,' + encodeURIComponent(text));
+        element.setAttribute('download', filename);
+        element.style.display = 'none';
+        document.body.appendChild(element);
+        element.click();
+        document.body.removeChild(element);
+      });
+      
+       Shiny.addCustomMessageHandler('downloadZip', function(message) {
+          var files = message.files;
+          var filenames = message.filenames;
+          console.log(files.length);
+          var zip = new JSZip();
+          console.log('bla');
+      });
+      "
+    ),
+    div(id = "output", style = "margin-top: 10px;"),
+    br(),
+    actionButton("download_button", "Download Appended Messages"),
+    actionButton("download_button2", "Download Appended Messages")
+  )
+)
+
+server <- function(input, output, session) {
+  observeEvent(input$trigger_button, {
+    user_message <- input$user_message
+    session$sendCustomMessage("updateField", list(message = user_message))
+  })
+
+  observeEvent(input$download_button, {
+    session$sendCustomMessage(type = "downloadText", list(text = "test", file = "bla.csv"))
+  })
+
+  observeEvent(input$download_button2, {
+    files <- c("File content 1", "File content 2")
+    filenames <- c(tempfile(fileext = ".txt"), tempfile(fileext = ".txt"))
+    session$sendCustomMessage(type = "downloadZip", list(files = files, filenames = filenames))
+  })
+}
+
+shinyApp(ui, server)

BiostatsGithubPage/app_biostats.R

@@ -0,0 +1,108 @@
+library(shiny)
+library(DT)
+library(bslib)
+library(broom)
+library(utils)
+library(ggplot2)
+
+source("check_ast.R")
+source("correlation.R")
+
+ui <- fluidPage(
+  sidebarLayout(
+    sidebarPanel(
+      conditionalPanel(
+        condition = "input.conditionedPanels == 'Data'",
+        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"),
+        verbatimTextOutput("mod_error"),
+        tags$hr(),
+        helpText("Please upload a CSV file.")
+      ),
+      conditionalPanel(
+        condition = "input.conditionedPanels == 'Correlation'",
+        corrSidebarUI("CORR")
+      )
+    ),  
+
+    mainPanel(
+      tabsetPanel(
+        tabPanel("Data",
+            DTOutput("df")
+        ),
+
+        tabPanel("Correlation",
+            corrUI("CORR")
+        ),
+
+
+        id = "conditionedPanels"   
+      )
+    )
+
+  )
+)
+
+server <- function(input, output) {
+  data <- reactiveValues(df = NA)
+  output$df <- renderDT({
+    req(input$file)
+    df <- try(read.csv(input$file$datapath))
+    if (inherits(df, "try-error")) {
+      err <- conditionMessage(attr(e, "condition"))
+      showNotification(err)
+      return(NULL)
+    } 
+    data$df <- df
+    req(!is.na(data$df))
+    datatable(data$df, options = list(pageLength = 10)) 
+  })
+
+  observeEvent(input$mod, {
+    req(!is.null(data$df))
+    req(is.data.frame(data$df))
+    req(input$op)
+    req(input$new_col)
+    dt <- data$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)))
+    )
+    if (inherits(e, "try-error")) {
+      err <- conditionMessage(attr(e, "condition"))
+    } else {
+      data$df[, new_col] <- new
+    }
+    output$df <- renderDT(data$df)
+    output$mod_error <- renderText(err)  
+    return(df)
+  })
+
+  listResults <- reactiveValues(curr_data = NULL, curr_name = NULL,
+                                all_data = list(), all_names = list())
+  listResults <- corrServer("CORR", data$df, listResults)
+
+
+}
+
+shinyApp(ui, server)

BiostatsGithubPage/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)
+}

BiostatsGithubPage/correlation.R

@@ -0,0 +1,139 @@
+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(
+        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),
+
+        tags$script(
+          "
+          Shiny.addCustomMessageHandler('downloadZip', function(message) {
+            var files = message.files;
+            var filenames = message.filenames;
+            var zip = new JSZip();
+            for (var i = 0; i < files.length; i++) {
+              zip.file(filenames[i], files[i]);
+            }
+            zip.generateAsync({type:'blob'}).then(function(content) {
+              saveAs(content, 'downloaded_files.zip');
+            });
+          });
+          "
+        )
+  )
+}
+
+corrServer <- function(id, df, listResults) {
+  moduleServer(id, function(input, output, session) {  
+      corr_fct <- function(method) {
+        req(input$dep)
+        req(input$indep)
+        dep <- input$dep
+        indep <- input$indep
+        d <- df
+        fit <- NULL
+        err <- NULL
+        e <- try(
+          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"))
+        } else {
+          listResults$curr_data <- renderTable(fit, digits = 6)
+          listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted test: ", method)
+          listResults$all_data[[length(listResults$all_data) + 1]] <- fit
+          listResults$all_names <- c(listResults$all_names, 
+                                     paste("Test Nr", length(listResults$all_names) + 1, "Conducted test: ", method))
+          output$corr_result <- renderTable(fit, digits = 6)
+          output$corr_error <- renderText(err)  
+        }
+      }
+
+      observeEvent(input$pear, {
+        corr_fct("pearson")
+      })
+      output$cor_result <- renderTable({
+        listResults$data
+        }, digits = 6
+      )
+
+      observeEvent(input$spear, {
+        corr_fct("spearman")
+      })
+      output$cor_result <- renderTable({
+        listResults$data
+        }, digits = 6
+      )
+
+      observeEvent(input$kendall, {
+        corr_fct("kendall")
+      })
+      output$cor_result <- renderTable({
+        listResults$data
+        }, digits = 6
+      )
+
+      observeEvent(input$corr_save, {
+        updateCheckboxGroupInput(session, "TableSaved",
+                                 choices = listResults$all_names)
+      })
+
+      observeEvent(input$download_corr, {
+        # indices <- which(input$TableSaved == listResults$all_names)
+        # req(length(indices) >= 1)
+        # files <- c()
+        # l <- listResults$all_data[indices]
+        # for (i in seq_along(l)) {
+        #   if (inherits(l[[i]], "ggplot")) {
+        #     files <- c(files, tempfile(fileext = ".png"))
+        #     ggsave(plot = l[[i]], filename = files[length(files)])
+        #   } else {
+        #     files <- c(files, tempfile(fileext = ".csv"))
+        #     write.csv(l[[i]], files[length(files)], 
+        #               quote = FALSE, row.names = FALSE)  
+        #   }
+        # }
+        # zip_file <- tempfile(fileext = ".zip")
+        # showNotification(zip_file, duration = 0)
+        # zip(zip_file, files) # issue: is this independent of OS?
+        # for (i in seq_along(files)) {
+        #   if (file.exists(files[i])) unlink(files[i])
+        # }
+
+        files <- c("File content 1", "File content 2")
+        filenames <- c("file1.txt", "file2.txt")
+        session$sendCustomMessage(type = "downloadZip", list(files = files, filenames = filenames))
+      })
+
+	})
+
+  return(listResults)
+}
+
+
+
+
+