golem
golem copied to clipboard
Published
20 hours ago •
ThinkR-open
ThinkR-open
Why I do not get my data under the Load Panel?
I am having two tabs in the navigation bar (I am trying to keep it simple, I have more, but won't matter). Now, I get my info tab the way I want it. But when I upload the module for load data, I cannot get it under 'Load Data' tab but rather under the first tab - Info .
Here is a snipped of the code (although full repo is available on the request -https://github.com/gabrielburcea/grwtgolem, it is golem shiny framework and would like to keep it this way.
First, I define app_ui :
app_ui <- function(request) {
tagList(# Leave this function for adding external resources
golem_add_external_resources(),
shinyjs::useShinyjs(),
# Your application UI logic
shinyUI(
shiny::navbarPage(title = div(tags$a(img(src = "www/AZ_SYMBOL_RGB.png", height = "50px"), "Growth Rate Explorer"),
id = "navBar",
theme = "www/style.css",
# collapsible = TRUE,
# inverse = TRUE,
style = "position: relative; top: -30px; margin-left: 10px; margin-top: 5px;"),
header = tags$head(includeCSS("www/style.css")),# sourcing css style sheet
# make navigation bar collapse on smaller screens
windowTitle = "Growth Rate Explorer",
collapsible = TRUE,
shiny::tabPanel("Info", icon = icon("fa-light fa-info"), mod_info_app_ui("info_app_1")),
shiny::tabPanel("Load Data", icon = icon("fa-light fa-database"), mod_load_app_ui("load_app_1"))
)
)
)
}
And then, I define the server_app as:
#' app_server
#'
#' @param input,output,session Internal parameters for {shiny}.
#' DO NOT REMOVE.
#' @import shiny
#' @noRd
app_server <- function(input, output, session){
mod_info_app_server("info_app_1")
mod_load_app_server("load_app_1")
}
To reiterate, I get my load app under the info tab. Why is this happening?
I have tried for the last two days different configuration but nothing helped.
I tried to re-define the app_server with the shiny::callModule(mod_load_server, mod_load_ui_1) and it did not work whatsoever.
For your info: mod_info_app and mod_load_app:
First is mod_info_app that contains html scripts (which I won't provide, these are way too big) but this module defines the ui and server for info tab, just as golem requires:
#'mod_info_app_ui UI Function
#'
#' @description A shiny Module.
#'
#' @param id,input,output,session Internal parameters for {shiny}.
#'
#' @noRd
#'
#' @importFrom shiny NS tagList
mod_info_app_ui <- function(id){
ns <- NS(id)
tagList(shiny::tabPanel(title = "Info",
icon = icon("fa-light fa-info"),
value = "Info",
tags$div(
class = "main",
shiny::fluidPage(
htmltools::htmlTemplate("www/welcome_to_growth_rate_explorer.html"),
htmltools::htmlTemplate("www/info_tabs_list.html")
)
)))
# )
}
#' mod_info_app_server Server Functions
#'
#' @noRd
mod_info_app_server <- function(id){
moduleServer( id, function(input, output, session){
ns <- session$ns
# Color coding
colorCoding <- reactive({
tagList(
tags$b("Legend"),
tags$p(drawBullet(color = paste(myColors[1], "; border: 1px solid black")), "Adjusted p Value > 0.05"),
tags$p(drawBullet(color = myColors[2]), "0.01 < Adjusted p Value", HTML("≤"), "0.05"),
tags$p(drawBullet(color = myColors[3]), "0.001 < Adjusted p Value", HTML("≤"), "0.01"),
tags$p(drawBullet(color = myColors[4]), "0.0001 < Adjusted p Value", HTML("≤"), "0.001"),
tags$p(drawBullet(color = myColors[5]), "Adjusted p Value", HTML("≤"), "0.0001")
)
})
output$info_colorCoding <- renderUI(colorCoding())
# Example Data
output$info_exampleData <- downloadHandler(
filename = "exampleData.zip",
content = function(file) {
dataDir <- system.file("extdata/exampleData", package = "astraGrowthRateExplorer")
oldDir <- getwd()
setwd(dataDir)
on.exit(setwd(oldDir))
zip(zipfile = file, files = list.files(dataDir))
}
)
# Pipeline: Make this graph once
if (FALSE) {
library("diagram")
png(file = file.path(system.file("app/www", package = "astraGrowthRateExplorer"), "diagram.png"),
width = 1500, height = 200)
par(mar = c(0, 0.5, 0, 0.5))
plot.new()
boxColor <- "blue"
elpos <- coordinates(5)
fromto <- matrix(ncol = 2, byrow = TRUE,
data = c(1, 2, 2, 3, 3, 4, 4, 5))
nr <- nrow(fromto)
arrpos <- matrix(ncol = 2, nrow = nr)
for (i in 1:nr)
arrpos[i,] <- straightarrow(to = elpos[fromto[i,2],], from = elpos[fromto[i,1],],
lwd = 2, arr.pos = 0.6, arr.length = 0.5, lcol = boxColor)
voi <- list(
"Input Data",
c("Data Quality Control"),
c("Calculate Growth Rate", "Summary Metric"),
c("Statistical Analysis of", "Growth Rate"),
"Report Generation"
)
for (iVar in 1:5)
textrect(elpos[iVar,], radx = 0.08, rady = 0.15,
lab = voi[[iVar]], lcol = boxColor, cex = 1.2, lwd = 1.5)
dev.off()
}
})
}
## To be copied in the UI
# mod_info_app_ui("info_app_1")
## To be copied in the server
# mod_info_app_server("info_app_1")
Here is load_data_app:
#' mod_load_app_ui UI Function
#'
#' @description A shiny Module.
#'
#' @param id,input,output,session Internal parameters for {shiny}.
#'
#' @noRd
#'
#' @importFrom shiny NS tagList
mod_load_app_ui <- function(id, label = "Load Data") {
ns <- NS(id)
tagList(
shiny::tabPanel(
title = "Load Data",
icon = icon("fa-light fa-database"),
label = label,
tags$br(),
shiny::sidebarLayout(
shiny::sidebarPanel(
hidden(
actionButton(
inputId = "load_loadNewButton",
icon = icon("arrow-alt-circle-up"),
label = "Upload new data"
)
),
# Load data
div(
id = "load_inputDataSpecifics",
fileInput(
inputId = "load_file",
label = "Data File(s)",
accept = c(".csv", ".xlsx"),
multiple = TRUE
),
uiOutput("load_selectColumnNamesUI"),
uiOutput("load_dayOffsetInput"),
uiOutput("load_loadDataButtonUI")
),
uiOutput("load_warnings"),
hidden(
div(
id = "load_hiddenOnLoad",
# Warning if duplicate variable names
tags$h4("Study Levels"),
uiOutput("load_studyLevels"),
# Treatment levels
tags$h4("Treatment Levels"),
uiOutput("load_trtLevels"),
# Sample Quality Control
shiny::uiOutput("load_sampleQC"),
shiny::tabsetPanel(
id = "load_sampleQCTables",
shiny::tabPanel(
title = "settings",
renderTable(
astraGrowthRateExplorer::QCsettingsOutput(results$load_QCsettings),
na = "",
width = "100%",
caption = "Current settings"
)
),
shiny::tabPanel(
title = "excluded",
renderTable(
results$load_excludedByQC,
na = "",
width = "100%",
caption = "Summary of excluded data points"
)
)
),
# uiOutput("load_nExcludedSamples"),
# tableOutput("load_excludedSamples"),
tags$h4("Exclude Outliers"),
div(
id = "load_exclude",
shiny::radioButtons(
inputId = "load_outlierType",
label = "Outlier data for",
choices = c(
"Animal" = 1,
"Day" = 2 ,
"Animal at specific day" = 3
),
inline = TRUE
),
shiny::selectInput(
inputId = "load_excludeIdSelect",
label = "Select animal_id",
choices = c()
),
shiny::selectInput(
inputId = "load_excludeDaySelect",
label = "Select day",
choices = c()
),
shiny::textInput(
inputId = "load_excludeReason",
label = NULL,
placeholder = "please provide a reason here"
),
shiny::uiOutput("load_excludeButtonUI")
),
# Excluded outliers
shiny::uiOutput("load_outliers")
)
)
),
shiny::mainPanel(
tags$h3("Loaded Data"),
shiny::uiOutput("load_missingValues"),
shiny::tabsetPanel(
id = "load_dataTabs",
shiny::tabPanel(
title = "Raw",
value = "load_dataRawPanel",
DT::DTOutput("load_dataRaw")
),
shiny::tabPanel(
title = "Volume",
value = "load_dataVolumePanel",
DT::DTOutput("load_dataVolume"),
shiny::fluidRow(column(
4,
shiny::uiOutput("load_plotVolumeStudy")
),
column(
4,
shiny::uiOutput("load_plotVolumeTreatments")
)),
shiny::actionButton("load_refresh_volume", label = icon("sync-alt")),
tags$div(style = "margin-bottom:50px",
plotlyOutput("load_plotVolume", height = "500px")),
shiny::fluidRow(column(
4,
uiOutput("load_plotlyVolumeLogTreatments")
),
column(
4,
uiOutput("load_plotlyVolumeLogIds")
)),
shiny::actionButton("load_refresh_volumeLogId", label = icon("sync-alt")),
tags$div(
style = "margin-bottom:50px",
plotlyOutput("load_plotVolumeLogId", height = "500px")
)
),
shiny::tabPanel(
title = "GR",
value = "load_dataPanel",
# Table
DT::DTOutput("load_data"),
# Plot
shiny::uiOutput("load_selectedRowGR"),
shiny::uiOutput("load_showPlot"),
shiny::selectInput(
inputId = "load_MBPlotFacet",
label = "group by",
choices = c("Study" = "study", "Treatment" = "treatment")
),
shiny::actionButton("load_refresh_GR", label = icon("sync-alt")),
tags$div(style = "margin-bottom:50px",
plotlyOutput("load_plotlyGR", height = "600px"))
)
)
)
)
))
# )
}
#' mod_load_app_server Server Functions
#'
#' @noRd
mod_load_app_server <- function(id) {
moduleServer(id, function(input, output, session) {
ns <- session$ns
observe({
req(results$load_dataType())
if (length(input$load_loadDataButton) == 1) {
toggleElement(id = "load_MBPlotFacet",
condition = results$load_dataType() == 2)
}
toggleElement(id = "load_excludeIdSelect",
condition = input$load_outlierType %in% c(1, 3))
toggleElement(id = "load_excludeButton",
condition = isTruthy(input$load_excludeReason))
toggleElement(id = "load_excludeDaySelect",
condition = input$load_outlierType %in% c(2, 3))
})
observe({
req(results$load_dataVolume())
updateSelectInput(session,
inputId = "load_excludeDaySelect",
choices = sort(unique(results$load_dataVolume()$day)))
sortedIds <- list()
for (treatment in levels(results$load_dataVolume()$treatment)) {
ids <-
unique(results$load_dataVolume()$animal_id[results$load_dataVolume()$treatment == treatment])
sortedIds[[treatment]] <- ids
}
updateSelectInput(session, inputId = "load_excludeIdSelect", choices = sortedIds)
})
output$load_selectColumnNamesUI <- renderUI({
req(results$load_dataInputFile0())
myColumns <- matchColumns(results$load_dataInputFile0())
names <- names(myColumns)
inputIds <- paste0("load_columnName_", names)
tagList(
textInput("load_dayOffset",
label = "Specify how day is defined",
value = "Post-implant"),
helpText(
"Please check whether the program has detected the right columns"
),
lapply(1:length(myColumns), function(i)
selectizeInput(
inputId = inputIds[i],
label = names[i],
choices = myColumns[[i]]$options,
selected = myColumns[[i]]$guess
))
)
})
output$load_dayOffsetInput <- renderUI({
req(results$load_dataInputFile0())
req(input$load_columnName_day)
dayColumn <-
results$load_dataInputFile0()[, input$load_columnName_day]
if (isDate(dayColumn)) {
minDate <- min(as.Date(dayColumn), na.rm = TRUE)
dateInput("load_dayDateOffset",
label = "Specify start date",
value = minDate)
}
else
NULL
})
output$load_excludeButtonUI <- renderUI({
validate(need(
!grepl("QC_", input$load_excludeReason),
"Please provide a reason without 'QC_'"
))
actionButton(inputId = "load_excludeButton",
label = "Exclude",
icon = icon("trash"))
})
# make resetting button when data specifications change
output$load_loadDataButtonUI <- renderUI({
req(results$load_dataInputFile0())
input$load_loadNewButton # rerender on when new data will be specified
if (length(results$load_validDataErrors()) == 0)
actionButton(inputId = "load_loadDataButton",
label = "Calculate growth rate",
icon = icon("random"))
else
tagList(
warningStyle("The app is not able to analyze your data."),
lapply(results$load_validDataErrors(), function(x) {
text <- sprintf("ERROR: %s", x)
warningStyle(text)
})
)
})
# start the actual transformering and loading of the data. Moreover, hide data input fields.
observeEvent(input$load_loadDataButton, {
req(results$load_dataInputFile0())
updateTabsetPanel(session = session,
inputId = "load_dataTabs",
selected = "load_dataVolumePanel")
hide("load_inputDataSpecifics")
show("load_loadNewButton")
show("load_hiddenOnLoad")
click("load_applyQC")
})
observeEvent(input$load_loadNewButton, {
updateTabsetPanel(session = session,
inputId = "load_dataTabs",
selected = "load_dataRawPanel")
results$load_exludedOutliers <- NULL
results$load_QCsettings <- NULL
show("load_inputDataSpecifics")
hide("load_hiddenOnLoad")
hide("load_loadNewButton")
})
# Sample quality control
output$load_sampleQC <- renderUI({
req(results$load_dataVolumeRaw())
df <- results$load_dataVolumeRaw()
t <- table(df$animal_id)
maxDay <- max(df$day, na.rm = TRUE)
minDay <- min(df$day, na.rm = TRUE)
guessedUnit <-
if (median(df$tumourVolume, na.rm = TRUE) < 2)
1000
else
1
tagList(
tags$h4("Sample Quality Control"),
sliderInput(
inputId = "load_days",
label = "Days to include",
min = minDay,
max = maxDay,
value = c(NA, NA),
step = 1
),
sliderInput(
"load_minNo",
label = "Select minimal # of measurements per animal",
value = 3,
min = 3,
max = max(t) - 1
),
textOutput("load_minOutliers"),
radioButtons(
inputId = "load_volumeScalingFactor",
label = "Loaded data volume unit",
selected = guessedUnit,
choices = c("mm3" = 1, "cm3" = 1000)
),
actionButton(
inputId = "load_applyQC",
label = "Apply QC settings",
icon = icon("cog")
)
)
})
# Choose treatment levels
output$load_trtLevels <- renderUI({
initLevels <-
getTreatmentLevels(data = results$load_dataVolumeRaw())
choices <- unlist(initLevels)
names(choices) <- NULL
tagList(
# Ref
selectInput(
inputId = "load_refTrt",
label = "Reference",
choices = choices,
selected = initLevels$ref
),
selectizeInput(
inputId = "load_otherTrt",
label = "Treatment(s)",
choices = initLevels$trt,
selected = initLevels$trt,
multiple = TRUE,
options = list(plugins = list('drag_drop'))
),
helpText(
"The order of the treatments in all tables/plots can be changed by dragging the levels"
)
)
})
# Exclude reference for treatment levels
observe({
allChoices <-
unlist(getTreatmentLevels(data = results$load_dataVolumeRaw()))
trtChoices <-
allChoices[-which(allChoices == input$load_refTrt)]
names(trtChoices) <- NULL
updateSelectInput(session,
"load_otherTrt",
choices = trtChoices,
selected = trtChoices)
})
# Selected treatment levels
results$load_trtLevels <- reactive({
req(input$load_refTrt)
req(input$load_otherTrt)
list(ref = input$load_refTrt,
trt = {
if (input$load_refTrt %in% input$load_otherTrt)
input$load_otherTrt[-which(input$load_otherTrt == input$load_refTrt)]
else
input$load_otherTrt
})
})
# Choose study levels
output$load_studyLevels <- renderUI({
initLevels <- levels(results$load_dataVolumeRaw()$study)
choices <- unlist(initLevels)
names(choices) <- NULL
tagList(
selectizeInput(
inputId = "load_studyLevels",
label = "Studies",
choices = choices,
selected = choices,
multiple = TRUE,
options = list(plugins = list('drag_drop'))
),
helpText(
"The order of the studies in all tables/plots can be changed by dragging the levels"
)
)
})
## ----- ##
## Input ##
## ----- ##
results$load_dataType <-
reactive({
# Single study or multiple? -> important for shown analysis
req(input$load_studyLevels)
if (length(input$load_studyLevels) > 1)
t <- 2
else
t <- 1
t
})
# data exactly as read by the file
results$load_dataInputFile0 <- reactive ({
validate(need(input$load_file, "Please load data"))
tryCatch({
files <- input$load_file$datapath
names(files) <- input$load_file$name
output <- loadData(file = files)
},
error = function(e)
validate(
need(
FALSE,
"Data could not be loaded. Please check whether you selected the correct 'Data Type'"
)
))
output
})
# data exactly as read by the file (but only load once start anaylsis is pressed)
results$load_dataInputFile <- reactive({
req(results$load_dataInputFile0())
validate(need(
input$load_loadDataButton == 1,
"Please start the analysis first."
))
results$load_dataInputFile0()
})
# raw volume data for single batch
results$load_dataVolumeRaw <- reactive({
df <- results$load_dataInputFile()
# remove columns without decent header
df <- df[, sapply(colnames(df), isTruthy)]
df <- transformSB(
df,
wide = FALSE,
group = input$load_columnName_group,
treatment = input$load_columnName_treatment,
animal_id = input$load_columnName_animal_id,
tumourVolume = input$load_columnName_tumourVolume,
day = input$load_columnName_day,
study = input$load_columnName_study,
dayOffset = input$load_dayDateOffset
)
df <- df[!is.na(df$tumourVolume), ]
})
results$load_selectedCols <- reactive({
req(results$load_dataInputFile0())
req(input$load_columnName_animal_id)
req(input$load_columnName_group)
req(input$load_columnName_treatment)
req(input$load_columnName_study)
req(input$load_columnName_tumourVolume)
req(input$load_columnName_day)
list(
"animal_id" = input$load_columnName_animal_id,
"group" = input$load_columnName_group,
"treatment" = input$load_columnName_treatment,
"study" = input$load_columnName_study,
"tumourVolume" = input$load_columnName_tumourVolume,
"day" = input$load_columnName_day
)
})
results$load_validDataErrors <- reactive({
req(results$load_selectedCols())
selectedCols <- results$load_selectedCols()
validId <-
isValidIdColumn(results$load_dataInputFile0()[, selectedCols$animal_id])
validGroup <-
isValidGroupColumn(results$load_dataInputFile0()[, selectedCols$group])
validTreatment <-
isValidTreatmentColumn(results$load_dataInputFile0()[, selectedCols$treatment])
validStudy <-
isValidStudyColumn(results$load_dataInputFile0()[, selectedCols$study])
validTumourVolume <-
isValidTumourVolumeColumn(results$load_dataInputFile0()[, selectedCols$tumourVolume])
validDay <-
isValidDayColumn(results$load_dataInputFile0()[, selectedCols$day])
errors <- list(
if (length(unique(selectedCols)) != length(selectedCols))
"Must select a different variable for each essential column.",
if (validId != TRUE)
validId,
if (validGroup != TRUE)
validGroup,
if (validTreatment != TRUE)
validTreatment,
if (validStudy != TRUE)
validStudy,
if (validTumourVolume != TRUE)
validTumourVolume,
if (validDay != TRUE)
validDay
) %>% unlist
errors
})
# Warnings from loading the data
results$load_warnings <- reactive({
req(results$load_dataInputFile0())
# duplicate variable names
duplicateNames <-
attr(results$load_dataInputFile0(), "duplicateNames")
# excluded count variables
excludedCount <-
attr(results$load_dataInputFile0(), "excludedVariables")
# other warnings
warning <- attr(results$load_dataInputFile0(), "warning")
tagList(
if (!is.null(duplicateNames))
warningStyle(text = "WARNING: Following duplicated variable names in loaded data are given unique name"),
tags$ul(lapply(duplicateNames, tags$li)),
if (!is.null(warning))
warningStyle(paste("WARNING:", warning))
)
})
output$load_warnings <- renderUI(results$load_warnings())
# Volume data after QC
results$load_dataVolume <- reactive({
req(results$load_dataVolumeRaw())
req(results$load_trtLevels())
req(results$load_QCsettings)
data <- results$load_dataVolumeRaw()
# exclude outliers
toExclude <- which(results$load_exludedOutliers != FALSE)
if (length(toExclude) > 0)
data <- data[-toExclude, ]
# apply QC settings
process <- processData(df = data,
settings = results$load_QCsettings)
data <- process$df
results$load_excludedByQC <- process$ex
# keep track of the rows excluded by QC
exQC <- rep(FALSE, nrow(results$load_dataVolumeRaw()))
rowNames <- rownames(results$load_dataVolumeRaw())
indices <- which(rowNames %in% process$name$name)
for (i in indices) {
name <- rowNames[i]
reason <-
as.character(process$name$reason[process$name$name == name])
exQC[i] <- paste0("QC_", reason)
}
results$load_exludedQC <- exQC
# set order of data
data <- assignStudyLevels(data, input$load_studyLevels)
data <- assignTreatmentLevels(data, results$load_trtLevels())
data <- data[order(data$study, data$treatment), ]
data
})
results$load_exludedRows <- reactive({
ex1 <- results$load_exludedOutliers
ex2 <- results$load_exludedQC
if (length(ex1) == 0)
ex1 <- FALSE
if (length(ex2) == 0)
ex2 <- FALSE
ex <- cbind(ex1, ex2)
apply(ex, 1, function(x) {
# first check if outlier is reason of exclusion, if not find QC reason
if (x[1] != FALSE)
x[1]
else
x[2]
})
})
results$load_outliers <- reactive({
req(results$load_dataVolumeRaw())
req(results$load_exludedRows)
summarizeExclusions(results$load_dataVolumeRaw(),
results$load_exludedRows())
})
# Growth rate data
results$load_data <- reactive({
req(results$load_dataVolume())
validate(need((nrow(
results$load_dataVolume()
) > 0),
"Need more data to calculate growthrates."))
regressionOutput(results$load_dataVolume())
})
# Quality control settings
results$load_QCsettings <- NULL
observeEvent(input$load_applyQC,
ignoreInit = FALSE,
ignoreNULL = FALSE,
{
if (is.null(results$load_QCsettings)) {
settings <- data.frame(
study = levels(results$load_dataVolumeRaw()$study),
startDay = input$load_days[1],
endDay = input$load_days[2],
minNo = input$load_minNo,
volumeScalingFactor = as.numeric(input$load_volumeScalingFactor)
)
}
else{
settings <- results$load_QCsettings
settings[settings$study %in% input$load_studyLevels, ] <-
data.frame(
study = input$load_studyLevels,
startDay = input$load_days[1],
endDay = input$load_days[2],
minNo = input$load_minNo,
volumeScalingFactor = as.numeric(input$load_volumeScalingFactor)
)
}
results$load_QCsettings <- settings
})
#' get rows that would be excluded from a data.frame
#' @param data.frame data.frame
#' @param values named list (possibly of lists)
#' @importFrom plyr match_df
excludedOutliers <- function(df, values) {
values <- expand.grid(values) # unlist list of values
myData <- df[, colnames(values)]
which(rownames(df) %in% rownames(plyr::match_df(myData, values)))
}
# Button for excluding outlier
output$load_outlierButton <- renderUI({
validate(need(input$load_outlierReason, "Please provide a reason"))
validate(need(
!grepl("QC_", input$load_outlierReason),
"Please provide a reason without 'QC_'"
))
actionButton(inputId = "load_excludeOutlier",
label = "Exclude Outlier",
icon = icon("trash"))
})
observe({
results$load_exludedOutliers <-
rep(FALSE, nrow(results$load_dataVolumeRaw()))
})
# Add selected plot outlier to the list
observeEvent(input$load_excludeOutlier, {
# update exclusion list
values <- list(
"animal_id" = results$load_selectedRowGR()$animal_id,
"study" = results$load_selectedRowGR()$study
)
exIndices <-
excludedOutliers(results$load_dataVolumeRaw(), values)
newEx <- results$load_exludedOutliers
newEx[exIndices] <- input$load_outlierReason
results$load_exludedOutliers <- newEx
})
# Add outlier to the list
observeEvent(input$load_excludeButton, {
req(input$load_excludeButton)
values <- list("study" = input$load_studyLevels)
if (input$load_outlierType %in% c(2, 3))
values$day <- as.integer(input$load_excludeDaySelect)
if (input$load_outlierType %in% c(1, 3)) {
values$animal_id <- input$load_excludeIdSelect
values$treatment <- results$load_dataVolumeRaw()$treatment[{
results$load_dataVolumeRaw()$animal_id == values$animal_id &
results$load_dataVolumeRaw()$study == values$study
}][1]
}
# update exclusion list
exIndices <-
excludedOutliers(results$load_dataVolumeRaw(), values)
newEx <- results$load_exludedOutliers
newEx[exIndices] <- input$load_excludeReason
results$load_exludedOutliers <- newEx
})
# Selected point in the graph
observe({
req(results$load_plotlyGR()) # prevent warning on startup
results$GRplotRegistered <- TRUE
})
observe({
req(results$GRplotRegistered)
results$load_selectedRownGR <-
event_data("plotly_click", source = "GRplot")$key
})
observe({
results$load_data()
results$load_selectedRownGR <- NULL
})
results$load_selectedRowGR <- reactive({
if (isTruthy(results$load_selectedRownGR)) {
GR_data <- isolate(results$load_data())
GR_data[results$load_selectedRownGR , ]
}
else
NULL
})
### ------ ##
### Output ##
### ------ ##
# Warning for missing values in data
output$load_missingValues <- renderUI({
req(results$load_dataInputFile0())
if (any(is.na(results$load_dataInputFile0())))
warningStyle("WARNING: Some values are missing for the loaded data. They are highlighted in red.")
})
# Table with raw data
output$load_dataRaw <- DT::renderDT({
req(results$load_dataInputFile0())
myData <- results$load_dataInputFile0()
myTable <-
DT::datatable(
results$load_dataInputFile0(),
rownames = FALSE,
selection = "none",
filter = list(position = 'top', clear = FALSE),
options = list(dom = 'tip')
)
# Highlight missing value
if (any(is.na(myData)))
myTable <-
myTable %>% DT::formatStyle(
columns = 1:ncol(myData),
target = "cell",
backgroundColor = DT::styleEqual(NA, "#e52323")
)
myTable
})
# Table with loaded data
output$load_data <- DT::renderDT({
req(results$load_data())
myData <- results$load_data()
myTable <- DT::datatable(
myData,
# rownames = FALSE,
selection = "none",
filter = list(position = 'top', clear = FALSE),
options = list(
dom = 'tip',
displayStart = {
if (!is.null(results$load_selectedRowGR()))
(which(
rownames(myData) == rownames(results$load_selectedRowGR())
) - 1) %/% 10 * 10
else
0
},
columnDefs = list(list(
targets = 0, visible = FALSE
)) # hide row names
)
)
# Highlight missing value
if (any(is.na(myData)))
myTable <-
myTable %>% DT::formatStyle(
columns = 1:ncol(myData),
target = "cell",
backgroundColor = DT::styleEqual(NA, "#e52323")
)
if (!is.null(results$load_selectedRowGR()))
myTable <- myTable %>%
DT::formatStyle(
0,
target = "row",
backgroundColor = DT::styleEqual(results$load_selectedRownGR, "#32a6d3")
)
myTable <-
myTable %>% DT::formatRound(columns = 4:ncol(myData), digits = 4)
})
# Table with loaded dataVolume
output$load_dataVolume <- DT::renderDT({
req(results$load_dataVolume())
myData <-
results$load_dataVolume()[, names(getCriticalColumns())]
myData[, "group"] <- NULL # do not display group
myTable <-
DT::datatable(
myData,
rownames = FALSE,
selection = "none",
filter = list(position = 'top', clear = FALSE),
options = list(dom = 'tip')
)
# Highlight missing value
if (any(is.na(myData)))
myTable <-
myTable %>% DT::formatStyle(
columns = 1:ncol(myData),
target = "cell",
backgroundColor = DT::styleEqual(NA, "#e52323")
)
# if (!is.null(results$load_selectedKey()))
# myTable <- myTable %>%
# DT::formatStyle(columns = "animal_id", target = "row",
# backgroundColor = DT::styleEqual(results$load_selectedKey(), "#32a6d3")
# )
myTable <- myTable %>%
DT::formatRound(columns = "tumourVolume", digits = 4) %>%
DT::formatRound(columns = "day", digits = 0)
})
# Selected animal_id in plot
output$load_selectedRowGR <- renderUI({
req(results$load_outliers)
# Update when point is excluded
nrow(results$load_outliers())
tagList(
helpText(
"By clicking on a point in the plot, the corresponding row will be highlighted in blue in the table"
),
if (!is.null(results$load_selectedRowGR()))
wellPanel(
warningStyle("Do you want to exclude the highlighted sample from the data?"),
p(
tags$b("Selected Sample:"),
results$load_selectedRowGR()$animal_id
),
p(tags$b("Study:"), results$load_selectedRowGR()$study),
tags$b("Reason"),
fluidRow(column(
10,
textInput(
inputId = "load_outlierReason",
label = NULL,
width = "100%"
)
),
column(2, uiOutput(
"load_outlierButton"
)))
)
)
})
# List excluded outliers
output$load_outliers <- renderUI({
req(results$load_exludedRows)
validate(need(
results$load_exludedRows(),
"No outliers have been excluded."
))
nOutliers <- sum(results$load_exludedRows() != FALSE)
tagList(
warningStyle(
paste(
"WARNING: There",
if (nOutliers == 1)
paste("was", nOutliers, "data point")
else
paste("were", nOutliers, "data points"),
"excluded"
)
),
renderTable(
results$load_outliers(),
na = "",
width = "100%",
caption = "Summary of excluded data points"
),
actionButton("load_outlierSummaryHelp", "?")
)
})
observeEvent(input$load_outlierSummaryHelp, {
showModal({
modalDialog(
title = "Outlier summary explanation",
p("Blank cells should be read as 'all'."),
renderTable(
na = "",
width = "100%",
data.frame(
animal_id = "",
treatment = "",
study = "myStudy",
day = "9",
reason = "QC_day",
N = "5"
)
),
p(
"\"All animals and all treatments for study 'myStudy' have been excluded at day 9 because of 'day quality control'.\""
),
p("A total of 5 data points have been exluded because of this."),
footer = modalButton("dismiss")
)
})
})
# PLOTS
# plot display control
output$load_plotVolumeStudy <- renderUI({
selectInput(
inputId = "load_plotVolumeStudy",
label = "choose study",
choices = input$load_studyLevels
)
})
output$load_plotVolumeTreatments <- renderUI({
treatments <- unique(
subset(
results$load_dataVolume(),
subset = study == input$load_plotVolumeStudy
)$treatment
)
startN <- min(5, length(treatments))
selectInput(
inputId = "load_plotVolumeTreatments",
label = "choose treatments",
choices = treatments,
selected = treatments[1:startN],
multiple = TRUE
)
})
output$load_plotlyVolumeLogTreatments <- renderUI({
req(results$load_trtLevels())
choices <- results$load_trtLevels()
# give appropriate names for display
names(choices)[1] <- choices$ref
if (length(choices$trt) == 1)
names(choices)[2] <- choices$trt
else
names(choices)[2] <- "treatments"
selectInput(inputId = "load_plotlyVolumeLogTreatment",
label = "choose treatment",
choices = choices)
})
output$load_plotlyVolumeLogIds <- renderUI({
ids <- unique(
subset(
results$load_dataVolume(),
subset =
treatment == input$load_plotlyVolumeLogTreatment &
study == input$load_plotVolumeStudy
)$animal_id
)
startN <- min(10, length(ids))
selectInput(
inputId = "load_plotlyVolumeLogIds",
label = "choose animal_id",
choices = ids,
selected = ids[1:startN],
multiple = TRUE
)
})
# plots
output$load_plotVolume <- renderPlotly({
req(results$load_dataVolume())
req(input$load_plotVolumeTreatments)
input$load_refresh_volume
validate(need(
!any(duplicated(unlist(
results$load_trtLevels()
))),
"Please choose Treatment(s) different from the reference"
))
myData <- subset(
results$load_dataVolume(),
study == input$load_plotVolumeStudy &
treatment %in% input$load_plotVolumeTreatments
)
if (nrow(myData) > 0) {
p <- plotlyVolume(myData)
}
else
p <- NULL
p
})
output$load_plotVolumeLogId <- renderPlotly({
req(results$load_dataVolume())
req(input$load_plotlyVolumeLogTreatment)
input$load_refresh_volumeLogId
validate(need(
!any(duplicated(unlist(
results$load_trtLevels()
))),
"Please choose Treatment(s) different from the reference"
))
myData <- subset(
results$load_dataVolume(),
treatment == input$load_plotlyVolumeLogTreatment &
animal_id %in% input$load_plotlyVolumeLogIds &
study == input$load_plotVolumeStudy
)
if (nrow(myData) > 0)
plot <- plotlyVolumeLogId(df = myData)
else
plot <- NULL
plot
})
results$load_plotGR <- reactive({
req(results$load_data())
req(input$load_MBPlotFacet)
if (input$load_MBPlotFacet == "treatment") {
xVar <- "study"
} else{
xVar <- "treatment"
}
suppressWarnings(
plotGrowthRate(
df = results$load_data(),
xVar = xVar,
facetVar = input$load_MBPlotFacet,
withJitter = TRUE
)
)
})
results$load_plotlyGR <- reactive({
req(results$load_data())
req(input$load_MBPlotFacet)
if (input$load_MBPlotFacet == "treatment") {
xVar <- "study"
} else{
xVar <- "treatment"
}
suppressWarnings(
plotlyGrowthRate(
df = results$load_data(),
xVar = xVar,
facetVar = input$load_MBPlotFacet,
withJitter = TRUE,
selected = rownames(results$load_selectedRowGR()),
source = "GRplot"
)
)
})
output$load_plotlyGR <- renderPlotly({
input$load_refresh_GR
results$load_plotlyGR()
})
})
}
## To be copied in the UI
# mod_load_app_ui("load_app_1")
## To be copied in the server
# mod_load_app_server("load_app_1")
If you want to see the user interface, as to how Info tab with Load Data tab get mixed up, check the stackoverflow link where I've posted a pic:
https://stackoverflow.com/questions/75453946/why-i-do-not-get-my-data-under-the-load-data-panel
Hello peps. Would you please help? I have opened up a bounty on stackoverlow! Wish someone can help. I can also make available the github repo for the person who's willing to help!
@ColinFay I beg for help! Please do help . Also the bounty on stackoverflow expires. I simply beg for help.
Hello @gabrielburcea,
Sorry for the long wait for a reply. Is this problem still true? If so, I'd be delighted to help.
