DraftApp2.R
In jngwehi/loxcodeR: Loxcode Tools
library(shiny)
library(plotly)
library(DT)
library(loxcoder)
library(shinydashboard)
library(rlist)
library(shinyFiles)
library(shinyalert)
### INITIALIZE
load_origin_distmaps('/wehisan/general/user_managed/grpu_naik.s_2/TW/maps/origin/')
load_pair_distmaps('/wehisan/general/user_managed/grpu_naik.s_2/TW/maps/origin/')
lox <- NN167
d <- summary_table(lox, "all_samples")
### VARIABLES
react <- reactiveValues(curr=lox, name=lox@name, exp=list(lox), samp=d)
global <- reactiveValues()
### CONSTANTS
chart_choices = c("Statistics Plots", "Heatmap", "Saturation Plot", "Pair Comparison Plot")
codeset_selectionID = c("codeset_stats", "view_codeset", "codeset_stats", "codeset_heat", "codeset_sat", "filter_code_name")
sample_selectionID = c("view_sample", "matrix_stats", "matrix_heat", "filter_name")
### FUNCTIONS
updateCodesetSelection <- function(session, selectionID, selected) {
for (ID in selectionID){
updateSelectInput(session, ID, choices=names(react$curr@code_sets), selected=selected)
}
}
updateSampleSelection <- function(session, selectionID, selected) {
for (ID in selectionID){
updateSelectInput(session, ID, choices=names(react$curr@count_matrixes), selected=selected)
}
}
updateCurrentExp <- function(session, curr, exp) {
index = match(curr@name, exp_table(exp)$Experiment_Name)
exp = list.remove(exp, index)
exp = list.append(exp, curr)
return(exp)
}
# validates fastq directory and sample sheet
# note: assumes that "R1_001" and "R2_001" will always be part of the naming convention for fastq
validateFastq <- function(session, samplesheet, files) {
files = sort(files[grepl(".fastq$", files)])
R1 = sort(files[grepl("R1_001.", files)])
R2 = sort(files[grepl("R2_001.", files)])
if ("sample" %in% names(samplesheet)){
sample_names = sort(samplesheet$sample)
} else {
return(FALSE)
}
for (s in R1){
if ((gsub("_R1_001", "_R2_001", s) %in% R2) == FALSE) {
return (FALSE)
}
}
for (i in sample_names) {
if (sum(grepl(i,R1))!=1) {
return(FALSE)
}
}
return (TRUE)
}
# Function to call in place of dropdownMenu
dropdownMenuCustom <- function (..., type = c("messages", "notifications", "tasks"),
badgeStatus, icon = NULL, .list = NULL, customSentence = customSentence)
{
type <- match.arg(type)
if (!is.null(badgeStatus)) shinydashboard:::validateStatus(badgeStatus)
items <- c(list(...), .list)
lapply(items, shinydashboard:::tagAssert, type = "li")
dropdownClass <- paste0("dropdown ", type, "-menu")
if (is.null(badgeStatus)) {badge <- NULL}
else {badge <- span(class = paste0("label label-", badgeStatus), numItems)}
tags$li(
class = dropdownClass,
a(
href = "#",
class = "dropdown-toggle",
`data-toggle` = "dropdown",
icon,
badge
),
tags$ul(
class = "dropdown-menu",
tags$li(
class = "header",
customSentence(numItems, type)
),
tags$li(
tags$ul(class = "menu", items)
)
)
)
}
customSentence <- function(numItems, type) {
paste("Current Loxcode Experiment")
}
### UI
header <- dashboardHeader(
title = "LoxCodeR",
dropdownMenuOutput("curr_lox")
)
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("Import", tabName="import", icon=icon("upload")),
menuItem(
"Create", tabName="create", icon=icon("folder-plus"),
menuSubItem("Create Code Sets", tabName="codeset-create"),
menuSubItem("Create Sample Sets", tabName="sample-create"),
menuSubItem("Filter Codes", tabName="codes-filter")
),
menuItem(
"Plots", tabName="plots", icon=icon("chart-bar"),
menuSubItem("Statistics Plots", tabName="stats-plot"),
menuSubItem("Heat Map", tabName="heatmap-plot"),
menuSubItem("Saturation Plot", "saturation-plot"),
menuSubItem("Pair Comparison Plot", "pair-plot")
)
)
)
body <- dashboardBody(
tabItems(
tabItem(
tabName = "import",
box(
width = 6,
title = "Method 1: Upload a loxcode experiment object",
status = NULL,
color = NULL,
solidHeader = FALSE,
collapsible = TRUE,
fileInput("rds_file", "Choose an rds file:", multiple=TRUE, accept=c("rds")),
useShinyalert(),
actionButton("submit_rds", "Upload")
),
box(
width = 6,
title = "Method 2: Upload samplesheet and fastq directory",
status = NULL,
color = NULL,
solidHeader = FALSE,
collapsible = TRUE,
textInput("name_exp", "Name of the loxcode experiment:", placeholder="Experiment Name"),
fileInput("samplesheet", "Choose an xlsx file of samples", multiple=FALSE, accept=c("xlsx")),
textInput("dir_input", "Choose a fastq directory"),
actionButton("submit_fastq", "Upload")
),
box(
width = 12,
title = "Loxcode Experiments",
status = "danger",
colur = NULL,
solidHeader = FALSE,
collapsible = FALSE,
dataTableOutput("experiments_table"),
actionButton("select_exp", "Select"),
actionButton("del_exp", "Delete"),
downloadButton("save_exp", "Download Current")
)
),
tabItem(
tabName = "codeset-create",
fluidRow(
box(
title = "View a code set",
status = NULL,
color = NULL,
solidHeader = TRUE,
collapsible = TRUE,
selectInput("view_codeset", label="", choices=names(lox@code_sets)),
actionButton("delete_codeset", "Delete Code Set")
),
box(
title = "Edit code sets",
status = NULL,
color = "red",
solidHeader = TRUE,
collapsible = TRUE,
textInput("name_codeset", label="Name of new codeset:", placeholder="Code Set Name"),
fluidRow(
column(4, actionButton("create_codeset", "Create from Selection")),
column(4, actionButton("create_all_codeset", "Create from All")),
column(4, actionButton("rename_codeset", "Rename Current"))
)
),
box(
width = 12,
title = "Code Set Table",
status = "danger",
solidHeader = FALSE,
wellPanel(dataTableOutput("codeset_table"))
)
)
),
tabItem(
tabName = "sample-create",
fluidRow(
column(
6,
style = "padding:0px;",
box(
width = 12,
title = "View a sample set",
status = NULL,
color = NULL,
solidHeader = TRUE,
collapsible = TRUE,
selectInput("view_sample", label="", choices=names(lox@count_matrixes)),
actionButton("delete_sample", "Delete Sample Set")
),
box(
width = 12,
title = "Edit sample sets",
status = NULL,
color = "red",
solidHeader = TRUE,
collapsible = TRUE,
textInput("name_sample", label="Name of new sample set:", placeholder="Sample Set Name"),
fluidRow(
column(4, actionButton("create_sample", "Create from Selection")),
column(4, actionButton("create_all_sample", "Create from All")),
column(4, actionButton("rename_sample", "Rename Current"))
)
)
),
column(
6,
style = "padding:0px;",
box(
width = 12,
title = "Collapse samples",
status = NULL,
solidHeader = TRUE,
collapsible = TRUE,
textInput("collapse_name", label="Name of new sample set:", placeholder="Sample Set Name"),
tags$strong("Collapse type: "),
fluidRow(
column(3, checkboxInput("collapse_union", "Union")),
column(3, checkboxInput("collapse_average", "Average"))
),
checkboxGroupInput("collapse_parameters", "Choose parameters to collapse:", choices=c("mouse", "population", "pcr")),
actionButton("collapse_samples", "Collapse")
)
),
box(
width = 12,
title = "Sample Set Table",
status = "danger",
solidHeader = FALSE,
wellPanel(dataTableOutput("sample_table"))
)
)
),
tabItem(
tabName = "codes-filter",
box(
width = 6,
title = "Set independent variables",
status = NULL,
color = NULL,
solidHeader = TRUE,
collapsible = TRUE,
textInput("filter_name", label="Name of new sample set:", placeholder="Sample Set Name"),
checkboxGroupInput("independent_parameters", "Independence Parameters:", choices=c("mouse", "population", "pcr")),
actionButton("filter_independenece", "Collapse"),
),
box(
width = 6,
title = "Filter parameters",
status = NULL,
color = NULL,
solidHeader = TRUE,
collapsible = TRUE,
textInput("filter_code_name", label="Name of new filtered code set:", placeholder="Code Set Name"),
fluidRow(
column(6, selectInput("independent_samples", label="Independent Sample Set", choices=names(lox@count_matrixes))),
column(6, selectInput("filter_codeset", label="Code Set", choices=names(lox@code_sets)))
),
fluidRow(
column(6, sliderInput("filter_reps", label="Maximum allowed code repetitions", min=2, max=2, value=2)),
column(6, sliderInput("filter_tolerance", label="Tolerance Level (%)", min=0.1, max=100, value=5, step=0.1))
),
actionButton("create_filtered", "Create Filtered Code Set")
),
box(
width = 12,
height = 680,
status = "danger",
title = "Uniqueness Plot",
tabBox(
width = 12,
tabPanel("Unfiltered", plotOutput("unfiltered_codes")),
tabPanel("Filtered", plotOutput("filtered_codes"))
)
)
),
tabItem(
tabName = "stats-plot",
fluidRow(
box(
title = "View a sample set",
status = NULL,
color = NULL,
solidHeader = TRUE,
collapsible = TRUE,
selectInput("matrix_stats", "Sample:", choices = names(lox@count_matrixes))
),
box(
title = "View a code set",
status = NULL,
color = NULL,
solidHeader = TRUE,
collapsible = TRUE,
selectInput("codeset_stats", "Codes:", choices = names(lox@code_sets))
),
box(
width = 12,
title = "Statistics Plots",
status = "danger",
tabBox(
width = 12,
tabPanel("Size", plotlyOutput("size_plot")),
tabPanel("Complexity", plotlyOutput("complexity_plot")),
tabPanel("Ratio", plotlyOutput("ratio_plot")),
tabPanel("Both", plotlyOutput("both_plot"))
)
)
)
),
tabItem(
tabName = "heatmap-plot",
box(
width = 6,
title = "View a sample set",
status = NULL,
color = NULL,
solidHeader = TRUE,
collapsible = TRUE,
selectInput("matrix_heat", "Sample:", choices = names(lox@count_matrixes))
),
box(
width = 6,
title = "View a code set",
status = NULL,
color = NULL,
solidHeader = TRUE,
collapsible = TRUE,
selectInput("codeset_heat", "Codes:", choices = names(lox@code_sets))
),
box(
width = 12,
title = "Heat Map",
status = "danger",
plotlyOutput("heatmap")
),
box(
width = 12,
title = "Sample Comparison Pie",
status = "danger",
plotOutput("sample_comparison_pie")
)
),
tabItem(
tabName = "saturation-plot",
box(
width = 12,
title = "View a code set",
status = NULL,
color = NULL,
solidHeader = TRUE,
collapsible = TRUE,
selectInput("codeset_sat", "Codes:", choices = names(lox@code_sets))
),
box(
width = 12,
title = "Saturation Plot",
status = "danger",
plotOutput("saturation")
)
),
tabItem(
tabName = "pair-plot",
box(
width = 6,
title = "Choose your samples",
status = NULL,
color = NULL,
solidHeader = TRUE,
collapsible = TRUE,
selectInput("sample1_pair", "Sample 1:", choices = names(lox@samples)),
selectInput("sample2_pair", "Sample 2:", choices = names(lox@samples))
),
box(
width = 6,
title = "Configure the plot",
status = NULL,
color = NULL,
solidHeader = TRUE,
collapsible = TRUE,
selectInput("colour_pair", "Colour by:", choices = c("size", "complexity")),
sliderInput("slider_pair", "Distance Range:", min = 1, max = 13, value = c(1,13))
),
box(
width = 12,
height = 770,
title = "Pair Comparison Plot",
status = "danger",
plotlyOutput("pair_plot")
)
)
)
)
### APP
shinyApp(
ui = fluidPage(
tags$head(
tags$style(
HTML("")
)
),
dashboardPage(header, sidebar, body, skin = "red")
),
server = function(input, output, session) {
# current loxcode_experiment object
output$curr_lox = renderMenu({
dropdownMenuCustom(
type = "messages",
icon = icon("bookmark"),
badgeStatus = NULL,
customSentence = customSentence,
messageItem(from=react$curr@name, message="", icon=icon("dna"), href=NULL)
)})
### IMPORT
# upload loxcode_experiment object
observeEvent(
input$submit_rds, {
if (is.null(input$rds_file)){
showNotification("Please specify a file path.")
return
} else {
if (grepl(".rds$", input$rds_file)){
obj = readRDS(file=input$rds_file$datapath)
if (is(obj, "loxcode_experiment")){
react$curr <- obj
react$samp <- sample_table(react$curr, "all_samples")
react$exp <- rlist::list.append(react$exp, react$curr)
updateSelectInput(session, "sample1_pair", "Sample 1:", choices=names(react$curr@samples))
updateSelectInput(session, "sample2_pair", "Sample 2:", choices=names(react$curr@samples))
} else {
shinyalert("Oops!", "Object uploaded was not of class <loxcode_experiment>")
}
} else {
shinyalert("Oops!", "File uploaded was not an R object (*.rds).", type="error")
}
}
}
)
observeEvent(
input$submit_fastq, {
files = list.files(input$dir_input)
print(input$dir_input)
if (is.null(input$samplesheet)){
showNotification("Please specify a file path.")
} else {
if (grepl(".xls$", input$samplesheet$datapath) | grepl(".xlsx$", input$samplesheet$datapath)){ # validate file extension
samplesheet = read_excel(input$samplesheet$datapath)
if (validateFastq(session, samplesheet, files)) { # validate file contents
newlox <- load_from_xlsx(
name = input$name_exp,
s=input$samplesheet$datapath,
dir=input$dir_input,
load = TRUE,
full = FALSE)
react$curr <- newlox
react$samp <- sample_table(react$curr, "all_samples")
react$exp <- rlist::list.append(react$exp, react$curr)
updateSelectInput(session, "sample1_pair", "Sample 1:", choices=names(react$curr@samples))
updateSelectInput(session, "sample2_pair", "Sample 2:", choices=names(react$curr@samples))
} else {
shinyalert("Oops!", "Invalid files uploaded.", type="error")
}
} else {
shinyalert("Oops!", "File uploaded was not an excel file (*.xls or *.xlsx).", type="error")
}
}
}
)
# table of loxcode_experiment objects
output$experiments_table = renderDataTable({datatable(
exp_table(react$exp),
rownames = FALSE,
class = "cell-border stripe",
filter = 'top',
selection = 'single'
)})
observeEvent(
input$select_exp, {
if (!is.null(input$experiments_table_rows_selected)) {
react$curr = react$exp[[input$experiments_table_rows_selected]]
}
}
)
output$save_exp = downloadHandler(
filename = function() {
paste("data-", Sys.Date(), ".rds", sep="")
},
content = function(file) {
saveRDS(react$curr, file)
}
)
observeEvent(
input$del_exp, {
if (!is.null(input$experiments_table_rows_selected)){
react$exp = list.remove(react$exp, input$experiments_table_rows_selected)
}
}
)
### CREATE CODESET
output$codeset_table = renderDataTable({datatable(
codeset_table(react$curr, input$view_codeset),
rownames = FALSE,
class = "cell-border stripe",
filter = 'top'
)} %>% formatStyle(columns=c(seq(2, ncol(react$samp))), 'text-align'='center'))
observeEvent(
input$delete_codeset, {
react$curr <- delete_codeset(react$curr, input$view_codeset)
updateCodesetSelection(session, codeset_selectionID, input$name_codeset)
react$exp = updateCurrentExp(session, react$curr, react$exp)
}
)
observeEvent(
input$create_codeset, {
react$curr = make_codeset_index(react$curr, c=input$view_codeset, I=input$codeset_table_rows_selected, n=input$name_codeset)
updateCodesetSelection(session, codeset_selectionID, input$name_codeset)
updateTextInput(session, "name_codeset", label="Name of new codeset:", placeholder="Codeset Name", value="")
react$exp = updateCurrentExp(session, react$curr, react$exp)
}
)
observeEvent(
input$create_all_codeset, {
react$curr = make_codeset_index(react$curr, c=input$view_codeset, I=input$codeset_table_rows_all, n=input$name_codeset)
updateCodesetSelection(session, codeset_selectionID, input$name_codeset)
updateTextInput(session, "name_codeset", label="Name of new codeset:", placeholder="Codeset Name", value="")
react$exp = updateCurrentExp(session, react$curr, react$exp)
}
)
observeEvent(
input$rename_codeset, {
react$curr = rename_codeset(react$curr, c=input$view_codeset, n=input$name_codeset)
updateCodesetSelection(session, codeset_selectionID, input$name_codeset)
updateTextInput(session, "name_codeset", label="Name of new codeset:", placeholder="Codeset Name", value="")
react$exp = updateCurrentExp(session, react$curr, react$exp)
}
)
### CREATE SAMPLE SET
output$sample_table = renderDataTable({
d <- summary_table(react$curr, input$view_sample)
react$samp <- d
datatable(
d,
filter = 'top',
rownames = FALSE,
class = "cell-border stripe",
editable = list(target="cell", disable=list(columns=c(0, seq(2, ncol(react$samp)))))
)} %>% formatStyle(columns=c(seq(3, ncol(react$samp))), 'text-align'='center'))
observeEvent(
input$view_sample, {
d <- summary_table(react$curr, input$view_sample)
react$samp <- d
})
# renaming samples
proxy = dataTableProxy("sample_table")
observeEvent(
input$sample_table_cell_edit, {
d = react$samp
info = input$sample_table_cell_edit
i = info$row
j = info$col + 1 # column index offset by 1
v = info$value
d[i, j] <<- coerceValue(v, d[i, j])
sample = d[i,j-1]
replaceData(proxy, d, resetPaging=FALSE, rownames=FALSE)
react$curr = new_nickname(react$curr, input$view_sample, sample, v)
updateSelectInput(session, "sample1_pair", "Sample 1:", choices=names(react$curr@samples), selected=input$sample1_pair)
updateSelectInput(session, "sample2_pair", "Sample 2:", choices=names(react$curr@samples), selected=input$sample1_pair)
react$exp = updateCurrentExp(session, react$curr, react$exp)
})
# create samples
observeEvent(
input$create_sample, {
react$curr = make_count_matrix(react$curr, c=input$view_sample, I=input$sample_table_rows_selected, n=input$name_sample)
updateSampleSelection(session, sample_selectionID, input$name_sample)
updateTextInput(session, "name_sample", label="Name of new collection of samples:", placeholder="Sample Collection Name", value="")
react$exp = updateCurrentExp(session, react$curr, react$exp)
}
)
observeEvent(
input$create_all_sample, {
react$curr = make_count_matrix(react$curr, c=input$view_sample, I=input$sample_table_rows_all, n=input$name_sample)
updateSampleSelection(session, sample_selectionID, input$name_sample)
updateTextInput(session, "name_sample", label="Name of new collection of samples:", placeholder="Sample Collection Name", value="")
react$exp = updateCurrentExp(session, react$curr, react$exp)
}
)
observeEvent(
input$delete_sample, {
react$curr <- delete_count_matrix(react$curr, input$view_sample)
updateSampleSelection(session, sample_selectionID, "all_samples")
react$exp = updateCurrentExp(session, react$curr, react$exp)
}
)
observeEvent(
input$rename_sample, {
react$curr = rename_sampleset(react$curr, input$view_sample, input$name_sample)
updateSampleSelection(session, sample_selectionID, input$name_sample)
updateTextInput(session, "name_sample", label="Name of new collection of samples:", placeholder="Sample Collection Name", value="")
react$exp = updateCurrentExp(session, react$curr, react$exp)
}
)
# collapse samples
observeEvent(
input$collapse_samples, {
react$curr <- collapse(react$curr, input$view_sample, input$collapse_parameters, input$collapse_name, input$collapse_union, input$collapse_average)
updateSampleSelection(session, sample_selectionID, input$collapse_name)
updateCheckboxInput(session, "collapse_union", "Union", value=NULL)
updateCheckboxInput(session, "collapse_average", "Average", value=NULL)
updateTextInput(session, "collapse_name", label="Name of new sample set:", placeholder="Sample Set Name", value="")
updateCheckboxGroupInput(session, "collapse_parameters", "Choose parameters to collapse:", choices=c("mouse", "population", "pcr"), selected=NULL)
react$exp = updateCurrentExp(session, react$curr, react$exp)
}
)
### FILTER CODES
output$unfiltered_codes = renderPlot(
code_frequency_pie(react$curr, input$independent_samples, input$filter_codeset),
height = 550
)
output$filtered_codes = renderPlot(
filtered_codes_pie(react$curr, input$independent_samples, input$filter_codeset, input$filter_tolerance, input$filter_reps),
height = 550
)
observe({
Y = code_freq_table(react$curr, input$independent_samples, input$filter_codeset)
total = max(as.numeric(names(Y[,!names(Y)%in%c("size", "dist_orig", "radius")])))
updateSliderInput(session, "filter_reps", label="Maximum allowed code repetitions", min=2, max=total, value=input$filter_reps, step=1)
})
observeEvent(
input$create_filtered, {
react$curr = make_filtered_codeset(react$curr, input$independent_samples, input$filter_codeset, input$filter_tolerance, input$filter_reps, input$filter_code_name)
react$exp = updateCurrentExp(session, react$curr, react$exp)
updateCodesetSelection(session, codeset_selectionID, input$filter_code_name)
updateSampleSelection(session, sample_selectionID, input$name_sample)
}
)
### STATISTICS PLOT
output$size_plot = renderPlotly({
ggplotly(readstats_plot(react$curr, count_matrix=input$matrix_stats, code_set=input$codeset_stats, plot="size"))
})
output$complexity_plot = renderPlotly({
ggplotly(readstats_plot(react$curr, code_set=input$codeset_stats, plot="complexity"))
})
output$ratio_plot = renderPlotly({
ggplotly(readstats_plot(react$curr, code_set=input$codeset_stats, plot="ratio"))
})
output$both_plot = renderPlotly({
ggplotly(readstats_plot(react$curr, code_set=input$codeset_stats, plot="both"))
})
### HEATMAP PLOT
output$heatmap = renderPlotly({
ggplotly(heatmap_plot(react$curr, count_matrix=input$matrix_heat, code_set=input$codeset_heat))
})
output$sample_comparison_pie = renderPlot({
sample_comparison_pie(react$curr)
})
### SATURATION PLOT
output$saturation = renderPlot({
saturation_plot(react$curr, code_set = input$codeset_sat)
})
### PAIR COMPARISON PLOT
output$pair_plot = renderPlotly({
p <- pair_comparison_plot(
x1=react$curr@samples[[input$sample1_pair]],
x2=react$curr@samples[[input$sample2_pair]],
dist_range = input$slider_pair,
plot = input$colour_pair
)
ggplotly(p, height = 700)
})
observeEvent(
input$sample1_pair, {
# updates the slider based on the distance range of the samples selected
# min_dist_one <- min(na.omit(react$curr@samples[[input$sample1_pair]]@decode@data$dist_orig))
# min_dist_two <- min(na.omit(react$curr@samples[[input$sample2_pair]]@decode@data$dist_orig))
# max_dist_one <- max(na.omit(react$curr@samples[[input$sample1_pair]]@decode@data$dist_orig))
# max_dist_two <- max(na.omit(react$curr@samples[[input$sample2_pair]]@decode@data$dist_orig))
# newmin <- min(min_dist_one, min_dist_two)
# newmax <- max(max_dist_one, max_dist_two)
})
#session$onSessionEnded(stopApp)
},
)
jngwehi/loxcodeR documentation built on March 17, 2020, 5:32 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
library(shiny)
library(plotly)
library(DT)
library(loxcoder)
library(shinydashboard)
library(rlist)
library(shinyFiles)
library(shinyalert)
### INITIALIZE
load_origin_distmaps('/wehisan/general/user_managed/grpu_naik.s_2/TW/maps/origin/')
load_pair_distmaps('/wehisan/general/user_managed/grpu_naik.s_2/TW/maps/origin/')
lox <- NN167
d <- summary_table(lox, "all_samples")
### VARIABLES
react <- reactiveValues(curr=lox, name=lox@name, exp=list(lox), samp=d)
global <- reactiveValues()
### CONSTANTS
chart_choices = c("Statistics Plots", "Heatmap", "Saturation Plot", "Pair Comparison Plot")
codeset_selectionID = c("codeset_stats", "view_codeset", "codeset_stats", "codeset_heat", "codeset_sat", "filter_code_name")
sample_selectionID = c("view_sample", "matrix_stats", "matrix_heat", "filter_name")
### FUNCTIONS
updateCodesetSelection <- function(session, selectionID, selected) {
for (ID in selectionID){
updateSelectInput(session, ID, choices=names(react$curr@code_sets), selected=selected)
}
}
updateSampleSelection <- function(session, selectionID, selected) {
for (ID in selectionID){
updateSelectInput(session, ID, choices=names(react$curr@count_matrixes), selected=selected)
}
}
updateCurrentExp <- function(session, curr, exp) {
index = match(curr@name, exp_table(exp)$Experiment_Name)
exp = list.remove(exp, index)
exp = list.append(exp, curr)
return(exp)
}
# validates fastq directory and sample sheet
# note: assumes that "R1_001" and "R2_001" will always be part of the naming convention for fastq
validateFastq <- function(session, samplesheet, files) {
files = sort(files[grepl(".fastq$", files)])
R1 = sort(files[grepl("R1_001.", files)])
R2 = sort(files[grepl("R2_001.", files)])
if ("sample" %in% names(samplesheet)){
sample_names = sort(samplesheet$sample)
} else {
return(FALSE)
}
for (s in R1){
if ((gsub("_R1_001", "_R2_001", s) %in% R2) == FALSE) {
return (FALSE)
}
}
for (i in sample_names) {
if (sum(grepl(i,R1))!=1) {
return(FALSE)
}
}
return (TRUE)
}
# Function to call in place of dropdownMenu
dropdownMenuCustom <- function (..., type = c("messages", "notifications", "tasks"),
badgeStatus, icon = NULL, .list = NULL, customSentence = customSentence)
{
type <- match.arg(type)
if (!is.null(badgeStatus)) shinydashboard:::validateStatus(badgeStatus)
items <- c(list(...), .list)
lapply(items, shinydashboard:::tagAssert, type = "li")
dropdownClass <- paste0("dropdown ", type, "-menu")
if (is.null(badgeStatus)) {badge <- NULL}
else {badge <- span(class = paste0("label label-", badgeStatus), numItems)}
tags$li(
class = dropdownClass,
a(
href = "#",
class = "dropdown-toggle",
`data-toggle` = "dropdown",
icon,
badge
),
tags$ul(
class = "dropdown-menu",
tags$li(
class = "header",
customSentence(numItems, type)
),
tags$li(
tags$ul(class = "menu", items)
)
)
)
}
customSentence <- function(numItems, type) {
paste("Current Loxcode Experiment")
}
### UI
header <- dashboardHeader(
title = "LoxCodeR",
dropdownMenuOutput("curr_lox")
)
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("Import", tabName="import", icon=icon("upload")),
menuItem(
"Create", tabName="create", icon=icon("folder-plus"),
menuSubItem("Create Code Sets", tabName="codeset-create"),
menuSubItem("Create Sample Sets", tabName="sample-create"),
menuSubItem("Filter Codes", tabName="codes-filter")
),
menuItem(
"Plots", tabName="plots", icon=icon("chart-bar"),
menuSubItem("Statistics Plots", tabName="stats-plot"),
menuSubItem("Heat Map", tabName="heatmap-plot"),
menuSubItem("Saturation Plot", "saturation-plot"),
menuSubItem("Pair Comparison Plot", "pair-plot")
)
)
)
body <- dashboardBody(
tabItems(
tabItem(
tabName = "import",
box(
width = 6,
title = "Method 1: Upload a loxcode experiment object",
status = NULL,
color = NULL,
solidHeader = FALSE,
collapsible = TRUE,
fileInput("rds_file", "Choose an rds file:", multiple=TRUE, accept=c("rds")),
useShinyalert(),
actionButton("submit_rds", "Upload")
),
box(
width = 6,
title = "Method 2: Upload samplesheet and fastq directory",
status = NULL,
color = NULL,
solidHeader = FALSE,
collapsible = TRUE,
textInput("name_exp", "Name of the loxcode experiment:", placeholder="Experiment Name"),
fileInput("samplesheet", "Choose an xlsx file of samples", multiple=FALSE, accept=c("xlsx")),
textInput("dir_input", "Choose a fastq directory"),
actionButton("submit_fastq", "Upload")
),
box(
width = 12,
title = "Loxcode Experiments",
status = "danger",
colur = NULL,
solidHeader = FALSE,
collapsible = FALSE,
dataTableOutput("experiments_table"),
actionButton("select_exp", "Select"),
actionButton("del_exp", "Delete"),
downloadButton("save_exp", "Download Current")
)
),
tabItem(
tabName = "codeset-create",
fluidRow(
box(
title = "View a code set",
status = NULL,
color = NULL,
solidHeader = TRUE,
collapsible = TRUE,
selectInput("view_codeset", label="", choices=names(lox@code_sets)),
actionButton("delete_codeset", "Delete Code Set")
),
box(
title = "Edit code sets",
status = NULL,
color = "red",
solidHeader = TRUE,
collapsible = TRUE,
textInput("name_codeset", label="Name of new codeset:", placeholder="Code Set Name"),
fluidRow(
column(4, actionButton("create_codeset", "Create from Selection")),
column(4, actionButton("create_all_codeset", "Create from All")),
column(4, actionButton("rename_codeset", "Rename Current"))
)
),
box(
width = 12,
title = "Code Set Table",
status = "danger",
solidHeader = FALSE,
wellPanel(dataTableOutput("codeset_table"))
)
)
),
tabItem(
tabName = "sample-create",
fluidRow(
column(
6,
style = "padding:0px;",
box(
width = 12,
title = "View a sample set",
status = NULL,
color = NULL,
solidHeader = TRUE,
collapsible = TRUE,
selectInput("view_sample", label="", choices=names(lox@count_matrixes)),
actionButton("delete_sample", "Delete Sample Set")
),
box(
width = 12,
title = "Edit sample sets",
status = NULL,
color = "red",
solidHeader = TRUE,
collapsible = TRUE,
textInput("name_sample", label="Name of new sample set:", placeholder="Sample Set Name"),
fluidRow(
column(4, actionButton("create_sample", "Create from Selection")),
column(4, actionButton("create_all_sample", "Create from All")),
column(4, actionButton("rename_sample", "Rename Current"))
)
)
),
column(
6,
style = "padding:0px;",
box(
width = 12,
title = "Collapse samples",
status = NULL,
solidHeader = TRUE,
collapsible = TRUE,
textInput("collapse_name", label="Name of new sample set:", placeholder="Sample Set Name"),
tags$strong("Collapse type: "),
fluidRow(
column(3, checkboxInput("collapse_union", "Union")),
column(3, checkboxInput("collapse_average", "Average"))
),
checkboxGroupInput("collapse_parameters", "Choose parameters to collapse:", choices=c("mouse", "population", "pcr")),
actionButton("collapse_samples", "Collapse")
)
),
box(
width = 12,
title = "Sample Set Table",
status = "danger",
solidHeader = FALSE,
wellPanel(dataTableOutput("sample_table"))
)
)
),
tabItem(
tabName = "codes-filter",
box(
width = 6,
title = "Set independent variables",
status = NULL,
color = NULL,
solidHeader = TRUE,
collapsible = TRUE,
textInput("filter_name", label="Name of new sample set:", placeholder="Sample Set Name"),
checkboxGroupInput("independent_parameters", "Independence Parameters:", choices=c("mouse", "population", "pcr")),
actionButton("filter_independenece", "Collapse"),
),
box(
width = 6,
title = "Filter parameters",
status = NULL,
color = NULL,
solidHeader = TRUE,
collapsible = TRUE,
textInput("filter_code_name", label="Name of new filtered code set:", placeholder="Code Set Name"),
fluidRow(
column(6, selectInput("independent_samples", label="Independent Sample Set", choices=names(lox@count_matrixes))),
column(6, selectInput("filter_codeset", label="Code Set", choices=names(lox@code_sets)))
),
fluidRow(
column(6, sliderInput("filter_reps", label="Maximum allowed code repetitions", min=2, max=2, value=2)),
column(6, sliderInput("filter_tolerance", label="Tolerance Level (%)", min=0.1, max=100, value=5, step=0.1))
),
actionButton("create_filtered", "Create Filtered Code Set")
),
box(
width = 12,
height = 680,
status = "danger",
title = "Uniqueness Plot",
tabBox(
width = 12,
tabPanel("Unfiltered", plotOutput("unfiltered_codes")),
tabPanel("Filtered", plotOutput("filtered_codes"))
)
)
),
tabItem(
tabName = "stats-plot",
fluidRow(
box(
title = "View a sample set",
status = NULL,
color = NULL,
solidHeader = TRUE,
collapsible = TRUE,
selectInput("matrix_stats", "Sample:", choices = names(lox@count_matrixes))
),
box(
title = "View a code set",
status = NULL,
color = NULL,
solidHeader = TRUE,
collapsible = TRUE,
selectInput("codeset_stats", "Codes:", choices = names(lox@code_sets))
),
box(
width = 12,
title = "Statistics Plots",
status = "danger",
tabBox(
width = 12,
tabPanel("Size", plotlyOutput("size_plot")),
tabPanel("Complexity", plotlyOutput("complexity_plot")),
tabPanel("Ratio", plotlyOutput("ratio_plot")),
tabPanel("Both", plotlyOutput("both_plot"))
)
)
)
),
tabItem(
tabName = "heatmap-plot",
box(
width = 6,
title = "View a sample set",
status = NULL,
color = NULL,
solidHeader = TRUE,
collapsible = TRUE,
selectInput("matrix_heat", "Sample:", choices = names(lox@count_matrixes))
),
box(
width = 6,
title = "View a code set",
status = NULL,
color = NULL,
solidHeader = TRUE,
collapsible = TRUE,
selectInput("codeset_heat", "Codes:", choices = names(lox@code_sets))
),
box(
width = 12,
title = "Heat Map",
status = "danger",
plotlyOutput("heatmap")
),
box(
width = 12,
title = "Sample Comparison Pie",
status = "danger",
plotOutput("sample_comparison_pie")
)
),
tabItem(
tabName = "saturation-plot",
box(
width = 12,
title = "View a code set",
status = NULL,
color = NULL,
solidHeader = TRUE,
collapsible = TRUE,
selectInput("codeset_sat", "Codes:", choices = names(lox@code_sets))
),
box(
width = 12,
title = "Saturation Plot",
status = "danger",
plotOutput("saturation")
)
),
tabItem(
tabName = "pair-plot",
box(
width = 6,
title = "Choose your samples",
status = NULL,
color = NULL,
solidHeader = TRUE,
collapsible = TRUE,
selectInput("sample1_pair", "Sample 1:", choices = names(lox@samples)),
selectInput("sample2_pair", "Sample 2:", choices = names(lox@samples))
),
box(
width = 6,
title = "Configure the plot",
status = NULL,
color = NULL,
solidHeader = TRUE,
collapsible = TRUE,
selectInput("colour_pair", "Colour by:", choices = c("size", "complexity")),
sliderInput("slider_pair", "Distance Range:", min = 1, max = 13, value = c(1,13))
),
box(
width = 12,
height = 770,
title = "Pair Comparison Plot",
status = "danger",
plotlyOutput("pair_plot")
)
)
)
)
### APP
shinyApp(
ui = fluidPage(
tags$head(
tags$style(
HTML("")
)
),
dashboardPage(header, sidebar, body, skin = "red")
),
server = function(input, output, session) {
# current loxcode_experiment object
output$curr_lox = renderMenu({
dropdownMenuCustom(
type = "messages",
icon = icon("bookmark"),
badgeStatus = NULL,
customSentence = customSentence,
messageItem(from=react$curr@name, message="", icon=icon("dna"), href=NULL)
)})
### IMPORT
# upload loxcode_experiment object
observeEvent(
input$submit_rds, {
if (is.null(input$rds_file)){
showNotification("Please specify a file path.")
return
} else {
if (grepl(".rds$", input$rds_file)){
obj = readRDS(file=input$rds_file$datapath)
if (is(obj, "loxcode_experiment")){
react$curr <- obj
react$samp <- sample_table(react$curr, "all_samples")
react$exp <- rlist::list.append(react$exp, react$curr)
updateSelectInput(session, "sample1_pair", "Sample 1:", choices=names(react$curr@samples))
updateSelectInput(session, "sample2_pair", "Sample 2:", choices=names(react$curr@samples))
} else {
shinyalert("Oops!", "Object uploaded was not of class <loxcode_experiment>")
}
} else {
shinyalert("Oops!", "File uploaded was not an R object (*.rds).", type="error")
}
}
}
)
observeEvent(
input$submit_fastq, {
files = list.files(input$dir_input)
print(input$dir_input)
if (is.null(input$samplesheet)){
showNotification("Please specify a file path.")
} else {
if (grepl(".xls$", input$samplesheet$datapath) | grepl(".xlsx$", input$samplesheet$datapath)){ # validate file extension
samplesheet = read_excel(input$samplesheet$datapath)
if (validateFastq(session, samplesheet, files)) { # validate file contents
newlox <- load_from_xlsx(
name = input$name_exp,
s=input$samplesheet$datapath,
dir=input$dir_input,
load = TRUE,
full = FALSE)
react$curr <- newlox
react$samp <- sample_table(react$curr, "all_samples")
react$exp <- rlist::list.append(react$exp, react$curr)
updateSelectInput(session, "sample1_pair", "Sample 1:", choices=names(react$curr@samples))
updateSelectInput(session, "sample2_pair", "Sample 2:", choices=names(react$curr@samples))
} else {
shinyalert("Oops!", "Invalid files uploaded.", type="error")
}
} else {
shinyalert("Oops!", "File uploaded was not an excel file (*.xls or *.xlsx).", type="error")
}
}
}
)
# table of loxcode_experiment objects
output$experiments_table = renderDataTable({datatable(
exp_table(react$exp),
rownames = FALSE,
class = "cell-border stripe",
filter = 'top',
selection = 'single'
)})
observeEvent(
input$select_exp, {
if (!is.null(input$experiments_table_rows_selected)) {
react$curr = react$exp[[input$experiments_table_rows_selected]]
}
}
)
output$save_exp = downloadHandler(
filename = function() {
paste("data-", Sys.Date(), ".rds", sep="")
},
content = function(file) {
saveRDS(react$curr, file)
}
)
observeEvent(
input$del_exp, {
if (!is.null(input$experiments_table_rows_selected)){
react$exp = list.remove(react$exp, input$experiments_table_rows_selected)
}
}
)
### CREATE CODESET
output$codeset_table = renderDataTable({datatable(
codeset_table(react$curr, input$view_codeset),
rownames = FALSE,
class = "cell-border stripe",
filter = 'top'
)} %>% formatStyle(columns=c(seq(2, ncol(react$samp))), 'text-align'='center'))
observeEvent(
input$delete_codeset, {
react$curr <- delete_codeset(react$curr, input$view_codeset)
updateCodesetSelection(session, codeset_selectionID, input$name_codeset)
react$exp = updateCurrentExp(session, react$curr, react$exp)
}
)
observeEvent(
input$create_codeset, {
react$curr = make_codeset_index(react$curr, c=input$view_codeset, I=input$codeset_table_rows_selected, n=input$name_codeset)
updateCodesetSelection(session, codeset_selectionID, input$name_codeset)
updateTextInput(session, "name_codeset", label="Name of new codeset:", placeholder="Codeset Name", value="")
react$exp = updateCurrentExp(session, react$curr, react$exp)
}
)
observeEvent(
input$create_all_codeset, {
react$curr = make_codeset_index(react$curr, c=input$view_codeset, I=input$codeset_table_rows_all, n=input$name_codeset)
updateCodesetSelection(session, codeset_selectionID, input$name_codeset)
updateTextInput(session, "name_codeset", label="Name of new codeset:", placeholder="Codeset Name", value="")
react$exp = updateCurrentExp(session, react$curr, react$exp)
}
)
observeEvent(
input$rename_codeset, {
react$curr = rename_codeset(react$curr, c=input$view_codeset, n=input$name_codeset)
updateCodesetSelection(session, codeset_selectionID, input$name_codeset)
updateTextInput(session, "name_codeset", label="Name of new codeset:", placeholder="Codeset Name", value="")
react$exp = updateCurrentExp(session, react$curr, react$exp)
}
)
### CREATE SAMPLE SET
output$sample_table = renderDataTable({
d <- summary_table(react$curr, input$view_sample)
react$samp <- d
datatable(
d,
filter = 'top',
rownames = FALSE,
class = "cell-border stripe",
editable = list(target="cell", disable=list(columns=c(0, seq(2, ncol(react$samp)))))
)} %>% formatStyle(columns=c(seq(3, ncol(react$samp))), 'text-align'='center'))
observeEvent(
input$view_sample, {
d <- summary_table(react$curr, input$view_sample)
react$samp <- d
})
# renaming samples
proxy = dataTableProxy("sample_table")
observeEvent(
input$sample_table_cell_edit, {
d = react$samp
info = input$sample_table_cell_edit
i = info$row
j = info$col + 1 # column index offset by 1
v = info$value
d[i, j] <<- coerceValue(v, d[i, j])
sample = d[i,j-1]
replaceData(proxy, d, resetPaging=FALSE, rownames=FALSE)
react$curr = new_nickname(react$curr, input$view_sample, sample, v)
updateSelectInput(session, "sample1_pair", "Sample 1:", choices=names(react$curr@samples), selected=input$sample1_pair)
updateSelectInput(session, "sample2_pair", "Sample 2:", choices=names(react$curr@samples), selected=input$sample1_pair)
react$exp = updateCurrentExp(session, react$curr, react$exp)
})
# create samples
observeEvent(
input$create_sample, {
react$curr = make_count_matrix(react$curr, c=input$view_sample, I=input$sample_table_rows_selected, n=input$name_sample)
updateSampleSelection(session, sample_selectionID, input$name_sample)
updateTextInput(session, "name_sample", label="Name of new collection of samples:", placeholder="Sample Collection Name", value="")
react$exp = updateCurrentExp(session, react$curr, react$exp)
}
)
observeEvent(
input$create_all_sample, {
react$curr = make_count_matrix(react$curr, c=input$view_sample, I=input$sample_table_rows_all, n=input$name_sample)
updateSampleSelection(session, sample_selectionID, input$name_sample)
updateTextInput(session, "name_sample", label="Name of new collection of samples:", placeholder="Sample Collection Name", value="")
react$exp = updateCurrentExp(session, react$curr, react$exp)
}
)
observeEvent(
input$delete_sample, {
react$curr <- delete_count_matrix(react$curr, input$view_sample)
updateSampleSelection(session, sample_selectionID, "all_samples")
react$exp = updateCurrentExp(session, react$curr, react$exp)
}
)
observeEvent(
input$rename_sample, {
react$curr = rename_sampleset(react$curr, input$view_sample, input$name_sample)
updateSampleSelection(session, sample_selectionID, input$name_sample)
updateTextInput(session, "name_sample", label="Name of new collection of samples:", placeholder="Sample Collection Name", value="")
react$exp = updateCurrentExp(session, react$curr, react$exp)
}
)
# collapse samples
observeEvent(
input$collapse_samples, {
react$curr <- collapse(react$curr, input$view_sample, input$collapse_parameters, input$collapse_name, input$collapse_union, input$collapse_average)
updateSampleSelection(session, sample_selectionID, input$collapse_name)
updateCheckboxInput(session, "collapse_union", "Union", value=NULL)
updateCheckboxInput(session, "collapse_average", "Average", value=NULL)
updateTextInput(session, "collapse_name", label="Name of new sample set:", placeholder="Sample Set Name", value="")
updateCheckboxGroupInput(session, "collapse_parameters", "Choose parameters to collapse:", choices=c("mouse", "population", "pcr"), selected=NULL)
react$exp = updateCurrentExp(session, react$curr, react$exp)
}
)
### FILTER CODES
output$unfiltered_codes = renderPlot(
code_frequency_pie(react$curr, input$independent_samples, input$filter_codeset),
height = 550
)
output$filtered_codes = renderPlot(
filtered_codes_pie(react$curr, input$independent_samples, input$filter_codeset, input$filter_tolerance, input$filter_reps),
height = 550
)
observe({
Y = code_freq_table(react$curr, input$independent_samples, input$filter_codeset)
total = max(as.numeric(names(Y[,!names(Y)%in%c("size", "dist_orig", "radius")])))
updateSliderInput(session, "filter_reps", label="Maximum allowed code repetitions", min=2, max=total, value=input$filter_reps, step=1)
})
observeEvent(
input$create_filtered, {
react$curr = make_filtered_codeset(react$curr, input$independent_samples, input$filter_codeset, input$filter_tolerance, input$filter_reps, input$filter_code_name)
react$exp = updateCurrentExp(session, react$curr, react$exp)
updateCodesetSelection(session, codeset_selectionID, input$filter_code_name)
updateSampleSelection(session, sample_selectionID, input$name_sample)
}
)
### STATISTICS PLOT
output$size_plot = renderPlotly({
ggplotly(readstats_plot(react$curr, count_matrix=input$matrix_stats, code_set=input$codeset_stats, plot="size"))
})
output$complexity_plot = renderPlotly({
ggplotly(readstats_plot(react$curr, code_set=input$codeset_stats, plot="complexity"))
})
output$ratio_plot = renderPlotly({
ggplotly(readstats_plot(react$curr, code_set=input$codeset_stats, plot="ratio"))
})
output$both_plot = renderPlotly({
ggplotly(readstats_plot(react$curr, code_set=input$codeset_stats, plot="both"))
})
### HEATMAP PLOT
output$heatmap = renderPlotly({
ggplotly(heatmap_plot(react$curr, count_matrix=input$matrix_heat, code_set=input$codeset_heat))
})
output$sample_comparison_pie = renderPlot({
sample_comparison_pie(react$curr)
})
### SATURATION PLOT
output$saturation = renderPlot({
saturation_plot(react$curr, code_set = input$codeset_sat)
})
### PAIR COMPARISON PLOT
output$pair_plot = renderPlotly({
p <- pair_comparison_plot(
x1=react$curr@samples[[input$sample1_pair]],
x2=react$curr@samples[[input$sample2_pair]],
dist_range = input$slider_pair,
plot = input$colour_pair
)
ggplotly(p, height = 700)
})
observeEvent(
input$sample1_pair, {
# updates the slider based on the distance range of the samples selected
# min_dist_one <- min(na.omit(react$curr@samples[[input$sample1_pair]]@decode@data$dist_orig))
# min_dist_two <- min(na.omit(react$curr@samples[[input$sample2_pair]]@decode@data$dist_orig))
# max_dist_one <- max(na.omit(react$curr@samples[[input$sample1_pair]]@decode@data$dist_orig))
# max_dist_two <- max(na.omit(react$curr@samples[[input$sample2_pair]]@decode@data$dist_orig))
# newmin <- min(min_dist_one, min_dist_two)
# newmax <- max(max_dist_one, max_dist_two)
})
#session$onSessionEnded(stopApp)
},
)
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.