Skip to content
GitLab
Commit 7cbe3b06 authored by Kunst, Jonathan's avatar Kunst, Jonathan
Browse files

Split up the model panel into separate modules of each modelling and visualisation packages

parent 4902813f
Hide whitespace changes
Inline Side-by-side
polyqtlvis/NAMESPACE
View file @ 7cbe3b06
......@@ -3,7 +3,6 @@
export(run_app)
import(shiny)
importFrom(dplyr,bind_rows)
importFrom(dplyr,distinct)
importFrom(dplyr,filter)
importFrom(dplyr,left_join)
importFrom(dplyr,select)
......
polyqtlvis/R/mod_model_panel.R
View file @ 7cbe3b06
......@@ -8,92 +8,22 @@
#'
#' @importFrom shiny NS tagList
#' @importFrom polyqtlR QTLscan
#' @importFrom dplyr left_join select bind_rows filter distinct
#' @importFrom dplyr left_join select bind_rows filter
#' @importFrom magrittr %>%
#' @importFrom ggplot2 ggplot aes geom_point geom_line facet_wrap theme element_blank
#' @importFrom plotly ggplotly renderPlotly plotlyOutput highlight layout event_data
#' @importFrom waiter Waiter useWaiter spin_6 transparent
#' @importFrom shinycssloaders withSpinner
#' @importFrom rhandsontable rhandsontable rHandsontableOutput renderRHandsontable hot_context_menu
mod_model_panel_ui <- function(id, rv){
ns <- NS(id)
tagList(
sidebarLayout(
sidebarPanel(
h3('Model settings'),
tabsetPanel(
# siebarpanel for polyqtlR qtlscan model options
# sidebarpanel for polyqtlR qtlscan model options
tabPanel('polyqtlR',
# genotype column selection
selectInput(inputId = ns('choice_geno'),
label = 'Select genotype column',
choices = 'Import phenotype file first'),
# phenotype column selection
selectInput(inputId = ns('choice_pheno'),
label = 'Select phenotype column',
choices = 'Import phenotype file first'),
# does co-factor need to be taken into account?
checkboxInput(inputId = ns('check_cofactor'),
label = 'Co-factor',
value = FALSE),
conditionalPanel(
condition ='input.check_cofactor',
ns = ns,
rHandsontableOutput(ns('cofactor_table')),
actionButton(inputId = ns('cofactor_save'),
label = 'Save')
),
# does block need to be taken into account?
checkboxInput(inputId = ns('check_block'),
label = 'Blocks',
value = FALSE),
# block column selection
conditionalPanel(
condition = 'input.check_block',
ns = ns,
selectInput(inputId = ns('choice_block'),
label = 'Select block column',
choices = 'Import phenotype file first')
),
# permutation test
checkboxInput(inputId = ns('check_permutation'),
label = 'Permutation test',
value = FALSE),
# max number of permutations
conditionalPanel(
condition = 'input.check_permutation',
ns = ns,
numericInput(inputId = ns('choice_permutation'),
label = 'Max number of permuations',
min = 1,
value = 1000,
max = 2000)
),
# cores
numericInput(inputId = ns('choice_core'),
label = 'Numbers of processing cores',
min = 1,
value = detectCores() / 2,
max = detectCores() - 2),
# model name
textInput(inputId = ns('model_name'),
label = 'Model name'),
hr(),
# scan
actionButton(inputId = ns('go'),
label = 'Create'),
useWaiter()
mod_pqtlr_ui(ns("pqtlr_ui_1"))
),
# sidebarpanel for QTLpoly model options
......@@ -105,12 +35,9 @@ mod_model_panel_ui <- function(id, rv){
),
mainPanel(
actionButton(inputId = ns('update_plot'),
label = 'Update plot'),
withSpinner(plotlyOutput(outputId = ns('plotly'))),
verbatimTextOutput(ns('click'))
h3('Visualisation'),
# plotly generator UI ----
mod_qtl_plotly_panel_ui(ns("qtl_plotly_panel_ui_1"))
)
)
)
......@@ -124,118 +51,10 @@ mod_model_panel_server <- function(id, rv){
ns <- session$ns
# polyqtlR qtlscan options ----
# genotype column selection
observeEvent(rv$phenotype, {
updateSelectInput(session, 'choice_geno',
choices = names(rv$phenotype[[1]]))
})
# phenotype column selection
observeEvent(rv$phenotype, {
updateSelectInput(session, 'choice_pheno',
choices = names(rv$phenotype[[1]]))
})
# block column selection
observeEvent(rv$phenotype, {
updateSelectInput(session, 'choice_block',
choices = names(rv$phenotype[[1]]))
})
# adding co-factor
observeEvent(input$cofactor_save, {
# save changes in editable table
rv$cofactor_df <- hot_to_r(input$cofactor_table)
# return feedback to user that cofactor was added
showNotification('Cofactor added', type = 'message')
Sys.sleep(.5)
})
# editable cofactor table
output$cofactor_table <- renderRHandsontable(rhandsontable(rv$cofactor_df, useTypes = TRUE) %>%
hot_context_menu(
allowRowEdit = TRUE,
allowColEdit = FALSE
)
)
# create polyqtlR model
observeEvent(input$go, {
progress <- Waiter$new(id = ns('go'),
html = spin_6(),
color = 'grey')
progress$show()
req(input$model_name, rv$ibd_estimate, rv$phenotype, input$choice_geno,
input$choice_pheno)
try(
rv$polyqtl_scan<- QTLscan(IBD_list = rv$ibd_estimate,
Phenotype.df = as.data.frame(rv$phenotype[[1]]), #BUG: load_file still needing indexing
genotype.ID = input$choice_geno,
trait.ID = input$choice_pheno,
cofactor_df = if(input$check_cofactor){rv$cofactor_df},
block = if(input$check_block){input$choice_block},
perm_test = input$check_permutation,
N_parm.max = input$choice_permutation,
ncores = input$choice_core,
verbose = TRUE)
)
progress$hide()
showNotification('Model created', type = 'message')
})
# add to model result of polyqtl scane to model_list for later binding
observeEvent(rv$polyqtl_scan, {
rv$model_list[[input$model_name]] <- rv$polyqtl_scan$QTL.res %>%
left_join(select(bind_rows(rv$linkmap), c(position, marker)), by = 'position')
})
# generate ggplot object
observeEvent(input$update_plot, {
req(rv$polyqtl_scan)
try(
rv$lod_ggplot <- ggplot(bind_rows(rv$model_list, .id = 'model'), aes(x = position,
y = LOD,
color = model,
linetype = model)) +
geom_point(aes(
text = paste(paste('LOD:', round(LOD, 2)),
paste('Marker:', marker),
sep = '\n'
))) +
geom_line() +
facet_wrap(~chromosome) +
theme(
panel.grid = element_blank(),
panel.background = element_blank(),
panel.border = element_blank(),
strip.background = element_blank(),
strip.placement = 'outside'
)
)
})
# render of ggplot object as plotly object
output$plotly <- renderPlotly({
req(rv$lod_ggplot)
ggplotly(rv$lod_ggplot, tooltip = 'text') %>%
highlight('plotly_selected') %>%
layout(title = list(text = 'Chromosome', xanchor = 'center'))
})
mod_pqtlr_server("pqtlr_ui_1", rv = rv)
# render print of dataframe from selected points
output$click <- renderPrint({
event_df <- event_data('plotly_selected')
if (is.null(event_df)) return('select points')
bind_rows(rv$model_list, .id = 'model') %>%
filter(position %in% event_df$x & round(LOD) %in% round(event_df$y))
})
# plotly generator ----
mod_qtl_plotly_panel_server("qtl_plotly_panel_ui_1", rv = rv)
})
}
......
polyqtlvis/R/mod_pqtlr.R
View file @ 7cbe3b06
......@@ -7,13 +7,85 @@
#' @noRd
#'
#' @importFrom shiny NS tagList
#' @importFrom rhandsontable rhandsontable rHandsontableOutput renderRHandsontable hot_context_menu
#' @importFrom waiter Waiter useWaiter spin_6 transparent
#' @importFrom dplyr left_join select bind_rows
#' @importFrom magrittr %>%
mod_pqtlr_ui <- function(id){
ns <- NS(id)
tagList(
if(id == 'plot_haplo'){
plotOutput('plot_haplo')
}
)
# genotype column selection
selectInput(inputId = ns('choice_geno'),
label = 'Select genotype column',
choices = 'Import phenotype file first'),
# phenotype column selection
selectInput(inputId = ns('choice_pheno'),
label = 'Select phenotype column',
choices = 'Import phenotype file first'),
# does co-factor need to be taken into account?
checkboxInput(inputId = ns('check_cofactor'),
label = 'Co-factor',
value = FALSE),
conditionalPanel(
condition ='input.check_cofactor',
ns = ns,
rHandsontableOutput(ns('cofactor_table')),
actionButton(inputId = ns('cofactor_save'),
label = 'Save')
),
# does block need to be taken into account?
checkboxInput(inputId = ns('check_block'),
label = 'Blocks',
value = FALSE),
# block column selection
conditionalPanel(
condition = 'input.check_block',
ns = ns,
selectInput(inputId = ns('choice_block'),
label = 'Select block column',
choices = 'Import phenotype file first')
),
# permutation test
checkboxInput(inputId = ns('check_permutation'),
label = 'Permutation test',
value = FALSE),
# max number of permutations
conditionalPanel(
condition = 'input.check_permutation',
ns = ns,
numericInput(inputId = ns('choice_permutation'),
label = 'Max number of permuations',
min = 1,
value = 1000,
max = 2000)
),
# cores
numericInput(inputId = ns('choice_core'),
label = 'Numbers of processing cores',
min = 1,
value = detectCores() / 2,
max = detectCores() - 2),
# model name
textInput(inputId = ns('model_name'),
label = 'Model name'),
hr(),
# scan
actionButton(inputId = ns('go'),
label = 'Create'),
useWaiter()
)
}
#' pqtlr Server Functions
......@@ -23,27 +95,77 @@ mod_pqtlr_server <- function(id, rv){
moduleServer( id, function(input, output, session){
ns <- session$ns
if(id == 'ibd_estimate'){
rv[[id]]<- eventReactive(rv$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)
# genotype column selection
observeEvent(rv$phenotype, {
updateSelectInput(session, 'choice_geno',
choices = names(rv$phenotype[[1]]))
})
# phenotype column selection
observeEvent(rv$phenotype, {
updateSelectInput(session, 'choice_pheno',
choices = names(rv$phenotype[[1]]))
})
} else if(id == 'plot_haplo'){
output[[id]] <- renderPlot(visualiseHaplo(IBD_list = rv$ibd_estimate,
display_by = "name",
linkage_group = 1,
select_offspring = 1,
multiplot = c(1, 1))
)
}
# block column selection
observeEvent(rv$phenotype, {
updateSelectInput(session, 'choice_block',
choices = names(rv$phenotype[[1]]))
})
# adding co-factor
observeEvent(input$cofactor_save, {
# save changes in editable table
rv$cofactor_df <- hot_to_r(input$cofactor_table)
# return feedback to user that cofactor was added
showNotification('Cofactor added', type = 'message')
Sys.sleep(.5)
})
})
# editable cofactor table
output$cofactor_table <- renderRHandsontable(rhandsontable(rv$cofactor_df, useTypes = TRUE) %>%
hot_context_menu(
allowRowEdit = TRUE,
allowColEdit = FALSE
)
)
# create polyqtlR model
observeEvent(input$go, {
progress <- Waiter$new(id = ns('go'),
html = spin_6(),
color = 'grey')
progress$show()
req(input$model_name, rv$ibd_estimate, rv$phenotype, input$choice_geno,
input$choice_pheno)
try(
rv$polyqtl_scan<- QTLscan(IBD_list = rv$ibd_estimate,
Phenotype.df = as.data.frame(rv$phenotype[[1]]), #BUG: load_file still needing indexing
genotype.ID = input$choice_geno,
trait.ID = input$choice_pheno,
cofactor_df = if(input$check_cofactor){rv$cofactor_df},
block = if(input$check_block){input$choice_block},
perm_test = input$check_permutation,
N_parm.max = input$choice_permutation,
ncores = input$choice_core,
verbose = TRUE)
)
progress$hide()
showNotification('Model created', type = 'message')
})
# add results of polyqtlscan to model_list for later binding
observeEvent(rv$polyqtl_scan, {
rv$model_list[[input$model_name]] <- rv$polyqtl_scan$QTL.res %>%
left_join(select(bind_rows(rv$linkmap), c(position, marker)), by = 'position')
})
})
}
## To be copied in the UI
......
polyqtlvis/R/mod_qtl_plotly_panel.R 0 → 100644
View file @ 7cbe3b06
#' qtl_plotly_panel UI Function
#'
#' @description A shiny Module.
#'
#' @param id,input,output,session Internal parameters for {shiny}.
#'
#' @noRd
#'
#' @importFrom shiny NS tagList
#' @importFrom shinycssloaders withSpinner
#' @importFrom plotly ggplotly renderPlotly plotlyOutput highlight layout event_data
#' @importFrom ggplot2 ggplot aes geom_point geom_line facet_wrap theme element_blank
#' @importFrom dplyr bind_rows filter
#' @importFrom magrittr %>%
mod_qtl_plotly_panel_ui <- function(id){
ns <- NS(id)
tagList(
fluidRow(
# models to include
selectizeInput(inputId = ns('choice_models'),
label = 'Models to include',
choices = 'Create a model first',
multiple = TRUE),
# linkage groups to include
actionButton(inputId = ns('update_plot'),
label = 'Update plot')
),
withSpinner(plotlyOutput(outputId = ns('plotly'))),
verbatimTextOutput(ns('click'))
)
}
#' qtl_plotly_panel Server Functions
#'
#' @noRd
mod_qtl_plotly_panel_server <- function(id, rv){
moduleServer( id, function(input, output, session){
ns <- session$ns
# model selection for plotly object
observeEvent(rv$polyqtl_scan, {
updateSelectInput(session, 'choice_models',
choices = names(rv$model_list))
})
# generate plotly object ----
observeEvent(input$update_plot, {
req(rv$polyqtl_scan)
try(
rv$lod_ggplot <- ggplot(bind_rows(rv$model_list, .id = 'model'), aes(x = position,
y = LOD,
color = model,
linetype = model)) +
geom_point(aes(
text = paste(paste('LOD:', round(LOD, 2)),
paste('Marker:', marker),
sep = '\n'
))) +
geom_line() +
facet_wrap(~chromosome) +
theme(
panel.grid = element_blank(),
panel.background = element_blank(),
panel.border = element_blank(),
strip.background = element_blank(),
strip.placement = 'outside'
)
)
})
# render of ggplot object as plotly object
output$plotly <- renderPlotly({
req(rv$lod_ggplot)
ggplotly(rv$lod_ggplot, tooltip = 'text') %>%
highlight('plotly_selected') %>%
layout(title = list(text = 'Chromosome', xanchor = 'center'))
})
# render print of dataframe from selected points
output$click <- renderPrint({
event_df <- event_data('plotly_selected')
if (is.null(event_df)) return('select points')
bind_rows(rv$model_list, .id = 'model') %>%
filter(position %in% event_df$x & round(LOD) %in% round(event_df$y))
})
})
}
## To be copied in the UI
# mod_qtl_plotly_panel_ui("qtl_plotly_panel_ui_1")
## To be copied in the server
# mod_qtl_plotly_panel_server("qtl_plotly_panel_ui_1")
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment