Commit 43e3e18c authored by Kunst, Jonathan's avatar Kunst, Jonathan
Browse files

Added conversion panel with functionality to extract BLUEs from dataframe,...

Added conversion panel with functionality to extract BLUEs from dataframe, need to change to allow for multiple phenotypes still
parent b34ebe2d
......@@ -27,17 +27,16 @@ importFrom(plotly,highlight)
importFrom(plotly,layout)
importFrom(plotly,plotlyOutput)
importFrom(plotly,renderPlotly)
importFrom(polyqtlR,BLUE)
importFrom(polyqtlR,QTLscan)
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)
......
......@@ -17,6 +17,9 @@ app_server <- function( input, output, session ) {
# Input data ----
mod_import_panel_server("import_panel_ui_1", rv = rv)
# Convert data panel ----
mod_convert_panel_server("convert_panel_ui_1", rv = rv)
# IBD estimation ----
mod_IBD_panel_server("IBD_panel_ui_1", rv = rv)
......
......@@ -15,6 +15,11 @@ app_ui <- function(request) {
mod_import_panel_ui('import_panel_ui_1')
),
# Data conversion panel ----
tabPanel('Data conversion',
mod_convert_panel_ui('convert_panel_ui_1')
),
# IBD panel ----
tabPanel('IBD',
mod_IBD_panel_ui("IBD_panel_ui_1")
......
#' blue UI Function
#'
#' @description A shiny Module.
#'
#' @param id,input,output,session Internal parameters for {shiny}.
#'
#' @noRd
#'
#' @importFrom shiny NS tagList
mod_blue_ui <- function(id){
ns <- NS(id)
tagList(
verbatimTextOutput(ns('pheno_names'))
)
}
#' blue Server Functions
#'
#' @noRd
mod_blue_server <- function(id, rv){
moduleServer( id, function(input, output, session){
ns <- session$ns
output$pheno_names <- renderPrint({names(rv$phenotype[[1]])})
})
}
## To be copied in the UI
# mod_blue_ui("blue_ui_1")
## To be copied in the server
# mod_blue_server("blue_ui_1")
#' convert_panel UI Function
#'
#' @description A shiny Module.
#'
#' @param id,input,output,session Internal parameters for {shiny}.
#'
#' @noRd
#'
#' @importFrom shiny NS tagList
#' @importFrom polyqtlR BLUE
mod_convert_panel_ui <- function(id){
ns <- NS(id)
tagList(
sidebarLayout(
sidebarPanel(
h3('Convert data'),
tabsetPanel(
tabPanel('BLUEs',
# genotype column selection
selectInput(inputId = ns('choice_geno'),
label = 'Select genotype column',
choices = 'Import phenotype file first'),
# model formula input
textInput(inputId = ns('model_formula'),
label = 'Model formula',
placeholder = 'pheno ~ geno'),
# Random formula input
textInput(inputId = ns('randomfx_formula'),
label = 'Model formula',
placeholder = '~1|block'),
# create BLUEs
actionButton(inputId = ns('go_blue'),
label = 'Create BLUEs')
),
tabPanel('polymapR -> MAPpoly'),
tabPanel('MAPpoly -> polymapR')
)
),
mainPanel(
tabsetPanel(
tabPanel('BLUEs',
DT::dataTableOutput(ns('table_blues'))
)
)
)
)
)
}
#' convert_panel Server Functions
#'
#' @noRd
mod_convert_panel_server <- function(id, rv){
moduleServer( id, function(input, output, session){
ns <- session$ns
# 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]]))
})
# create BLUEs table
observeEvent(input$go_blue,{
req(rv$phenotype)
try(
rv$blues <- BLUE(data = as.data.frame(rv$phenotype[[1]]),
model = as.formula(input$model_formula),
random = as.formula(input$randomfx_formula),
genotype.ID = input$choice_geno)
)
})
# render BLUEs table
output$table_blues <- DT::renderDataTable(rv[['blues']])
})
}
## To be copied in the UI
# mod_convert_panel_ui("convert_panel_ui_1")
## To be copied in the server
# mod_convert_panel_server("convert_panel_ui_1")
......@@ -27,10 +27,7 @@ mod_model_panel_ui <- function(id, rv){
),
# sidebarpanel for QTLpoly model options
tabPanel('QTLpoly'),
# siebarpanel for diaQTL model options
tabPanel('diaQTL')
tabPanel('QTLpoly')
)
),
......
......@@ -164,7 +164,7 @@ mod_pqtlr_server <- function(id, rv){
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')
})
})
})
}
......
......@@ -7,15 +7,12 @@
#' @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'))
verbatimTextOutput(ns('pheno_names')),
hr(),
mod_blue_ui("blue_ui_1")
)
}
......@@ -26,19 +23,10 @@ mod_test_panel_server <- function(id, rv){
moduleServer( id, function(input, output, session){
ns <- session$ns
output$edit <- renderRHandsontable(rhandsontable(rv$cofactor_df))
output$pheno_names <- renderPrint({names(rv$phenotype[[1]])})
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)
})
mod_blue_server("blue_ui_1", rv = rv)
})
}
......
......@@ -24,7 +24,7 @@ usethis::use_package('tools')
## Add modules ----
## Create a module infrastructure in R/
golem::add_module(name = "test_panel") # Name of the module
golem::add_module(name = "") # 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