Commit 930f8798 authored by Jonathan Kunst's avatar Jonathan Kunst
Browse files

Refactored code and removed unused files of old app structure

parent 5423ddff
# Polyploid datavisualisation
R Shiny application for polyploid QTL mapping based on packages such as polqtlR, MAPpoly and others.
library(plotly)
# plotly ----
data("diamonds", package = 'ggplot2')
diamonds
plot_ly(diamonds, x = ~cut)
plot_ly(diamonds, x = ~cut, y = ~clarity)
plot_ly(diamonds, x = ~cut, y = ~clarity, colors = "Accent")
# plotly uses purely functional programming style
# input -> function modifies -> modified output
# layout expect a plot_ly object and modifies it according to function call
layout(plot_ly(diamonds, x = ~cut),
title = 'beautiful histogram')
# above code is less readable than
diamonds %>%
plot_ly(x = ~cut) %>%
layout(title = 'beautiful histogram')
# we can control layout even more by using add_* (i.e. add_histogram)
diamonds %>%
plot_ly() %>%
add_histogram(x = ~cut)
# or with bars where you need to calculate the statistics beforehand
diamonds %>%
count(cut) %>%
plot_ly() %>%
add_bars( x = ~cut, y = ~n)
# non-statistical layers (i.e. bars) are faster and more responsive but less flexible client-side
# another example of:
# - globally assigning x to cut
# - modify data after histogram is plotted
# - add another layer of text from modified summarised data
# note: make sure you want to display this information on the same axes
diamonds %>%
plot_ly(x = ~cut) %>%
add_histogram() %>%
group_by(cut) %>%
summarise(n = n()) %>%
add_text(
text = ~scales::comma(n), y = ~n,
textposition = "top middle",
cliponaxis = FALSE
)
# underlying plot_ly() is the json code which is captured in a list in plotly_build()
plot <- plot_ly(diamonds, x = ~cut, color = ~clarity, colors = "Accent")
# the underlying json
plotly_json(plot)
# the json figure contains data (traces) and layout
# a trace defines mapping from data and visuals
# every trace has a type and determines attributes
# using plotly_build we can debug a plot
b_plot <- plotly_build(plot)
length(b_plot$x$data)
# extract name of each trace (8 traces for 8 clarities) appearing in the figure definition x in data
map_chr(b_plot$x$data, "name")
length(unique(diamonds$clarity))
# the colors of the clarity are not directly coded in the json list
# instead plotly_build() designates colors with marker.color
m <- lm(log(price) ~ log(carat), data = diamonds)
diamonds <- modelr::add_residuals(diamonds, m)
diamonds <- modelr::add_predictions(diamonds, m)
head(diamonds)
p <- plot_ly(mpg, x = ~cty, y = ~hwy, alpha = 0.3)
subplot(
add_markers(p, symbol = ~cyl, name = "A single trace"),
add_markers(p, symbol = ~factor(cyl), color = I("black"))
)
# pass any number of plotly objects to subplot()
p1 <- plot_ly(economics, x = ~date, y = ~uempmed)
p2 <- plot_ly(economics, x = ~date, y = ~unemploy)
subplot(p1, p2, p1, p2, nrows = 2, margin = 0.05)
#' # anchor multiple traces on the same legend entry
p1 <- add_lines(p1, color = I("black"), name = "1st", legendgroup = "1st")
p2 <- add_lines(p2, color = I("red"), name = "2nd", legendgroup = "2nd")
subplot(
p1, style(p1, showlegend = FALSE),
p2, style(p2, showlegend = FALSE),
nrows = 2, margin = 0.05
)
\ No newline at end of file
Version: 1.0
RestoreWorkspace: Default
SaveWorkspace: Default
AlwaysSaveHistory: Default
EnableCodeIndexing: Yes
UseSpacesForTab: Yes
NumSpacesForTab: 2
Encoding: UTF-8
RnwWeave: Sweave
LaTeX: pdfLaTeX
# Header ----
# R Shiny Script
# Author: Jonathan Kunst
# Date created: 27-09-2021
# Date updated: 21-10-2021
# Packages ----
library(DT)
library(readr)
library(shiny)
library(shinybusy)
library(polyqtlR)
library(parallel)
# UI ----
# Define page layout, fluidPage automatically adjusts to user border dimensions
# navbarPage allows for multiple sheets for several pages
ui <- fluidPage(
navbarPage(title = 'Polyploid QTL visualisation', inverse = TRUE,
tabPanel(# Page for data import with instructions ----
'Data import',
sidebarLayout(
sidebarPanel(
h3('Input'),
# Phenotype input
fileInput(inputId = 'i_phenotype',
label = 'Phenotype file'),
hr(),
# Linkage map input
fileInput(inputId = 'i_link_map',
label = 'Phased linkage map files',
multiple = TRUE),
hr(),
fileInput(inputId = 'i_dosage',
label = 'SNP dosage score file')
),
mainPanel(
tabsetPanel(
tabPanel('Phenotype',
DT::dataTableOutput('table_phenotype')),
tabPanel('Phased Linkage Map',
selectInput(inputId = 'choice_map',
label = 'Linkage Group',
choices = 'Input map first'),
DT::dataTableOutput('table_link_map'),
textOutput('text_link_map')),
tabPanel('SNP Dosage Score',
DT::dataTableOutput('table_dosage'))
)
)
)
),
tabPanel(# IBD page ----
'IBD',
sidebarLayout(
sidebarPanel(
h3('Estimation'),
# method of estimation
selectInput(inputId = 'IBD_method',
label = 'Estimation Method',
choices = c('Heuristic'= 'heur',
'HMM' = 'hmm')),
# mapping function
selectInput(inputId = 'IBD_map',
label = 'Mapping Function',
choices = c('Haldane' = 'haldane',
'Kosambi' = 'kosambi')),
# Ploidy level indicator
numericInput(inputId = 'ploidy',
label = 'Ploidy level',
min = 2,
value = 4,
step = 2),
# cores selection
numericInput(inputId = 'IBD_core',
label = 'Numbers of processing cores',
min = 1,
value = detectCores() / 2,
max = detectCores() - 2),
# Estimate starter
actionButton('go_estimate',
label = 'Estimate IBD'),
hr(),
h3('Import'),
# IBD input
fileInput(inputId = 'i_IBD',
label = 'IBD file')
),
mainPanel(
h3('Output'),
selectInput(inputId = 'choice_LG',
label = 'Select linkage group',
choices = 'Estimate or import first'),
selectInput(inputId = 'choice_offspring',
label = 'Select offspring',
choices = 'Estimate or import first'),
plotOutput('plot_haplo')
)
)
),
tabPanel('QTL visualisation'),
tabPanel('Data export'),
tabPanel('About',
fluidPage(
mainPanel(
p('This R Shiny application was built to make polyploid QTL analysis
package available for non-R users. Packages are:'),
strong('polyqtlR'),
br(),
br(),
p('For questions and feedback please contact Jonathan Kunst at jonathan.kunst@wur.nl')
)
)
)
)
)
# Server functions ----
load_file <- function(name, path){
extension <- tools::file_ext(name)
switch(extension,
csv = read_csv(path),
rds = read_rds(path),
validate('Invalid file type, please use .csv or .rds'))
}
# Server ----
server <- function(input, output, session) {
# initiate reactive values object
rv <- reactiveValues()
rv$select_map <- NULL
rv$select_LG <- NULL
rv$select_offspring <- NULL
# Read Data ----
# Phenotype
phenotype <- reactive({
req(input$i_phenotype)
load_file(name = input$i_phenotype$name, path = input$i_phenotype$datapath)
})
# Phased Linkage maps
link_map <- reactive({
req(input$i_link_map)
name <- input$i_link_map$name[1] # if multiple csv length too long
extension <- tools::file_ext(name)
# typical .rds file is already a list and nesting from mapply makes uneven
switch(extension,
csv = mapply(load_file,
name = input$i_link_map$name,
path = input$i_link_map$datapath,
SIMPLIFY = FALSE),
rds = load_file(name = name, path = input$i_link_map$datapath)
)
})
# update maplist selection
observeEvent(input$i_link_map, {
file_list <- 1:length(link_map())
updateSelectInput(session, 'choice_map', label = 'Linkage Groups', choices = file_list)
})
# retrieve map LG selection
rv$select_map <- eventReactive(input$choice_map, {input$choice_map})
# SNP Dosage data
dosage <- reactive({
req(input$i_dosage)
# estimate IBD will need a matrix of snp dosages, expecting matrix input
read.csv(input$i_dosage$datapath, row.names = 1)
})
# Data tables ----
# table for phenotype
output$table_phenotype <- DT::renderDataTable(phenotype())
# table for linkage map file(s)
output$table_link_map <- DT::renderDataTable(link_map()[[as.numeric(rv$select_map())]])
# table for SNP dosage
output$table_dosage <- DT::renderDataTable(dosage())
# IBD ----
# IBD estimation
IBD_est <- eventReactive(input$go_estimate, {
estimate_IBD(phased_maplist = link_map(),
genotypes = as.matrix(dosage()),
method = input$IBD_method,
map_function = input$IBD_map,
ploidy = input$ploidy,
ncores = input$IBD_core)
})
# IBD import
IBD_imp <- reactive({
req(input$i_IBD)
load_file(name = input$i_IBD$name, path = input$i_IBD$datapath)
})
# Modal window to prevent interaction
# observeEvent(input$go_estimate, {
# show_modal_spinner(text = 'Estimating IBDs, please wait')
# remove_modal_spinner()
# })
# update LG selection IBD file
observeEvent(input$go_estimate, {
updateSelectInput(session, 'choice_LG', label = 'Linkage Group', choices = 1:length(names(IBD_est())))
})
# retrieve LG selection
rv$select_LG <- eventReactive(input$choice_LG, {input$choice_LG})
#update offspring selection
observeEvent(input$choice_LG, {
updateSelectInput(session, 'choice_offspring', label = 'Offspring', choices = IBD_est()[[as.numeric(input$choice_LG)]]$offspring)
})
# retrieve offspring selection
rv$select_offspring <- eventReactive(input$choice_offspring, {input$choice_offspring})
# show haplotypes from estimated IBDs
output$plot_haplo <- renderPlot(visualiseHaplo(IBD_list = IBD_est(),
display_by = "name",
linkage_group = as.numeric(rv$select_LG()),
select_offspring = rv$select_offspring(),
multiplot = c(1, 1))
)
#
# output$plot_haplo_imp <- renderPlot(visualiseHaplo(IBD_list = IBD_imp(),
# display_by = "name",
# linkage_group = 1,
# select_offspring = IBD_imp()[1]$offspring[3:11],
# multiplot = c(3, 3))
# )
}
# Run Shiny app example ----
shinyApp(ui = ui, server = server)
......@@ -46,6 +46,7 @@ importFrom(qtlpoly,remim)
importFrom(readr,read_csv)
importFrom(readr,read_rds)
importFrom(rhandsontable,hot_context_menu)
importFrom(rhandsontable,hot_to_r)
importFrom(rhandsontable,rHandsontableOutput)
importFrom(rhandsontable,renderRHandsontable)
importFrom(rhandsontable,rhandsontable)
......
# Disabling shiny autoload
# See ?shiny::loadSupport for more information
......@@ -26,11 +26,11 @@ app_server <- function( input, output, session ) {
rv$cofactor_df <- data.frame('LG' = integer(1), 'cM' = numeric(1))
# Input data ----
mod_import_panel_server("import_panel_ui_1", rv = rv)
mod_import_panel_server("import_panel_ui", rv = rv)
# IBD estimation ----
mod_IBD_panel_server("IBD_panel_ui_1", rv = rv)
mod_IBD_panel_server("IBD_panel_ui", rv = rv)
# Modelling panel ----
mod_model_panel_server("model_panel_ui_1", rv = rv)
mod_model_panel_server("model_panel_ui", rv = rv)
}
......@@ -14,17 +14,17 @@ app_ui <- function(request) {
# Input panel ----
tabPanel('Data import',
mod_import_panel_ui('import_panel_ui_1')
mod_import_panel_ui('import_panel_ui')
),
# IBD panel ----
tabPanel('IBD',
mod_IBD_panel_ui("IBD_panel_ui_1")
mod_IBD_panel_ui("IBD_panel_ui")
),
# Model panel ----
tabPanel('Model',
mod_model_panel_ui("model_panel_ui_1")
mod_model_panel_ui("model_panel_ui")
)
)
)
......
......@@ -8,9 +8,12 @@
#'
#' @importFrom shiny NS tagList
#' @importFrom polyqtlR estimate_IBD visualiseHaplo
#' @importFrom waiter Waiter useWaiter spin_6 transparent
#' @importFrom waiter Waiter useWaiter spin_6
#' @importFrom mappoly calc_genoprob
#' @importFrom qtlpoly read_data
#' @importFrom dplyr select bind_rows filter mutate
#' @importFrom magrittr %>%
#' @importFrom parallel detectCores
mod_IBD_panel_ui <- function(id){
ns <- NS(id)
tagList(
......@@ -21,84 +24,18 @@ mod_IBD_panel_ui <- function(id){
tabsetPanel(
# polyqtlR IBD estimation ----
tabPanel('polyqtlR',
# method of estimation
selectInput(inputId = ns('ibd_method'),
label = 'Estimation Method',
choices = c('Heuristic'= 'heur',
'HMM' = 'hmm')),
# mapping function
selectInput(inputId = ns('ibd_mf'),
label = 'Mapping Function',
choices = c('Haldane' = 'haldane',
'Kosambi' = 'kosambi')),
# ploidy level
numericInput(inputId = ns('ibd_ploidy'),
label = 'Ploidy level',
min = 2,
value = 4,
step = 2),
# cores
numericInput(inputId = ns('ibd_core'),
label = 'Numbers of processing cores',
min = 1,
value = detectCores() / 2,
max = detectCores() - 2),
# Estimate
actionButton(inputId = ns('go'),
label = 'Estimate')
mod_IBD_pqtlr_ui(ns("IBD_pqtlr_ui"))
),
# QTLpoly IBD estimation ----
tabPanel('QTLpoly',
# ploidy level
numericInput(inputId = ns('qtlpoly_ploidy'),
label = 'Ploidy level',
min = 2,
value = 4,
max = 6,
step = 2),
# stepsize (cM)
numericInput(inputId = ns('qtlpoly_step'),
label = 'Stepsize (cM)',
min = 0,
value = 1,
step = 1),
# create genoprob file and generate qtlpoly data object
actionButton(inputId = ns('qtlpoly_go'),
label = 'Estimate')
)
mod_IBD_qtlpoly_ui(ns("IBD_qtlpoly_ui"))
)
),
)
),
mainPanel(
tabsetPanel(
# output polyqtlR ----
tabPanel('polyqtlR',
selectInput(inputId = ns('choice_lg'),
label = 'Select linkage group',
choices = 'Estimate or import first'),
selectInput(inputId = ns('choice_offspring'),
label = 'Select offspring',
choices = 'Estimate or import first'),
plotOutput(ns('plot_haplo'))
),
# output QTLpoly ----
tabPanel('QTLpoly',
verbatimTextOutput(ns('qtlpoly_ibd_print'))
)
)
mod_IBD_vis_ui(ns("IBD_vis_ui"))
)
)
)
......@@ -113,78 +50,13 @@ mod_IBD_panel_server <- function(id, rv){
# Side panel ----
# polyqtlr
observeEvent(input$go, {
progress <- Waiter$new(id = ns('go'),
html = spin_6(),
color = 'grey')
progress$show()
rv$ibd_estimate <- estimate_IBD(phased_maplist = rv$pqtlr_linkmap,
genotypes = as.matrix(rv$pqtlr_snp),
method = input$ibd_method,
map_function = input$ibd_mf,
ploidy = input$ibd_ploidy,
ncores = input$ibd_core)
progress$hide()
})
mod_IBD_pqtlr_server("IBD_pqtlr_ui", rv = rv)
# QTLpoly
observeEvent(input$qtlpoly_go, {
progress <- Waiter$new(id = ns('qtlpoly_go'),
html = spin_6(),
color = 'grey')
progress$show()
rv$qtlpoly_ibd <- lapply(rv$qtlpoly_linkmap, calc_genoprob, verbose = FALSE)
progress$hide()
})
observeEvent(rv$qtlpoly_ibd, {
req(rv$qtlpoly_ibd, rv$qtlpoly_phenotype)
rv$qtlpoly_data <- read_data(ploidy = input$qtlpoly_ploidy,
geno.prob = rv$qtlpoly_ibd,
pheno = rv$qtlpoly_phenotype,
step = input$qtlpoly_step
)
print(rv$qtlpoly_data)
})
mod_IBD_qtlpoly_server("IBD_qtlpoly_ui", rv = rv)
# Main panel ----
# polyqtlr
# Linkage group selection modifier
observeEvent(rv$ibd_estimate, {
req(rv$ibd_estimate)
updateSelectInput(session, 'choice_lg',
choices = 1:length(names(rv$ibd_estimate)))
})
# offspring selection modifier
observeEvent(input$choice_lg, {
req(rv$ibd_estimate)
updateSelectInput(session, 'choice_offspring',