Commit f29a7645 authored by Kunst, Jonathan's avatar Kunst, Jonathan
Browse files

Added an editable table for cofactors for the polyqtlR function

parent cbde5fd9
......@@ -32,6 +32,12 @@ importFrom(polyqtlR,estimate_IBD)
importFrom(polyqtlR,visualiseHaplo)
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)
importFrom(rhandsontable,set_data)
importFrom(shiny,NS)
importFrom(shiny,shinyApp)
importFrom(shiny,tagList)
......
......@@ -12,7 +12,7 @@ app_server <- function( input, output, session ) {
rv$model_list <- list()
# construct dataframe for possible cofactors in polyqtlR::QTLscan
rv$co_factor_df <- data.frame('LG' = numeric(0), 'cM' = numeric(0))
rv$cofactor_df <- data.frame('LG' = integer(1), 'cM' = numeric(1))
# Input data ----
mod_import_panel_server("import_panel_ui_1", rv = rv)
......@@ -20,6 +20,9 @@ app_server <- function( input, output, session ) {
# IBD estimation ----
mod_IBD_panel_server("IBD_panel_ui_1", rv = rv)
# Modelling panel ----
mod_model_panel_server("model_panel_ui_1", rv = rv)
# REMOVE: TEST PANEL ----
mod_test_panel_server("test_panel_ui_1", rv = rv)
}
......@@ -20,9 +20,14 @@ app_ui <- function(request) {
mod_IBD_panel_ui("IBD_panel_ui_1")
),
# Model panel
# Model panel ----
tabPanel('Model',
mod_model_panel_ui("model_panel_ui_1"))
mod_model_panel_ui("model_panel_ui_1")
),
# REMOVE: test panel ----
tabPanel('TEST',
mod_test_panel_ui("test_panel_ui_1"))
)
)
}
......
......@@ -103,11 +103,14 @@ mod_IBD_panel_server <- function(id, rv){
# haplotype visualisation as proof of succesful estimation
output$plot_haplo <- renderPlot({
req(rv$ibd_estimate, input$choice_lg, input$choice_offspring) # BUG: SHORT UBSCRIPT OUT OF BOUNDS ERROR
try(
visualiseHaplo(IBD_list = rv$ibd_estimate,
display_by = "name",
linkage_group = as.numeric(input$choice_lg),
select_offspring = input$choice_offspring,
multiplot = c(1, 1))
)
})
})
}
......
......@@ -32,16 +32,17 @@ mod_import_panel_ui <- function(id){
),
mainPanel(
# sets of DF to show upload being successful
tabsetPanel(
tabPanel('Phenotype',
mod_table_ui(ns('phenotype'))),
mod_table_ui(ns('phenotype'), type = 'DT')),
tabPanel('Linkage map',
selectInput(inputId = ns('choice_map'),
label = 'Select linkage group',
choices = 'Input map first'),
mod_table_ui(ns('linkmap'))),
mod_table_ui(ns('linkmap'), type = 'DT')),
tabPanel('SNP Dosage',
mod_table_ui(ns('snp')))
mod_table_ui(ns('snp'), type = 'DT'))
)
)
)
......
......@@ -14,6 +14,7 @@
#' @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(
......@@ -41,19 +42,9 @@ mod_model_panel_ui <- function(id, rv){
conditionalPanel(
condition ='input.check_cofactor',
ns = ns,
fluidRow(
column(6,
numericInput(inputId = ns('cofactor_LG'),
label = 'Linkage Group',
value = 1)
),
column(6,
textInput(inputId = ns('cofactor_cm'),
label = 'Postion (cM)')
)
),
actionButton(inputId = ns('cofactor_add'),
label = 'Add')
rHandsontableOutput(ns('cofactor_table')),
actionButton(inputId = ns('cofactor_save'),
label = 'Save')
),
# does block need to be taken into account?
......@@ -105,8 +96,11 @@ mod_model_panel_ui <- function(id, rv){
useWaiter()
),
# sidebarpanel for qtlpoly model options
tabPanel('qtlpoly')
# sidebarpanel for QTLpoly model options
tabPanel('QTLpoly'),
# siebarpanel for diaQTL model options
tabPanel('diaQTL')
)
),
......@@ -149,16 +143,21 @@ mod_model_panel_server <- function(id, rv){
})
# adding co-factor
observeEvent(input$cofactor_add, {
# co_factor_df is originally empty, every add, adds a co_factor row
rv$co_factor_df[nrow(rv$co_factor_df)+1,] <- c(as.numeric(input$cofactor_LG),
as.numeric(input$cofactor_cm))
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('Co-factor added', type = 'message')
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
)
)
# create polyqtlR model
observeEvent(input$go, {
......@@ -175,7 +174,7 @@ mod_model_panel_server <- function(id, rv){
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$co_factor_df},
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,
......@@ -233,10 +232,8 @@ mod_model_panel_server <- function(id, rv){
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) %>%
distinct(position, .keep_all = TRUE) %>%
select(-model)
bind_rows(rv$model_list, .id = 'model') %>%
filter(position %in% event_df$x & round(LOD) %in% round(event_df$y))
})
})
}
......@@ -247,5 +244,3 @@ mod_model_panel_server <- function(id, rv){
## To be copied in the server
# mod_model_panel_server("model_panel_ui_1")
#' test_panel UI Function
#'
#' @description A shiny Module.
#'
#' @param id,input,output,session Internal parameters for {shiny}.
#'
#' @noRd
#'
#' @importFrom shiny NS tagList
#' @importFrom rhandsontable rhandsontable rHandsontableOutput renderRHandsontable hot_to_r set_data
mod_test_panel_ui <- function(id){
ns <- NS(id)
tagList(
rHandsontableOutput(ns('edit')),
actionButton(inputId = ns('cofactor_save'),
label = 'Save'),
DT::dataTableOutput(ns('table'))
)
}
#' test_panel Server Functions
#'
#' @noRd
mod_test_panel_server <- function(id, rv){
moduleServer( id, function(input, output, session){
ns <- session$ns
output$edit <- renderRHandsontable(rhandsontable(rv$cofactor_df))
output$table <- DT::renderDataTable(rv$cofactor_df)
observeEvent(input$cofactor_save, {
# save changes in editable table
rv$cofactor_df <- hot_to_r(input$edit)
# return feedback to user that cofactor was added
showNotification('Cofactor added', type = 'message')
Sys.sleep(.5)
})
})
}
## To be copied in the UI
# mod_test_panel_ui("test_panel_ui_1")
## To be copied in the server
# mod_test_panel_server("test_panel_ui_1")
......@@ -24,7 +24,7 @@ usethis::use_package('tools')
## Add modules ----
## Create a module infrastructure in R/
golem::add_module(name = "model_panel") # Name of the module
golem::add_module(name = "test_panel") # Name of the module
## Add helper functions ----
......
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