added tests for assumption checking

BiostatsGithubPage/app.R

@@ -16,6 +16,7 @@ source("utils.R")
 source("plottingInternally.R")
 source("correlation.R")
 source("visualisation.R")
+source("assumption.R")
 
 ui <- fluidPage(
   useShinyjs(),
@@ -49,6 +50,10 @@ ui <- fluidPage(
       conditionalPanel(
         condition = "input.conditionedPanels == 'Visualisation'",
         visSidebarUI("VIS")
+      ),
+      conditionalPanel(
+        condition = "input.conditionedPanels == 'Assumption'",
+        assSidebarUI("ASS")
       )
     ),  
 
@@ -65,6 +70,10 @@ ui <- fluidPage(
         tabPanel("Visualisation",
             visUI("VIS")
         ),
+
+        tabPanel("Assumption",
+            assUI("ASS")
+        ),
 
         id = "conditionedPanels"   
       )
@@ -157,6 +166,7 @@ server <- function(input, output) {
                                 all_data = list(), all_names = list())
   corrServer("CORR", dataSet, listResults)
   visServer("VIS", dataSet, listResults)
+  assServer("ASS", dataSet, listResults)
 
 }
 

BiostatsGithubPage/assumption.R

@@ -0,0 +1,227 @@
+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))
+          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))
+        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))
+        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))
+        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)
+}
+
+
+
+
+

BiostatsGithubPage/correlation.R

@@ -80,12 +80,13 @@ corrServer <- function(id, data, listResults) {
       observeEvent(input$kendall, {
         corr_fct("kendall")
       })
-      output$cor_result <- renderTable({
+      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  

BiostatsGithubPage/utils.R

@@ -20,6 +20,12 @@ setClass("plot",
   )
 )
 
+setClass("diagnosticPlot",
+  slots = c(
+    p = "character"
+  )
+)
+
 createJSString <- function(l) {
 	jsString <- character(length(l))
 	for (i in seq_along(l)) {
@@ -32,6 +38,9 @@ createJSString <- function(l) {
           ggsave(plot = p, filename = fn, width = width, height = height, dpi = resolution) 
           jsString[i] <- paste0("data:image/png;base64,", base64enc::base64encode(fn))
           unlink(fn)
+        } else if (inherits(l[[i]], "diagnosticPlot")) {
+          jsString[i] <- paste0("data:image/png;base64,", base64enc::base64encode(l[[i]]@p))
+          unlink(l[[i]]@p)
         } else if (inherits(l[[i]], "data.frame")) {
           jsString[i] <- DF2String(l[[i]])
         } else if (is.character(l[[i]])) {
@@ -51,4 +60,55 @@ unstackDF <- function(df, name, 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)
 }