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

Input of both polymapr and mappoly object possible and conversion happens...

Input of both polymapr and mappoly object possible and conversion happens immediately. model comparison fully possible, however rescale button happen immediately due to reactivity in the render
parent 756607e6
......@@ -3,12 +3,16 @@
export(run_app)
import(shiny)
importFrom(dplyr,bind_rows)
importFrom(dplyr,case_when)
importFrom(dplyr,filter)
importFrom(dplyr,left_join)
importFrom(dplyr,mutate)
importFrom(dplyr,select)
importFrom(dplyr,transmute)
importFrom(ggplot2,aes)
importFrom(ggplot2,element_blank)
importFrom(ggplot2,facet_wrap)
importFrom(ggplot2,geom_hline)
importFrom(ggplot2,geom_line)
importFrom(ggplot2,geom_point)
importFrom(ggplot2,ggplot)
......@@ -21,6 +25,9 @@ importFrom(golem,favicon)
importFrom(golem,with_golem_options)
importFrom(magrittr,"%>%")
importFrom(mappoly,calc_genoprob)
importFrom(mappoly,export_data_to_polymapR)
importFrom(mappoly,import_data_from_polymapR)
importFrom(mappoly,import_phased_maplist_from_polymapR)
importFrom(parallel,detectCores)
importFrom(plotly,event_data)
importFrom(plotly,ggplotly)
......@@ -28,10 +35,12 @@ importFrom(plotly,highlight)
importFrom(plotly,layout)
importFrom(plotly,plotlyOutput)
importFrom(plotly,renderPlotly)
importFrom(polyqtlR,BLUE)
importFrom(polyqtlR,QTLscan)
importFrom(polyqtlR,convert_mappoly_to_phased.maplist)
importFrom(polyqtlR,estimate_IBD)
importFrom(polyqtlR,visualiseHaplo)
importFrom(pryr,where)
importFrom(qtlpoly,null_model)
importFrom(qtlpoly,read_data)
importFrom(qtlpoly,remim)
importFrom(readr,read_csv)
......
......@@ -9,7 +9,18 @@ app_server <- function( input, output, session ) {
rv <- reactiveValues()
# construct list in rv to carry different models made
rv$model_list <- list()
rv$models <- list()
# construct df containing model results for qtl plotly
rv$model_df <- data.frame(
marker = character(),
model = character(),
chromosome = numeric(),
cM = numeric(),
stattype = character(),
stat = numeric(),
threshold = numeric(),
centered = numeric())
# construct dataframe for possible cofactors in polyqtlR::QTLscan
rv$cofactor_df <- data.frame('LG' = integer(1), 'cM' = numeric(1))
......@@ -17,9 +28,6 @@ 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,11 +15,6 @@ 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")
......
#' import
#'
#' @description A fct function
#'
#' @return The return value, if any, from executing the function.
#'
#' @noRd
......@@ -96,8 +96,7 @@ mod_IBD_panel_ui <- function(id){
# output QTLpoly ----
tabPanel('QTLpoly',
verbatimTextOutput(ns('qtlpoly_ibd_print')),
verbatimTextOutput(ns('qtlpoldy_data_print'))
verbatimTextOutput(ns('qtlpoly_ibd_print'))
)
)
)
......@@ -120,8 +119,8 @@ mod_IBD_panel_server <- function(id, rv){
color = 'grey')
progress$show()
rv$ibd_estimate <- estimate_IBD(phased_maplist = rv$linkmap,
genotypes = as.matrix(rv$snp),
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,
......@@ -136,19 +135,21 @@ mod_IBD_panel_server <- function(id, rv){
color = 'grey')
progress$show()
rv$qtlpoly_ibd <- lapply(rv$qtlpoly_linkmap, calc_genoprob)
rv$qtlpoly_ibd <- lapply(rv$qtlpoly_linkmap, calc_genoprob, verbose = FALSE)
progress$hide()
})
observeEvent(rv$qtlpoly_ibd, {
req(rv$qtlpoly_ibd, rv$qtlpoly_pheno)
req(rv$qtlpoly_ibd, rv$qtlpoly_phenotype)
rv$qtlpoly_data <- read_data(ploidy = input$qtlpoly_ploidy,
geno.prob = rv$qtlpoly_ibd,
pheno = rv$qtlpoly_pheno,
pheno = rv$qtlpoly_phenotype,
step = input$qtlpoly_step
)
})
print(rv$qtlpoly_data)
})
# Main panel ----
# polyqtlr
......@@ -168,7 +169,7 @@ 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
req(rv$ibd_estimate, input$choice_lg, input$choice_offspring)
try(
visualiseHaplo(IBD_list = rv$ibd_estimate,
......
#' 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")
#' go UI Function
#'
#' @description A shiny Module for action buttons
#'
#' @param id,input,output,session Internal parameters for {shiny}.
#'
#' @noRd
#'
#' @importFrom shiny NS tagList
mod_go_ui <- function(id, label){
ns <- NS(id)
tagList(
actionButton(inputId = ns('go'),
label = label)
)
}
#' go Server Functions
#'
#' @noRd
mod_go_server <- function(id, rv, rvlab){
moduleServer( id, function(input, output, session){
ns <- session$ns
rv[[rvlab]] <- eventReactive(input$go, {input$go})
})
}
## To be copied in the UI
# mod_go_ui("go_ui_1")
## To be copied in the server
# mod_go_server("go_ui_1")
......@@ -26,22 +26,14 @@ mod_import_server <- function(id, rv, rvlab){
# snp data is expected as matrix and needs other load in
observeEvent(input$file, {
req(input$file)
if(rvlab == 'snp'){
if (rvlab == 'snp') {
rv[[rvlab]] <- as.matrix(read.csv(input$file$datapath, row.names = 1))
} else {
name <- input$file$name[1] # if multiple csv length too long
extension <- tools::file_ext(name)
rv[[rvlab]] <- switch(extension,
csv = mapply(load_file,
name = input$file$name,
path = input$file$datapath,
SIMPLIFY = FALSE),
rds = load_file(name = name, path = input$file$datapath)
)
rv[[rvlab]] <- load_file(name = input$file$name, path = input$file$datapath)
}
})
})
}
}
## To be copied in the UI
# mod_import_ui("import_ui_1")
......
......@@ -7,6 +7,9 @@
#' @noRd
#'
#' @importFrom shiny NS tagList
#' @importFrom mappoly import_data_from_polymapR import_phased_maplist_from_polymapR export_data_to_polymapR
#' @importFrom polyqtlR convert_mappoly_to_phased.maplist
#' @importFrom pryr where
mod_import_panel_ui <- function(id){
ns <- NS(id)
tagList(
......@@ -14,62 +17,81 @@ mod_import_panel_ui <- function(id){
sidebarPanel(
h3('Input'),
tabsetPanel(
tabPanel('polyqtlR',
# Phenotype input
mod_import_ui(ns('phenotype'),
label = 'Phenotype'),
hr(),
# Linkage map input
mod_import_ui(ns('linkmap'),
label = 'Phased linkage map (polymapR)',
multiple = TRUE),
hr(),
# SNP dosage input
mod_import_ui(ns('snp'),
label = 'SNP Dosage matrix')
),
tabPanel('QTLpoly',
tabPanel('polyqtlR',
# Phenotype input
mod_import_ui(ns('phenotype'),
label = 'Phenotype'),
# Linkage map input
numericInput(ns('ploidy'),
label = 'Ploidy',
value = NULL,
min = 1,
max = 12),
# only show options once ploidy level is selected
conditionalPanel(
condition = 'input.ploidy',
ns = ns,
# Phenotype input
mod_import_ui(ns('qtlpoly_pheno'),
label = 'Phenotype'),
hr(),
# check where map comes from
radioButtons(ns('choice_maptype'),
label = 'Map created by',
choices = list('polymapR' = 1, 'MAPpoly' = 2),
selected = 1),
# Linkage map input
mod_import_ui(ns('qtlpoly_linkmap'),
label = 'Phased linkage map (MAPpoly)')
# SNP dosage input if linkmap is polymapR
conditionalPanel(
condition = 'input.choice_maptype == "1"',
ns = ns,
mod_import_ui(ns('snp'),
label = 'SNP Dosage matrix'),
mod_import_ui(ns('polymapr_linkmap'),
label = 'polymapR Phased linkage map'),
actionButton(ns('go_polyqtlr'),
label = 'Create')
),
# only MAPpoly file needed otherwie
conditionalPanel(
condition = 'input.choice_maptype == "2"',
ns = ns,
# SNP data from MAPpoly
mod_import_ui(ns('mappoly_snp'),
label = 'MAPpoly SNP data'),
mod_import_ui(ns('mappoly_linkmap'),
label = 'MAPpoly Phased linkage map'),
actionButton(ns('go_qtlpoly'),
label = 'Create')
)
)
)
)
),
mainPanel(
# sets of DF to show upload being successful
tabsetPanel(
tabPanel('Phenotype',
mod_table_ui(ns('phenotype')),
mod_table_ui(ns('qtlpoly_pheno'))),
tabPanel('Linkage map',
selectInput(inputId = ns('choice_map'),
label = 'Select linkage group',
choices = 'Input map first'),
mod_table_ui(ns('linkmap')),
verbatimTextOutput(ns('qtlpoly_linkmap'))),
tabPanel('SNP Dosage',
mod_table_ui(ns('snp')))
)
mainPanel(
# sets of DF to show upload being successful
tabsetPanel(
tabPanel('Phenotype',
mod_table_ui(ns('pqtlr_phenotype'))),
tabPanel('Linkage map',
selectInput(inputId = ns('choice_map'),
label = 'Select linkage group',
choices = 'Input map first'),
mod_table_ui(ns('pqtlr_linkmap'))),
tabPanel('SNP Dosage',
mod_table_ui(ns('pqtlr_snp')))
)
)
)
)
}
#' import_panel Server Functions
......@@ -79,40 +101,81 @@ mod_import_panel_server <- function(id, rv){
moduleServer( id, function(input, output, session){
ns <- session$ns
# polyqtlR ----
# file upload ----
# phenotype
mod_import_server('phenotype', rv = rv, rvlab = 'phenotype')
mod_table_server('phenotype', rv = rv, rvlab = 'phenotype')
mod_table_server('pqtlr_phenotype', rv = rv, rvlab = 'pqtlr_phenotype')
# linkage map
mod_import_server('linkmap', rv = rv, rvlab = 'linkmap')
mod_import_server('polymapr_linkmap', rv = rv, rvlab = 'linkmap')
mod_import_server('mappoly_linkmap', rv = rv, rvlab = 'linkmap')
# selection modifier
observeEvent(rv$linkmap, {
file_list <- 1:length(rv$linkmap)
observeEvent(rv$pqtlr_linkmap, {
file_list <- 1:length(rv$pqtlr_linkmap)
updateSelectInput(session, 'choice_map', choices = file_list)
})
rv$select_map <- eventReactive(input$choice_map, {input$choice_map})
mod_table_server('linkmap', rv = rv, rvlab = 'linkmap')
# show pqtlR map
mod_table_server('pqtlr_linkmap', rv = rv, rvlab = 'pqtlr_linkmap')
# # SNP dosage
# snp pqtlR
mod_import_server('snp', rv = rv, rvlab = 'snp')
mod_table_server('snp', rv = rv, rvlab = 'snp')
# QTLpoly ----
# phenotype
mod_import_server('qtlpoly_pheno', rv = rv, rvlab = 'qtlpoly_pheno')
mod_table_server('qtlpoly_pheno', rv = rv, rvlab = 'qtlpoly_pheno')
# snp mappolydata
mod_import_server('mappoly_snp', rv = rv, rvlab = 'mappoly_snp')
# linkage map
mod_import_server('qtlpoly_linkmap', rv = rv, rvlab = 'qtlpoly_linkmap')
output$qtlpoly_linkmap <- renderPrint({req(rv$qtlpoly_linkmap)
str(rv$qtlpoly_linkmap, max.level = 3)})
# present table once go is done
mod_table_server('pqtlr_snp', rv = rv, rvlab = 'pqtlr_snp')
# converting in the background ---
# from polymapR to MAPpoly
observeEvent(input$go_polyqtlr, {
req(input$ploidy, rv$snp, rv$linkmap)
# convert to polymapR to MAPpoly object
# BEFORE DEPLOYING ONLINE: MAPPOLY_SNP SHARED THROUGH ALL INSTANCES
mappoly_snp <<- import_data_from_polymapR(as.matrix(rv$snp), ploidy = as.numeric(input$ploidy))
where('mappoly_snp')
# Create qtlpoly linkmap
rv$qtlpoly_linkmap <- import_phased_maplist_from_polymapR(rv$linkmap, mappoly_snp)
rv$qtlpoly_phenotype <- qtlpoly_pheno(as.data.frame(rv$phenotype))
# keep the different map types distinct
rv$pqtlr_linkmap <- rv$linkmap
rv$pqtlr_snp <- rv$snp
rv$pqtlr_phenotype <- rv$phenotype
})
})
# from MAPpoly to polymapR
observeEvent(input$go_qtlpoly, {
req(rv$mappoly_snp, rv$linkmap)
# convert mappoly data to pqtlr format
try(rv$pqtlr_snp <- export_data_to_polymapR(rv$mappoly_snp))
# convert mappoly data to phased linkmap in pqtlr format
try(rv$pqtlr_linkmap <- convert_mappoly_to_phased.maplist(rv$linkmap))
# phenotype file is already in correct format
rv$pqtlr_phenotype <- rv$phenotype
# keep qtlpoly and pqtlr separate
rv$qtlpoly_linkmap <- rv$linkmap
rv$qtlpoly_phenotype <- qtlpoly_pheno(as.data.frame(rv$phenotype))
})
})
}
## To be copied in the UI
......
......@@ -16,4 +16,15 @@ load_file <- function(name, path){
csv = read_csv(path),
rds = read_rds(path),
validate('Invalid file type, please use .csv or .rds'))
}
# Change phenotype dataframe to phenotype matrix used by QTLpoly model
# @param pheno_df a phenotype data.frame with the first column containing genotype names, all other phenotype columns should be numeric
qtlpoly_pheno <- function(pheno_df){
qtlpheno_df <- as.data.frame(pheno_df[,-1])
rownames(qtlpheno_df) <- pheno_df[,1]
colnames(qtlpheno_df) <- colnames(pheno_df)[-1]
return(qtlpheno_df)
}
\ No newline at end of file
......@@ -8,12 +8,12 @@
#'
#' @importFrom shiny NS tagList
#' @importFrom polyqtlR QTLscan
#' @importFrom dplyr left_join select bind_rows filter
#' @importFrom dplyr select bind_rows filter mutate
#' @importFrom magrittr %>%
#' @importFrom ggplot2 ggplot aes geom_point geom_line facet_wrap theme element_blank