diff --git a/DESCRIPTION b/DESCRIPTION index c6b5dbd..5f62532 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,83 +1,83 @@ -Package: viewpoly -Title: A Shiny App to Visualize Genetic Maps and QTL Analysis in Polyploid Species -Version: 0.4.1 -Authors@R: c( - person(given = "Cristiane", - family = "Taniguti", - role = c("aut", "cre"), - email = "chtaniguti@tamu.edu"), - person(given = "Gabriel", - family = "de Siqueira Gesteira", - role = c("aut"), - email = "gdesiqu@ncsu.edu"), - person(given = "Jeekin", - family = "Lau", - role = c("aut")), - person(given = "Olivia", - family = "Angelin-Bonnet", - role = c("aut")), - person(given = "Susan", - family = "Thomson", - role = c("ctb")), - person(given = "Guilherme", - family = "da Silva Pereira", - role = c("ctb")), - person(given = "David", - family = "Byrne", - role = c("ctb")), - person(given = "Zhao-Bang", - family = "Zeng", - role = c("ctb")), - person(given = "Oscar", - family = "Riera-Lizarazu", - role = c("ctb")), - person(given = "Marcelo", - family = "Mollinari", - role = c("aut"), - email = "mmollin@ncsu.edu") - ) -Maintainer: Cristiane Taniguti -Description: Provides a graphical user interface to integrate, visualize and explore results - from linkage and quantitative trait loci analysis, together with genomic information for autopolyploid - species. The app is meant for interactive use and allows users to optionally upload different sources - of information, including gene annotation and alignment files, enabling the exploitation and search for - candidate genes in a genome browser. In its current version, 'VIEWpoly' supports inputs from 'MAPpoly', - 'polymapR', 'diaQTL', 'QTLpoly', 'polyqtlR', 'GWASpoly', and 'HIDECAN' packages. -License: GPL (>= 3) -Depends: - R (>= 4.0) -Imports: - shiny (>= 1.6.0), - shinyjs, - shinythemes, - shinyWidgets, - shinydashboard, - config (>= 0.3.1), - golem (>= 0.3.1), - JBrowseR, - dplyr, - tidyr, - DT, - ggplot2, - ggpubr, - plotly, - vroom, - abind, - reshape2, - markdown, - stats, - hidecan, - purrr -URL: https://github.com/mmollina/viewpoly -BugReports: https://github.com/mmollina/viewpoly/issues -Encoding: UTF-8 -LazyData: true -RoxygenNote: 7.2.3 -Suggests: - testthat (>= 3.0.0), - shinytest, - rlang, - pkgload, - vdiffr -Config/testthat/edition: 3 -Language: en-US +Package: viewpoly +Title: A Shiny App to Visualize Genetic Maps and QTL Analysis in Polyploid Species +Version: 0.4.2 +Authors@R: c( + person(given = "Cristiane", + family = "Taniguti", + role = c("aut", "cre"), + email = "chtaniguti@tamu.edu"), + person(given = "Gabriel", + family = "de Siqueira Gesteira", + role = c("aut"), + email = "gdesiqu@ncsu.edu"), + person(given = "Jeekin", + family = "Lau", + role = c("aut")), + person(given = "Olivia", + family = "Angelin-Bonnet", + role = c("aut")), + person(given = "Susan", + family = "Thomson", + role = c("ctb")), + person(given = "Guilherme", + family = "da Silva Pereira", + role = c("ctb")), + person(given = "David", + family = "Byrne", + role = c("ctb")), + person(given = "Zhao-Bang", + family = "Zeng", + role = c("ctb")), + person(given = "Oscar", + family = "Riera-Lizarazu", + role = c("ctb")), + person(given = "Marcelo", + family = "Mollinari", + role = c("aut"), + email = "mmollin@ncsu.edu") + ) +Maintainer: Cristiane Taniguti +Description: Provides a graphical user interface to integrate, visualize and explore results + from linkage and quantitative trait loci analysis, together with genomic information for autopolyploid + species. The app is meant for interactive use and allows users to optionally upload different sources + of information, including gene annotation and alignment files, enabling the exploitation and search for + candidate genes in a genome browser. In its current version, 'VIEWpoly' supports inputs from 'MAPpoly', + 'polymapR', 'diaQTL', 'QTLpoly', 'polyqtlR', 'GWASpoly', and 'HIDECAN' packages. +License: GPL (>= 3) +Depends: + R (>= 4.0) +Imports: + shiny (>= 1.6.0), + shinyjs, + shinythemes, + shinyWidgets, + shinydashboard, + config (>= 0.3.1), + golem (>= 0.3.1), + JBrowseR, + dplyr, + tidyr, + DT, + ggplot2, + ggpubr, + plotly, + vroom, + abind, + reshape2, + markdown, + stats, + hidecan, + purrr +URL: https://github.com/mmollina/viewpoly +BugReports: https://github.com/mmollina/viewpoly/issues +Encoding: UTF-8 +LazyData: true +RoxygenNote: 7.3.2 +Suggests: + testthat (>= 3.0.0), + shinytest, + rlang, + pkgload, + vdiffr +Config/testthat/edition: 3 +Language: en-US diff --git a/NEWS.md b/NEWS.md index 48b274e..abd94ab 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,46 +1,56 @@ -# viewpoly 0.1.0 - -* Added a `NEWS.md` file to track changes to the package. - -# viewpoly 0.1.1 - -* Bug fixed in VIEWgenome module -* Add GitHub link in DESCRIPTION -* Add tutorial video link -* Update README.md - - -# viewpoly 0.2.0 - -Main modifications made during JOSS review: - -* Fix broken links -* Fix download of the images with .tiff format -* Remove warnings and error messages displayed in the console during app execution -* Improve error messages -* Improve function documentation -* Aesthetic improvements -* App is also available on shinyapps.io: https://cris-taniguti.shinyapps.io/viewpoly/ -* Functional testing added -* Disable the download buttons when image parameters are not reliable -* Title of boxes are now also collapsible - -# viewpoly 0.3.0 - -* Support for diaQTL multi-population evaluation -* User-defined parents names in effects graphics -* Download of plots with RData format -* Docker image available -* Allow to exclude haplotypes from haplotypes probability view in VIEWqtl module -* Bug fixed to upload genome through genome link -* Bug fixed to upload viewpoly object - -# viewpoly 0.3.1 - -* Avoid errors if user has not internet connection -* Inform number and ID of individuals selected by haplotypes -* README updated to include new vignette for server version (available at brach publishing_data) - -# viewpoly 0.3.2 - -* CRAN version without all testthat tests \ No newline at end of file +# viewpoly 0.1.0 + +* Added a `NEWS.md` file to track changes to the package. + +# viewpoly 0.1.1 + +* Bug fixed in VIEWgenome module +* Add GitHub link in DESCRIPTION +* Add tutorial video link +* Update README.md + + +# viewpoly 0.2.0 + +Main modifications made during JOSS review: + +* Fix broken links +* Fix download of the images with .tiff format +* Remove warnings and error messages displayed in the console during app execution +* Improve error messages +* Improve function documentation +* Aesthetic improvements +* App is also available on shinyapps.io: https://cris-taniguti.shinyapps.io/viewpoly/ +* Functional testing added +* Disable the download buttons when image parameters are not reliable +* Title of boxes are now also collapsible + +# viewpoly 0.3.0 + +* Support for diaQTL multi-population evaluation +* User-defined parents names in effects graphics +* Download of plots with RData format +* Docker image available +* Allow to exclude haplotypes from haplotypes probability view in VIEWqtl module +* Bug fixed to upload genome through genome link +* Bug fixed to upload viewpoly object + +# viewpoly 0.3.1 + +* Avoid errors if user has not internet connection +* Inform number and ID of individuals selected by haplotypes +* README updated to include new vignette for server version (available at brach publishing_data) + +# viewpoly 0.3.2 + +* CRAN version without all testthat tests + +# viewpoly 0.4.0 + +* All testthat back +* Add HIDECAN module + +# viewpoly 0.4.2 + +* HIDECAN module now supports multiple GWASpoly output files +* Support for diploid QTL results in the QTL module \ No newline at end of file diff --git a/R/functions_map.R b/R/functions_map.R index 9536a10..7548eba 100644 --- a/R/functions_map.R +++ b/R/functions_map.R @@ -1,421 +1,421 @@ - -#' Draws linkage map, parents haplotypes and marker doses -#' Adapted from MAPpoly -#' -#' @param left.lim covered window in the linkage map start position -#' @param rigth.lim covered window in the linkage map end position -#' @param ch linkage group ID -#' @param maps list containing a vector for each linkage group markers with marker positions (named with marker names) -#' @param ph.p1 list containing a data.frame for each group with parent 1 estimated phases. The data.frame contain the columns: -#' 1) Character vector with chromosome ID; 2) Character vector with marker ID; -#' 3 to (ploidy number)*2 columns with each parents haplotypes -#' @param ph.p2 list containing a data.frame for each group with parent 2 estimated phases. See ph.p1 parameter description. -#' @param d.p1 list containing a data.frame for each group with parent 1 dosages. The data.frame contain the columns: -#' 1) character vector with chromosomes ID; -#' 2) Character vector with markers ID; 3) Character vector with parent ID; -#' 4) numerical vector with dosage -#' @param d.p2 list containing a data.frame for each group with parent 2 dosages. See d.p1 parameter description -#' @param snp.names logical TRUE/FALSE. If TRUE it includes the marker names in the plot -#' @param software character defined from each software it comes from -#' -#' @return graphic representing selected section of a linkage group -#' @importFrom graphics legend -#' -#' @keywords internal -draw_map_shiny<-function(left.lim = 0, right.lim = 5, ch = 1, - maps.dist, ph.p1, ph.p2, d.p1, d.p2, snp.names=TRUE, software = NULL) -{ - par <- lines <- points <- axis <- mtext <- text <- NULL - Set1 <- c("#E41A1C", "#377EB8", "#4DAF4A", "#984EA3", "#FF7F00", "#FFFF33", "#A65628", "#F781BF", "#999999") - Dark2 <- c("#1B9E77", "#D95F02", "#7570B3", "#E7298A", "#66A61E", "#E6AB02", "#A6761D", "#666666") - setout <- c("#9E0142", "#BE2449", "#DA464C", "#EC6145", "#F7834D", "#FCAA5F", "#FDC877", "#FEE391", - "#FEF5AF", "#F7FCB3", "#E8F69C", "#CAE99D","#A6DBA4", "#7ECBA4", "#59B4AA", "#3B92B8", "#4470B1", "#5E4FA2") - ch <- as.numeric(ch) - ploidy <- dim(ph.p1[[1]])[2] - # if(is.character(ch)) - # ch <- as.numeric(strsplit(ch, split = " ")[[1]][3]) - if(software == "onemap"){ - alleles <- unique(as.vector(sapply(ph.p1, function(x) unique(unlist(x))))) - alleles <- sort(unique(c(alleles, as.vector(sapply(ph.p2, function(x) unique(unlist(x))))))) - } else alleles <- unique(as.vector(ph.p1[[1]])) - - if(length(alleles) < 3) var.col <- c("#E41A1C", "#377EB8") else var.col <- Set1[1:length(alleles)] - names(var.col) <- alleles - - if(ploidy < 3) d.col <- c(NA, "#1B9E77", "#D95F02") else d.col<-c(NA, Dark2[1:ploidy]) - names(d.col) <- 0:ploidy - d.col[1]<-NA - x <- maps.dist[[ch]] - lab <- names(maps.dist[[ch]]) - zy <- seq(0, 0.5, length.out = ploidy) + 1.5 - pp1 <- ph.p1[[ch]] - pp2 <- ph.p2[[ch]] - dp1 <- d.p1[[ch]] - dp2 <- d.p2[[ch]] - x1<-abs(left.lim - x) - x2<-abs(right.lim - x) - id.left<-which(x1==min(x1))[1] - id.right<-rev(which(x2==min(x2)))[1] - par(mai = c(0.5,0.15,0,0)) - curx<-x[id.left:id.right] - exten <- curx - exten[1] <- exten[1] - 1 - exten[length(exten)] <- exten[length(exten)] + 1 - plot(x = exten, - y = rep(.5,length(curx)), - type = "n" , - ylim = c(.1, 5.5), - #xlim = c(min(curx), max(curx)), - axes = FALSE) - lines(c(x[id.left], x[id.right]), c(.5, .5), lwd=15, col = "gray") - points(x = curx, - y = rep(.5,length(curx)), - xlab = "", ylab = "", - pch = "|", cex=1.5, - ylim = c(0,2)) - axis(side = 1, line = -1) - mtext(text = "Distance (cM)", side = 1, adj = 1, line = 1) - #Parent 2 - for(i in 1:ploidy) - { - lines(c(x[id.left], x[id.right]), c(zy[i], zy[i]), lwd=10, col = "gray") - points(x = seq(x[id.left], x[id.right], length.out = length(curx)), - y = rep(zy[i], length(curx)), - col = var.col[pp2[id.left:id.right,i]], - pch = 15, - cex = 2) - } - mtext(text = "Parent 2", side = 2, at = mean(zy), line = -3, font = 4, padj =1) - for(i in 1:ploidy) - mtext(letters[(2*ploidy):(ploidy+1)][i], at = zy[i], side = 2, line = -4, font = 1, padj =1) - connect.lines<-seq(x[id.left], x[id.right], length.out = length(curx)) - for(i in 1:length(connect.lines)) - lines(c(curx[i], connect.lines[i]), c(0.575, zy[1]-.05), lwd=0.3) - if(software == "mappoly") { - points(x = seq(x[id.left], x[id.right], length.out = length(curx)), - y = zy[ploidy]+0.05+dp2[id.left:id.right]/20, - col = d.col[as.character(dp2[id.left:id.right])], - pch = 19, cex = .7) - } - corners = par("usr") - par(xpd = TRUE) - text(x = corners[1]+.5, y = mean(zy[ploidy]+0.05+(1:ploidy/20)), "Doses") - #Parent 1 - zy<-zy+1.1 - for(i in 1:ploidy) - { - lines(c(x[id.left], x[id.right]), c(zy[i], zy[i]), lwd=10, col = "gray") - points(x = seq(x[id.left], x[id.right], length.out = length(curx)), - y = rep(zy[i], length(curx)), - col = var.col[pp1[id.left:id.right,i]], - pch = 15, - cex = 2) - } - mtext(text = "Parent 1", side = 2, at = mean(zy), line = -3, font = 4) - if(software == "mappoly") { - points(x = seq(x[id.left], x[id.right], length.out = length(curx)), - y = zy[ploidy]+0.05+dp1[id.left:id.right]/20, - col = d.col[as.character(dp1[id.left:id.right])], - pch = 19, cex = .7) - } - corners = par("usr") - par(xpd = TRUE) - text(x = corners[1]+.5, y = mean(zy[ploidy]+0.05+(1:ploidy/20)), "Doses") - if(snp.names) - text(x = seq(x[id.left], x[id.right], length.out = length(curx)), - y = rep(zy[ploidy]+0.05+.3, length(curx)), - labels = names(curx), - srt=90, adj = 0, cex = .7) - for(i in 1:ploidy) - mtext(letters[ploidy:1][i], at = zy[i], side = 2, line = -4, font = 1, padj =1) - legend("topleft", legend= c(alleles, "-"), - fill =c(var.col, "white"), horiz = TRUE, - box.lty=0, bg="transparent") -} - -#' Gets summary information from map. -#' Adapted from MAPpoly -#' -#' @param left.lim covered window in the linkage map start position -#' @param rigth.lim covered window in the linkage map end position -#' @param ch linkage group ID -#' @param maps list containing a vector for each linkage group markers with marker positions (named with marker names) -#' @param d.p1 list containing a data.frame for each group with parent 1 dosages. The data.frame contain the columns: -#' 1) character vector with chromosomes ID; -#' 2) Character vector with markers ID; 3) Character vector with parent ID; -#' 4) numerical vector with dosage -#' @param d.p2 list containing a data.frame for each group with parent 2 dosages. See d.p1 parameter description -#' -#' @return list with linkage map information: doses; number snps by group; cM per snp; map size; number of linkage groups -#' -#' -#' @keywords internal -map_summary<-function(left.lim = 0, right.lim = 5, ch = 1, - maps, d.p1, d.p2){ - ch <- as.numeric(ch) - # if(is.character(ch)) - # ch <- as.numeric(strsplit(ch, split = " ")[[1]][3]) - x <- maps[[ch]] - lab <- names(maps[[ch]]) - ploidy = max(c(d.p1[[ch]], d.p2[[ch]])) - d.p1<-d.p2[[ch]] - d.p2<-d.p1[[ch]] - x1<-abs(left.lim - x) - x2<-abs(right.lim - x) - id.left<-which(x1==min(x1))[1] - id.right<-rev(which(x2==min(x2)))[1] - curx<-x[id.left:id.right] - w<-table(paste(d.p1[id.left:id.right], d.p2[id.left:id.right], sep = "-")) - M<-matrix(0, nrow = ploidy+1, ncol = ploidy+1, dimnames = list(0:ploidy, 0:ploidy)) - for(i in as.character(0:ploidy)) - for(j in as.character(0:ploidy)) - M[i,j]<-w[paste(i,j,sep = "-")] - M[is.na(M)]<-0 - return(list(doses = M, - number.snps = length(curx), - length = diff(range(curx)), - cM.per.snp = round(diff(range(curx))/length(curx), 3), - full.size = as.numeric(maps[[ch]][length(maps[[ch]])]), - number.of.lgs = length(maps))) -} - -#' Summary maps - adapted from MAPpoly -#' -#' This function generates a brief summary table -#' -#' @param viewmap a list of objects of class \code{viewmap} -#' @param software character defined from each software it comes from -#' -#' @return a data frame containing a brief summary of all maps -#' -#' @author Gabriel Gesteira, \email{gabrielgesteira@usp.br} -#' @author Cristiane Taniguti, \email{chtaniguti@tamu.edu} -#' -#' -#' @keywords internal -summary_maps = function(viewmap, software = NULL){ - - max_gap <- sapply(viewmap$maps, function(x) max(diff(x$l.dist))) - - if(software == "mappoly"){ - simplex <- mapply(function(x,y) { - sum((x == 1 & y == 0) | (x == 0 & y == 1) | - (x == max(x) & y == (max(y) -1)) | - (x == (max(x) -1) & y == max(y))) - }, viewmap$d.p1, viewmap$d.p2) - - double_simplex <- mapply(function(x,y) { - sum((x == 1 & y == 1) | (x == 3 & y == 3)) - }, viewmap$d.p1, viewmap$d.p2) - - results = data.frame("LG" = as.character(seq(1,length(viewmap$maps),1)), - "Genomic sequence" = as.character(unlist(lapply(viewmap$maps, function(x) paste(unique(x$g.chr), collapse = "-")))), - "Map length (cM)" = round(sapply(viewmap$maps, function(x) x$l.dist[length(x$l.dist)]),2), - "Markers/cM" = round(sapply(viewmap$maps, function(x) length(x$l.dist)/x$l.dist[length(x$l.dist)]),2), - "Simplex" = simplex, - "Double-simplex" = double_simplex, - "Multiplex" = sapply(viewmap$maps, function(x) length(x$mk.names)) - (simplex + double_simplex), - "Total" = sapply(viewmap$maps, function(x) length(x$mk.names)), - "Max gap" = round(max_gap,2), - check.names = FALSE, stringsAsFactors = F) - - results = rbind(results, c('Total', NA, sum(as.numeric(results$`Map length (cM)`)), - round(mean(as.numeric(results$`Markers/cM`)),2), - sum(as.numeric(results$Simplex)), - sum(as.numeric(results$`Double-simplex`)), - sum(as.numeric(results$Multiplex)), - sum(as.numeric(results$Total)), - round(mean(as.numeric(results$`Max gap`)),2))) - - } else if(software == "onemap"){ - counts <- lapply(viewmap$d.p1, function(x) - as.data.frame(pivot_longer(as.data.frame(table(names(x))), cols = 2)[,-2])) - colnames(counts[[1]])[2] <- paste0("LG",1) - all_count <- counts[[1]] - for(i in 2:(length(counts))){ - colnames(counts[[i]])[2] <- paste0("LG",i) - all_count <- full_join(all_count, counts[[i]], by="Var1") - } - rm.na <- as.matrix(all_count[,2:4]) - rm.na[which(is.na(rm.na))] <- 0 - all_count <- data.frame(marker_types = all_count[,1], rm.na) - all_count <- t(all_count) - colnames(all_count) <- all_count[1,] - all_count <- all_count[-1,] - all_count <- apply(all_count, 2, as.numeric) - - LG = as.character(seq(1,length(viewmap$maps),1)) - - if(any(sapply(viewmap$maps, function(x) any(is.na(x$g.chr))))){ - warning("There are missing genomic position information in at least one of the groups") - } - - chr <- sapply(viewmap$maps, function(x) unique(x$g.chr[-which(is.na(x$g.chr))])) - if(is.list(chr)) { - warning("There are groups with combination of more than one genomic chromosome.") - chr[which(sapply(chr, length) >= 2)] <- NA - chr <- unlist(chr) - } - - results1 = data.frame(LG, - "Genomic sequence" = chr, - "Map length (cM)" = round(sapply(viewmap$maps, function(x) x$l.dist[length(x$l.dist)]),2), - "Markers/cM" = round(sapply(viewmap$maps, function(x) length(x$l.dist)/x$l.dist[length(x$l.dist)]),2)) - colnames(results1) <- c("LG", "Genomic sequence", "Map length (cM)", "Markers/cM") - - results2 = data.frame("Total" = sapply(viewmap$maps, function(x) length(x$mk.names)), - "Max gap" = round(max_gap,2), - check.names = FALSE, stringsAsFactors = F) - - results <- cbind(results1, all_count, results2) - results<- rbind(results, c("Total", "NA", apply(results[,3:ncol(results)], 2, sum))) - } - return(results) -} - - -#' Plot a genetic map - Adapted from MAPpoly -#' -#' This function plots a genetic linkage map(s) -#' -#' @param viewmap object of class \code{viewmap} -#' -#' @param horiz logical. If FALSE, the maps are plotted vertically with the first map to the left. -#' If TRUE (default), the maps are plotted horizontally with the first at the bottom -#' -#' @param col a vector of colors for the bars or bar components (default = 'lightgrey') -#' \code{ggstyle} produces maps using the default \code{ggplot} color palette -#' -#' @param title a title (string) for the maps (default = 'Linkage group') -#' -#' @return A \code{data.frame} object containing the name of the markers and their genetic position -#' -#' @author Marcelo Mollinari, \email{mmollin@ncsu.edu} -#' @author Cristiane Taniguti, \email{chtaniguti@tamu.edu} -#' -#' @references -#' Mollinari, M., and Garcia, A. A. F. (2019) Linkage -#' analysis and haplotype phasing in experimental autopolyploid -#' populations with high ploidy level using hidden Markov -#' models, _G3: Genes, Genomes, Genetics_. -#' \doi{10.1534/g3.119.400378} -#' -#' -#' @keywords internal -plot_map_list <- function(viewmap, horiz = TRUE, col = "ggstyle", title = "Linkage group"){ - axis <- NULL - map.list <- viewmap$maps - if(all(col == "ggstyle")) - col <- gg_color_hue(length(map.list)) - if(length(col) == 1) - col <- rep(col, length(map.list)) - z <- NULL - if(is.null(names(map.list))) - names(map.list) <- 1:length(map.list) - max.dist <- max(sapply(map.list, function(x) x$l.dist[length(x$l.dist)])) - if(horiz){ - plot(0, - xlim = c(0, max.dist), - ylim = c(0,length(map.list)+1), - type = "n", axes = FALSE, - xlab = "Map position (cM)", - ylab = title) - axis(1) - for(i in 1:length(map.list)){ - z <- rbind(z, data.frame(mrk = map.list[[i]]$mk.names, - LG = names(map.list)[i], pos = map.list[[i]]$l.dist)) - plot_one_map(map.list[[i]]$l.dist, i = i, horiz = TRUE, col = col[i]) - } - axis(2, at = 1:length(map.list), labels = names(map.list), lwd = 0, las = 2) - } else{ - plot(0, - ylim = c(-max.dist, 0), - xlim = c(0,length(map.list)+1), - type = "n", axes = FALSE, - ylab = "Map position (cM)", - xlab = title) - x <- axis(2, labels = FALSE, lwd = 0) - axis(2, at = x, labels = abs(x)) - for(i in 1:length(map.list)){ - z <- rbind(z, data.frame(mrk = map.list[[i]]$mk.names, - LG = names(map.list)[i],pos = map.list[[i]]$l.dist)) - plot_one_map(map.list[[i]]$l.dist, i = i, horiz = FALSE, col = col[i]) - } - axis(3, at = 1:length(map.list), labels = names(map.list), lwd = 0, las = 2) - } - invisible(z) -} - - -#' Color pallet ggplot-like - Adapted from MAPpoly -#' -#' @param n number of colors -#' -#' @importFrom grDevices hcl col2rgb hsv rgb2hsv -#' -#' -#' @keywords internal -gg_color_hue <- function(n) { - x <- rgb2hsv(col2rgb("steelblue"))[, 1] - cols = seq(x[1], x[1] + 1, by = 1/n) - cols = cols[1:n] - cols[cols > 1] <- cols[cols > 1] - 1 - return(hsv(cols, x[2], x[3])) -} - -#' Plot a single linkage group with no phase - from MAPpoly -#' -#' @param x vector of genetic distances -#' @param i margins size -#' @param horiz logical TRUE/FALSE. If TRUE the map is plotted horizontally. -#' @param col color pallete to be used -#' -#' @keywords internal -plot_one_map <- function(x, i = 0, horiz = FALSE, col = "lightgray") -{ - rect <- tail <- lines <- NULL - if(horiz) - { - rect(xleft = x[1], ybottom = i-0.25, - xright = tail(x,1), ytop = i+0.25, - col = col) - for(j in 1:length(x)) - lines(x = c(x[j], x[j]), y = c(i-0.25, i+0.25), lwd = .5) - } else { - x <- -rev(x) - rect(xleft = i-0.25, ybottom = x[1], - xright = i+0.25, ytop = tail(x,1), - col = col) - for(j in 1:length(x)) - lines(y = c(x[j], x[j]), x = c(i-0.25, i+0.25), lwd = .5) - } -} - -#' Scatter plot relating linkage map and genomic positions -#' -#' @param viewmap object of class \code{viewmap} -#' @param group selected group ID -#' @param range.min minimum value of the selected position range -#' @param range.max maximum value of the selected position range -#' -#' @keywords internal -plot_cm_mb <- function(viewmap, group, range.min, range.max) { - l.dist <- g.dist <- high <- mk.names <- NULL - map.lg <- viewmap$maps[[as.numeric(group)]] - - map.lg$high <- map.lg$g.dist - map.lg$high[round(map.lg$l.dist,5) < range.min | round(map.lg$l.dist,5) > range.max] <- "black" - map.lg$high[round(map.lg$l.dist,5) >= range.min & round(map.lg$l.dist,5) <= range.max] <- "red" - - map.lg$high <- as.factor(map.lg$high) - p <- ggplot(map.lg, aes(x=l.dist, y = g.dist/1000, - colour = high, - text = paste("Marker:", mk.names, "\n", - "Genetic:", round(l.dist,2), "cM \n", - "Genomic:", g.dist/1000, "Mb"))) + - geom_point() + scale_color_manual(values=c('black','red')) + - theme(legend.position = "none") + - labs(x = "Linkage map (cM)", y = "Reference genome (Mb)") + - theme_bw() - return(p) -} + +#' Draws linkage map, parents haplotypes and marker doses +#' Adapted from MAPpoly +#' +#' @param left.lim covered window in the linkage map start position +#' @param right.lim covered window in the linkage map end position +#' @param ch linkage group ID +#' @param maps list containing a vector for each linkage group markers with marker positions (named with marker names) +#' @param ph.p1 list containing a data.frame for each group with parent 1 estimated phases. The data.frame contain the columns: +#' 1) Character vector with chromosome ID; 2) Character vector with marker ID; +#' 3 to (ploidy number)*2 columns with each parents haplotypes +#' @param ph.p2 list containing a data.frame for each group with parent 2 estimated phases. See ph.p1 parameter description. +#' @param d.p1 list containing a data.frame for each group with parent 1 dosages. The data.frame contain the columns: +#' 1) character vector with chromosomes ID; +#' 2) Character vector with markers ID; 3) Character vector with parent ID; +#' 4) numerical vector with dosage +#' @param d.p2 list containing a data.frame for each group with parent 2 dosages. See d.p1 parameter description +#' @param snp.names logical TRUE/FALSE. If TRUE it includes the marker names in the plot +#' @param software character defined from each software it comes from +#' +#' @return graphic representing selected section of a linkage group +#' @importFrom graphics legend +#' +#' @keywords internal +draw_map_shiny<-function(left.lim = 0, right.lim = 5, ch = 1, + maps.dist, ph.p1, ph.p2, d.p1, d.p2, snp.names=TRUE, software = NULL) +{ + par <- lines <- points <- axis <- mtext <- text <- NULL + Set1 <- c("#E41A1C", "#377EB8", "#4DAF4A", "#984EA3", "#FF7F00", "#FFFF33", "#A65628", "#F781BF", "#999999") + Dark2 <- c("#1B9E77", "#D95F02", "#7570B3", "#E7298A", "#66A61E", "#E6AB02", "#A6761D", "#666666") + setout <- c("#9E0142", "#BE2449", "#DA464C", "#EC6145", "#F7834D", "#FCAA5F", "#FDC877", "#FEE391", + "#FEF5AF", "#F7FCB3", "#E8F69C", "#CAE99D","#A6DBA4", "#7ECBA4", "#59B4AA", "#3B92B8", "#4470B1", "#5E4FA2") + ch <- as.numeric(ch) + ploidy <- dim(ph.p1[[1]])[2] + # if(is.character(ch)) + # ch <- as.numeric(strsplit(ch, split = " ")[[1]][3]) + if(software == "onemap"){ + alleles <- unique(as.vector(sapply(ph.p1, function(x) unique(unlist(x))))) + alleles <- sort(unique(c(alleles, as.vector(sapply(ph.p2, function(x) unique(unlist(x))))))) + } else alleles <- unique(as.vector(ph.p1[[1]])) + + if(length(alleles) < 3) var.col <- c("#E41A1C", "#377EB8") else var.col <- Set1[1:length(alleles)] + names(var.col) <- alleles + + if(ploidy < 3) d.col <- c(NA, "#1B9E77", "#D95F02") else d.col<-c(NA, Dark2[1:ploidy]) + names(d.col) <- 0:ploidy + d.col[1]<-NA + x <- maps.dist[[ch]] + lab <- names(maps.dist[[ch]]) + zy <- seq(0, 0.5, length.out = ploidy) + 1.5 + pp1 <- ph.p1[[ch]] + pp2 <- ph.p2[[ch]] + dp1 <- d.p1[[ch]] + dp2 <- d.p2[[ch]] + x1<-abs(left.lim - x) + x2<-abs(right.lim - x) + id.left<-which(x1==min(x1))[1] + id.right<-rev(which(x2==min(x2)))[1] + par(mai = c(0.5,0.15,0,0)) + curx<-x[id.left:id.right] + exten <- curx + exten[1] <- exten[1] - 1 + exten[length(exten)] <- exten[length(exten)] + 1 + plot(x = exten, + y = rep(.5,length(curx)), + type = "n" , + ylim = c(.1, 5.5), + #xlim = c(min(curx), max(curx)), + axes = FALSE) + lines(c(x[id.left], x[id.right]), c(.5, .5), lwd=15, col = "gray") + points(x = curx, + y = rep(.5,length(curx)), + xlab = "", ylab = "", + pch = "|", cex=1.5, + ylim = c(0,2)) + axis(side = 1, line = -1) + mtext(text = "Distance (cM)", side = 1, adj = 1, line = 1) + #Parent 2 + for(i in 1:ploidy) + { + lines(c(x[id.left], x[id.right]), c(zy[i], zy[i]), lwd=10, col = "gray") + points(x = seq(x[id.left], x[id.right], length.out = length(curx)), + y = rep(zy[i], length(curx)), + col = var.col[pp2[id.left:id.right,i]], + pch = 15, + cex = 2) + } + mtext(text = "Parent 2", side = 2, at = mean(zy), line = -3, font = 4, padj =1) + for(i in 1:ploidy) + mtext(letters[(2*ploidy):(ploidy+1)][i], at = zy[i], side = 2, line = -4, font = 1, padj =1) + connect.lines<-seq(x[id.left], x[id.right], length.out = length(curx)) + for(i in 1:length(connect.lines)) + lines(c(curx[i], connect.lines[i]), c(0.575, zy[1]-.05), lwd=0.3) + if(software == "mappoly") { + points(x = seq(x[id.left], x[id.right], length.out = length(curx)), + y = zy[ploidy]+0.05+dp2[id.left:id.right]/20, + col = d.col[as.character(dp2[id.left:id.right])], + pch = 19, cex = .7) + } + corners = par("usr") + par(xpd = TRUE) + text(x = corners[1]+.5, y = mean(zy[ploidy]+0.05+(1:ploidy/20)), "Doses") + #Parent 1 + zy<-zy+1.1 + for(i in 1:ploidy) + { + lines(c(x[id.left], x[id.right]), c(zy[i], zy[i]), lwd=10, col = "gray") + points(x = seq(x[id.left], x[id.right], length.out = length(curx)), + y = rep(zy[i], length(curx)), + col = var.col[pp1[id.left:id.right,i]], + pch = 15, + cex = 2) + } + mtext(text = "Parent 1", side = 2, at = mean(zy), line = -3, font = 4) + if(software == "mappoly") { + points(x = seq(x[id.left], x[id.right], length.out = length(curx)), + y = zy[ploidy]+0.05+dp1[id.left:id.right]/20, + col = d.col[as.character(dp1[id.left:id.right])], + pch = 19, cex = .7) + } + corners = par("usr") + par(xpd = TRUE) + text(x = corners[1]+.5, y = mean(zy[ploidy]+0.05+(1:ploidy/20)), "Doses") + if(snp.names) + text(x = seq(x[id.left], x[id.right], length.out = length(curx)), + y = rep(zy[ploidy]+0.05+.3, length(curx)), + labels = names(curx), + srt=90, adj = 0, cex = .7) + for(i in 1:ploidy) + mtext(letters[ploidy:1][i], at = zy[i], side = 2, line = -4, font = 1, padj =1) + legend("topleft", legend= c(alleles, "-"), + fill =c(var.col, "white"), horiz = TRUE, + box.lty=0, bg="transparent") +} + +#' Gets summary information from map. +#' Adapted from MAPpoly +#' +#' @param left.lim covered window in the linkage map start position +#' @param right.lim covered window in the linkage map end position +#' @param ch linkage group ID +#' @param maps list containing a vector for each linkage group markers with marker positions (named with marker names) +#' @param d.p1 list containing a data.frame for each group with parent 1 dosages. The data.frame contain the columns: +#' 1) character vector with chromosomes ID; +#' 2) Character vector with markers ID; 3) Character vector with parent ID; +#' 4) numerical vector with dosage +#' @param d.p2 list containing a data.frame for each group with parent 2 dosages. See d.p1 parameter description +#' +#' @return list with linkage map information: doses; number snps by group; cM per snp; map size; number of linkage groups +#' +#' +#' @keywords internal +map_summary<-function(left.lim = 0, right.lim = 5, ch = 1, + maps, d.p1, d.p2){ + ch <- as.numeric(ch) + # if(is.character(ch)) + # ch <- as.numeric(strsplit(ch, split = " ")[[1]][3]) + x <- maps[[ch]] + lab <- names(maps[[ch]]) + ploidy = max(c(d.p1[[ch]], d.p2[[ch]])) + d.p1<-d.p2[[ch]] + d.p2<-d.p1[[ch]] + x1<-abs(left.lim - x) + x2<-abs(right.lim - x) + id.left<-which(x1==min(x1))[1] + id.right<-rev(which(x2==min(x2)))[1] + curx<-x[id.left:id.right] + w<-table(paste(d.p1[id.left:id.right], d.p2[id.left:id.right], sep = "-")) + M<-matrix(0, nrow = ploidy+1, ncol = ploidy+1, dimnames = list(0:ploidy, 0:ploidy)) + for(i in as.character(0:ploidy)) + for(j in as.character(0:ploidy)) + M[i,j]<-w[paste(i,j,sep = "-")] + M[is.na(M)]<-0 + return(list(doses = M, + number.snps = length(curx), + length = diff(range(curx)), + cM.per.snp = round(diff(range(curx))/length(curx), 3), + full.size = as.numeric(maps[[ch]][length(maps[[ch]])]), + number.of.lgs = length(maps))) +} + +#' Summary maps - adapted from MAPpoly +#' +#' This function generates a brief summary table +#' +#' @param viewmap a list of objects of class \code{viewmap} +#' @param software character defined from each software it comes from +#' +#' @return a data frame containing a brief summary of all maps +#' +#' @author Gabriel Gesteira, \email{gabrielgesteira@usp.br} +#' @author Cristiane Taniguti, \email{chtaniguti@tamu.edu} +#' +#' +#' @keywords internal +summary_maps = function(viewmap, software = NULL){ + + max_gap <- sapply(viewmap$maps, function(x) max(diff(x$l.dist))) + + if(software == "mappoly"){ + simplex <- mapply(function(x,y) { + sum((x == 1 & y == 0) | (x == 0 & y == 1) | + (x == max(x) & y == (max(y) -1)) | + (x == (max(x) -1) & y == max(y))) + }, viewmap$d.p1, viewmap$d.p2) + + double_simplex <- mapply(function(x,y) { + sum((x == 1 & y == 1) | (x == 3 & y == 3)) + }, viewmap$d.p1, viewmap$d.p2) + + results = data.frame("LG" = as.character(seq(1,length(viewmap$maps),1)), + "Genomic sequence" = as.character(unlist(lapply(viewmap$maps, function(x) paste(unique(x$g.chr), collapse = "-")))), + "Map length (cM)" = round(sapply(viewmap$maps, function(x) x$l.dist[length(x$l.dist)]),2), + "Markers/cM" = round(sapply(viewmap$maps, function(x) length(x$l.dist)/x$l.dist[length(x$l.dist)]),2), + "Simplex" = simplex, + "Double-simplex" = double_simplex, + "Multiplex" = sapply(viewmap$maps, function(x) length(x$mk.names)) - (simplex + double_simplex), + "Total" = sapply(viewmap$maps, function(x) length(x$mk.names)), + "Max gap" = round(max_gap,2), + check.names = FALSE, stringsAsFactors = F) + + results = rbind(results, c('Total', NA, sum(as.numeric(results$`Map length (cM)`)), + round(mean(as.numeric(results$`Markers/cM`)),2), + sum(as.numeric(results$Simplex)), + sum(as.numeric(results$`Double-simplex`)), + sum(as.numeric(results$Multiplex)), + sum(as.numeric(results$Total)), + round(mean(as.numeric(results$`Max gap`)),2))) + + } else if(software == "onemap"){ + counts <- lapply(viewmap$d.p1, function(x) + as.data.frame(pivot_longer(as.data.frame(table(names(x))), cols = 2)[,-2])) + colnames(counts[[1]])[2] <- paste0("LG",1) + all_count <- counts[[1]] + for(i in 2:(length(counts))){ + colnames(counts[[i]])[2] <- paste0("LG",i) + all_count <- full_join(all_count, counts[[i]], by="Var1") + } + rm.na <- as.matrix(all_count[,2:4]) + rm.na[which(is.na(rm.na))] <- 0 + all_count <- data.frame(marker_types = all_count[,1], rm.na) + all_count <- t(all_count) + colnames(all_count) <- all_count[1,] + all_count <- all_count[-1,] + all_count <- apply(all_count, 2, as.numeric) + + LG = as.character(seq(1,length(viewmap$maps),1)) + + if(any(sapply(viewmap$maps, function(x) any(is.na(x$g.chr))))){ + warning("There are missing genomic position information in at least one of the groups") + } + + chr <- sapply(viewmap$maps, function(x) unique(x$g.chr[-which(is.na(x$g.chr))])) + if(is.list(chr)) { + warning("There are groups with combination of more than one genomic chromosome.") + chr[which(sapply(chr, length) >= 2)] <- NA + chr <- unlist(chr) + } + + results1 = data.frame(LG, + "Genomic sequence" = chr, + "Map length (cM)" = round(sapply(viewmap$maps, function(x) x$l.dist[length(x$l.dist)]),2), + "Markers/cM" = round(sapply(viewmap$maps, function(x) length(x$l.dist)/x$l.dist[length(x$l.dist)]),2)) + colnames(results1) <- c("LG", "Genomic sequence", "Map length (cM)", "Markers/cM") + + results2 = data.frame("Total" = sapply(viewmap$maps, function(x) length(x$mk.names)), + "Max gap" = round(max_gap,2), + check.names = FALSE, stringsAsFactors = F) + + results <- cbind(results1, all_count, results2) + results<- rbind(results, c("Total", "NA", apply(results[,3:ncol(results)], 2, sum))) + } + return(results) +} + + +#' Plot a genetic map - Adapted from MAPpoly +#' +#' This function plots a genetic linkage map(s) +#' +#' @param viewmap object of class \code{viewmap} +#' +#' @param horiz logical. If FALSE, the maps are plotted vertically with the first map to the left. +#' If TRUE (default), the maps are plotted horizontally with the first at the bottom +#' +#' @param col a vector of colors for the bars or bar components (default = 'lightgrey') +#' \code{ggstyle} produces maps using the default \code{ggplot} color palette +#' +#' @param title a title (string) for the maps (default = 'Linkage group') +#' +#' @return A \code{data.frame} object containing the name of the markers and their genetic position +#' +#' @author Marcelo Mollinari, \email{mmollin@ncsu.edu} +#' @author Cristiane Taniguti, \email{chtaniguti@tamu.edu} +#' +#' @references +#' Mollinari, M., and Garcia, A. A. F. (2019) Linkage +#' analysis and haplotype phasing in experimental autopolyploid +#' populations with high ploidy level using hidden Markov +#' models, _G3: Genes, Genomes, Genetics_. +#' \doi{10.1534/g3.119.400378} +#' +#' +#' @keywords internal +plot_map_list <- function(viewmap, horiz = TRUE, col = "ggstyle", title = "Linkage group"){ + axis <- NULL + map.list <- viewmap$maps + if(all(col == "ggstyle")) + col <- gg_color_hue(length(map.list)) + if(length(col) == 1) + col <- rep(col, length(map.list)) + z <- NULL + if(is.null(names(map.list))) + names(map.list) <- 1:length(map.list) + max.dist <- max(sapply(map.list, function(x) x$l.dist[length(x$l.dist)])) + if(horiz){ + plot(0, + xlim = c(0, max.dist), + ylim = c(0,length(map.list)+1), + type = "n", axes = FALSE, + xlab = "Map position (cM)", + ylab = title) + axis(1) + for(i in 1:length(map.list)){ + z <- rbind(z, data.frame(mrk = map.list[[i]]$mk.names, + LG = names(map.list)[i], pos = map.list[[i]]$l.dist)) + plot_one_map(map.list[[i]]$l.dist, i = i, horiz = TRUE, col = col[i]) + } + axis(2, at = 1:length(map.list), labels = names(map.list), lwd = 0, las = 2) + } else{ + plot(0, + ylim = c(-max.dist, 0), + xlim = c(0,length(map.list)+1), + type = "n", axes = FALSE, + ylab = "Map position (cM)", + xlab = title) + x <- axis(2, labels = FALSE, lwd = 0) + axis(2, at = x, labels = abs(x)) + for(i in 1:length(map.list)){ + z <- rbind(z, data.frame(mrk = map.list[[i]]$mk.names, + LG = names(map.list)[i],pos = map.list[[i]]$l.dist)) + plot_one_map(map.list[[i]]$l.dist, i = i, horiz = FALSE, col = col[i]) + } + axis(3, at = 1:length(map.list), labels = names(map.list), lwd = 0, las = 2) + } + invisible(z) +} + + +#' Color pallet ggplot-like - Adapted from MAPpoly +#' +#' @param n number of colors +#' +#' @importFrom grDevices hcl col2rgb hsv rgb2hsv +#' +#' +#' @keywords internal +gg_color_hue <- function(n) { + x <- rgb2hsv(col2rgb("steelblue"))[, 1] + cols = seq(x[1], x[1] + 1, by = 1/n) + cols = cols[1:n] + cols[cols > 1] <- cols[cols > 1] - 1 + return(hsv(cols, x[2], x[3])) +} + +#' Plot a single linkage group with no phase - from MAPpoly +#' +#' @param x vector of genetic distances +#' @param i margins size +#' @param horiz logical TRUE/FALSE. If TRUE the map is plotted horizontally. +#' @param col color pallete to be used +#' +#' @keywords internal +plot_one_map <- function(x, i = 0, horiz = FALSE, col = "lightgray") +{ + rect <- tail <- lines <- NULL + if(horiz) + { + rect(xleft = x[1], ybottom = i-0.25, + xright = tail(x,1), ytop = i+0.25, + col = col) + for(j in 1:length(x)) + lines(x = c(x[j], x[j]), y = c(i-0.25, i+0.25), lwd = .5) + } else { + x <- -rev(x) + rect(xleft = i-0.25, ybottom = x[1], + xright = i+0.25, ytop = tail(x,1), + col = col) + for(j in 1:length(x)) + lines(y = c(x[j], x[j]), x = c(i-0.25, i+0.25), lwd = .5) + } +} + +#' Scatter plot relating linkage map and genomic positions +#' +#' @param viewmap object of class \code{viewmap} +#' @param group selected group ID +#' @param range.min minimum value of the selected position range +#' @param range.max maximum value of the selected position range +#' +#' @keywords internal +plot_cm_mb <- function(viewmap, group, range.min, range.max) { + l.dist <- g.dist <- high <- mk.names <- NULL + map.lg <- viewmap$maps[[as.numeric(group)]] + + map.lg$high <- map.lg$g.dist + map.lg$high[round(map.lg$l.dist,5) < range.min | round(map.lg$l.dist,5) > range.max] <- "black" + map.lg$high[round(map.lg$l.dist,5) >= range.min & round(map.lg$l.dist,5) <= range.max] <- "red" + + map.lg$high <- as.factor(map.lg$high) + p <- ggplot(map.lg, aes(x=l.dist, y = g.dist/1000, + colour = high, + text = paste("Marker:", mk.names, "\n", + "Genetic:", round(l.dist,2), "cM \n", + "Genomic:", g.dist/1000, "Mb"))) + + geom_point() + scale_color_manual(values=c('black','red')) + + theme(legend.position = "none") + + labs(x = "Linkage map (cM)", y = "Reference genome (Mb)") + + theme_bw() + return(p) +} diff --git a/R/functions_qtl.R b/R/functions_qtl.R index 7532c99..6718556 100644 --- a/R/functions_qtl.R +++ b/R/functions_qtl.R @@ -1,826 +1,854 @@ -#' Logarithm of \emph{P}-value (LOP) profile plots. Modified version of QTLpoly function. -#' -#' Plots profiled logarithm of score-based \emph{P}-values (LOP) from individual or combined traits. -#' -#' @param profile data.frame with: pheno - phenotype ID; LOP - significance value for the QTL. -#' It can be LOP, LOD or DIC depending of the software used -#' @param qtl_info data.frame with: LG - linkage group ID; Pos - position in linkage map (cM); -#' Pheno - phenotype ID; Pos_lower - lower position of confidence interval; -#' Pos_upper - upper position of the confidence interval; Pval - QTL p-value; h2 - herdability -#' @param selected_mks data.frame with: LG - linkage group ID; mk - marker ID; pos - position in linkage map (cM) -#' @param pheno.col integer identifying phenotype -#' @param lgs.id integer identifying linkage group -#' @param by_range logical TRUE/FALSE. If TRUE range.min and range.max will set a colored window in the plot and the other positions will be gray. -#' If FALSE, range.min and range.max is ignored -#' @param range.min position in centimorgan defining the start of the colored window -#' @param range.max position in centimorgan defining the end of the colored window -#' @param plot logical TRUE/FALSE. If FALSE the function return a data.frame with information for \code{only_plot_profile} function. -#' If TRUE, it returns a ggplot graphic. -#' @param software character defining which software was used for QTL analysis. Currently support for: QTLpoly, diaQTL and polyqtlR. -#' -#' @import ggplot2 -#' @import dplyr -#' @importFrom plotly TeX -#' @importFrom utils tail -#' -#' @return ggplot graphic (if plot == TRUE) or data.frame (if plot == FALSE) with information -#' from QTL significance profile -#' -#' @keywords internal -plot_profile <- function(profile, qtl_info, selected_mks, pheno.col = NULL, - lgs.id = NULL, by_range = TRUE, range.min = NULL, - range.max = NULL, plot=TRUE, software = NULL) { - - pheno <- LG <- `Position (cM)` <- Trait <- INT <- . <- NULL - - lgs.size <- selected_mks %>% group_by(.data$LG) %>% group_map(~ tail(.x, 1)) %>% do.call(rbind, .) - lgs.size <- lgs.size$pos - lines <- points <- thre <- map <- data.frame() - y.dat <- trait.names <- c() - count <- 0 - - nphe <- length(pheno.col) - LGS <- selected_mks$LG - POS <- selected_mks$pos - for(p in 1:nphe) { #lines - TRT <- rep(unique(profile$pheno)[pheno.col[p]], length(LGS)) - SIG <- profile[which(profile$pheno == TRT),2] - lines <- rbind(lines, data.frame(TRT=as.factor(TRT), LGS=LGS, POS=POS, SIG=SIG)) - } - count <- 0 - y.dat <- c() - for(p in 1:nphe) { #points - trait.names <- unique(profile$pheno)[pheno.col[p]] - if(!is.null(qtl_info)) { - qtl_info.sub <- qtl_info %>% filter(pheno == trait.names) %>% filter(LG %in% lgs.id) - if(dim(qtl_info.sub)[1] > 0){ - nqtls <- qtl_info.sub %>% summarize(n()) - TRT <- qtl_info.sub$pheno - LGS <- qtl_info.sub$LG - POS <- qtl_info.sub$Pos - INF <- qtl_info.sub$Pos_lower - SUP <- qtl_info.sub$Pos_upper - PVAL <- qtl_info.sub[,6] - H2 <- qtl_info.sub$h2 - if(!is.null(H2)){ - points <- rbind(points, data.frame(TRT=TRT, LGS=LGS, POS=POS, INF=INF, SUP=SUP, PVAL = PVAL, H2 = round(H2,2))) - } else - points <- rbind(points, data.frame(TRT=TRT, LGS=LGS, POS=POS, INF=INF, SUP=SUP, PVAL = PVAL)) - count <- count+1 - y.dat <- c(y.dat, rep((-0.5*count), nqtls)) - } - } - } - points <- cbind(points, y.dat) - # The axis name change according with software - y.lab <- colnames(profile)[2] - if(y.lab == "LOP") { - if(by_range){ - y.lab <- "LOP" - } else { - y.lab <- expression(-log[10](italic(P))) - } - } else if(y.lab == "deltaDIC") { - lines$SIG <- -lines$SIG - y.lab <- "-\U0394 DIC" - } - - # Filter group - if(!is.null(lgs.id)){ - lines <- lines[which(lines$LGS %in% lgs.id),] - points <- points[which(points$LGS %in% lgs.id),] - } - - # Interval - lines$INT <- NA - for(i in 1:dim(points)[1]){ - idx <- which(lines$POS >= points$INF[i] & - lines$POS <= points$SUP[i] & - lines$LGS == points$LGS[i] & - lines$TRT == points$TRT[i]) - lines$INT[idx] <- lines$POS[idx] - } - # Filter position - lines$range <- NA - if(!is.null(range.min)){ - lines$range[which(lines$POS >= range.min & lines$POS <= range.max)] <- lines$SIG[which(lines$POS >= range.min & lines$POS <= range.max)] - lines$SIG[which(lines$POS > range.min & lines$POS < range.max)] <- NA - } - - if(dim(points)[1] > 0){ - dot.height <- data.frame(trt = unique(points$TRT), heigth = unique(points$y.dat)) - y.dat.lines <- dot.height$heigth[match(lines$TRT, dot.height$trt)] - lines$y.dat <- y.dat.lines - colnames(points)[1:3] <- c("Trait", "LG", "Position (cM)") - } else lines$y.dat <- NA - - colnames(lines) <- c("Trait", "LG", "Position (cM)", "SIG", "INT", "range","y.dat") - - if(max(lgs.size[lgs.id]) > 200) cutx <- 150 else cutx <- 100 - if(length(lgs.size[lgs.id]) > 10) {linesize <- 1} else {cutx <- 50; linesize <- 1.25} - - lines$y.dat <- lines$y.dat + min(lines$SIG, na.rm = T) - points$y.dat <- points$y.dat + min(lines$SIG, na.rm = T) - - scale.max <- round(max(lines$SIG[which(is.finite(lines$SIG))], na.rm = T),0) - scale.max <- scale.max*1.2 - scale.min <- round(min(lines$SIG[which(is.finite(lines$SIG))], na.rm = T),0) - - if(scale.max > 50) { - lines$y.dat <- lines$y.dat*3 - points$y.dat <- points$y.dat*3 - scale.each <- 10 - } else scale.each = 2 - if(plot){ - if(by_range){ - pl <- ggplot(data = lines, aes(x = `Position (cM)`, color = Trait)) + - facet_grid(.~LG, space = "free") + - {if(!all(is.na(lines$INT))) geom_path(data=lines, aes(x = INT, y = y.dat), colour = "black", na.rm = TRUE)} + - geom_line(data=lines, aes(y = range, color = Trait), linewidth=linesize, alpha=0.8, lineend = "round", na.rm = TRUE) + - geom_line(data=lines, aes(y = SIG, group = Trait), colour = "gray", linewidth=linesize, alpha=0.8, lineend = "round", na.rm = TRUE) + - scale_x_continuous(breaks=seq(0,max(lgs.size),cutx)) + - {if(dim(points)[1] > 0) geom_point(data=points, aes(y = y.dat, color = Trait), shape = 2, size = 2, stroke = 1, alpha = 0.8)} + - scale_y_continuous(breaks=seq(scale.min, scale.max,scale.each)) + - guides(color = guide_legend("Trait")) + - labs(y = y.lab, x = "Position (cM)", subtitle="Linkage group") + - theme_classic() + theme(plot.margin = margin(0.8,1,1.5,1.2, "cm")) - } else { - pl <- ggplot(data = lines, aes(x = `Position (cM)`, color = Trait, group=1)) + - facet_grid(.~LG, space = "free") + - {if(!all(is.na(lines$INT))) geom_path(data=lines, aes(x = INT, y =y.dat), colour = "black", na.rm = TRUE)} + - geom_line(data=lines, aes(y = SIG, color = Trait), linewidth=linesize, alpha=0.8, lineend = "round", na.rm = TRUE) + - scale_x_continuous(breaks=seq(0,max(lgs.size),cutx)) + - {if(dim(points)[1] > 0) geom_point(data=points, aes(y = y.dat, color = Trait), shape = 2, size = 2, stroke = 1, alpha = 0.8)} + - scale_y_continuous(breaks=seq(scale.min, scale.max, scale.each)) + - guides(color = guide_legend("Trait")) + - labs(y = y.lab, x = "Position (cM)", subtitle="Linkage group") + - theme_classic() - } - } else { - pl <- list(lines = lines, points =points, linesize = linesize, - cutx = cutx, y.lab = y.lab) - - size <- table(pl$lines$Trait)[1] - pl$lines$x <- rep(1:size, length(table(pl$lines$Trait))) - pl$lines$x.int <- NA - pl$lines$x.int[which(!is.na(pl$lines$INT))] <- pl$lines$x[which(!is.na(pl$lines$INT))] - - if(dim(points)[1] > 0){ - all <- paste0(pl$lines$Trait, "_", round(pl$lines$`Position (cM)`,2), "_", pl$lines$LG) - point <- paste0(pl$points$Trait, "_", round(pl$points$`Position (cM)`,2), "_", pl$points$LG) - pl$points$x <- pl$lines$x[match(point, all)] - } - - pl$lines$SIG[which(pl$lines$SIG == "Inf")] <- NA ## Bugfix!!! - } - return(pl) -} - -#' Only the plot part of plot_profile function -#' -#' @param pl.in output object from \code{plot_profile} when plot == TRUE -#' -#' @return ggplot graphic with QTL significance profile -#' -#' -#' @keywords internal -only_plot_profile <- function(pl.in){ - x <- x.int <- y.dat <- SIG <- Trait <- qtl <- NULL - - vlines <- split(pl.in$lines$x, pl.in$lines$LG) - vlines <- sapply(vlines, function(x) x[1]) - - pl <- ggplot(data = pl.in$lines, aes(x = x)) + - {if(!all(is.na( pl.in$lines$INT))) geom_path(data= pl.in$lines, aes(x = x.int, y =y.dat), colour = "black", na.rm = TRUE)} + - geom_line(data=pl.in$lines, aes(y = SIG, color = Trait), linewidth=pl.in$linesize, alpha=0.8) + - #guides(color = guide_legend("Trait")) + - {if(dim(pl.in$points)[1] > 0) geom_point(data=pl.in$points, aes(y = y.dat, color = Trait), shape = 2, size = 2, stroke = 1, alpha = 0.8)} + - {if(length(vlines) > 1) geom_vline(xintercept=vlines, linetype="dashed", linewidth=.5, alpha=0.8, na.rm = TRUE)} + #threshold - labs(y = pl.in$y.lab, x = "Linkage group") + - annotate(x=vlines,y=+Inf,label= paste0("LG", names(vlines)),vjust=1, hjust= -0.1,geom="label") + - ylim(c(min(pl.in$lines$y.dat),max(pl.in$lines$SIG, na.rm = T) + 3)) + - theme_classic() + theme(axis.text.x=element_blank(), - axis.ticks.x=element_blank()) - - return(pl) -} - -#' Get effects information -#' -#' @param qtl_info data.frame with: LG - linkage group ID; Pos - position in linkage map (cM); -#' Pheno - phenotype ID; Pos_lower - lower position of confidence interval; -#' Pos_upper - upper position of the confidence interval; Pval - QTL p-value; h2 - herdability -#' @param effects data.frame with: pheno - phenotype ID; qtl.id - QTL ID; haplo - haplotype ID; effect - haplotype effect value -#' @param pheno.col integer identifying phenotype -#' @param parents vector with parents ID -#' @param lgs vector of integers with linkage group ID of selected QTL/s -#' @param groups vector of integers with selected linkage group ID -#' @param position vector of centimorgan positions of selected QTL/s -#' @param software character defining which software was used for QTL analysis. Currently support for: QTLpoly, diaQTL and polyqtlR. -#' @param design character defining the graphic design. Options: `bar` - barplot of the effects; -#' `circle` - circular plot of the effects (useful to compare effects of different traits); -#' `digenic` - heatmap plotting sum of additive effects (bottom diagonal) and digenic effects (top diagonal) when present -#' -#' @return ggplot graphic -#' -#' -#' @importFrom tidyr pivot_longer -#' @importFrom dplyr filter `%>%` -#' @import ggplot2 -#' -#' @keywords internal -data_effects <- function(qtl_info, effects, pheno.col = NULL, - parents = NULL, - lgs = NULL, groups = NULL, position = NULL, - software, design = c("bar", "circle", "digenic")) { - - - CI.lower <- CI.upper <- x <- y <- z <- Estimates <- LG <- unique.id <- NULL - x.axis <- haplo <- effect <- qtl.id <- Alleles <- . <- NULL - - if(is.null(pheno.col)) { - pheno.col.n <- 1:length(unique(qtl_info$pheno)) - } else { - pheno.col.n <- which(unique(qtl_info$pheno) %in% pheno.col) - } - - - if(software == "QTLpoly" | software == "diaQTL"){ - - if(software == "QTLpoly"){ - ploidy <- max(nchar(effects$haplo)) - if(is.null(parents)) {# Multi-population still not implemented - parents <- c("P1", "P2") - } - - if(ploidy == 4){ - p1_old <- c("a","b","c","d") - p2_old <- c("e","f","g", "h") - } else if(ploidy == 6){ - p1_old <- c("a","b","c","d","e","f") - p2_old <- c("g", "h","i", "j","k","l") - } - - duo <- expand.grid(c(p1_old, p2_old), c(p1_old, p2_old)) - duo <- apply(duo, 1, function(x) paste0(sort(unique(x)),collapse = "")) - duo <- unique(duo) - - p1 <- parents[1] - p2 <- parents[2] - p1_new <- paste0(p1,".",1:ploidy) - p2_new <- paste0(p2,".",1:ploidy) - - duo_new <- expand.grid(c(p1_new, p2_new), c(p1_new, p2_new)) - duo_new <- apply(duo_new, 1, function(x) paste0(sort(unique(x)),collapse = "x")) - duo_new <- unique(duo_new) - - names(duo_new) <- duo - - } else if(software == "diaQTL") { - get.size <- filter(effects, .data$pheno == unique(qtl_info$pheno)[1] & .data$qtl.id == 1 & !grepl("x",.data$haplo)) # issue if parents name has x: fixme! - ploidy = as.numeric(table(substring(unique(get.size$haplo), 1, nchar(unique(get.size$haplo)) -2))[1]) - - old.parents.names <- unique(substr(get.size$haplo,1,nchar(get.size$haplo)-2)) - n.parents <- length(old.parents.names) - if(is.null(parents)) { - parents <- paste0("P", 1:n.parents) - } else { - if(length(parents) != n.parents) - stop(safeError(paste0("Your data set has", n.parents, " parental genotyopes. Please, provide a name for each one."))) - } - - # Update parents names in effects data - for(z in 1:n.parents) - effects$haplo <- gsub(old.parents.names[z], parents[z], effects$haplo) - } else if(software == "polyqtlR"){ - ploidy <- (dim(effects)[2] - 3)/2 - if(is.null(parents)) {# Multi-population still not implemented - p1 <- "P1" - p2 <- "P2" - } else { - p1 <- parents[1] - p2 <- parents[2] - } - } - - qtl_info.sub <- qtl_info %>% filter(.data$pheno %in% unique(qtl_info$pheno)[pheno.col.n]) %>% - filter(.data$Pos %in% position) %>% filter(.data$LG %in% lgs) - - total <- split(qtl_info, qtl_info$pheno) - total <- lapply(total, function(x) paste0(x[,1], "_", x[,2], "_", x[,5])) - total <- total[match(unique(qtl_info$pheno), names(total))] - - sub <- split(qtl_info.sub, qtl_info.sub$pheno) - sub <- lapply(sub, function(x) paste0(x[,1], "_", x[,2], "_", x[,5])) - - sub <- sub[order(match(names(sub), pheno.col))] - - group.idx <- list() - for(i in 1:length(pheno.col.n)){ - idx <- match(names(sub)[i], names(total)) - group.idx[[idx]] <- match(sub[[i]], total[[idx]]) - } - - plots2 <- all.additive <- list() - count <- count.p <- 1 - for(p in pheno.col.n) { - effects.sub <- effects %>% filter(.data$pheno == unique(qtl_info$pheno)[p]) %>% - filter(.data$qtl.id %in% group.idx[[p]]) - nqtl <- length(unique(effects.sub$qtl.id)) - if(nqtl > 0) { - plots1 <- list() - count.q <- 1 - for(q in group.idx[[p]]) { - data <- filter(effects.sub, qtl.id == q) - if(ploidy == 4) { - if(software == "diaQTL"){ - if(any(data$type == "Digenic")){ - data <- data.frame(Estimates=as.numeric(data$effect), CI.lower = data$CI.lower, CI.upper = data$CI.upper, Alleles=data$haplo, Parent=c(rep(parents, each = ploidy),rep(NA,dim(data)[1]-n.parents*ploidy)), Effects=c(rep("Additive",n.parents*ploidy),rep("Digenic",dim(data)[1]-n.parents*ploidy))) - } else { - data <- data.frame(Estimates=as.numeric(data$effect), CI.lower = data$CI.lower, CI.upper = data$CI.upper, Alleles=data$haplo, Parent=rep(parents, each = ploidy), Effects="Additive") - } - } else { - data <- data[1:36,] - data <- data.frame(Estimates=as.numeric(data$effect), Alleles=data$haplo, Parent=c(rep(p1,4),rep(p2,4),rep(p1,14),rep(p2,14)), Effects=c(rep("Additive",8),rep("Digenic",28))) - data$Alleles <- duo_new[match(data$Alleles, names(duo_new))] - } - } else if(ploidy == 6) { - #data <- data[-c(18:23,28:33,37:42,45:50,52:63,83:88,92:97,100:105,107:133,137:142,145:150,152:178,181:186,188:214,216:278,299:1763),] # fix me - data <- data[1:78,] - data <- data.frame(Estimates=as.numeric(data$effect), Alleles=data$haplo, Parent=c(rep(p1,6),rep(p2,6),rep(p1,33),rep(p2,33)), Effects=c(rep("Additive",12),rep("Digenic",66))) - data$Alleles <- duo_new[match(data$Alleles, names(duo_new))] - } - data$Parent <- factor(data$Parent, levels=unique(data$Parent)) - if(design == "bar"){ - if(software == "QTLpoly"){ - lim <- max(abs(data[which(data$Effects == "Additive"),]$Estimates)) - } else - lim <- max(abs(c(data[which(data$Effects == "Additive"),]$CI.lower, data[which(data$Effects == "Additive"),]$CI.upper))) - plot <- ggplot(data[which(data$Effects == "Additive"),], aes(x = Alleles, y = Estimates, fill = Estimates)) + - geom_bar(stat="identity") + ylim(c(-lim, lim)) + - {if(software == "diaQTL") geom_errorbar(aes(ymin=CI.lower, ymax=CI.upper), width=.2, position=position_dodge(.9))} + - scale_fill_gradient2(low = "red", high = "blue", guide = "none") + - labs(title=unique(qtl_info$pheno)[p], subtitle=paste("LG:", sapply(strsplit(sub[[count.p]][count.q], "_"), "[",1), - "Pos:", sapply(strsplit(sub[[count.p]][count.q], "_"), "[",2))) + - facet_wrap(. ~ Parent, scales="free_x", ncol = 2, strip.position="bottom") + - theme_minimal() + - theme(plot.title = element_text(hjust = 0.5), - plot.subtitle = element_text(hjust = 0.5), - axis.text.x.bottom = element_text(hjust = 1, vjust = 0.5, angle = 90)) - plots1[[q]] <- plot - - } else if(design == "digenic"){ - if(!all(is.na(data[which(data$Effects == "Digenic"),]$Estimates))){ - temp <- do.call(rbind, strsplit(data$Alleles, "x")) - data$x <- temp[,1] - data$y <- temp[,2] - digenic.effects <- data[which(data$Effects == "Digenic"),] - additive.effects <- data[which(data$Effects == "Additive"),] - if(software == "QTLpoly") { - plot.data <- data.frame(x= c(digenic.effects$y), - y= c(digenic.effects$x), - z= c(additive.effects$Estimates[match(digenic.effects$x, additive.effects$Alleles)] + - additive.effects$Estimates[match(digenic.effects$y, additive.effects$Alleles)])) - } else { - plot.data <- data.frame(x= c(digenic.effects$x, digenic.effects$y), - y= c(digenic.effects$y, digenic.effects$x), - z= c(digenic.effects$Estimates, digenic.effects$Estimates+ - additive.effects$Estimates[match(digenic.effects$x, additive.effects$Alleles)] + - additive.effects$Estimates[match(digenic.effects$y, additive.effects$Alleles)])) - } - - plot = ggplot(data= plot.data,aes(x= x, y= y, fill= z)) + - geom_tile() + scale_fill_gradient2(name="") + - labs(title = paste("Trait:", unique(qtl_info$pheno)[p]), - subtitle = paste("LG:", sapply(strsplit(sub[[count.p]][count.q], "_"), "[",1), - "Pos:", sapply(strsplit(sub[[count.p]][count.q], "_"), "[",2))) + - theme_bw() + xlab("") + ylab("") + - theme(text = element_text(size=13),axis.text.x = element_text(angle = 90,vjust=0.5,hjust=1)) + - coord_fixed(ratio=1) - plots1[[q]] <- plot - } else plots1[[q]] <- NULL - - } else if(design == "circle"){ - additive.effects <- data[which(data$Effects == "Additive"),] - additive.effects$pheno <- unique(qtl_info$pheno)[p] - additive.effects$qtl_id <- q - additive.effects$LG <- qtl_info.sub$LG[count] - additive.effects$Pos <- qtl_info.sub$Pos[count] - additive.effects$Estimates <- additive.effects$Estimates/max(abs(additive.effects$Estimates)) # normalize to be between -1 and 1 - all.additive[[count]] <- additive.effects - names(all.additive)[count] <- unique(additive.effects$LG) - count <- count + 1 - plots1 <- NULL - } - count.q <- count.q + 1 - } - plots2[[p]] <- plots1 - } - count.p <- count.p + 1 - } - - if(design != "circle"){ - p <- unlist(plots2, recursive = F) - nulls <- which(sapply(p, is.null)) - if(length(nulls) > 0) p <- p[-nulls] - return(p) - } else { - all.additive <- lapply(all.additive, function(x) rbind(x, x[1,])) - all.additive <- do.call(rbind, all.additive) - all.additive$unique.id <- paste0(all.additive$pheno, "/ LG:", all.additive$LG, "/ Pos:", all.additive$Pos) - breaks <- c(-1,0,1) - lgs <- unique(all.additive$LG) - p <- list() - for(i in 1:length(lgs)){ - p[[i]] <- all.additive %>% filter(LG == lgs[i]) %>% - ggplot(aes(x=Alleles, y=Estimates, group=unique.id, colour=unique.id, alpha = abs(Estimates))) + - geom_path(alpha =0.7, linewidth = 1.5) + - #geom_polygon(fill = NA, size =1, alpha = abs(data_temp$Estimates))+ - geom_point(size=5) + - coord_radar() + - labs(title = paste0("LG", lgs[i])) + - annotate(x= 0,y=c(-1.3,breaks), label= round(c(NA, breaks),2),geom="text", na.rm = TRUE) + - theme_bw() + - theme(axis.title.y=element_blank(), - axis.text.y=element_blank(), - axis.ticks.y=element_blank(), - axis.title.x=element_blank(), - legend.title = element_blank()) + guides(alpha = "none") - } - return(p) - } - } else if(software == "polyqtlR"){ - if(design == "circle" | design == "digenic"){ - stop(safeError("Design option not available for: polyqtlR")) - } else { - effects.df <- effects %>% filter(.data$pheno %in% unique(qtl_info$pheno)[pheno.col.n]) %>% - filter(.data$LG %in% groups) %>% pivot_longer(cols = 4:ncol(.), names_to = "haplo", values_to = "effect") - - effects.df <- effects.df %>% group_by(.data$haplo, .data$pheno) %>% mutate(x.axis = 1:n()) %>% ungroup() %>% as.data.frame() - - vlines <- split(effects.df$x.axis, effects.df$LG) - vlines <- sapply(vlines, function(x) x[1]) - - p <- list() - for(i in 1:length(pheno.col.n)){ - p[[i]] <- effects.df %>% filter(.data$pheno == unique(qtl_info$pheno)[pheno.col.n][i]) %>% - ggplot() + - geom_path(aes(x=x.axis, y=haplo, col = effect), linewidth = 5) + - scale_color_gradient2(low = "purple4", mid = "white",high = "seagreen") + - {if(length(vlines) > 1) geom_vline(xintercept=vlines, linetype="dashed", linewidth=.5, alpha=0.8, na.rm = TRUE)} + - labs(y = "Haplotype", x = "Linkage group", title = unique(qtl_info$pheno)[pheno.col.n][i]) + - annotate(x=vlines,y=+Inf,label= paste0("LG", names(vlines)),vjust= 1, hjust= -0.1,geom="label") + - coord_cartesian(ylim = c(1,8.5)) + - theme_classic() + theme(axis.text.x=element_blank(), - axis.ticks.x=element_blank(), legend.title = element_blank()) - } - return(p) - } - } -} - -#' Change ggplot coordinates to plot radar - From package see -#' -#' @param theta ariable to map angle to (x or y) -#' @param start offset of starting point from 12 o'clock in radians. Offset is applied clockwise or anticlockwise depending on value of direction. -#' @param direction 1, clockwise; -1, anticlockwise -#' -#' -#' @keywords internal -coord_radar <- function (theta = "x", start = 0, direction = 1) { - theta <- match.arg(theta, c("x", "y")) - r <- if (theta == "x") "y" else "x" - ggproto("CordRadar", CoordPolar, theta = theta, r = r, start = start, - direction = sign(direction), - is_linear = function(coord) TRUE) -} - -#' Plot effects data -#' -#' @param data_effects.obj output of function \code{data_effects} -#' @param software character defining which software was used for QTL analysis. Currently support for: QTLpoly, diaQTL and polyqtlR. -#' @param design character defining the graphic design. Options: `bar` - barplot of the effects; -#' `circle` - circular plot of the effects (useful to compare effects of different traits); -#' `digenic` - heatmap plotting sum of additive effects (bottom diagonal) and digenic effects (top diagonal) when present -#' -#' -#' @keywords internal -plot_effects <- function(data_effects.obj, software, - design = c("bar", "circle", "digenic")){ - - if(software == "polyqtlR"){ - p.t <- ggarrange(plotlist = data_effects.obj, common.legend = T, ncol = 1, legend = "right") - } else { - if(design == "circle"){ - rows <- ceiling(length(data_effects.obj)/2) - if(rows == 0) rows <- 1 - p.t <- ggarrange(plotlist = data_effects.obj, nrow = rows, ncol = 2) - } else { - rows <- ceiling(length(data_effects.obj)/4) - if(rows == 0) rows <- 1 - p.t <- ggarrange(plotlist = data_effects.obj, nrow = rows, ncol = 4) - } - } - return(p.t) -} - -#' Estimate breeding values - Adapted function from QTLpoly -#' -#' @param qtl_info data.frame with: LG - linkage group ID; Pos - position in linkage map (cM); -#' Pheno - phenotype ID; Pos_lower - lower position of confidence interval; -#' Pos_upper - upper position of the confidence interval; Pval - QTL p-value; h2 - herdability -#' @param probs data.frame with first column (named `ind`) as individuals ID and next columns -#' named with markers ID and containing the genotype probability at each marker -#' @param selected_mks data.frame with: LG - linkage group ID; mk - marker ID; pos - position in linkage map (cM) -#' @param blups data.frame with: haplo - haplotype ID; pheno - phenotype ID; qtl - QTL ID; u.hat - QTL estimated BLUPs -#' @param beta.hat data.frame with: pheno - phenotype ID; beta.hat - estimated beta -#' @param pos selected QTL position (cM) -#' -#' @return data.frame containing breeding values -#' -#' @import dplyr -#' -#' -#' @keywords internal -breeding_values <- function(qtl_info, probs, selected_mks, blups, beta.hat, pos) { - - pheno.names <- unique(as.character(qtl_info$pheno)) - results <- vector("list", length(pheno.names)) - names(results) <- pheno.names - - # possible to index individuals - phenos <- which(pheno.names %in% names(pos)) - for(p in phenos) { # select pheno - nqtl <- length(pos[[pheno.names[p]]]) - infos <- filter(qtl_info, .data$pheno == pheno.names[p]) - infos <- infos[which(infos$Pos %in% pos[[pheno.names[p]]]),] - markers <- which((round(selected_mks$pos,2) %in% infos$Pos) & (selected_mks$LG %in% infos$LG)) - Z <- probs[,markers,] # select by pos - u.hat <- filter(blups, .data$pheno == pheno.names[p]) - u.hat <- split(u.hat$u.hat, u.hat$qtl) - - beta.hat.sub <- filter(beta.hat, .data$pheno == pheno.names[p]) - beta.hat.v <- beta.hat.sub$beta.hat - - Zu <- vector("list", nqtl) - if(nqtl > 1) { - for(m in 1:nqtl) { - Zu[[m]] <- t(Z[,m,]) %*% u.hat[[m]] - } - nind <- dim(Z)[3] - y.hat <- matrix(rep(beta.hat.v, nind), byrow = FALSE) + Reduce("+", Zu) - } else if(nqtl == 1) { - Zu <- t(Z) %*% u.hat[[1]] - nind <- dim(Z)[2] - y.hat <- matrix(rep(beta.hat.v, nind), byrow = FALSE) + Zu - } - - colnames(y.hat) <- pheno.names[p] - results[[p]] <- round(y.hat,2) - } - - id.names <- rownames(results[[which(sapply(results, function(x) !is.null(x)))[1]]]) - results <- as.data.frame(do.call(cbind, results)) - results <- cbind(gen=id.names, results) - - return(results) -} - -#' Calculates homologues probabilities - Adapted from MAPpoly -#' -#' @param probs data.frame with first column (named `ind`) as individuals ID and next columns named with markers ID and containing the genotype probability at each marker -#' @param selected_mks data.frame with: LG - linkage group ID; mk - marker ID; pos - position in linkage map (cM) -#' @param selected_lgs vector containing selected LGs ID -#' -#' @return object of class \code{mappoly.homoprob} -#' -#' -#' @importFrom reshape2 melt -#' @importFrom dplyr filter -#' -#' @keywords internal -calc_homologprob <- function(probs, selected_mks, selected_lgs){ - input.genoprobs <- probs - each.split <- vector() - sizes <- table(selected_mks$LG) - probs.b <- probs - input.genoprobs <- list() - for(i in 1:length(sizes)){ - input.genoprobs[[i]] <- probs.b[,1:sizes[i],] - probs.b <- probs.b[,-c(1:sizes[i]),] - } - - lgs <- as.numeric(unique(selected_lgs)) - input.genoprobs <- input.genoprobs[sort(lgs)] - selected_mks_lg <- filter(selected_mks, .data$LG %in% lgs) - - pos <- split(selected_mks_lg$pos, selected_mks_lg$LG) - df.res <- NULL - for(j in 1:length(input.genoprobs)){ - stt.names <- dimnames(input.genoprobs[[j]])[[1]] ## state names - mrk.names <- dimnames(input.genoprobs[[j]])[[2]] ## mrk names - ind.names <- dimnames(input.genoprobs[[j]])[[3]] ## individual names - v <- c(2,4,6,8,10,12) - names(v) <- choose(v,v/2)^2 - ploidy <- v[as.character(length(stt.names))] - hom.prob <- array(NA, dim = c(ploidy*2, length(mrk.names), length(ind.names))) - dimnames(hom.prob) <- list(letters[1:(2*ploidy)], mrk.names, ind.names) - for(i in letters[1:(2*ploidy)]) - hom.prob[i,,] <- apply(input.genoprobs[[j]][grep(stt.names, pattern = i),,], c(2,3), function(x) round(sum(x, na.rm = TRUE),4)) - df.hom <- melt(hom.prob) - map <- data.frame(map.position = pos[[j]], marker = mrk.names) - colnames(df.hom) <- c("homolog", "marker", "individual", "probability") - df.hom <- merge(df.hom, map, sort = FALSE) - df.hom$LG <- names(pos)[j] - df.res <- rbind(df.res, df.hom) - } - if(ploidy == 4){ - df.res$homolog <- gsub("a", paste0("P1.1_"), df.res$homolog) - df.res$homolog <- gsub("b", paste0("P1.2_"), df.res$homolog) - df.res$homolog <- gsub("c", paste0("P1.3_"), df.res$homolog) - df.res$homolog <- gsub("d", paste0("P1.4_"), df.res$homolog) - df.res$homolog <- gsub("e", paste0("P2.1_"), df.res$homolog) - df.res$homolog <- gsub("f", paste0("P2.2_"), df.res$homolog) - df.res$homolog <- gsub("g", paste0("P2.3_"), df.res$homolog) - df.res$homolog <- gsub("h", paste0("P2.4_"), df.res$homolog) - df.res$homolog = substring(df.res$homolog,1, nchar(df.res$homolog)-1) - } else if(ploidy == 6){ - df.res$homolog <- gsub("a", paste0("P1.1_"), df.res$homolog) - df.res$homolog <- gsub("b", paste0("P1.2_"), df.res$homolog) - df.res$homolog <- gsub("c", paste0("P1.3_"), df.res$homolog) - df.res$homolog <- gsub("d", paste0("P1.4_"), df.res$homolog) - df.res$homolog <- gsub("e", paste0("P1.5_"), df.res$homolog) - df.res$homolog <- gsub("f", paste0("P1.6_"), df.res$homolog) - df.res$homolog <- gsub("g", paste0("P2.1_"), df.res$homolog) - df.res$homolog <- gsub("h", paste0("P2.2_"), df.res$homolog) - df.res$homolog <- gsub("i", paste0("P2.3_"), df.res$homolog) - df.res$homolog <- gsub("j", paste0("P2.4_"), df.res$homolog) - df.res$homolog <- gsub("k", paste0("P2.5_"), df.res$homolog) - df.res$homolog <- gsub("l", paste0("P2.6_"), df.res$homolog) - df.res$homolog = substring(df.res$homolog,1, nchar(df.res$homolog)-1) - } - structure(list(info = list(ploidy = ploidy, - n.ind = length(ind.names)) , - homoprob = df.res), class = "mappoly.homoprob") -} - -#' Plots mappoly.homoprob from MAPpoly -#' -#' @param x an object of class \code{mappoly.homoprob} -#' -#' @param stack logical. If \code{TRUE}, probability profiles of all homologues -#' are stacked in the plot (default = FALSE) -#' -#' @param lg indicates which linkage group should be plotted. If \code{NULL} -#' (default), it plots the first linkage group. If -#' \code{"all"}, it plots all linkage groups -#' -#' @param ind indicates which individuals should be plotted. It can be the -#' position of the individuals in the dataset or it's name. -#' If \code{NULL} (default), the function plots the first -#' individual -#' -#' @param verbose if \code{TRUE} (default), the current progress is shown; if -#' \code{FALSE}, no output is produced -#' -#' @param ... unused arguments -#' -#' -#' @keywords internal -plot.mappoly.homoprob <- function(x, stack = FALSE, lg = NULL, - ind = NULL, - verbose = TRUE, ...){ - qtl <- NULL - - all.ind <- as.character(unique(x$homoprob$individual)) - #### Individual handling #### - if(length(ind) > 1){ - if (verbose) message("More than one individual provided: using the first one") - ind <- ind[1] - } - if(is.null(ind)){ - ind <- as.character(all.ind[1]) - df.pr1 <- subset(x$homoprob, individual == ind) - } else if(is.numeric(ind)) { - if(ind > length(all.ind)) - stop("Please chose an individual number between 1 and ", length(all.ind)) - ind <- as.character(all.ind[ind]) - df.pr1 <- subset(x$homoprob, individual == ind) - } else if (is.character(ind)){ - if(!ind%in%all.ind) - stop(safeError("Invalid individual name")) - } else stop(safeError("Invalid individual name")) - - #### LG handling #### - if(is.null(lg)) - lg <- 1 - if(all(lg == "all")) - lg <- unique(x$homoprob$LG) - LG <- individual <- map.position <- probability <- homolog <- NULL - if(length(lg) > 1 & !stack) - { - if (verbose) message("Using 'stack = TRUE' to plot multiple linkage groups") - stack <- TRUE - } - if(stack){ - ##subset linkage group - if(!is.null(lg)){ - df.pr1 <- subset(x$homoprob, LG%in%lg) - df.pr1 <- subset(df.pr1, individual == ind) - } else - df.pr1 <- subset(x$homoprob, individual == ind) - p <- ggplot(df.pr1, aes(x = map.position, y = probability, fill = homolog, color = homolog)) + - geom_density(stat = "identity", alpha = 0.7, position = "stack") + - ggtitle(ind) + - facet_grid(rows = vars(LG)) + - ylab(label = "Homologs probabilty") + - xlab(label = "Map position") + - geom_vline(data = df.pr1, aes(xintercept = qtl), linetype="dashed", na.rm = TRUE) + - theme_minimal() - } else { - ##subset linkage group - if(is.null(lg)){ - lg <- 1 - df.pr1 <- subset(x$homoprob, LG %in% lg) - } else df.pr1 <- subset(x$homoprob, LG %in% lg) - df.pr1 <- subset(df.pr1, individual == ind) - p <- ggplot(df.pr1, aes(x = map.position, y = probability, fill = homolog, color = homolog)) + - geom_density(stat = "identity", alpha = 0.7) + - ggtitle(paste(ind, " LG", lg)) + - facet_grid(rows = vars(homolog)) + - theme_minimal() + - ylab(label = "Homologs probabilty") + - xlab(label = "Map position") + - geom_vline(data = df.pr1, aes(xintercept = qtl), linetype="dashed", na.rm = TRUE) - } - return(p) -} - -#' Plot selected haplotypes -#' -#' @param input.haplo character vector with selected haplotypes. It contains the information: "Trait:_LG:" -#' @param exclude.haplo character vector with haplotypes to be excluded. It contains the information: "Trait:_LG:" -#' @param probs data.frame with first column (named `ind`) as individuals ID and next columns named with markers ID and containing the genotype probability at each marker -#' @param selected_mks data.frame with: LG - linkage group ID; mk - marker ID; pos - position in linkage map (cM) -#' @param effects.data output object from \code{data_effects} function -#' -#' @return ggplot graphic -#' -#' @import dplyr tidyr -#' -#' @keywords internal -select_haplo <- function(input.haplo,probs, selected_mks, effects.data, exclude.haplo = NULL){ - LG <- map.position <- individual <- probability <- NULL - - include <- strsplit(unlist(input.haplo), "_") - if(!is.null(exclude.haplo)) exclude <- strsplit(unlist(exclude.haplo), "_") else exclude <- NULL - - lgs <- c(sapply(include, "[[", 2), sapply(exclude, "[[", 2)) - lgs <- gsub("LG:", "", unique(lgs)) - - homo.dat <- calc_homologprob(probs = probs, selected_mks = selected_mks, selected_lgs = lgs) - data_match <- paste0("LG:",homo.dat$homoprob$LG, "_Pos:", - round(homo.dat$homoprob$map.position,0), - "_homolog:", homo.dat$homoprob$homolog) - - # Include haplo - include <- sapply(include, function(x) paste0(x[-1], collapse = "_")) - - subset <- homo.dat$homoprob[which(data_match %in% include),] - subset <- subset[which(subset$probability > 0.5),] - - counts <- subset %>% group_by(individual) %>% summarise(n = n()) - selected <- counts$individual[counts$n == length(input.haplo)] - - if(length(selected) == 0) stop("None of the inviduals have these combination of haplotypes") - - # Exclude haplo - if(!is.null(exclude.haplo)){ - exclude <- sapply(exclude, function(x) paste0(x[-1], collapse = "_")) - - subset <- homo.dat$homoprob[which(data_match %in% exclude),] - subset <- subset[which(subset$probability > 0.5),] - - selected <- selected[-which(selected %in% unique(subset$individual))] - } - - if(length(selected) == 0) stop("None of the inviduals have these combination of haplotypes") - - dashline <- strsplit(c(unlist(input.haplo), unlist(exclude.haplo)), "_") - dashline <- sapply(dashline, function(x) paste0(x[-c(1,4)], collapse = "_")) - - data_match <- sapply(strsplit(data_match, "_"), function(x) paste0(x[-length(x)], collapse = "_")) - - homo.dat$homoprob$qtl <- NA - homo.dat$homoprob$qtl[which(data_match %in% dashline)] <- homo.dat$homoprob$map.position[which(data_match %in% dashline)] - - p <- list() - for(i in 1:length(selected)){ - p[[i]] <- plot.mappoly.homoprob(x = homo.dat, - lg = unique(as.numeric(lgs)), - ind = as.character(selected)[i], - use.plotly = FALSE) - } - return(list(p, inds = as.character(selected))) -} - +#' Logarithm of \emph{P}-value (LOP) profile plots. Modified version of QTLpoly function. +#' +#' Plots profiled logarithm of score-based \emph{P}-values (LOP) from individual or combined traits. +#' +#' @param profile data.frame with: pheno - phenotype ID; LOP - significance value for the QTL. +#' It can be LOP, LOD or DIC depending of the software used +#' @param qtl_info data.frame with: LG - linkage group ID; Pos - position in linkage map (cM); +#' Pheno - phenotype ID; Pos_lower - lower position of confidence interval; +#' Pos_upper - upper position of the confidence interval; Pval - QTL p-value; h2 - herdability +#' @param selected_mks data.frame with: LG - linkage group ID; mk - marker ID; pos - position in linkage map (cM) +#' @param pheno.col integer identifying phenotype +#' @param lgs.id integer identifying linkage group +#' @param by_range logical TRUE/FALSE. If TRUE range.min and range.max will set a colored window in the plot and the other positions will be gray. +#' If FALSE, range.min and range.max is ignored +#' @param range.min position in centimorgan defining the start of the colored window +#' @param range.max position in centimorgan defining the end of the colored window +#' @param plot logical TRUE/FALSE. If FALSE the function return a data.frame with information for \code{only_plot_profile} function. +#' If TRUE, it returns a ggplot graphic. +#' @param software character defining which software was used for QTL analysis. Currently support for: QTLpoly, diaQTL and polyqtlR. +#' +#' @import ggplot2 +#' @import dplyr +#' @importFrom plotly TeX +#' @importFrom utils tail +#' +#' @return ggplot graphic (if plot == TRUE) or data.frame (if plot == FALSE) with information +#' from QTL significance profile +#' +#' @keywords internal +plot_profile <- function(profile, qtl_info, selected_mks, pheno.col = NULL, + lgs.id = NULL, by_range = TRUE, range.min = NULL, + range.max = NULL, plot=TRUE, software = NULL) { + + pheno <- LG <- `Position (cM)` <- Trait <- INT <- . <- NULL + + lgs.size <- selected_mks %>% group_by(.data$LG) %>% group_map(~ tail(.x, 1)) %>% do.call(rbind, .) + lgs.size <- lgs.size$pos + lines <- points <- thre <- map <- data.frame() + y.dat <- trait.names <- c() + count <- 0 + + nphe <- length(pheno.col) + LGS <- selected_mks$LG + POS <- selected_mks$pos + for(p in 1:nphe) { #lines + TRT <- rep(unique(profile$pheno)[pheno.col[p]], length(LGS)) + SIG <- profile[which(profile$pheno == TRT),2] + lines <- rbind(lines, data.frame(TRT=as.factor(TRT), LGS=LGS, POS=POS, SIG=SIG)) + } + count <- 0 + y.dat <- c() + for(p in 1:nphe) { #points + trait.names <- unique(profile$pheno)[pheno.col[p]] + if(!is.null(qtl_info)) { + qtl_info.sub <- qtl_info %>% filter(pheno == trait.names) %>% filter(LG %in% lgs.id) + if(dim(qtl_info.sub)[1] > 0){ + nqtls <- qtl_info.sub %>% summarize(n()) + TRT <- qtl_info.sub$pheno + LGS <- qtl_info.sub$LG + POS <- qtl_info.sub$Pos + INF <- qtl_info.sub$Pos_lower + SUP <- qtl_info.sub$Pos_upper + PVAL <- qtl_info.sub[,6] + H2 <- qtl_info.sub$h2 + if(!is.null(H2)){ + points <- rbind(points, data.frame(TRT=TRT, LGS=LGS, POS=POS, INF=INF, SUP=SUP, PVAL = PVAL, H2 = round(H2,2))) + } else + points <- rbind(points, data.frame(TRT=TRT, LGS=LGS, POS=POS, INF=INF, SUP=SUP, PVAL = PVAL)) + count <- count+1 + y.dat <- c(y.dat, rep((-0.5*count), nqtls)) + } + } + } + points <- cbind(points, y.dat) + # The axis name change according with software + y.lab <- colnames(profile)[2] + if(y.lab == "LOP") { + if(by_range){ + y.lab <- "LOP" + } else { + y.lab <- expression(-log[10](italic(P))) + } + } else if(y.lab == "deltaDIC") { + lines$SIG <- -lines$SIG + y.lab <- "-\U0394 DIC" + } + + # Filter group + if(!is.null(lgs.id)){ + lines <- lines[which(lines$LGS %in% lgs.id),] + points <- points[which(points$LGS %in% lgs.id),] + } + + # Interval + lines$INT <- NA + for(i in 1:dim(points)[1]){ + idx <- which(lines$POS >= points$INF[i] & + lines$POS <= points$SUP[i] & + lines$LGS == points$LGS[i] & + lines$TRT == points$TRT[i]) + lines$INT[idx] <- lines$POS[idx] + } + # Filter position + lines$range <- NA + if(!is.null(range.min)){ + lines$range[which(lines$POS >= range.min & lines$POS <= range.max)] <- lines$SIG[which(lines$POS >= range.min & lines$POS <= range.max)] + lines$SIG[which(lines$POS > range.min & lines$POS < range.max)] <- NA + } + + if(dim(points)[1] > 0){ + dot.height <- data.frame(trt = unique(points$TRT), heigth = unique(points$y.dat)) + y.dat.lines <- dot.height$heigth[match(lines$TRT, dot.height$trt)] + lines$y.dat <- y.dat.lines + colnames(points)[1:3] <- c("Trait", "LG", "Position (cM)") + } else lines$y.dat <- NA + + colnames(lines) <- c("Trait", "LG", "Position (cM)", "SIG", "INT", "range","y.dat") + + if(max(lgs.size[lgs.id]) > 200) cutx <- 150 else cutx <- 100 + if(length(lgs.size[lgs.id]) > 10) {linesize <- 1} else {cutx <- 50; linesize <- 1.25} + + lines$y.dat <- lines$y.dat + min(lines$SIG, na.rm = T) + points$y.dat <- points$y.dat + min(lines$SIG, na.rm = T) + + scale.max <- round(max(lines$SIG[which(is.finite(lines$SIG))], na.rm = T),0) + scale.max <- scale.max*1.2 + scale.min <- round(min(lines$SIG[which(is.finite(lines$SIG))], na.rm = T),0) + + if(scale.max > 50) { + lines$y.dat <- lines$y.dat*3 + points$y.dat <- points$y.dat*3 + scale.each <- 10 + } else scale.each = 2 + if(plot){ + if(by_range){ + pl <- ggplot(data = lines, aes(x = `Position (cM)`, color = Trait)) + + facet_grid(.~LG, space = "free") + + {if(!all(is.na(lines$INT))) geom_path(data=lines, aes(x = INT, y = y.dat), colour = "black", na.rm = TRUE)} + + geom_line(data=lines, aes(y = range, color = Trait), linewidth=linesize, alpha=0.8, lineend = "round", na.rm = TRUE) + + geom_line(data=lines, aes(y = SIG, group = Trait), colour = "gray", linewidth=linesize, alpha=0.8, lineend = "round", na.rm = TRUE) + + scale_x_continuous(breaks=seq(0,max(lgs.size),cutx)) + + {if(dim(points)[1] > 0) geom_point(data=points, aes(y = y.dat, color = Trait), shape = 2, size = 2, stroke = 1, alpha = 0.8)} + + scale_y_continuous(breaks=seq(scale.min, scale.max,scale.each)) + + guides(color = guide_legend("Trait")) + + labs(y = y.lab, x = "Position (cM)", subtitle="Linkage group") + + theme_classic() + theme(plot.margin = margin(0.8,1,1.5,1.2, "cm")) + } else { + pl <- ggplot(data = lines, aes(x = `Position (cM)`, color = Trait, group=1)) + + facet_grid(.~LG, space = "free") + + {if(!all(is.na(lines$INT))) geom_path(data=lines, aes(x = INT, y =y.dat), colour = "black", na.rm = TRUE)} + + geom_line(data=lines, aes(y = SIG, color = Trait), linewidth=linesize, alpha=0.8, lineend = "round", na.rm = TRUE) + + scale_x_continuous(breaks=seq(0,max(lgs.size),cutx)) + + {if(dim(points)[1] > 0) geom_point(data=points, aes(y = y.dat, color = Trait), shape = 2, size = 2, stroke = 1, alpha = 0.8)} + + scale_y_continuous(breaks=seq(scale.min, scale.max, scale.each)) + + guides(color = guide_legend("Trait")) + + labs(y = y.lab, x = "Position (cM)", subtitle="Linkage group") + + theme_classic() + } + } else { + pl <- list(lines = lines, points =points, linesize = linesize, + cutx = cutx, y.lab = y.lab) + + size <- table(pl$lines$Trait)[1] + pl$lines$x <- rep(1:size, length(table(pl$lines$Trait))) + pl$lines$x.int <- NA + pl$lines$x.int[which(!is.na(pl$lines$INT))] <- pl$lines$x[which(!is.na(pl$lines$INT))] + + if(dim(points)[1] > 0){ + all <- paste0(pl$lines$Trait, "_", round(pl$lines$`Position (cM)`,2), "_", pl$lines$LG) + point <- paste0(pl$points$Trait, "_", round(pl$points$`Position (cM)`,2), "_", pl$points$LG) + pl$points$x <- pl$lines$x[match(point, all)] + } + + pl$lines$SIG[which(pl$lines$SIG == "Inf")] <- NA ## Bugfix!!! + } + return(pl) +} + +#' Only the plot part of plot_profile function +#' +#' @param pl.in output object from \code{plot_profile} when plot == TRUE +#' +#' @return ggplot graphic with QTL significance profile +#' +#' +#' @keywords internal +only_plot_profile <- function(pl.in){ + x <- x.int <- y.dat <- SIG <- Trait <- qtl <- NULL + + vlines <- split(pl.in$lines$x, pl.in$lines$LG) + vlines <- sapply(vlines, function(x) x[1]) + + pl <- ggplot(data = pl.in$lines, aes(x = x)) + + {if(!all(is.na( pl.in$lines$INT))) geom_path(data= pl.in$lines, aes(x = x.int, y =y.dat), colour = "black", na.rm = TRUE)} + + geom_line(data=pl.in$lines, aes(y = SIG, color = Trait), linewidth=pl.in$linesize, alpha=0.8) + + #guides(color = guide_legend("Trait")) + + {if(dim(pl.in$points)[1] > 0) geom_point(data=pl.in$points, aes(y = y.dat, color = Trait), shape = 2, size = 2, stroke = 1, alpha = 0.8)} + + {if(length(vlines) > 1) geom_vline(xintercept=vlines, linetype="dashed", linewidth=.5, alpha=0.8, na.rm = TRUE)} + #threshold + labs(y = pl.in$y.lab, x = "Linkage group") + + annotate(x=vlines,y=+Inf,label= paste0("LG", names(vlines)),vjust=1, hjust= -0.1,geom="label") + + ylim(c(min(pl.in$lines$y.dat),max(pl.in$lines$SIG, na.rm = T) + 3)) + + theme_classic() + theme(axis.text.x=element_blank(), + axis.ticks.x=element_blank()) + + return(pl) +} + +#' Get effects information +#' +#' @param qtl_info data.frame with: LG - linkage group ID; Pos - position in linkage map (cM); +#' Pheno - phenotype ID; Pos_lower - lower position of confidence interval; +#' Pos_upper - upper position of the confidence interval; Pval - QTL p-value; h2 - herdability +#' @param effects data.frame with: pheno - phenotype ID; qtl.id - QTL ID; haplo - haplotype ID; effect - haplotype effect value +#' @param pheno.col integer identifying phenotype +#' @param parents vector with parents ID +#' @param lgs vector of integers with linkage group ID of selected QTL/s +#' @param groups vector of integers with selected linkage group ID +#' @param position vector of centimorgan positions of selected QTL/s +#' @param software character defining which software was used for QTL analysis. Currently support for: QTLpoly, diaQTL and polyqtlR. +#' @param design character defining the graphic design. Options: `bar` - barplot of the effects; +#' `circle` - circular plot of the effects (useful to compare effects of different traits); +#' `digenic` - heatmap plotting sum of additive effects (bottom diagonal) and digenic effects (top diagonal) when present +#' +#' @return ggplot graphic +#' +#' +#' @importFrom tidyr pivot_longer +#' @importFrom dplyr filter `%>%` +#' @import ggplot2 +#' +#' @keywords internal +data_effects <- function(qtl_info, effects, pheno.col = NULL, + parents = NULL, + lgs = NULL, groups = NULL, position = NULL, + software, design = c("bar", "circle", "digenic")) { + + + CI.lower <- CI.upper <- x <- y <- z <- Estimates <- LG <- unique.id <- NULL + x.axis <- haplo <- effect <- qtl.id <- Alleles <- . <- NULL + + if(is.null(pheno.col)) { + pheno.col.n <- 1:length(unique(qtl_info$pheno)) + } else { + pheno.col.n <- which(unique(qtl_info$pheno) %in% pheno.col) + } + + + if(software == "QTLpoly" | software == "diaQTL"){ + + if(software == "QTLpoly"){ + ploidy <- max(nchar(effects$haplo)) + if(is.null(parents)) {# Multi-population still not implemented + parents <- c("P1", "P2") + } + + if(ploidy == 2){ + p1_old <- c("a","b") + p2_old <- c("c","d") + } else if(ploidy == 4){ + p1_old <- c("a","b","c","d") + p2_old <- c("e","f","g", "h") + } else if(ploidy == 6){ + p1_old <- c("a","b","c","d","e","f") + p2_old <- c("g", "h","i", "j","k","l") + } + + duo <- expand.grid(c(p1_old, p2_old), c(p1_old, p2_old)) + duo <- apply(duo, 1, function(x) paste0(sort(unique(x)),collapse = "")) + duo <- unique(duo) + + p1 <- parents[1] + p2 <- parents[2] + p1_new <- paste0(p1,".",1:ploidy) + p2_new <- paste0(p2,".",1:ploidy) + + duo_new <- expand.grid(c(p1_new, p2_new), c(p1_new, p2_new)) + duo_new <- apply(duo_new, 1, function(x) paste0(sort(unique(x)),collapse = "x")) + duo_new <- unique(duo_new) + + names(duo_new) <- duo + + } else if(software == "diaQTL") { + get.size <- filter(effects, .data$pheno == unique(qtl_info$pheno)[1] & .data$qtl.id == 1 & !grepl("x",.data$haplo)) # issue if parents name has x: fixme! + ploidy = as.numeric(table(substring(unique(get.size$haplo), 1, nchar(unique(get.size$haplo)) -2))[1]) + + old.parents.names <- unique(substr(get.size$haplo,1,nchar(get.size$haplo)-2)) + n.parents <- length(old.parents.names) + if(is.null(parents)) { + parents <- paste0("P", 1:n.parents) + } else { + if(length(parents) != n.parents) + stop(safeError(paste0("Your data set has", n.parents, " parental genotyopes. Please, provide a name for each one."))) + } + + # Update parents names in effects data + for(z in 1:n.parents) + effects$haplo <- gsub(old.parents.names[z], parents[z], effects$haplo) + } else if(software == "polyqtlR"){ + ploidy <- (dim(effects)[2] - 3)/2 + if(is.null(parents)) {# Multi-population still not implemented + p1 <- "P1" + p2 <- "P2" + } else { + p1 <- parents[1] + p2 <- parents[2] + } + } + + qtl_info.sub <- qtl_info %>% filter(.data$pheno %in% unique(qtl_info$pheno)[pheno.col.n]) %>% + filter(.data$Pos %in% position) %>% filter(.data$LG %in% lgs) + + total <- split(qtl_info, qtl_info$pheno) + total <- lapply(total, function(x) paste0(x[,1], "_", x[,2], "_", x[,5])) + total <- total[match(unique(qtl_info$pheno), names(total))] + + sub <- split(qtl_info.sub, qtl_info.sub$pheno) + sub <- lapply(sub, function(x) paste0(x[,1], "_", x[,2], "_", x[,5])) + + sub <- sub[order(match(names(sub), pheno.col))] + + group.idx <- list() + for(i in 1:length(pheno.col.n)){ + idx <- match(names(sub)[i], names(total)) + group.idx[[idx]] <- match(sub[[i]], total[[idx]]) + } + + plots2 <- all.additive <- list() + count <- count.p <- 1 + for(p in pheno.col.n) { + effects.sub <- effects %>% filter(.data$pheno == unique(qtl_info$pheno)[p]) %>% + filter(.data$qtl.id %in% group.idx[[p]]) + nqtl <- length(unique(effects.sub$qtl.id)) + if(nqtl > 0) { + plots1 <- list() + count.q <- 1 + for(q in group.idx[[p]]) { + data <- filter(effects.sub, qtl.id == q) + if(ploidy == 2){ + if(software == "diaQTL"){ + if(any(data$type == "Digenic")){ + data <- data.frame(Estimates=as.numeric(data$effect), CI.lower = data$CI.lower, CI.upper = data$CI.upper, Alleles=data$haplo, Parent=c(rep(parents, each = ploidy),rep(NA,dim(data)[1]-n.parents*ploidy)), Effects=c(rep("Additive",n.parents*ploidy),rep("Digenic",dim(data)[1]-n.parents*ploidy))) + } else { + data <- data.frame(Estimates=as.numeric(data$effect), CI.lower = data$CI.lower, CI.upper = data$CI.upper, Alleles=data$haplo, Parent=rep(parents, each = ploidy), Effects="Additive") + } + } else { + data <- data[1:8,] + data <- data.frame(Estimates=as.numeric(data$effect), Alleles=data$haplo, Parent=c(rep(p1,2),rep(p2,2),rep(p1,2),rep(p2,2)), Effects=c(rep("Additive",4),rep("Digenic",4))) + data$Alleles <- duo_new[match(data$Alleles, names(duo_new))] + } + } else if(ploidy == 4) { + if(software == "diaQTL"){ + if(any(data$type == "Digenic")){ + data <- data.frame(Estimates=as.numeric(data$effect), CI.lower = data$CI.lower, CI.upper = data$CI.upper, Alleles=data$haplo, Parent=c(rep(parents, each = ploidy),rep(NA,dim(data)[1]-n.parents*ploidy)), Effects=c(rep("Additive",n.parents*ploidy),rep("Digenic",dim(data)[1]-n.parents*ploidy))) + } else { + data <- data.frame(Estimates=as.numeric(data$effect), CI.lower = data$CI.lower, CI.upper = data$CI.upper, Alleles=data$haplo, Parent=rep(parents, each = ploidy), Effects="Additive") + } + } else { + data <- data[1:36,] + data <- data.frame(Estimates=as.numeric(data$effect), Alleles=data$haplo, Parent=c(rep(p1,4),rep(p2,4),rep(p1,14),rep(p2,14)), Effects=c(rep("Additive",8),rep("Digenic",28))) + data$Alleles <- duo_new[match(data$Alleles, names(duo_new))] + } + } else if(ploidy == 6) { + #data <- data[-c(18:23,28:33,37:42,45:50,52:63,83:88,92:97,100:105,107:133,137:142,145:150,152:178,181:186,188:214,216:278,299:1763),] # fix me + data <- data[1:78,] + data <- data.frame(Estimates=as.numeric(data$effect), Alleles=data$haplo, Parent=c(rep(p1,6),rep(p2,6),rep(p1,33),rep(p2,33)), Effects=c(rep("Additive",12),rep("Digenic",66))) + data$Alleles <- duo_new[match(data$Alleles, names(duo_new))] + } + data$Parent <- factor(data$Parent, levels=unique(data$Parent)) + if(design == "bar"){ + if(software == "QTLpoly"){ + lim <- max(abs(data[which(data$Effects == "Additive"),]$Estimates)) + } else + lim <- max(abs(c(data[which(data$Effects == "Additive"),]$CI.lower, data[which(data$Effects == "Additive"),]$CI.upper))) + plot <- ggplot(data[which(data$Effects == "Additive"),], aes(x = Alleles, y = Estimates, fill = Estimates)) + + geom_bar(stat="identity") + ylim(c(-lim, lim)) + + {if(software == "diaQTL") geom_errorbar(aes(ymin=CI.lower, ymax=CI.upper), width=.2, position=position_dodge(.9))} + + scale_fill_gradient2(low = "red", high = "blue", guide = "none") + + labs(title=unique(qtl_info$pheno)[p], subtitle=paste("LG:", sapply(strsplit(sub[[count.p]][count.q], "_"), "[",1), + "Pos:", sapply(strsplit(sub[[count.p]][count.q], "_"), "[",2))) + + facet_wrap(. ~ Parent, scales="free_x", ncol = 2, strip.position="bottom") + + theme_minimal() + + theme(plot.title = element_text(hjust = 0.5), + plot.subtitle = element_text(hjust = 0.5), + axis.text.x.bottom = element_text(hjust = 1, vjust = 0.5, angle = 90)) + plots1[[q]] <- plot + + } else if(design == "digenic"){ + if(!all(is.na(data[which(data$Effects == "Digenic"),]$Estimates))){ + temp <- do.call(rbind, strsplit(data$Alleles, "x")) + data$x <- temp[,1] + data$y <- temp[,2] + digenic.effects <- data[which(data$Effects == "Digenic"),] + additive.effects <- data[which(data$Effects == "Additive"),] + if(software == "QTLpoly") { + plot.data <- data.frame(x= c(digenic.effects$y), + y= c(digenic.effects$x), + z= c(additive.effects$Estimates[match(digenic.effects$x, additive.effects$Alleles)] + + additive.effects$Estimates[match(digenic.effects$y, additive.effects$Alleles)])) + } else { + plot.data <- data.frame(x= c(digenic.effects$x, digenic.effects$y), + y= c(digenic.effects$y, digenic.effects$x), + z= c(digenic.effects$Estimates, digenic.effects$Estimates+ + additive.effects$Estimates[match(digenic.effects$x, additive.effects$Alleles)] + + additive.effects$Estimates[match(digenic.effects$y, additive.effects$Alleles)])) + } + + plot = ggplot(data= plot.data,aes(x= x, y= y, fill= z)) + + geom_tile() + scale_fill_gradient2(name="") + + labs(title = paste("Trait:", unique(qtl_info$pheno)[p]), + subtitle = paste("LG:", sapply(strsplit(sub[[count.p]][count.q], "_"), "[",1), + "Pos:", sapply(strsplit(sub[[count.p]][count.q], "_"), "[",2))) + + theme_bw() + xlab("") + ylab("") + + theme(text = element_text(size=13),axis.text.x = element_text(angle = 90,vjust=0.5,hjust=1)) + + coord_fixed(ratio=1) + plots1[[q]] <- plot + } else plots1[[q]] <- NULL + + } else if(design == "circle"){ + additive.effects <- data[which(data$Effects == "Additive"),] + additive.effects$pheno <- unique(qtl_info$pheno)[p] + additive.effects$qtl_id <- q + additive.effects$LG <- qtl_info.sub$LG[count] + additive.effects$Pos <- qtl_info.sub$Pos[count] + additive.effects$Estimates <- additive.effects$Estimates/max(abs(additive.effects$Estimates)) # normalize to be between -1 and 1 + all.additive[[count]] <- additive.effects + names(all.additive)[count] <- unique(additive.effects$LG) + count <- count + 1 + plots1 <- NULL + } + count.q <- count.q + 1 + } + plots2[[p]] <- plots1 + } + count.p <- count.p + 1 + } + + if(design != "circle"){ + p <- unlist(plots2, recursive = F) + nulls <- which(sapply(p, is.null)) + if(length(nulls) > 0) p <- p[-nulls] + return(p) + } else { + all.additive <- lapply(all.additive, function(x) rbind(x, x[1,])) + all.additive <- do.call(rbind, all.additive) + all.additive$unique.id <- paste0(all.additive$pheno, "/ LG:", all.additive$LG, "/ Pos:", all.additive$Pos) + breaks <- c(-1,0,1) + lgs <- unique(all.additive$LG) + p <- list() + for(i in 1:length(lgs)){ + p[[i]] <- all.additive %>% filter(LG == lgs[i]) %>% + ggplot(aes(x=Alleles, y=Estimates, group=unique.id, colour=unique.id, alpha = abs(Estimates))) + + geom_path(alpha =0.7, linewidth = 1.5) + + #geom_polygon(fill = NA, size =1, alpha = abs(data_temp$Estimates))+ + geom_point(size=5) + + coord_radar() + + labs(title = paste0("LG", lgs[i])) + + annotate(x= 0,y=c(-1.3,breaks), label= round(c(NA, breaks),2),geom="text", na.rm = TRUE) + + theme_bw() + + theme(axis.title.y=element_blank(), + axis.text.y=element_blank(), + axis.ticks.y=element_blank(), + axis.title.x=element_blank(), + legend.title = element_blank()) + guides(alpha = "none") + } + return(p) + } + } else if(software == "polyqtlR"){ + if(design == "circle" | design == "digenic"){ + stop(safeError("Design option not available for: polyqtlR")) + } else { + effects.df <- effects %>% filter(.data$pheno %in% unique(qtl_info$pheno)[pheno.col.n]) %>% + filter(.data$LG %in% groups) %>% pivot_longer(cols = 4:ncol(.), names_to = "haplo", values_to = "effect") + + effects.df <- effects.df %>% group_by(.data$haplo, .data$pheno) %>% mutate(x.axis = 1:n()) %>% ungroup() %>% as.data.frame() + + vlines <- split(effects.df$x.axis, effects.df$LG) + vlines <- sapply(vlines, function(x) x[1]) + + p <- list() + for(i in 1:length(pheno.col.n)){ + p[[i]] <- effects.df %>% filter(.data$pheno == unique(qtl_info$pheno)[pheno.col.n][i]) %>% + ggplot() + + geom_path(aes(x=x.axis, y=haplo, col = effect), linewidth = 5) + + scale_color_gradient2(low = "purple4", mid = "white",high = "seagreen") + + {if(length(vlines) > 1) geom_vline(xintercept=vlines, linetype="dashed", linewidth=.5, alpha=0.8, na.rm = TRUE)} + + labs(y = "Haplotype", x = "Linkage group", title = unique(qtl_info$pheno)[pheno.col.n][i]) + + annotate(x=vlines,y=+Inf,label= paste0("LG", names(vlines)),vjust= 1, hjust= -0.1,geom="label") + + coord_cartesian(ylim = c(1,8.5)) + + theme_classic() + theme(axis.text.x=element_blank(), + axis.ticks.x=element_blank(), legend.title = element_blank()) + } + return(p) + } + } +} + +#' Change ggplot coordinates to plot radar - From package see +#' +#' @param theta ariable to map angle to (x or y) +#' @param start offset of starting point from 12 o'clock in radians. Offset is applied clockwise or anticlockwise depending on value of direction. +#' @param direction 1, clockwise; -1, anticlockwise +#' +#' +#' @keywords internal +coord_radar <- function (theta = "x", start = 0, direction = 1) { + theta <- match.arg(theta, c("x", "y")) + r <- if (theta == "x") "y" else "x" + ggproto("CordRadar", CoordPolar, theta = theta, r = r, start = start, + direction = sign(direction), + is_linear = function(coord) TRUE) +} + +#' Plot effects data +#' +#' @param data_effects.obj output of function \code{data_effects} +#' @param software character defining which software was used for QTL analysis. Currently support for: QTLpoly, diaQTL and polyqtlR. +#' @param design character defining the graphic design. Options: `bar` - barplot of the effects; +#' `circle` - circular plot of the effects (useful to compare effects of different traits); +#' `digenic` - heatmap plotting sum of additive effects (bottom diagonal) and digenic effects (top diagonal) when present +#' +#' +#' @keywords internal +plot_effects <- function(data_effects.obj, software, + design = c("bar", "circle", "digenic")){ + + if(software == "polyqtlR"){ + p.t <- ggarrange(plotlist = data_effects.obj, common.legend = T, ncol = 1, legend = "right") + } else { + if(design == "circle"){ + rows <- ceiling(length(data_effects.obj)/2) + if(rows == 0) rows <- 1 + p.t <- ggarrange(plotlist = data_effects.obj, nrow = rows, ncol = 2) + } else { + rows <- ceiling(length(data_effects.obj)/4) + if(rows == 0) rows <- 1 + p.t <- ggarrange(plotlist = data_effects.obj, nrow = rows, ncol = 4) + } + } + return(p.t) +} + +#' Estimate breeding values - Adapted function from QTLpoly +#' +#' @param qtl_info data.frame with: LG - linkage group ID; Pos - position in linkage map (cM); +#' Pheno - phenotype ID; Pos_lower - lower position of confidence interval; +#' Pos_upper - upper position of the confidence interval; Pval - QTL p-value; h2 - herdability +#' @param probs data.frame with first column (named `ind`) as individuals ID and next columns +#' named with markers ID and containing the genotype probability at each marker +#' @param selected_mks data.frame with: LG - linkage group ID; mk - marker ID; pos - position in linkage map (cM) +#' @param blups data.frame with: haplo - haplotype ID; pheno - phenotype ID; qtl - QTL ID; u.hat - QTL estimated BLUPs +#' @param beta.hat data.frame with: pheno - phenotype ID; beta.hat - estimated beta +#' @param pos selected QTL position (cM) +#' +#' @return data.frame containing breeding values +#' +#' @import dplyr +#' +#' +#' @keywords internal +breeding_values <- function(qtl_info, probs, selected_mks, blups, beta.hat, pos) { + + pheno.names <- unique(as.character(qtl_info$pheno)) + results <- vector("list", length(pheno.names)) + names(results) <- pheno.names + + # possible to index individuals + phenos <- which(pheno.names %in% names(pos)) + for(p in phenos) { # select pheno + nqtl <- length(pos[[pheno.names[p]]]) + infos <- filter(qtl_info, .data$pheno == pheno.names[p]) + infos <- infos[which(infos$Pos %in% pos[[pheno.names[p]]]),] + markers <- which((round(selected_mks$pos,2) %in% infos$Pos) & (selected_mks$LG %in% infos$LG)) + Z <- probs[,markers,] # select by pos + u.hat <- filter(blups, .data$pheno == pheno.names[p]) + u.hat <- split(u.hat$u.hat, u.hat$qtl) + + beta.hat.sub <- filter(beta.hat, .data$pheno == pheno.names[p]) + beta.hat.v <- beta.hat.sub$beta.hat + + Zu <- vector("list", nqtl) + if(nqtl > 1) { + for(m in 1:nqtl) { + Zu[[m]] <- t(Z[,m,]) %*% u.hat[[m]] + } + nind <- dim(Z)[3] + y.hat <- matrix(rep(beta.hat.v, nind), byrow = FALSE) + Reduce("+", Zu) + } else if(nqtl == 1) { + Zu <- t(Z) %*% u.hat[[1]] + nind <- dim(Z)[2] + y.hat <- matrix(rep(beta.hat.v, nind), byrow = FALSE) + Zu + } + + colnames(y.hat) <- pheno.names[p] + results[[p]] <- round(y.hat,2) + } + + id.names <- rownames(results[[which(sapply(results, function(x) !is.null(x)))[1]]]) + results <- as.data.frame(do.call(cbind, results)) + results <- cbind(gen=id.names, results) + + return(results) +} + +#' Calculates homologues probabilities - Adapted from MAPpoly +#' +#' @param probs data.frame with first column (named `ind`) as individuals ID and next columns named with markers ID and containing the genotype probability at each marker +#' @param selected_mks data.frame with: LG - linkage group ID; mk - marker ID; pos - position in linkage map (cM) +#' @param selected_lgs vector containing selected LGs ID +#' +#' @return object of class \code{mappoly.homoprob} +#' +#' +#' @importFrom reshape2 melt +#' @importFrom dplyr filter +#' +#' @keywords internal +calc_homologprob <- function(probs, selected_mks, selected_lgs){ + input.genoprobs <- probs + each.split <- vector() + sizes <- table(selected_mks$LG) + probs.b <- probs + input.genoprobs <- list() + for(i in 1:length(sizes)){ + input.genoprobs[[i]] <- probs.b[,1:sizes[i],] + probs.b <- probs.b[,-c(1:sizes[i]),] + } + + lgs <- as.numeric(unique(selected_lgs)) + input.genoprobs <- input.genoprobs[sort(lgs)] + selected_mks_lg <- filter(selected_mks, .data$LG %in% lgs) + + pos <- split(selected_mks_lg$pos, selected_mks_lg$LG) + df.res <- NULL + for(j in 1:length(input.genoprobs)){ + stt.names <- dimnames(input.genoprobs[[j]])[[1]] ## state names + mrk.names <- dimnames(input.genoprobs[[j]])[[2]] ## mrk names + ind.names <- dimnames(input.genoprobs[[j]])[[3]] ## individual names + v <- c(2,4,6,8,10,12) + names(v) <- choose(v,v/2)^2 + ploidy <- v[as.character(length(stt.names))] + hom.prob <- array(NA, dim = c(ploidy*2, length(mrk.names), length(ind.names))) + dimnames(hom.prob) <- list(letters[1:(2*ploidy)], mrk.names, ind.names) + for(i in letters[1:(2*ploidy)]) + hom.prob[i,,] <- apply(input.genoprobs[[j]][grep(stt.names, pattern = i),,], c(2,3), function(x) round(sum(x, na.rm = TRUE),4)) + df.hom <- melt(hom.prob) + map <- data.frame(map.position = pos[[j]], marker = mrk.names) + colnames(df.hom) <- c("homolog", "marker", "individual", "probability") + df.hom <- merge(df.hom, map, sort = FALSE) + df.hom$LG <- names(pos)[j] + df.res <- rbind(df.res, df.hom) + } + if(ploidy == 2){ + df.res$homolog <- gsub("a", paste0("P1.1_"), df.res$homolog) + df.res$homolog <- gsub("b", paste0("P1.2_"), df.res$homolog) + df.res$homolog <- gsub("c", paste0("P2.1_"), df.res$homolog) + df.res$homolog <- gsub("d", paste0("P2.2_"), df.res$homolog) + df.res$homolog = substring(df.res$homolog,1, nchar(df.res$homolog)-1) + } else if(ploidy == 4){ + df.res$homolog <- gsub("a", paste0("P1.1_"), df.res$homolog) + df.res$homolog <- gsub("b", paste0("P1.2_"), df.res$homolog) + df.res$homolog <- gsub("c", paste0("P1.3_"), df.res$homolog) + df.res$homolog <- gsub("d", paste0("P1.4_"), df.res$homolog) + df.res$homolog <- gsub("e", paste0("P2.1_"), df.res$homolog) + df.res$homolog <- gsub("f", paste0("P2.2_"), df.res$homolog) + df.res$homolog <- gsub("g", paste0("P2.3_"), df.res$homolog) + df.res$homolog <- gsub("h", paste0("P2.4_"), df.res$homolog) + df.res$homolog = substring(df.res$homolog,1, nchar(df.res$homolog)-1) + } else if(ploidy == 6){ + df.res$homolog <- gsub("a", paste0("P1.1_"), df.res$homolog) + df.res$homolog <- gsub("b", paste0("P1.2_"), df.res$homolog) + df.res$homolog <- gsub("c", paste0("P1.3_"), df.res$homolog) + df.res$homolog <- gsub("d", paste0("P1.4_"), df.res$homolog) + df.res$homolog <- gsub("e", paste0("P1.5_"), df.res$homolog) + df.res$homolog <- gsub("f", paste0("P1.6_"), df.res$homolog) + df.res$homolog <- gsub("g", paste0("P2.1_"), df.res$homolog) + df.res$homolog <- gsub("h", paste0("P2.2_"), df.res$homolog) + df.res$homolog <- gsub("i", paste0("P2.3_"), df.res$homolog) + df.res$homolog <- gsub("j", paste0("P2.4_"), df.res$homolog) + df.res$homolog <- gsub("k", paste0("P2.5_"), df.res$homolog) + df.res$homolog <- gsub("l", paste0("P2.6_"), df.res$homolog) + df.res$homolog = substring(df.res$homolog,1, nchar(df.res$homolog)-1) + } + structure(list(info = list(ploidy = ploidy, + n.ind = length(ind.names)) , + homoprob = df.res), class = "mappoly.homoprob") +} + +#' Plots mappoly.homoprob from MAPpoly +#' +#' @param x an object of class \code{mappoly.homoprob} +#' +#' @param stack logical. If \code{TRUE}, probability profiles of all homologues +#' are stacked in the plot (default = FALSE) +#' +#' @param lg indicates which linkage group should be plotted. If \code{NULL} +#' (default), it plots the first linkage group. If +#' \code{"all"}, it plots all linkage groups +#' +#' @param ind indicates which individuals should be plotted. It can be the +#' position of the individuals in the dataset or it's name. +#' If \code{NULL} (default), the function plots the first +#' individual +#' +#' @param verbose if \code{TRUE} (default), the current progress is shown; if +#' \code{FALSE}, no output is produced +#' +#' @param ... unused arguments +#' +#' +#' @keywords internal +plot.mappoly.homoprob <- function(x, stack = FALSE, lg = NULL, + ind = NULL, + verbose = TRUE, ...){ + qtl <- NULL + + all.ind <- as.character(unique(x$homoprob$individual)) + #### Individual handling #### + if(length(ind) > 1){ + if (verbose) message("More than one individual provided: using the first one") + ind <- ind[1] + } + if(is.null(ind)){ + ind <- as.character(all.ind[1]) + df.pr1 <- subset(x$homoprob, individual == ind) + } else if(is.numeric(ind)) { + if(ind > length(all.ind)) + stop("Please chose an individual number between 1 and ", length(all.ind)) + ind <- as.character(all.ind[ind]) + df.pr1 <- subset(x$homoprob, individual == ind) + } else if (is.character(ind)){ + if(!ind%in%all.ind) + stop(safeError("Invalid individual name")) + } else stop(safeError("Invalid individual name")) + + #### LG handling #### + if(is.null(lg)) + lg <- 1 + if(all(lg == "all")) + lg <- unique(x$homoprob$LG) + LG <- individual <- map.position <- probability <- homolog <- NULL + if(length(lg) > 1 & !stack) + { + if (verbose) message("Using 'stack = TRUE' to plot multiple linkage groups") + stack <- TRUE + } + if(stack){ + ##subset linkage group + if(!is.null(lg)){ + df.pr1 <- subset(x$homoprob, LG%in%lg) + df.pr1 <- subset(df.pr1, individual == ind) + } else + df.pr1 <- subset(x$homoprob, individual == ind) + p <- ggplot(df.pr1, aes(x = map.position, y = probability, fill = homolog, color = homolog)) + + geom_density(stat = "identity", alpha = 0.7, position = "stack") + + ggtitle(ind) + + facet_grid(rows = vars(LG)) + + ylab(label = "Homologs probabilty") + + xlab(label = "Map position") + + geom_vline(data = df.pr1, aes(xintercept = qtl), linetype="dashed", na.rm = TRUE) + + theme_minimal() + } else { + ##subset linkage group + if(is.null(lg)){ + lg <- 1 + df.pr1 <- subset(x$homoprob, LG %in% lg) + } else df.pr1 <- subset(x$homoprob, LG %in% lg) + df.pr1 <- subset(df.pr1, individual == ind) + p <- ggplot(df.pr1, aes(x = map.position, y = probability, fill = homolog, color = homolog)) + + geom_density(stat = "identity", alpha = 0.7) + + ggtitle(paste(ind, " LG", lg)) + + facet_grid(rows = vars(homolog)) + + theme_minimal() + + ylab(label = "Homologs probabilty") + + xlab(label = "Map position") + + geom_vline(data = df.pr1, aes(xintercept = qtl), linetype="dashed", na.rm = TRUE) + } + return(p) +} + +#' Plot selected haplotypes +#' +#' @param input.haplo character vector with selected haplotypes. It contains the information: "Trait:_LG:" +#' @param exclude.haplo character vector with haplotypes to be excluded. It contains the information: "Trait:_LG:" +#' @param probs data.frame with first column (named `ind`) as individuals ID and next columns named with markers ID and containing the genotype probability at each marker +#' @param selected_mks data.frame with: LG - linkage group ID; mk - marker ID; pos - position in linkage map (cM) +#' @param effects.data output object from \code{data_effects} function +#' +#' @return ggplot graphic +#' +#' @import dplyr tidyr +#' +#' @keywords internal +select_haplo <- function(input.haplo,probs, selected_mks, effects.data, exclude.haplo = NULL){ + LG <- map.position <- individual <- probability <- NULL + + include <- strsplit(unlist(input.haplo), "LG:") + include.lgs <- sapply(include, "[[", 2) |> strsplit(split = "_") |> sapply("[[",1) + + if(length(exclude.haplo) ==0) exclude.haplo <- NULL + if(!is.null(exclude.haplo)){ + exclude <- strsplit(unlist(exclude.haplo), "LG:") + exclude.lgs <- sapply(exclude, "[[", 2) |> strsplit(split = "_") |> sapply("[[",1) + lgs <- c(include.lgs, exclude.lgs) + } else { + exclude <- NULL + lgs <- include.lgs + } + + homo.dat <- calc_homologprob(probs = probs, selected_mks = selected_mks, selected_lgs = lgs) + data_match <- paste0("LG:",homo.dat$homoprob$LG, "_Pos:", + round(homo.dat$homoprob$map.position,0), + "_homolog:", homo.dat$homoprob$homolog) + + # Include haplo + include <- sapply(include, function(x) paste0("LG:",x[2])) + + subset <- homo.dat$homoprob[which(data_match %in% include),] + subset <- subset[which(subset$probability > 0.5),] + + counts <- subset %>% group_by(individual) %>% summarise(n = n()) + selected <- counts$individual[counts$n == length(input.haplo)] + + if(length(selected) == 0) stop("None of the inviduals have these combination of haplotypes") + + # Exclude haplo + if(!is.null(exclude.haplo)){ + exclude <- sapply(exclude, function(x) paste0("LG:",x[2])) + + subset <- homo.dat$homoprob[which(data_match %in% exclude),] + subset <- subset[which(subset$probability > 0.5),] + + selected <- selected[-which(selected %in% unique(subset$individual))] + } + + if(length(selected) == 0) stop("None of the inviduals have these combination of haplotypes") + + dashline <- strsplit(c(unlist(input.haplo), unlist(exclude.haplo)), "_") + dashline <- sapply(dashline, function(x) paste0(x[-c(1,4)], collapse = "_")) + + data_match <- sapply(strsplit(data_match, "_"), function(x) paste0(x[-length(x)], collapse = "_")) + + homo.dat$homoprob$qtl <- NA + homo.dat$homoprob$qtl[which(data_match %in% dashline)] <- homo.dat$homoprob$map.position[which(data_match %in% dashline)] + + p <- list() + for(i in 1:length(selected)){ + p[[i]] <- plot.mappoly.homoprob(x = homo.dat, + lg = unique(as.numeric(lgs)), + ind = as.character(selected)[i], + use.plotly = FALSE) + } + return(list(p, inds = as.character(selected))) +} + diff --git a/R/functions_upload.R b/R/functions_upload.R index ef1424a..8391866 100644 --- a/R/functions_upload.R +++ b/R/functions_upload.R @@ -1,561 +1,541 @@ -#' Upload example files -#' -#' @param example character indicating the example dataset selected -#' -#' @return object of class \code{viewpoly} -#' -#' -#' @importFrom utils download.file -#' -#' @keywords internal -prepare_examples <- function(example){ - viewmap_tetra <- viewqtl_tetra <- NULL - if(example == "tetra_map"){ - load(system.file("ext/viewmap_tetra.rda", package = "viewpoly")) - load(system.file("ext/viewqtl_tetra.rda", package = "viewpoly")) - - structure(list(map=viewmap_tetra, - qtl=viewqtl_tetra, - fasta = "https://gesteira.statgen.ncsu.edu/files/genome-browser/Stuberosum_448_v4.03.fa.gz", - gff3 = "https://gesteira.statgen.ncsu.edu/files/genome-browser/Stuberosum_448_v4.03.gene_exons.gff3.gz", - vcf = NULL, - align = NULL, - wig = NULL, - version = packageVersion("viewpoly")), - class = "viewpoly") - } -} - -#' Upload hidecan example files -#' -#' @param example character indicating the example dataset selected -#' -#' @return object of class \code{viewpoly} -#' -#' @import hidecan -#' -#' @keywords internal -prepare_hidecan_examples <- function(example){ - gwas <- read.csv(system.file("ext/gwas.csv", package = "viewpoly")) - de <- read.csv(system.file("ext/de.csv", package = "viewpoly")) - can <- read.csv(system.file("ext/can.csv", package = "viewpoly")) - - structure(list(GWASpoly = NULL, - GWAS= gwas, - DE= de, - CAN = can)) -} - -#' Converts map information in custom format files to viewmap object -#' -#' -#' @param dosages TSV or TSV.GZ file with both parents dosage information. -#' It should contain four columns: 1) character vector with chromosomes ID; -#' 2) Character vector with markers ID; 3) Character vector with parent ID; -#' 4) numerical vector with dosage. -#' @param phases TSV or TSV.GZ file with phases information. It should contain: -#' 1) Character vector with chromosome ID; 2) Character vector with marker ID; -#' 3 to (ploidy number)*2 columns with each parents haplotypes. -#' @param genetic_map TSV or TSV.GZ file with the genetic map information -#' @param mks_pos TSV or TSV.GZ file with table with three columns: 1) marker ID; -#' 2) genome position; 3) chromosome -#' -#' @return object of class \code{viewmap} -#' -#' @import dplyr -#' @import vroom -#' -#' @keywords internal -prepare_map_custom_files <- function(dosages, phases, genetic_map, mks_pos=NULL){ - parent <- chr <- marker <- NULL - ds <- vroom(dosages$datapath, progress = FALSE, col_types = cols()) - ph <- vroom(phases$datapath, progress = FALSE, col_types = cols()) - map <- vroom(genetic_map$datapath, progress = FALSE, col_types = cols()) - if(!is.null(mks_pos)) mks_pos <- vroom(mks_pos$datapath, progress = FALSE, col_types = cols()) - - parent1 <- unique(ds$parent)[1] - parent2 <- unique(ds$parent)[2] - d.p1 <- ds %>% filter(parent == parent1) %>% select(chr, marker, dosages) - d.p1.names <- split(d.p1$marker, d.p1$chr) - d.p1 <- split(d.p1$dosages, d.p1$chr) - d.p1 <- Map(function(x,y) { - names(x) <- y - return(x) - }, d.p1, d.p1.names) - - d.p2 <- ds %>% filter(parent == parent2) %>% select(chr, marker, dosages) - d.p2.names <- split(d.p2$marker, d.p2$chr) - d.p2 <- split(d.p2$dosages, d.p2$chr) - d.p2 <- Map(function(x,y) { - names(x) <- y - return(x) - }, d.p2, d.p2.names) - - if(!is.null(mks_pos)) pos <- mks_pos[,2][match(map$marker,mks_pos[,1])] else pos <- NA - - maps <- data.frame(mk.names = map$marker, - l.dist = map$dist, - g.chr = map$chr, - g.dist = pos, - alt = NA, - ref= NA) - - maps <- split.data.frame(maps, maps$g.chr) - - ploidy <- (dim(ph)[2] - 2)/2 - - ph.p1 <- as.data.frame(select(ph, 3:(ploidy +2))) - rownames(ph.p1) <- ph$marker - ph.p1 <- split(ph.p1, ph$chr) - ph.p1 <- lapply(ph.p1, as.matrix) - - ph.p2 <- as.data.frame(select(ph, (ploidy +3):dim(ph)[2])) - rownames(ph.p2) <- ph$marker - ph.p2 <- split(ph.p2, ph$chr) - ph.p2 <- lapply(ph.p2, as.matrix) - - structure(list(d.p1 = d.p1, - d.p2 = d.p2, - ph.p1 = ph.p1, - ph.p2 = ph.p2, - maps = maps, - software = "custom"), - class = "viewmap") -} - -#' Converts list of mappoly.map object into viewmap object -#' -#' @param mappoly_list list with objects of class \code{mappoly.map} -#' -#' @return object of class \code{viewmap} -#' -#' -#' @keywords internal -prepare_MAPpoly <- function(mappoly_list){ - is <- NULL - - if(!is(mappoly_list[[1]], "mappoly.map")){ - temp <- load(mappoly_list$datapath) - mappoly_list <- get(temp) - } - prep <- lapply(mappoly_list, prepare_map) - - structure(list(d.p1 = lapply(prep, "[[", 5), - d.p2 = lapply(prep, "[[", 6), - ph.p1 = lapply(prep, "[[", 3), - ph.p2 = lapply(prep, "[[", 4), - maps = lapply(prep, "[[", 2), - software = "MAPpoly"), - class = "viewmap") -} - -#' Converts polymapR ouputs to viewmap object -#' -#' @param polymapR.dataset a \code{polymapR} dataset -#' @param polymapR.map output map sequence from polymapR -#' @param input.type indicates whether the input is discrete ("disc") or probabilistic ("prob") -#' @param ploidy ploidy level -#' -#' @return object of class \code{viewmap} -#' -#' -#' @keywords internal -prepare_polymapR <- function(polymapR.dataset, polymapR.map, input.type, ploidy){ - - temp <- load(polymapR.dataset$datapath) - polymapR.dataset <- get(temp) - - temp <- load(polymapR.map$datapath) - polymapR.map <- get(temp) - data <- import_data_from_polymapR(input.data = polymapR.dataset, - ploidy = ploidy, - parent1 = "P1", - parent2 = "P2", - input.type = , - prob.thres = 0.95, - pardose = NULL, - offspring = NULL, - filter.non.conforming = TRUE, - verbose = FALSE) - - map_seq <- import_phased_maplist_from_polymapR(maplist = polymapR.map, - mappoly.data = data) - - viewmap <- prepare_MAPpoly(mappoly_list = map_seq) - viewmap$software <- "polymapR" - - structure(viewmap, class = "viewmap") -} - -#' Converts QTLpoly outputs to viewqtl object -#' -#' -#' @param data object of class "qtlpoly.data" -#' @param remim.mod object of class "qtlpoly.model" "qtlpoly.remim". -#' @param est.effects object of class "qtlpoly.effects" -#' @param fitted.mod object of class "qtlpoly.fitted" -#' -#' @author Cristiane Taniguti, \email{chtaniguti@tamu.edu} -#' -#' @return object of class \code{viewqtl} -#' -#' @importFrom tidyr pivot_longer -#' @import dplyr -#' -#' @keywords internal -prepare_QTLpoly <- function(data, remim.mod, est.effects, fitted.mod){ - is <- NULL - - temp <- load(data$datapath) - data <- get(temp) - - temp <- load(remim.mod$datapath) - remim.mod <- get(temp) - - temp <- load(est.effects$datapath) - est.effects <- get(temp) - - temp <- load(fitted.mod$datapath) - fitted.mod <- get(temp) - - # Only selected markers - lgs.t <- lapply(data$lgs, function(x) data.frame(mk = names(x), pos = x)) - lgs <- data.frame() - for(i in 1:length(lgs.t)) { - lgs <- rbind(lgs, cbind(LG = i,lgs.t[[i]])) - } - - rownames(lgs) <- NULL - qtl_info <- u.hat <- beta.hat <- pvalue <- profile <- effects <- data.frame() - for(i in 1:length(remim.mod$results)){ - pheno = names(fitted.mod$results)[i] - if(!is.null(dim(fitted.mod$results[[i]]$qtls)[1])){ - lower <- remim.mod$results[[i]]$lower[,1:2] - upper <- remim.mod$results[[i]]$upper[,1:2] - qtl <- remim.mod$results[[i]]$qtls[,c(1,2,6)] - int <- cbind(LG = lower$LG, Pos_lower = lower$Pos_lower, - Pos_upper = upper$Pos_upper, qtl[,2:3]) - int <- cbind(pheno = names(remim.mod$results)[i], int) - - - if(dim(fitted.mod$results[[i]]$qtls)[1] > 1) { - h2 <- fitted.mod$results[[i]]$qtls[-dim(fitted.mod$results[[i]]$qtls)[1],c(1:2,7)] - h2 <- data.frame(apply(h2, 2, unlist)) - }else { - h2 <- fitted.mod$results[[i]]$qtls[,c(1:2,7)] - } - int <- merge(int, h2, by = c("LG", "Pos")) - - qtl_info <- rbind(qtl_info, int[order(int$LG, int$Pos),]) - - u.hat.t <- do.call(cbind, fitted.mod$results[[i]]$fitted$U) - colnames(u.hat.t) <- names(fitted.mod$results[[i]]$fitted$U) - u.hat.t <- cbind(haplo = fitted.mod$results[[i]]$fitted$alleles, pheno , as.data.frame(u.hat.t)) - u.hat.t <- pivot_longer(u.hat.t, cols = c(1:length(u.hat.t))[-c(1:2)], values_to = "u.hat", names_to = "qtl") - u.hat <- rbind(u.hat, u.hat.t) - u.hat$qtl <- gsub("g", "", u.hat$qtl) - - beta.hat.t <- data.frame(pheno, beta.hat = fitted.mod$results[[i]]$fitted$Beta[,1]) - beta.hat <- rbind(beta.hat, beta.hat.t) - - for(j in 1:length(est.effects$results[[i]]$effects)){ - effects.t <- do.call(rbind, lapply(est.effects$results[[i]]$effects[[j]], function(x) data.frame(haplo = names(x), effect = x))) - effects.t <- cbind(pheno = pheno, qtl.id= j, effects.t) - effects <- rbind(effects, effects.t) - } - } - - if(is(remim.mod, "qtlpoly.feim")) SIG <- remim.mod$results[[i]][[3]] else SIG <- -log10(as.numeric(remim.mod$results[[i]][[3]])) - - profile.t <- data.frame(pheno, LOP = SIG) - profile <- rbind(profile, profile.t) - } - - # Rearrange the progeny probabilities into a list - probs <- data$Z - - structure(list(selected_mks = lgs, - qtl_info = qtl_info, - blups = as.data.frame(u.hat), - beta.hat = beta.hat, - profile = profile, - effects = effects, - probs = probs, - software = "QTLpoly"), - class = "viewqtl") -} - -#' Converts diaQTL output to viewqtl object -#' -#' @param scan1_list list with results from diaQTL \code{scan1} function -#' @param scan1_summaries_list list with results from diaQTL \code{scan1_summaries} function -#' @param fitQTL_list list with results from diaQTL \code{fitQTL} function -#' @param BayesCI_list list with results from diaQTL \code{BayesCI} function -#' -#' @return object of class \code{viewqtl} -#' -#' @importFrom dplyr filter -#' -#' -#' @keywords internal -prepare_diaQTL <- function(scan1_list, scan1_summaries_list, fitQTL_list, BayesCI_list){ - marker <- pheno <- NULL - - temp <- load(scan1_list$datapath) - scan1_list <- get(temp) - - temp <- load(scan1_summaries_list$datapath) - scan1_summaries_list <- get(temp) - - temp <- load(fitQTL_list$datapath) - fitQTL_list <- get(temp) - - temp <- load(BayesCI_list$datapath) - BayesCI_list <- get(temp) - - selected_mks <- scan1_list[[1]][,c(2,1,3)] - colnames(selected_mks) <- c("LG", "mk", "pos") - qtl_info <- data.frame() - - for(i in 1:length(scan1_summaries_list)){ - temp <- cbind(pheno = names(scan1_summaries_list)[i],scan1_summaries_list[[i]]$peaks) - qtl_info <- rbind(qtl_info, temp) - } - - qtls.id <- list() - qtl_info2 <- data.frame() - - if(is.null(fitQTL_list[[1]]$plots)) fitQTL_list <- unlist(fitQTL_list, recursive = F) - - profile <- effects <- data.frame() - for(i in 1:length(fitQTL_list)){ - qtls.id <- colnames(fitQTL_list[[i]]$effects$additive) - trait <- gsub("Trait: ","",fitQTL_list[[i]]$plots[[1]]$additive$labels$title) - qtl_temp <- filter(qtl_info, pheno == trait & marker %in% qtls.id) - qtl_info2 <- rbind(qtl_info2, qtl_temp) - # profile - profile_temp <- data.frame(pheno = trait, deltaDIC = scan1_list[[which(names(scan1_list) == trait)]]$deltaDIC) - profile <- rbind(profile, profile_temp) - - # Sometimes there is a graphic about epistasis that is not described anywhere yet. We ignored it here by now. - if(any(grepl("epistasis", names(fitQTL_list[[i]]$plots)))) fitQTL_list[[i]]$plots <- fitQTL_list[[i]]$plots[-grep("epistasis", names(fitQTL_list[[i]]$plots))] - - for(j in 1:length(fitQTL_list[[i]]$plots)){ - # aditive effect - temp <- fitQTL_list[[i]]$plots[[j]]$additive$data - effects.ad.t <- data.frame(pheno = trait, - haplo = rownames(temp), - qtl.id = j, - effect= temp$mean, - type = "Additive", - CI.lower = temp$CI.lower, - CI.upper = temp$CI.upper) - - # digenic effect - temp <- data.frame(haplo = rownames(fitQTL_list[[i]]$effects$digenic), z = fitQTL_list[[i]]$effects$digenic[,j]) - if(!is.null(temp)){ - effects.di.t <- data.frame(pheno = trait, - haplo = gsub("[+]", "x", temp$haplo), - qtl.id = j, - effect = as.numeric(temp$z), - type = "Digenic", - CI.lower = NA, - CI.upper = NA) - - effects.t <- rbind(effects.ad.t, effects.di.t) - } else effects.t <- effects.ad.t - effects.t <- effects.t[order(effects.t$pheno, effects.t$qtl.id, effects.t$type,effects.t$haplo),] - effects <- rbind(effects, effects.t) - } - } - - # Ordering Bayes info according to qtl info - BayesCI_list_ord <- list() - for(i in 1:dim(qtl_info2)[1]){ - for(j in 1:length(BayesCI_list)){ - if(any(paste0(BayesCI_list[[j]]$pheno, BayesCI_list[[j]]$marker, BayesCI_list[[j]]$chrom) %in% - paste0(qtl_info2$pheno[i], qtl_info2$marker[i], qtl_info2$chrom[i]))){ - BayesCI_list_ord[[i]] <- BayesCI_list[[j]] - } - } - } - - if(length(BayesCI_list_ord) != dim(qtl_info2)[1]) BayesCI_list_ord[[length(BayesCI_list_ord) + 1]] <- NULL - idx <- which(sapply(BayesCI_list_ord, is.null)) - if(length(idx) != 0 | length(BayesCI_list_ord) != dim(qtl_info2)[1]){ - warning(paste0("Bayes confidence interval information (from diaQTL function BayesCI) was not provided for the QTL in chromosome:", qtl_info2[idx, 3], - "; phenotype: ", qtl_info2[idx, 1])) - } - - CI <- lapply(BayesCI_list_ord, function(x) { - y = c(Pos_lower = x$cM[1], Pos_upper = x$cM[length(x$cM)]) - return(y) - }) - - - idx <- which(sapply(CI, is.null)) - if(length(idx) != 0 | length(BayesCI_list_ord) != dim(qtl_info2)[1]){ - if(length(idx) != 0) - CI[[idx]] <- c(NA, NA) - else CI[[length(CI) + 1]] <- c(NA, NA) - - } - - CI <- do.call(rbind, CI) - - qtl_info <- qtl_info2[,c(3,4,1,6)] - qtl_info <- cbind(qtl_info, CI) - qtl_info <- qtl_info[,c(1:3,5,6,4)] - colnames(qtl_info)[1:2] <- c("LG", "Pos") - - structure(list(selected_mks = selected_mks, - qtl_info = qtl_info, - profile = profile, - effects = effects, - software = "diaQTL"), - class = "viewqtl") -} - -#' Converts polyqtlR outputs to viewqtl object -#' -#' @param polyqtlR_QTLscan_list list containing results from polyqtlR \code{QTLscan_list} function -#' @param polyqtlR_qtl_info data.frame containing the QTL information:LG - group ID; Pos - QTL position (cM); -#' pheno - phenotype ID; Pos_lower - lower position of confidence interval; Pos_upper - upper position of the confidence interval; -#' thresh - LOD threshold applied -#' @param polyqtlR_effects data.frame with results from \code{visualiseQTLeffects} polyqtlR function -#' -#' @return object of class \code{viewqtl} -#' -#' -#' @keywords internal -prepare_polyqtlR <- function(polyqtlR_QTLscan_list, polyqtlR_qtl_info, polyqtlR_effects){ - - temp <- load(polyqtlR_QTLscan_list$datapath) - polyqtlR_QTLscan_list <- get(temp) - - temp <- load(polyqtlR_qtl_info$datapath) - polyqtlR_qtl_info <- get(temp) - - temp <- load(polyqtlR_effects$datapath) - polyqtlR_effects <- get(temp) - - # selected markers - selected_mks <- polyqtlR_QTLscan_list[[1]]$Map - colnames(selected_mks) <- c("LG", "mk", "pos") - - profile <- qtl_info <- effects <- data.frame() - for(i in 1:length(polyqtlR_QTLscan_list)){ - pheno <- names(polyqtlR_QTLscan_list)[i] - # profile - profile_temp <- data.frame(pheno = pheno, - LOD = polyqtlR_QTLscan_list[[i]]$QTL.res$LOD) - profile <- rbind(profile, profile_temp) - } - - structure(list(selected_mks = selected_mks, - qtl_info = polyqtlR_qtl_info, - profile = profile, - effects = polyqtlR_effects, - software = "polyqtlR"), - class = "viewqtl") -} - -#' Converts QTL information in custom files to viewqtl object -#' -#' @param selected_mks data.frame with: LG - linkage group ID; mk - marker ID; pos - position in linkage map (cM) -#' @param qtl_info data.frame with: LG - linkage group ID; Pos - position in linkage map (cM); -#' Pheno - phenotype ID; Pos_lower - lower position of confidence interval; -#' Pos_upper - upper position of the confidence interval; Pval - QTL p-value; h2 - herdability -#' @param blups data.frame with: haplo - haplotype ID; pheno - phenotype ID; qtl - QTL ID; u.hat - QTL estimated BLUPs -#' @param beta.hat data.frame with: pheno - phenotype ID; beta.hat - estimated beta -#' @param profile data.frame with: pheno - phenotype ID; LOP - significance value for the QTL, in this case LOP (can be LOD or DIC depending of the software used) -#' @param effects data.frame with: pheno - phenotype ID; qtl.id - QTL ID; haplo - haplotype ID; effect - haplotype effect value -#' @param probs data.frame with first column (named `ind`) as individuals ID and next columns named with markers ID and containing the genotype probability at each marker -#' -#' -#' @return object of class \code{viewqtl} -#' -#' @import vroom -#' @import abind -#' -#' @keywords internal -prepare_qtl_custom_files <- function(selected_mks, qtl_info, blups, beta.hat, - profile, effects, probs){ - - qtls <- list() - qtls$selected_mks <- as.data.frame(vroom(selected_mks$datapath, progress = FALSE, col_types = cols())) - qtls$qtl_info <- as.data.frame(vroom(qtl_info$datapath, progress = FALSE, col_types = cols())) - qtls$blups <- as.data.frame(vroom(blups$datapath, progress = FALSE, col_types = cols())) - qtls$beta.hat <- as.data.frame(vroom(beta.hat$datapath, progress = FALSE, col_types = cols())) - qtls$profile <- as.data.frame(vroom(profile$datapath, progress = FALSE, col_types = cols())) - qtls$profile[,2] <- as.numeric(qtls$profile[,2]) - qtls$effects <- as.data.frame(vroom(effects$datapath, progress = FALSE, col_types = cols())) - - probs.t <- vroom(probs$datapath, progress = FALSE, col_types = cols()) - ind <- probs.t$ind - probs.t <- as.data.frame(probs.t[,-1]) - probs.df <- split(probs.t, ind) - qtls$probs <- abind(probs.df, along = 3) - qtls$software <- "custom" - - structure(qtls, class = "viewqtl") -} - -#' Check hidecan inputs -#' -#' @param input_list shiny input result containing file path -#' @param func hidecan read input function -#' -#' @importFrom stats setNames -#' @importFrom utils read.csv -#' @import hidecan -#' @import purrr -#' -read_input_hidecan <- function(input_list, func){ - - ## Turning the hidecan constructors into safe functions - ## i.e. instead of throwing an error they return the error - ## message -> useful to escalate the error message in the app - safe_func <- safely(func) - - ## Read all files uploaded - res <- lapply(input_list$datapath, - read.csv) - - ## Add file name - names(res) <- input_list$name - - ## Apply the hidecan constructor to each file: this will - ## check whether the input files have the correct columns etc - res <- lapply(res, safe_func) |> - ## rather than the resulting list being: level 1 = file, level 2 = result and error - ## we get the result and error as level 1, and files as level 2 - transpose() - - ## Checking whether any file returned an error - no_error <- res$error |> - purrr::map_lgl(is.null) |> - all() - - if(!no_error){ - - ## Extract error message - error_msg <- res$error |> - setNames(input_list$name) |> - purrr::map(purrr::pluck, "message") |> - purrr::imap(~ paste0("Input file ", .y, ": ", .x)) |> - purrr::reduce(paste0, collapse = "\n") - - ## Remove NULL elements from the list or results - ## If all are NULL, will return an empty list() - res$result <- purrr::discard(res$result, - is.null) - - showNotification(error_msg, type = "error", duration = 20) - validate(need(no_error, error_msg)) - - } - - return(res$result) - +#' Upload example files +#' +#' @param example character indicating the example dataset selected +#' +#' @return object of class \code{viewpoly} +#' +#' +#' @importFrom utils download.file +#' +#' @keywords internal +prepare_examples <- function(example){ + viewmap_tetra <- viewqtl_tetra <- NULL + if(example == "tetra_map"){ + load(system.file("ext/viewmap_tetra.rda", package = "viewpoly")) + load(system.file("ext/viewqtl_tetra.rda", package = "viewpoly")) + + structure(list(map=viewmap_tetra, + qtl=viewqtl_tetra, + fasta = "https://gesteira.statgen.ncsu.edu/files/genome-browser/Stuberosum_448_v4.03.fa.gz", + gff3 = "https://gesteira.statgen.ncsu.edu/files/genome-browser/Stuberosum_448_v4.03.gene_exons.gff3.gz", + vcf = NULL, + align = NULL, + wig = NULL, + version = packageVersion("viewpoly")), + class = "viewpoly") + } +} + +#' Converts map information in custom format files to viewmap object +#' +#' +#' @param dosages TSV or TSV.GZ file with both parents dosage information. +#' It should contain four columns: 1) character vector with chromosomes ID; +#' 2) Character vector with markers ID; 3) Character vector with parent ID; +#' 4) numerical vector with dosage. +#' @param phases TSV or TSV.GZ file with phases information. It should contain: +#' 1) Character vector with chromosome ID; 2) Character vector with marker ID; +#' 3 to (ploidy number)*2 columns with each parents haplotypes. +#' @param genetic_map TSV or TSV.GZ file with the genetic map information +#' @param mks_pos TSV or TSV.GZ file with table with three columns: 1) marker ID; +#' 2) genome position; 3) chromosome +#' +#' @return object of class \code{viewmap} +#' +#' @import dplyr +#' @import vroom +#' +#' @keywords internal +prepare_map_custom_files <- function(dosages, phases, genetic_map, mks_pos=NULL){ + parent <- chr <- marker <- NULL + ds <- vroom(dosages$datapath, progress = FALSE, col_types = cols()) + ph <- vroom(phases$datapath, progress = FALSE, col_types = cols()) + map <- vroom(genetic_map$datapath, progress = FALSE, col_types = cols()) + if(!is.null(mks_pos)) mks_pos <- vroom(mks_pos$datapath, progress = FALSE, col_types = cols()) + + parent1 <- unique(ds$parent)[1] + parent2 <- unique(ds$parent)[2] + d.p1 <- ds %>% filter(parent == parent1) %>% select(chr, marker, dosages) + d.p1.names <- split(d.p1$marker, d.p1$chr) + d.p1 <- split(d.p1$dosages, d.p1$chr) + d.p1 <- Map(function(x,y) { + names(x) <- y + return(x) + }, d.p1, d.p1.names) + + d.p2 <- ds %>% filter(parent == parent2) %>% select(chr, marker, dosages) + d.p2.names <- split(d.p2$marker, d.p2$chr) + d.p2 <- split(d.p2$dosages, d.p2$chr) + d.p2 <- Map(function(x,y) { + names(x) <- y + return(x) + }, d.p2, d.p2.names) + + if(!is.null(mks_pos)) pos <- mks_pos[,2][match(map$marker,mks_pos[,1])] else pos <- NA + + maps <- data.frame(mk.names = map$marker, + l.dist = map$dist, + g.chr = map$chr, + g.dist = pos, + alt = NA, + ref= NA) + + maps <- split.data.frame(maps, maps$g.chr) + + ploidy <- (dim(ph)[2] - 2)/2 + + ph.p1 <- as.data.frame(select(ph, 3:(ploidy +2))) + rownames(ph.p1) <- ph$marker + ph.p1 <- split(ph.p1, ph$chr) + ph.p1 <- lapply(ph.p1, as.matrix) + + ph.p2 <- as.data.frame(select(ph, (ploidy +3):dim(ph)[2])) + rownames(ph.p2) <- ph$marker + ph.p2 <- split(ph.p2, ph$chr) + ph.p2 <- lapply(ph.p2, as.matrix) + + structure(list(d.p1 = d.p1, + d.p2 = d.p2, + ph.p1 = ph.p1, + ph.p2 = ph.p2, + maps = maps, + software = "custom"), + class = "viewmap") +} + +#' Converts list of mappoly.map object into viewmap object +#' +#' @param mappoly_list list with objects of class \code{mappoly.map} +#' +#' @return object of class \code{viewmap} +#' +#' +#' @keywords internal +prepare_MAPpoly <- function(mappoly_list){ + is <- NULL + + if(!is(mappoly_list[[1]], "mappoly.map")){ + temp <- load(mappoly_list$datapath) + mappoly_list <- get(temp) + } + prep <- lapply(mappoly_list, prepare_map) + + structure(list(d.p1 = lapply(prep, "[[", 5), + d.p2 = lapply(prep, "[[", 6), + ph.p1 = lapply(prep, "[[", 3), + ph.p2 = lapply(prep, "[[", 4), + maps = lapply(prep, "[[", 2), + software = "MAPpoly"), + class = "viewmap") +} + +#' Converts polymapR ouputs to viewmap object +#' +#' @param polymapR.dataset a \code{polymapR} dataset +#' @param polymapR.map output map sequence from polymapR +#' @param input.type indicates whether the input is discrete ("disc") or probabilistic ("prob") +#' @param ploidy ploidy level +#' +#' @return object of class \code{viewmap} +#' +#' +#' @keywords internal +prepare_polymapR <- function(polymapR.dataset, polymapR.map, input.type, ploidy){ + + temp <- load(polymapR.dataset$datapath) + polymapR.dataset <- get(temp) + + temp <- load(polymapR.map$datapath) + polymapR.map <- get(temp) + data <- import_data_from_polymapR(input.data = polymapR.dataset, + ploidy = ploidy, + parent1 = "P1", + parent2 = "P2", + input.type = , + prob.thres = 0.95, + pardose = NULL, + offspring = NULL, + filter.non.conforming = TRUE, + verbose = FALSE) + + map_seq <- import_phased_maplist_from_polymapR(maplist = polymapR.map, + mappoly.data = data) + + viewmap <- prepare_MAPpoly(mappoly_list = map_seq) + viewmap$software <- "polymapR" + + structure(viewmap, class = "viewmap") +} + +#' Converts QTLpoly outputs to viewqtl object +#' +#' +#' @param data object of class "qtlpoly.data" +#' @param remim.mod object of class "qtlpoly.model" "qtlpoly.remim". +#' @param est.effects object of class "qtlpoly.effects" +#' @param fitted.mod object of class "qtlpoly.fitted" +#' +#' @author Cristiane Taniguti, \email{chtaniguti@tamu.edu} +#' +#' @return object of class \code{viewqtl} +#' +#' @importFrom tidyr pivot_longer +#' @import dplyr +#' +#' @keywords internal +prepare_QTLpoly <- function(data, remim.mod, est.effects, fitted.mod){ + is <- NULL + + temp <- load(data$datapath) + data <- get(temp) + + temp <- load(remim.mod$datapath) + remim.mod <- get(temp) + + temp <- load(est.effects$datapath) + est.effects <- get(temp) + + temp <- load(fitted.mod$datapath) + fitted.mod <- get(temp) + + # Only selected markers + lgs.t <- lapply(data$lgs, function(x) data.frame(mk = names(x), pos = x)) + lgs <- data.frame() + for(i in 1:length(lgs.t)) { + lgs <- rbind(lgs, cbind(LG = i,lgs.t[[i]])) + } + + rownames(lgs) <- NULL + qtl_info <- u.hat <- beta.hat <- pvalue <- profile <- effects <- data.frame() + for(i in 1:length(remim.mod$results)){ + pheno = names(fitted.mod$results)[i] + if(!is.null(dim(fitted.mod$results[[i]]$qtls)[1])){ + lower <- remim.mod$results[[i]]$lower[,1:2] + upper <- remim.mod$results[[i]]$upper[,1:2] + qtl <- remim.mod$results[[i]]$qtls[,c(1,2,6)] + int <- cbind(LG = lower$LG, Pos_lower = lower$Pos_lower, + Pos_upper = upper$Pos_upper, qtl[,2:3]) + int <- cbind(pheno = names(remim.mod$results)[i], int) + + + if(dim(fitted.mod$results[[i]]$qtls)[1] > 1) { + h2 <- fitted.mod$results[[i]]$qtls[-dim(fitted.mod$results[[i]]$qtls)[1],c(1:2,7)] + h2 <- data.frame(apply(h2, 2, unlist)) + }else { + h2 <- fitted.mod$results[[i]]$qtls[,c(1:2,7)] + } + int <- merge(int, h2, by = c("LG", "Pos")) + + qtl_info <- rbind(qtl_info, int[order(int$LG, int$Pos),]) + + u.hat.t <- do.call(cbind, fitted.mod$results[[i]]$fitted$U) + colnames(u.hat.t) <- names(fitted.mod$results[[i]]$fitted$U) + u.hat.t <- cbind(haplo = fitted.mod$results[[i]]$fitted$alleles, pheno , as.data.frame(u.hat.t)) + u.hat.t <- pivot_longer(u.hat.t, cols = c(1:length(u.hat.t))[-c(1:2)], values_to = "u.hat", names_to = "qtl") + u.hat <- rbind(u.hat, u.hat.t) + u.hat$qtl <- gsub("g", "", u.hat$qtl) + + beta.hat.t <- data.frame(pheno, beta.hat = fitted.mod$results[[i]]$fitted$Beta[,1]) + beta.hat <- rbind(beta.hat, beta.hat.t) + + for(j in 1:length(est.effects$results[[i]]$effects)){ + effects.t <- do.call(rbind, lapply(est.effects$results[[i]]$effects[[j]], function(x) data.frame(haplo = names(x), effect = x))) + effects.t <- cbind(pheno = pheno, qtl.id= j, effects.t) + effects <- rbind(effects, effects.t) + } + } + + if(is(remim.mod, "qtlpoly.feim")) SIG <- remim.mod$results[[i]][[3]] else SIG <- -log10(as.numeric(remim.mod$results[[i]][[3]])) + + profile.t <- data.frame(pheno, LOP = SIG) + profile <- rbind(profile, profile.t) + } + + # Rearrange the progeny probabilities into a list + probs <- data$Z + + structure(list(selected_mks = lgs, + qtl_info = qtl_info, + blups = as.data.frame(u.hat), + beta.hat = beta.hat, + profile = profile, + effects = effects, + probs = probs, + software = "QTLpoly"), + class = "viewqtl") +} + +#' Converts diaQTL output to viewqtl object +#' +#' @param scan1_list list with results from diaQTL \code{scan1} function +#' @param scan1_summaries_list list with results from diaQTL \code{scan1_summaries} function +#' @param fitQTL_list list with results from diaQTL \code{fitQTL} function +#' @param BayesCI_list list with results from diaQTL \code{BayesCI} function +#' +#' @return object of class \code{viewqtl} +#' +#' @importFrom dplyr filter +#' +#' +#' @keywords internal +prepare_diaQTL <- function(scan1_list, scan1_summaries_list, fitQTL_list, BayesCI_list){ + marker <- pheno <- NULL + + temp <- load(scan1_list$datapath) + scan1_list <- get(temp) + + temp <- load(scan1_summaries_list$datapath) + scan1_summaries_list <- get(temp) + + temp <- load(fitQTL_list$datapath) + fitQTL_list <- get(temp) + + temp <- load(BayesCI_list$datapath) + BayesCI_list <- get(temp) + + selected_mks <- scan1_list[[1]][,c(2,1,3)] + colnames(selected_mks) <- c("LG", "mk", "pos") + qtl_info <- data.frame() + + for(i in 1:length(scan1_summaries_list)){ + temp <- cbind(pheno = names(scan1_summaries_list)[i],scan1_summaries_list[[i]]$peaks) + qtl_info <- rbind(qtl_info, temp) + } + + qtls.id <- list() + qtl_info2 <- data.frame() + + if(is.null(fitQTL_list[[1]]$plots)) fitQTL_list <- unlist(fitQTL_list, recursive = F) + + profile <- effects <- data.frame() + for(i in 1:length(fitQTL_list)){ + qtls.id <- colnames(fitQTL_list[[i]]$effects$additive) + trait <- gsub("Trait: ","",fitQTL_list[[i]]$plots[[1]]$additive$labels$title) + qtl_temp <- filter(qtl_info, pheno == trait & marker %in% qtls.id) + qtl_info2 <- rbind(qtl_info2, qtl_temp) + # profile + profile_temp <- data.frame(pheno = trait, deltaDIC = scan1_list[[which(names(scan1_list) == trait)]]$deltaDIC) + profile <- rbind(profile, profile_temp) + + # Sometimes there is a graphic about epistasis that is not described anywhere yet. We ignored it here by now. + if(any(grepl("epistasis", names(fitQTL_list[[i]]$plots)))) fitQTL_list[[i]]$plots <- fitQTL_list[[i]]$plots[-grep("epistasis", names(fitQTL_list[[i]]$plots))] + + for(j in 1:length(fitQTL_list[[i]]$plots)){ + # aditive effect + temp <- fitQTL_list[[i]]$plots[[j]]$additive$data + effects.ad.t <- data.frame(pheno = trait, + haplo = rownames(temp), + qtl.id = j, + effect= temp$mean, + type = "Additive", + CI.lower = temp$CI.lower, + CI.upper = temp$CI.upper) + + # digenic effect + temp <- data.frame(haplo = rownames(fitQTL_list[[i]]$effects$digenic), z = fitQTL_list[[i]]$effects$digenic[,j]) + if(!is.null(temp)){ + effects.di.t <- data.frame(pheno = trait, + haplo = gsub("[+]", "x", temp$haplo), + qtl.id = j, + effect = as.numeric(temp$z), + type = "Digenic", + CI.lower = NA, + CI.upper = NA) + + effects.t <- rbind(effects.ad.t, effects.di.t) + } else effects.t <- effects.ad.t + effects.t <- effects.t[order(effects.t$pheno, effects.t$qtl.id, effects.t$type,effects.t$haplo),] + effects <- rbind(effects, effects.t) + } + } + + # Ordering Bayes info according to qtl info + BayesCI_list_ord <- list() + for(i in 1:dim(qtl_info2)[1]){ + for(j in 1:length(BayesCI_list)){ + if(any(paste0(BayesCI_list[[j]]$pheno, BayesCI_list[[j]]$marker, BayesCI_list[[j]]$chrom) %in% + paste0(qtl_info2$pheno[i], qtl_info2$marker[i], qtl_info2$chrom[i]))){ + BayesCI_list_ord[[i]] <- BayesCI_list[[j]] + } + } + } + + if(length(BayesCI_list_ord) != dim(qtl_info2)[1]) BayesCI_list_ord[[length(BayesCI_list_ord) + 1]] <- NULL + idx <- which(sapply(BayesCI_list_ord, is.null)) + if(length(idx) != 0 | length(BayesCI_list_ord) != dim(qtl_info2)[1]){ + warning(paste0("Bayes confidence interval information (from diaQTL function BayesCI) was not provided for the QTL in chromosome:", qtl_info2[idx, 3], + "; phenotype: ", qtl_info2[idx, 1])) + } + + CI <- lapply(BayesCI_list_ord, function(x) { + y = c(Pos_lower = x$cM[1], Pos_upper = x$cM[length(x$cM)]) + return(y) + }) + + + idx <- which(sapply(CI, is.null)) + if(length(idx) != 0 | length(BayesCI_list_ord) != dim(qtl_info2)[1]){ + if(length(idx) != 0) + CI[[idx]] <- c(NA, NA) + else CI[[length(CI) + 1]] <- c(NA, NA) + + } + + CI <- do.call(rbind, CI) + + qtl_info <- qtl_info2[,c(3,4,1,6)] + qtl_info <- cbind(qtl_info, CI) + qtl_info <- qtl_info[,c(1:3,5,6,4)] + colnames(qtl_info)[1:2] <- c("LG", "Pos") + + structure(list(selected_mks = selected_mks, + qtl_info = qtl_info, + profile = profile, + effects = effects, + software = "diaQTL"), + class = "viewqtl") +} + +#' Converts polyqtlR outputs to viewqtl object +#' +#' @param polyqtlR_QTLscan_list list containing results from polyqtlR \code{QTLscan_list} function +#' @param polyqtlR_qtl_info data.frame containing the QTL information:LG - group ID; Pos - QTL position (cM); +#' pheno - phenotype ID; Pos_lower - lower position of confidence interval; Pos_upper - upper position of the confidence interval; +#' thresh - LOD threshold applied +#' @param polyqtlR_effects data.frame with results from \code{visualiseQTLeffects} polyqtlR function +#' +#' @return object of class \code{viewqtl} +#' +#' +#' @keywords internal +prepare_polyqtlR <- function(polyqtlR_QTLscan_list, polyqtlR_qtl_info, polyqtlR_effects){ + + temp <- load(polyqtlR_QTLscan_list$datapath) + polyqtlR_QTLscan_list <- get(temp) + + temp <- load(polyqtlR_qtl_info$datapath) + polyqtlR_qtl_info <- get(temp) + + temp <- load(polyqtlR_effects$datapath) + polyqtlR_effects <- get(temp) + + # selected markers + selected_mks <- polyqtlR_QTLscan_list[[1]]$Map + colnames(selected_mks) <- c("LG", "mk", "pos") + + profile <- qtl_info <- effects <- data.frame() + for(i in 1:length(polyqtlR_QTLscan_list)){ + pheno <- names(polyqtlR_QTLscan_list)[i] + # profile + profile_temp <- data.frame(pheno = pheno, + LOD = polyqtlR_QTLscan_list[[i]]$QTL.res$LOD) + profile <- rbind(profile, profile_temp) + } + + structure(list(selected_mks = selected_mks, + qtl_info = polyqtlR_qtl_info, + profile = profile, + effects = polyqtlR_effects, + software = "polyqtlR"), + class = "viewqtl") +} + +#' Converts QTL information in custom files to viewqtl object +#' +#' @param selected_mks data.frame with: LG - linkage group ID; mk - marker ID; pos - position in linkage map (cM) +#' @param qtl_info data.frame with: LG - linkage group ID; Pos - position in linkage map (cM); +#' Pheno - phenotype ID; Pos_lower - lower position of confidence interval; +#' Pos_upper - upper position of the confidence interval; Pval - QTL p-value; h2 - herdability +#' @param blups data.frame with: haplo - haplotype ID; pheno - phenotype ID; qtl - QTL ID; u.hat - QTL estimated BLUPs +#' @param beta.hat data.frame with: pheno - phenotype ID; beta.hat - estimated beta +#' @param profile data.frame with: pheno - phenotype ID; LOP - significance value for the QTL, in this case LOP (can be LOD or DIC depending of the software used) +#' @param effects data.frame with: pheno - phenotype ID; qtl.id - QTL ID; haplo - haplotype ID; effect - haplotype effect value +#' @param probs data.frame with first column (named `ind`) as individuals ID and next columns named with markers ID and containing the genotype probability at each marker +#' +#' +#' @return object of class \code{viewqtl} +#' +#' @import vroom +#' @import abind +#' +#' @keywords internal +prepare_qtl_custom_files <- function(selected_mks, qtl_info, blups, beta.hat, + profile, effects, probs){ + + qtls <- list() + qtls$selected_mks <- as.data.frame(vroom(selected_mks$datapath, progress = FALSE, col_types = cols())) + qtls$qtl_info <- as.data.frame(vroom(qtl_info$datapath, progress = FALSE, col_types = cols())) + qtls$blups <- as.data.frame(vroom(blups$datapath, progress = FALSE, col_types = cols())) + qtls$beta.hat <- as.data.frame(vroom(beta.hat$datapath, progress = FALSE, col_types = cols())) + qtls$profile <- as.data.frame(vroom(profile$datapath, progress = FALSE, col_types = cols())) + qtls$profile[,2] <- as.numeric(qtls$profile[,2]) + qtls$effects <- as.data.frame(vroom(effects$datapath, progress = FALSE, col_types = cols())) + + probs.t <- vroom(probs$datapath, progress = FALSE, col_types = cols()) + ind <- probs.t$ind + probs.t <- as.data.frame(probs.t[,-1]) + probs.df <- split(probs.t, ind) + qtls$probs <- abind(probs.df, along = 3) + qtls$software <- "custom" + + structure(qtls, class = "viewqtl") +} + +#' Check hidecan inputs +#' +#' @param input_list shiny input result containing file path +#' @param func hidecan read input function +#' +#' @importFrom stats setNames +#' @importFrom utils read.csv +#' @import hidecan +#' @import purrr +#' +read_input_hidecan <- function(input_list, func){ + + ## Turning the hidecan constructors into safe functions + ## i.e. instead of throwing an error they return the error + ## message -> useful to escalate the error message in the app + safe_func <- safely(func) + + ## Read all files uploaded + res <- lapply(input_list$datapath, + read.csv) + + ## Add file name + names(res) <- input_list$name + + ## Apply the hidecan constructor to each file: this will + ## check whether the input files have the correct columns etc + res <- lapply(res, safe_func) |> + ## rather than the resulting list being: level 1 = file, level 2 = result and error + ## we get the result and error as level 1, and files as level 2 + transpose() + + ## Checking whether any file returned an error + no_error <- res$error |> + purrr::map_lgl(is.null) |> + all() + + if(!no_error){ + + ## Extract error message + error_msg <- res$error |> + setNames(input_list$name) |> + purrr::map(purrr::pluck, "message") |> + purrr::imap(~ paste0("Input file ", .y, ": ", .x)) |> + purrr::reduce(paste0, collapse = "\n") + + ## Remove NULL elements from the list or results + ## If all are NULL, will return an empty list() + res$result <- purrr::discard(res$result, + is.null) + + showNotification(error_msg, type = "error", duration = 20) + validate(need(no_error, error_msg)) + + } + + return(res$result) + } \ No newline at end of file diff --git a/R/mod_hidecan.R b/R/mod_hidecan.R index 9c1af0e..6a266d2 100644 --- a/R/mod_hidecan.R +++ b/R/mod_hidecan.R @@ -1,454 +1,473 @@ -#' hidecan_view UI Function -#' -#' @description A shiny Module. -#' -#' @param id,input,output,session Internal parameters for {shiny}. -#' -#' @importFrom shinyjs inlineCSS useShinyjs -#' @importFrom plotly plotlyOutput -#' @importFrom shiny NS tagList -#' @import hidecan -#' -#' @noRd -#' -mod_hidecan_view_ui <- function(id){ - ns <- NS(id) - tagList( - fluidPage( - verticalLayout( - fluidRow( - column(width = 12, - div(style = "position:absolute;right:1em;", - div( - actionButton(ns("goMap"), "Go to Map", icon("arrow-circle-left", verify_fa = FALSE), class = "btn btn-primary")) - ) - ), - tags$h2(tags$b("HIDECAN")), br(), hr(), - column(12, - column(12, - box( - background = "light-blue", - "Required inputs (*)", br(), - ) - ), - column(6, - box(width = 12, solidHeader = TRUE, status="info", title = "Select dataset *", - pickerInput(ns("tracks"), - label = h4("Select data sets to be displayed as tracks:"), - choices = "This will be updated", - selected = "This will be updated", - options = list( - `actions-box` = TRUE, - size = 10, - `selected-text-format` = "count > 3" - ), - multiple = TRUE), - pickerInput(ns("chrom"), - label = h4("Select chromosomes to be displayed:"), - choices = "This will be updated", - selected = "This will be updated", - options = list( - `actions-box` = TRUE, - size = 10, - `selected-text-format` = "count > 3" - ), - multiple = TRUE)) - ), - column(6, - box(width = 12, solidHeader = TRUE, status="info", title = "Define thresholds *", - ## Input sliders for GWAS score threshold - sliderInput(ns("score_thr_gwas"), "Score threshold for GWAS results", value = 4, min = 0, max = 10, step = 0.1),br(), - ## Input sliders for DE score and log2FC threshold - sliderInput(ns("score_thr_de"), "Score threshold for DE results", value = 1.3, min = 0, max = 10, step = 0.1), br(), - sliderInput(ns("log2fc_thr_de"), "log2(fold-change) threshold for DE results", value = 1, min = 0, max = 10, step = 0.1) - ) - ), - column(6, - box(width = 12, solidHeader = TRUE, status="info", collapsible = TRUE, collapsed = TRUE, title = "HIDECAN plot options", - textInput(ns("title"), "Title"), - textInput(ns("subtitle"), "Subtitle"), - fluidRow( - column(6, - numericInput(ns("nrows"), "Number of rows", value = NULL, min = 1, max = Inf)), - column(6, - numericInput(ns("ncols"), "Number of columns", value = 2, min = 1, max = Inf)) - ), - selectInput(ns("legend_position"), "Legend position", c("bottom", "top", "left", "right", "none")), - fluidRow( - column(6, - numericInput(ns("point_size"), "Point size", value = 3, min = 0, max = Inf)) - ), - fluidRow( - column(6, - numericInput(ns("label_size"), "Label size", value = 3.5, min = 0, max = Inf)), - column(6, - numericInput(ns("label_padding"), "Label padding", value = 0.15, min = 0, max = Inf)) - ), br(), - textInput(ns("data_names"), label = "No inputs detected", value = NULL), br(), - checkboxInput(ns("colour_genes_by_score"), "Colour genes by score?", value = TRUE), - checkboxInput(ns("remove_empty_chrom"), "Remove empty chromosomes?", value = TRUE) - ) - ) - ), - column(12, - box(id = ns("box_hidecan"), width = 12, solidHeader = TRUE, collapsible = TRUE, collapsed = FALSE, status="primary", title = actionLink(inputId = ns("hidecanID"), label = "HIDECAN plot"), - column(12, - box( - background = "light-blue", - "* HIDECAN analysis files or viewpoly object or example dataset (check `Input data` tab)" - ) - ), - column(12, - column(3, - useShinyjs(), - tags$head(tags$style(".butt{background-color:#add8e6; border-color: #add8e6; color: #337ab7;}")), - downloadButton(ns('bn_download'), "Download", class = "butt") - ), - column(3, - radioButtons(ns("fformat"), "File type", choices=c("png","tiff","jpeg","pdf", "RData"), selected = "png", inline = T) - ), - column(2, - numericInput(ns("width_hidecan"), "Width (mm)", value = 180), - ), - column(2, - numericInput(ns("height_hidecan"), "Height (mm)", value = 120), - ), - column(2, - numericInput(ns("dpi_hidecan"), "DPI", value = 300) - )), br(), - column(12, - hr(), - uiOutput(ns("plot.ui")) - ) - ) - ) - ) - ) - ) - ) -} - -# Inputs for tests -# input <- list() -# input$colour_genes_by_score <- TRUE -# input$remove_empty_chrom <- TRUE -# input$title <- NULL -# input$subtitle <- NULL -# input$ncols <- 2 -# input$legend_position <- "bottom" -# input$point_size <- 3 -# input$label_size <- 3.5 -# input$label_padding <- 0.15 -# input$score_thr_gwas <- 4 -# input$score_thr_de <- 1.3 -# input$log2fc_thr_de <- 1 - -#' hidecan_view Server Functions -#' -#' @importFrom plotly ggplotly renderPlotly -#' @importFrom dplyr `%>%` -#' @importFrom shinyjs js -#' @noRd -mod_hidecan_view_server <- function(input, output, session, - loadHidecan, - parent_session){ - ns <- session$ns - - observeEvent(input$goMap, { - updateTabsetPanel(session = parent_session, inputId = "viewpoly", - selected = "map") - }) - - observe({ - if(!is.null(loadHidecan()$GWASpoly)){ - shinyjs::disable("score_thr_gwas") - shinyjs::disable("score_thr_de") - shinyjs::disable("log2fc_thr_de") - } else if(length(loadHidecan()$GWAS)){ - max_score <- max(sapply(loadHidecan()$GWAS, function(x){max(x$score, na.rm = TRUE)})) - updateSliderInput(inputId = "score_thr_gwas", max = round(max_score,2), step = round(max_score/20,1)) - } else { - shinyjs::disable("score_thr_gwas") - } - - if(length(loadHidecan()$DE)){ - max_score <- max(sapply(loadHidecan()$DE, function(x){max(x$score, na.rm = TRUE)})) - max_log2fc <- max(sapply(loadHidecan()$DE, function(x){max(abs(x$log2FoldChange), na.rm = TRUE)})) - updateSliderInput(inputId = "score_thr_de", max = round(max_score,2), step = round(max_score/20,1)) - updateSliderInput(inputId = "log2fc_thr_de", max = round(max_log2fc,2), step = round(max_log2fc/10,1)) - } else { - shinyjs::disable("score_thr_de") - shinyjs::disable("log2fc_thr_de") - } - - }) - - observe({ - if (!is.null(hidecan_data()) & input$width_hidecan > 1 & input$height_hidecan > 1 & input$dpi_hidecan > 1) { - Sys.sleep(1) - # enable the download button - shinyjs::enable("bn_download") - } else { - shinyjs::disable("bn_download") - } - }) - - plot_nrows <- reactive({ - res <- input$nrows - if(missing(res) | is.na(res)) res <- NULL - res - }) - - hidecan_data <- reactive({ - - if(!is.null(loadHidecan()[["GWASpoly"]])){ - x <- loadHidecan()[["GWASpoly"]]$gwas_data_thr_list - } else { - x <- list() - } - - ## Adding file name as custom names for the different tracks - - ## For GWAS data, add file name if 1) there is some GWAS data from GWASpoly - ## or 2) if there is more than one file uploaded - - if(!is.null(loadHidecan()[["GWASpoly"]])){ - csv_names_gwas <- names(loadHidecan()[["GWAS"]]) - } else { - if(length(loadHidecan()[["GWAS"]]) == 0){ - csv_names_gwas <- NULL - } else if(length(loadHidecan()[["GWAS"]]) == 1){ - csv_names_gwas <- " " - } else { - csv_names_gwas <- names(loadHidecan()[["GWAS"]]) - } - } - - ## For DE and GWAS data, add file name only if there is more than one file - ## uploaded - csv_names <- c( - csv_names_gwas, - lapply(loadHidecan()[c("DE", "CAN")], - function(x){ - if(length(x) == 0) return(NULL) - if(length(x) > 1) return(names(x)) - return(" ") - }) |> - unlist() - ) - - x_csv <- c( - loadHidecan()[["GWAS"]] |> - lapply(hidecan::apply_threshold, input$score_thr_gwas), - loadHidecan()[["DE"]] |> - lapply(hidecan::apply_threshold, input$score_thr_de, input$log2fc_thr_de), - loadHidecan()[["CAN"]] |> - lapply(hidecan::apply_threshold) - ) - - ## Use custom names computed above - names(x_csv) <- csv_names - - x <- c(x, x_csv) - - chrom_length <- combine_chrom_length( - c( - loadHidecan()[["GWASpoly"]][["gwas_data_list"]], - loadHidecan()[["GWAS"]], - loadHidecan()[["DE"]], - loadHidecan()[["CAN"]] - ) - ) - - hidecan_data <- list(x, chrom_length) - hidecan_data - }) - - ## Function to create a name for each dataset to use when choosing which - ## dataset should be plotted - make_names_hidecan_data <- function(hidecan_list){ - - data_type_labels <- c("GWAS_data_thr" = "GWAS data", - "DE_data_thr" = "DE data", - "CAN_data_thr" = "Candidate genes list") - - labels <- sapply(hidecan_list, function(x){class(x)[[1]]}) - - labels <- paste0( - data_type_labels[labels], - " (", - names(hidecan_list), - ")" - ) - - labels <- sub(" ( )", "", labels, fixed = TRUE) - - labels - } - - ## Function to create a placeholder in the text input section when adding - ## custom prefix to track names - make_placeholders_hidecan_data <- function(hidecan_list){ - - data_type_labels <- c("GWAS_data_thr" = "[GWAS peaks]", - "DE_data_thr" = "[DE genes]", - "CAN_data_thr" = "[Candidate genes]") - - labels <- sapply(hidecan_list, function(x){data_type_labels[class(x)[[1]]]}) |> - unname() - labels[names(hidecan_list) != " "] <- names(hidecan_list)[names(hidecan_list) != " "] - - return(labels) - } - - observe({ - updateTextInput(inputId = "data_names", - label = paste0("Add custom prefix for your ",length(hidecan_data()[[1]]), - " tracks."), value = NULL, placeholder = make_placeholders_hidecan_data(hidecan_data()[[1]])) - - track_choices <- as.list(make_names_hidecan_data(hidecan_data()[[1]])) - names(track_choices) <- make_names_hidecan_data(hidecan_data()[[1]]) - - updatePickerInput(session, "tracks", - label = "Select data sets to be displayed as tracks:", - choices = track_choices, - selected=unlist(track_choices)) - - chrom_choices <- as.list(unique(hidecan_data()[[2]]$chromosome)) - names(chrom_choices) <- unique(hidecan_data()[[2]]$chromosome) - - updatePickerInput(session, "chrom", - label = "Select chromosomes", - choices = chrom_choices, - selected=unlist(chrom_choices)) - }) - - hidecan_plot <- reactive({ - validate( - need(!is.null(loadHidecan()), "Upload HIDECAN information in the upload session to access this feature.") - ) - - x <- hidecan_data()[[1]] - x <- x[match(input$tracks, make_names_hidecan_data(x))] - - ## At the start of the app input$chrom is equal to "This will be updated" - ## which would throw an error if trying to use it to subset the data - validate( - need(input$chrom != "This will be updated", "Waiting to initialise chromosomes selection.") - ) - - x <- lapply(x, function(y) y[which(y$chromosome %in% input$chrom),]) - - chrom_length <- hidecan_data()[[2]] - chrom_length <- chrom_length[match(input$chrom, chrom_length$chromosome),] - - ## Handling custom prefix for the tracks - if(input$data_names != ""){ - - ## Read in the prefixes - new_names <- unlist(strsplit(input$data_names, ",")) - - ## If one value is just space, it means no input - new_names[grep("^[:blank:]*$", new_names)] <- NA - - ## Making sure that there is a value per dataset (not more, not less) - ## This will select the first n values if there are too many values - ## or fill the vector with NAs if there are not enough values - length(new_names) <- length(x) - - ## For the tracks where there is no input, use what was originally planned - ## (e.g. custom label or nothing) - names(x) <- coalesce(new_names, names(x)) - - } else{ - names(x) <- names(x) - } - - p <- create_hidecan_plot(x, - chrom_length, - colour_genes_by_score = input$colour_genes_by_score, - remove_empty_chrom = input$remove_empty_chrom, - title = input$title, - subtitle = input$subtitle, - n_rows = plot_nrows(), - n_cols = input$ncols, - legend_position = input$legend_position, - point_size = input$point_size, - label_size = input$label_size, - label_padding = input$label_padding) - p - }) - - plotHeight <- reactive({ - validate( - need(!all(c(is.null(loadHidecan()$GWAS),is.null(loadHidecan()$GWASpoly))), "Upload HIDECAN information in upload session to access this feature."), - ) - - ## Extract number of chromosomes directly from the plot - n.chr <- length(unique(hidecan_plot()$data$chromosome)) - ## Also use the number of tracks on the y axis - n.ytracks <- length(unique(hidecan_plot()$data$dataset)) - - size <- (n.ytracks * n.chr/input$ncols)*80 - - size - }) - - output$plot_hidecan <- renderPlot({ - validate( - need(!is.null(loadHidecan()), "Upload HIDECAN information in the upload session to access this feature.") - ) - hidecan_plot() - }) - - output$plot.ui <- renderUI({ - plotOutput(ns("plot_hidecan"), height = plotHeight()) - }) - - # HIDECAN download - fn_downloadname <- reactive({ - seed <- sample(1:1000,1) - if(input$fformat=="png") filename <- paste0("hidecan","_",seed,".png") - if(input$fformat=="tiff") filename <- paste0("hidecan","_",seed,".tiff") - if(input$fformat=="jpeg") filename <- paste0("hidecan","_",seed,".jpg") - if(input$fformat=="pdf") filename <- paste0("hidecan","_",seed,".pdf") - if(input$fformat=="RData") filename <- paste0("hidecan","_",seed,".RData") - return(filename) - }) - - # download profile - fn_download <- function() - { - if(input$fformat!="RData"){ - ggsave(hidecan_data(), filename = fn_downloadname(), - width = input$width_hidecan, height = input$height_hidecan, - units = "mm", dpi = input$dpi_hidecan) - } else save(hidecan_data(), file = fn_downloadname()) - } - - observe({ - if (!is.null(hidecan_data()) & input$width_hidecan > 1 & input$height_hidecan > 1 & input$dpi_hidecan > 1) { - Sys.sleep(1) - # enable the download button - shinyjs::enable("bn_download") - } else { - shinyjs::disable("bn_download") - } - }) - - # download handler - output$bn_download <- downloadHandler( - filename = fn_downloadname, - content = function(file) { - fn_download() - file.copy(fn_downloadname(), file, overwrite=T) - file.remove(fn_downloadname()) - } - ) -} - -## To be copied in the UI -# mod_hidecan_view_ui("hidecan_view_ui_1") - -## To be copied in the server -# mod_hidecan_view_server("hidecan_view_ui_1") +#' hidecan_view UI Function +#' +#' @description A shiny Module. +#' +#' @param id,input,output,session Internal parameters for {shiny}. +#' +#' @importFrom shinyjs inlineCSS useShinyjs +#' @importFrom plotly plotlyOutput +#' @importFrom shiny NS tagList +#' @import hidecan +#' +#' @noRd +#' +mod_hidecan_view_ui <- function(id){ + ns <- NS(id) + tagList( + fluidPage( + verticalLayout( + fluidRow( + column(width = 12, + div(style = "position:absolute;right:1em;", + div( + actionButton(ns("goMap"), "Go to Map", icon("arrow-circle-left", verify_fa = FALSE), class = "btn btn-primary")) + ) + ), + tags$h2(tags$b("HIDECAN")), br(), hr(), + column(12, + column(12, + box( + background = "light-blue", + "Required inputs (*)", br(), + ) + ), + column(6, + box(width = 12, solidHeader = TRUE, status="info", title = "Select dataset *", + pickerInput(ns("tracks"), + label = h4("Select data sets to be displayed as tracks:"), + choices = "This will be updated", + selected = "This will be updated", + options = list( + `actions-box` = TRUE, + `live-search`=TRUE, + size = 10, + `selected-text-format` = "count > 3" + ), + multiple = TRUE), + pickerInput(ns("chrom"), + label = h4("Select chromosomes to be displayed:"), + choices = "This will be updated", + selected = "This will be updated", + options = list( + `actions-box` = TRUE, + `live-search`=TRUE, + size = 10, + `selected-text-format` = "count > 3" + ), + multiple = TRUE)) + ), + column(6, + box(width = 12, solidHeader = TRUE, status="info", title = "Define thresholds *", + ## Input sliders for GWAS score threshold + sliderInput(ns("score_thr_gwas"), "Score threshold for GWAS results", value = 4, min = 0, max = 10, step = 0.1),br(), + ## Input sliders for DE score and log2FC threshold + sliderInput(ns("score_thr_de"), "Score threshold for DE results", value = 1.3, min = 0, max = 10, step = 0.1), br(), + sliderInput(ns("log2fc_thr_de"), "log2(fold-change) threshold for DE results", value = 1, min = 0, max = 10, step = 0.1) + ) + ), + column(6, + box(width = 12, solidHeader = TRUE, status="info", collapsible = TRUE, collapsed = TRUE, title = "HIDECAN plot options", + textInput(ns("title"), "Title"), + textInput(ns("subtitle"), "Subtitle"), + fluidRow( + column(4, + numericInput(ns("nrows"), "Number of rows", value = NULL, min = 1, max = Inf)), + column(4, + numericInput(ns("ncols"), "Number of columns", value = 2, min = 1, max = Inf)), + column(4, + numericInput(ns("height"), "Graphic height (px)", value = NULL, min = 100, max = Inf)) + ), + selectInput(ns("legend_position"), "Legend position", c("bottom", "top", "left", "right", "none")), + fluidRow( + column(6, + numericInput(ns("point_size"), "Point size", value = 3, min = 0, max = Inf)), + column(6, + numericInput(ns("font_size"), "Font size", value =12, min = 1, max = Inf)) + ), + fluidRow( + column(6, + numericInput(ns("label_size"), "Label size", value = 3.5, min = 0, max = Inf)), + column(6, + numericInput(ns("label_padding"), "Label padding", value = 0.15, min = 0, max = Inf)) + ), br(), + textInput(ns("data_names"), label = "No inputs detected", value = NULL), br(), + checkboxInput(ns("colour_genes_by_score"), "Colour genes by score?", value = TRUE), + checkboxInput(ns("remove_empty_chrom"), "Remove empty chromosomes?", value = TRUE), + checkboxInput(ns("remove_empty_traits"), "Remove empty traits?", value = FALSE) + ) + ) + ), + column(12, + box(id = ns("box_hidecan"), width = 12, solidHeader = TRUE, collapsible = TRUE, collapsed = FALSE, status="primary", title = actionLink(inputId = ns("hidecanID"), label = "HIDECAN plot"), + column(12, + box( + background = "light-blue", + "* HIDECAN analysis files or viewpoly object or example dataset (check `Input data` tab)" + ) + ), + column(12, + column(3, + useShinyjs(), + tags$head(tags$style(".butt{background-color:#add8e6; border-color: #add8e6; color: #337ab7;}")), + downloadButton(ns('bn_download'), "Download", class = "butt") + ), + column(3, + radioButtons(ns("fformat"), "File type", choices=c("png","tiff","jpeg","pdf", "RData"), selected = "png", inline = T) + ), + column(2, + numericInput(ns("width_hidecan"), "Width (mm)", value = 180), + ), + column(2, + numericInput(ns("height_hidecan"), "Height (mm)", value = 120), + ), + column(2, + numericInput(ns("dpi_hidecan"), "DPI", value = 300) + )), br(), + column(12, + hr(), + uiOutput(ns("plot.ui")) + ) + ) + ) + ) + ) + ) + ) +} + +# Inputs for tests +# input <- list() +# input$colour_genes_by_score <- TRUE +# input$remove_empty_chrom <- TRUE +# input$title <- NULL +# input$subtitle <- NULL +# input$ncols <- 2 +# input$legend_position <- "bottom" +# input$point_size <- 3 +# input$label_size <- 3.5 +# input$label_padding <- 0.15 +# input$score_thr_gwas <- 4 +# input$score_thr_de <- 1.3 +# input$log2fc_thr_de <- 1 + +#' hidecan_view Server Functions +#' +#' @importFrom plotly ggplotly renderPlotly +#' @importFrom dplyr `%>%` +#' @importFrom shinyjs js +#' @noRd +mod_hidecan_view_server <- function(input, output, session, + loadHidecan, + parent_session){ + ns <- session$ns + + observeEvent(input$goMap, { + updateTabsetPanel(session = parent_session, inputId = "viewpoly", + selected = "map") + }) + + observe({ + if(!is.null(loadHidecan()$GWASpoly)){ + shinyjs::disable("score_thr_gwas") + shinyjs::disable("score_thr_de") + shinyjs::disable("log2fc_thr_de") + } else if(length(loadHidecan()$GWAS)){ + max_score <- max(sapply(loadHidecan()$GWAS, function(x){max(x$score, na.rm = TRUE)})) + updateSliderInput(inputId = "score_thr_gwas", max = round(max_score,2), step = round(max_score/20,1)) + } else { + shinyjs::disable("score_thr_gwas") + } + + if(length(loadHidecan()$DE)){ + max_score <- max(sapply(loadHidecan()$DE, function(x){max(x$score, na.rm = TRUE)})) + max_log2fc <- max(sapply(loadHidecan()$DE, function(x){max(abs(x$log2FoldChange), na.rm = TRUE)})) + updateSliderInput(inputId = "score_thr_de", max = round(max_score,2), step = round(max_score/20,1)) + updateSliderInput(inputId = "log2fc_thr_de", max = round(max_log2fc,2), step = round(max_log2fc/10,1)) + } else { + shinyjs::disable("score_thr_de") + shinyjs::disable("log2fc_thr_de") + } + + }) + + observe({ + if (!is.null(hidecan_data()) & input$width_hidecan > 1 & input$height_hidecan > 1 & input$dpi_hidecan > 1) { + Sys.sleep(1) + # enable the download button + shinyjs::enable("bn_download") + } else { + shinyjs::disable("bn_download") + } + }) + + plot_nrows <- reactive({ + res <- input$nrows + if(missing(res) | is.na(res)) res <- NULL + res + }) + + hidecan_data <- reactive({ + + if(!is.null(loadHidecan()[["GWASpoly"]])){ + x <- loadHidecan()[["GWASpoly"]]$gwas_data_thr_list + } else { + x <- list() + } + + ## Adding file name as custom names for the different tracks + + ## For GWAS data, add file name if 1) there is some GWAS data from GWASpoly + ## or 2) if there is more than one file uploaded + + if(!is.null(loadHidecan()[["GWASpoly"]])){ + csv_names_gwas <- names(loadHidecan()[["GWAS"]]) + } else { + if(length(loadHidecan()[["GWAS"]]) == 0){ + csv_names_gwas <- NULL + } else if(length(loadHidecan()[["GWAS"]]) == 1){ + csv_names_gwas <- " " + } else { + csv_names_gwas <- names(loadHidecan()[["GWAS"]]) + } + } + + ## For DE and GWAS data, add file name only if there is more than one file + ## uploaded + csv_names <- c( + csv_names_gwas, + lapply(loadHidecan()[c("DE", "CAN")], + function(x){ + if(length(x) == 0) return(NULL) + if(length(x) > 1) return(names(x)) + return(" ") + }) |> + unlist() + ) + + x_csv <- c( + loadHidecan()[["GWAS"]] |> + lapply(hidecan::apply_threshold, input$score_thr_gwas), + loadHidecan()[["DE"]] |> + lapply(hidecan::apply_threshold, input$score_thr_de, input$log2fc_thr_de), + loadHidecan()[["CAN"]] |> + lapply(hidecan::apply_threshold) + ) + + ## Use custom names computed above + names(x_csv) <- csv_names + + x <- c(x, x_csv) + + chrom_length <- combine_chrom_length( + c( + loadHidecan()[["GWASpoly"]][["gwas_data_list"]], + loadHidecan()[["GWAS"]], + loadHidecan()[["DE"]], + loadHidecan()[["CAN"]] + ) + ) + + hidecan_data <- list(x, chrom_length) + hidecan_data + }) + + ## Function to create a name for each dataset to use when choosing which + ## dataset should be plotted + make_names_hidecan_data <- function(hidecan_list){ + + data_type_labels <- c("GWAS_data_thr" = "GWAS data", + "DE_data_thr" = "DE data", + "CAN_data_thr" = "Candidate genes list") + + labels <- sapply(hidecan_list, function(x){class(x)[[1]]}) + + labels <- paste0( + data_type_labels[labels], + " (", + names(hidecan_list), + ")" + ) + + labels <- sub(" ( )", "", labels, fixed = TRUE) + + labels + } + + ## Function to create a placeholder in the text input section when adding + ## custom prefix to track names + make_placeholders_hidecan_data <- function(hidecan_list){ + + data_type_labels <- c("GWAS_data_thr" = "[GWAS peaks]", + "DE_data_thr" = "[DE genes]", + "CAN_data_thr" = "[Candidate genes]") + + labels <- sapply(hidecan_list, function(x){data_type_labels[class(x)[[1]]]}) |> + unname() + labels[names(hidecan_list) != " "] <- names(hidecan_list)[names(hidecan_list) != " "] + + return(labels) + } + + observe({ + updateTextInput(inputId = "data_names", + label = paste0("Add custom prefix for your ",length(hidecan_data()[[1]]), + " tracks."), value = NULL, placeholder = make_placeholders_hidecan_data(hidecan_data()[[1]])) + + track_choices <- as.list(make_names_hidecan_data(hidecan_data()[[1]])) + names(track_choices) <- make_names_hidecan_data(hidecan_data()[[1]]) + + updatePickerInput(session, "tracks", + label = "Select data sets to be displayed as tracks:", + choices = track_choices, + selected=unlist(track_choices)[1]) + + chrom_choices <- as.list(unique(hidecan_data()[[2]]$chromosome)) + names(chrom_choices) <- unique(hidecan_data()[[2]]$chromosome) + + updatePickerInput(session, "chrom", + label = "Select chromosomes", + choices = chrom_choices, + selected=unlist(chrom_choices)) + }) + + hidecan_plot <- reactive({ + validate( + need(!is.null(loadHidecan()), "Upload HIDECAN information in the upload session to access this feature.") + ) + + x <- hidecan_data()[[1]] + x <- x[match(input$tracks, make_names_hidecan_data(x))] + + ## At the start of the app input$chrom is equal to "This will be updated" + ## which would throw an error if trying to use it to subset the data + validate( + need(input$chrom != "This will be updated", "Waiting to initialise chromosomes selection.") + ) + + x <- lapply(x, function(y) y[which(y$chromosome %in% input$chrom),]) + + chrom_length <- hidecan_data()[[2]] + chrom_length <- chrom_length[match(input$chrom, chrom_length$chromosome),] + + ## Handling custom prefix for the tracks + if(input$data_names != ""){ + + ## Read in the prefixes + new_names <- unlist(strsplit(input$data_names, ",")) + + ## If one value is just space, it means no input + new_names[grep("^[:blank:]*$", new_names)] <- NA + + ## Making sure that there is a value per dataset (not more, not less) + ## This will select the first n values if there are too many values + ## or fill the vector with NAs if there are not enough values + length(new_names) <- length(x) + + ## For the tracks where there is no input, use what was originally planned + ## (e.g. custom label or nothing) + names(x) <- coalesce(new_names, names(x)) + + } else{ + names(x) <- names(x) + } + + if(input$remove_empty_traits){ + x <- x[-which(sapply(x, nrow) == 0)] + } + + validate( + need(any(sapply(x, nrow) != 0), "No QTL found") + ) + + p <- create_hidecan_plot(x, + chrom_length, + colour_genes_by_score = input$colour_genes_by_score, + remove_empty_chrom = input$remove_empty_chrom, + title = input$title, + subtitle = input$subtitle, + n_rows = plot_nrows(), + n_cols = input$ncols, + legend_position = input$legend_position, + point_size = input$point_size, + label_size = input$label_size, + label_padding = input$label_padding) + p + }) + + plotHeight <- reactive({ + validate( + need(!all(c(is.null(loadHidecan()$GWAS),is.null(loadHidecan()$GWASpoly))), "Upload HIDECAN information in upload session to access this feature."), + ) + + ## Extract number of chromosomes directly from the plot + n.chr <- length(unique(hidecan_plot()$data$chromosome)) + ## Also use the number of tracks on the y axis + n.ytracks <- length(unique(hidecan_plot()$data$dataset)) + + if(!(is.null(input$height) | is.na(input$height))){ + size <- input$height + } else if(n.chr == 1 & n.ytracks == 1) { + size <- 240 + } else size <- (n.ytracks * n.chr/input$ncols)*240 + + size + }) + + output$plot_hidecan <- renderPlot({ + validate( + need(!is.null(loadHidecan()), "Upload HIDECAN information in the upload session to access this feature.") + ) + hidecan_plot() + theme(text = element_text(size = input$font_size)) + }) + + output$plot.ui <- renderUI({ + plotOutput(ns("plot_hidecan"), height = paste0(plotHeight(),"px")) + }) + + # HIDECAN download + fn_downloadname <- reactive({ + seed <- sample(1:1000,1) + if(input$fformat=="png") filename <- paste0("hidecan","_",seed,".png") + if(input$fformat=="tiff") filename <- paste0("hidecan","_",seed,".tiff") + if(input$fformat=="jpeg") filename <- paste0("hidecan","_",seed,".jpg") + if(input$fformat=="pdf") filename <- paste0("hidecan","_",seed,".pdf") + if(input$fformat=="RData") filename <- paste0("hidecan","_",seed,".RData") + return(filename) + }) + + # download profile + fn_download <- function() + { + if(input$fformat!="RData"){ + ggsave(hidecan_data(), filename = fn_downloadname(), + width = input$width_hidecan, height = input$height_hidecan, + units = "mm", dpi = input$dpi_hidecan) + } else save(hidecan_data(), file = fn_downloadname()) + } + + observe({ + if (!is.null(hidecan_data()) & input$width_hidecan > 1 & input$height_hidecan > 1 & input$dpi_hidecan > 1) { + Sys.sleep(1) + # enable the download button + shinyjs::enable("bn_download") + } else { + shinyjs::disable("bn_download") + } + }) + + # download handler + output$bn_download <- downloadHandler( + filename = fn_downloadname, + content = function(file) { + fn_download() + file.copy(fn_downloadname(), file, overwrite=T) + file.remove(fn_downloadname()) + } + ) +} + +## To be copied in the UI +# mod_hidecan_view_ui("hidecan_view_ui_1") + +## To be copied in the server +# mod_hidecan_view_server("hidecan_view_ui_1") diff --git a/R/mod_qtl_view.R b/R/mod_qtl_view.R index 5f61723..ade0eb5 100644 --- a/R/mod_qtl_view.R +++ b/R/mod_qtl_view.R @@ -1,733 +1,731 @@ -#' qtl_view UI Function -#' -#' @description A shiny Module. -#' -#' @param id,input,output,session Internal parameters for {shiny}. -#' -#' @import shinydashboard -#' @import shinyWidgets -#' @importFrom shinyjs inlineCSS useShinyjs -#' -#' @noRd -#' -#' @importFrom shiny NS tagList -mod_qtl_view_ui <- function(id){ - ns <- NS(id) - tagList( - useShinyjs(), - extendShinyjs(text = jscode, functions = "collapse"), - fluidPage( - verticalLayout( - fluidRow( - column(width = 12, - div(style = "position:absolute;right:1em;", - div( - actionButton(ns("goUploads"), "Go to Input data", icon("arrow-circle-left", verify_fa = FALSE), class = "btn btn-primary"), - actionButton(ns("goGenes"), label = div("Go to Genome", icon("arrow-circle-right", verify_fa = FALSE)), class = "btn btn-primary")) - ) - ), - tags$h2(tags$b("VIEWqtl")), br(), hr(), - column(6, - column(12, - box( - background = "light-blue", - "Required inputs (*)", br(), - ) - ), - column(6, - box(width = 12, solidHeader = TRUE, status="info", title = "Select linkage group/s *", - pickerInput(ns("group"), - label = h6("Linkage group/s:"), - choices = "This will be updated", - selected = "This will be updated", - options = list( - `actions-box` = TRUE, - size = 10, - `selected-text-format` = "count > 3" - ), - multiple = TRUE) - ) - ), - column(6, - box(width = 12, solidHeader = TRUE, status="info", title = "Select phenotype/s *", - pickerInput(ns("phenotypes"), - label = h6("Phenotype/s:"), - choices = "This will be updated", - selected = "This will be updated", - options = list( - `actions-box` = TRUE, - size = 10, - `selected-text-format` = "count > 3" - ), - multiple = TRUE) - ) - ) - ), - column(12, - box(id = ns("box_profile"), width = 12, solidHeader = TRUE, collapsible = TRUE, collapsed = FALSE, status="primary", title = actionLink(inputId = ns("profileID"), label = "QTL profile"), - column(12, - box( - background = "light-blue", - "* QTL analysis files or viewpoly object or example dataset (check `Input data` tab)" - ) - ), - column(12, - column(3, - useShinyjs(), - tags$head(tags$style(".butt{background-color:#add8e6; border-color: #add8e6; color: #337ab7;}")), - downloadButton(ns('bn_download'), "Download", class = "butt") - ), - column(3, - radioButtons(ns("fformat"), "File type", choices=c("png","tiff","jpeg","pdf", "RData"), selected = "png", inline = T) - ), - column(2, - numericInput(ns("width_profile"), "Width (mm)", value = 180), - ), - column(2, - numericInput(ns("height_profile"), "Height (mm)", value = 120), - ), - column(2, - numericInput(ns("dpi_profile"), "DPI", value = 300) - )), br(), - column(12, - hr(), - plotOutput(ns("plot_qtl"), - click=ns("plot_click"), brush = ns("plot_brush")) - ), - box(id = ns("box_effects"), width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("effectsID"), label = "Effects"), - column(12, - box( - background = "light-blue", - "* QTL analysis files or viewpoly object or example dataset (check `Input data` tab)", br(), - "* Selection of QTL/s (triangle/s at the bottom of QTL profile graphic)" - ) - ), - div(style = "position:absolute;right:3em;", - radioButtons(ns("effects_design"), "Design", - choices = c("Additive (bar)" = "bar", "Additive (circle)" = "circle", "Alleles combination" = "digenic"), - selected = "bar") - ), br(), br(), - column(3, - downloadButton(ns('bn_download_effects'), "Download", class = "butt") - ), - - column(3, - numericInput(ns("width_effects"), "Width (mm)", value = 180), - ), - column(3, - numericInput(ns("height_effects"), "Height (mm)", value = 120), - ), - column(3, - numericInput(ns("dpi_effects"), "DPI", value = 300) - ), br(), - column(12, - column(6, - radioButtons(ns("fformat_effects"), "File type", choices=c("png","tiff","jpeg","pdf", "RData"), selected = "png", inline = T) - ), - column(6, - textInput(ns("parents_name"), "Parents name", value = "P1, P2") - ), - ), - column(12, - hr(), - uiOutput(ns("plot.ui")) - ) - ), br(), - box(id = ns("box_haplo"),width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("haploID"), label = "Progeny haplotypes"), - column(12, - box( - background = "light-blue", - "* QTLpoly analysis files or viewpoly object or example dataset (check `Input data` tab)", br(), - "* Selection of QTL/s (triangle/s at the bottom of QTL profile graphic)" - ) - ), - column(12, - actionBttn(ns("haplo_update"), style = "jelly", color = "royal", size = "sm", label = "update available haplotypes", icon = icon("refresh", verify_fa = FALSE)), - br(), br(), - pickerInput(ns("haplo"), - label = h6("Select haplotypes*"), - choices = "Click on `update available haplotype` to update", - selected = "Click on `update available haplotype` to update", - options = pickerOptions( - size = 15, - `selected-text-format` = "count > 3", - `live-search`=TRUE, - actionsBox = TRUE, - dropupAuto = FALSE, - dropdownAlignRight = TRUE - ), - multiple = TRUE), br(), - pickerInput(ns("haplo_exclude"), - label = h6("Exclude haplotypes (optional)"), - choices = "Click on `update available haplotype` to update", - selected = "Click on `update available haplotype` to update", - options = pickerOptions( - size = 15, - `selected-text-format` = "count > 3", - `live-search`=TRUE, - actionsBox = TRUE, - dropupAuto = FALSE, - dropdownAlignRight = TRUE - ), - multiple = TRUE), br(), - actionBttn(ns("haplo_submit"), style = "jelly", color = "royal", size = "sm", label = "submit selected haplotypes*", icon = icon("share-square", verify_fa = FALSE)), - br(), hr()), - column(3, - downloadButton(ns('bn_download_haplo'), "Download", class = "butt") - ), - column(3, - radioButtons(ns("fformat_haplo"), "File type", choices=c("png","tiff","jpeg","pdf", "RData"), selected = "png", inline = T) - ), - column(2, - numericInput(ns("width_haplo"), "Width (mm)", value = 180), - ), - column(2, - numericInput(ns("height_haplo"), "Height (mm)", value = 120), - ), - column(2, - numericInput(ns("dpi_haplo"), "DPI", value = 300) - ), br(), - column(12, - hr(), - htmlOutput(ns("ind_names")), hr(), - uiOutput(ns("plot_haplo.ui")) - ) - ), - box(id = ns("box_bree"), width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("breeID"), label = "Breeding values"), - column(12, - box( - background = "light-blue", - "* QTLpoly analysis files or viewpoly object or example dataset (check `Input data` tab)", br(), - "* Selection of QTL/s (triangle/s at the bottom of QTL profile graphic)" - ) - ), - column(12, - DT::dataTableOutput(ns("breeding_values")) - ) - ), br(), br(), - box(id = ns("box_summary"),width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("summaryID"), label = "QTL summary"), - column(12, - box( - background = "light-blue", - "* QTL analysis files or viewpoly object or example dataset (check `Input data` tab)", br(), - "* Selection of QTL/s (triangle/s at the bottom of QTL profile graphic)" - ) - ), - column(12, - DT::dataTableOutput(ns("info")) - ) - ) - ) - ) - ) - ) - ) - ) -} - -#' qtl_view Server Functions -#' -#' @importFrom ggpubr ggarrange -#' @import shinydashboard -#' @importFrom shinyjs js -#' -#' @noRd -mod_qtl_view_server <- function(input, output, session, - loadMap, loadQTL, - parent_session){ - ns <- session$ns - - #Collapse boxes - observeEvent(input$profileID, { - js$collapse(ns("box_profile")) - }) - - observeEvent(input$effectsID, { - js$collapse(ns("box_effects")) - }) - - observeEvent(input$haploID, { - js$collapse(ns("box_haplo")) - }) - - observeEvent(input$breeID, { - js$collapse(ns("box_bree")) - }) - - observeEvent(input$summaryID, { - js$collapse(ns("box_summary")) - }) - - observe({ - # Dynamic linkage group number - if(!is.null(loadMap())){ - group_choices <- as.list(1:length(loadMap()$d.p1)) - names(group_choices) <- 1:length(loadMap()$d.p1) - } else if(!is.null(loadQTL())){ - group_choices <- as.list(1:length(unique(loadQTL()$selected_mks$LG))) - names(group_choices) <- 1:length(unique(loadQTL()$selected_mks$LG)) - } else { - group_choices <- as.list("Upload map or QTL data in `upload` session.") - names(group_choices) <- "Upload map or QTL data in `upload` session." - } - - if(length(group_choices) < 5) the_choice <- group_choices[[1]] else the_choice <- group_choices[[5]] - - updatePickerInput(session, "group", - label="Linkage group/s:", - choices = group_choices, - selected= the_choice) - - - # Dynamic QTL - if(!is.null(loadQTL())){ - pheno_choices <- as.list(unique(loadQTL()$profile$pheno)) - names(pheno_choices) <- unique(loadQTL()$profile$pheno) - - updatePickerInput(session, "phenotypes", - label = "Phenotype/s:", - choices = pheno_choices, - selected=unlist(pheno_choices)[1]) - } else { - updatePickerInput(session, "phenotypes", - label = "Phenotype/s:", - choices = "Upload QTL information to update", - selected= "Upload QTL information to update") - } - }) - - observeEvent(input$goGenes, { - updateTabsetPanel(session = parent_session, inputId = "viewpoly", - selected = "genes") - }) - - observeEvent(input$goUploads, { - updateTabsetPanel(session = parent_session, inputId = "viewpoly", - selected = "upload") - }) - - qtl.data <- reactive({ - validate( - need(length(input$phenotypes) != 0 & input$phenotypes != "Upload QTL information to update", "Select at least one phenotype"), - need(length(input$group) != 0 & input$group != "Upload map or QTL data in `upload` session.", "Select at least one linkage group"), - need(!is.null(loadQTL()), "Upload the QTL information in upload session to access this feature.") - ) - idx <- which(unique(loadQTL()$profile$pheno) %in% input$phenotypes) - - withProgress(message = 'Working:', value = 0, { - incProgress(0.3, detail = paste("building graphic...")) - pl <- plot_profile(profile = loadQTL()$profile, - qtl_info = loadQTL()$qtl_info, - selected_mks = loadQTL()$selected_mks, - pheno.col = idx, - lgs.id = as.numeric(input$group), - by_range=F, plot = F) - }) - }) - - output$plot_qtl <- renderPlot({ - withProgress(message = 'Working:', value = 0, { - incProgress(0.3, detail = paste("building graphic...")) - only_plot_profile(pl.in = qtl.data()) - }) - }) - - effects.data <- reactive({ - validate( - need(!is.null(loadQTL()), "Upload the QTL information in upload session to access this feature."), - need(!is.null(input$plot_brush), "Select at least one triangle on the bottom of the QTL profile graphic. The triangles refer to QTL peaks detected. You can click and brush your cursor to select more than one.") - ) - df <- try(brushedPoints(qtl.data()[[2]], input$plot_brush, xvar = "x", yvar = "y.dat")) - validate( - need(dim(df)[1] > 0, "Select at least one triangle on the bottom of the QTL profile graphic. The triangles refer to QTL peaks detected. You can click and brush your cursor to select more than one.") - ) - - print(input$parents_name) - parents <- unlist(strsplit(input$parents_name, ",")) - parents <- gsub(" ", "", parents) - print(parents) - - withProgress(message = 'Working:', value = 0, { - incProgress(0.5, detail = paste("Getting data...")) - data <- data_effects(qtl_info = loadQTL()$qtl_info, - effects = loadQTL()$effects, - pheno.col = as.character(df$Trait), - lgs = df$LG, - position = df$`Position (cM)`, - groups = as.numeric(input$group), - software = loadQTL()$software, - design = input$effects_design, - parents = parents) - }) - }) - - output$effects <- renderPlot({ - withProgress(message = 'Working:', value = 0, { - incProgress(0.5, detail = paste("building graphic...")) - plot_effects(effects.data(), software = loadQTL()$software, design = input$effects_design) - }) - }) - - plotHeight <- reactive({ - - validate( - need(!is.null(loadQTL()), "Upload the QTL information in upload session to access this feature."), - need(!is.null(input$plot_brush), "Select at least one triangle on the bottom of the QTL profile graphic. The triangles refer to QTL peaks detected. You can click and brush your cursor to select more than one.") - ) - dframe <- try(brushedPoints(qtl.data()[[2]], input$plot_brush, xvar = "x", yvar = "y.dat")) - validate( - need(!inherits(dframe, "try-error"), "Select at least one triangle on the bottom of the QTL profile graphic. The triangles refer to QTL peaks detected. You can click and brush your cursor to select more than one.") - ) - counts <- nrow(dframe) - counts <- ceiling(counts/4) - if(counts == 0) counts <- 1 - if(loadQTL()$software == "polyqtlR") { - size <- counts*650 - } else if(input$effects_design == "bar" | input$effects_design == "digenic"){ - size <- counts*350 - } else if(input$effects_design == "circle"){ - counts <- length(unique(dframe$LG)) - counts <- ceiling(counts/2) - if(counts == 0) counts <- 1 - size <- counts*500 - } - size - }) - - output$plot.ui <- renderUI({ - withProgress(message = 'Working:', value = 0, { - incProgress(0.5, detail = paste("building graphic...")) - plotOutput(ns("effects"), height = plotHeight()) - }) - }) - - observeEvent(input$haplo_update,{ - if(!is.null(loadQTL())){ - if(loadQTL()$software == "polyqtlR" | loadQTL()$software == "diaQTL") { - dframe <- NULL - updatePickerInput(session, "haplo", - label = "Select haplotypes", - choices = paste0("Feature not implemented for software: ", loadQTL()$software), - selected= paste0("Feature not implemented for software: ", loadQTL()$software)) - - updatePickerInput(session, "haplo_exclude", - label = "Exclude haplotypes (optional)", - choices = paste0("Feature not implemented for software: ", loadQTL()$software), - selected= paste0("Feature not implemented for software: ", loadQTL()$software)) - } else if(!is.null(input$plot_brush)){ - dframe <- brushedPoints(qtl.data()[[2]], input$plot_brush, xvar = "x", yvar = "y.dat") - } else { - dframe <- NULL - updatePickerInput(session, "haplo", - label = "Select haplotypes", - choices = "Select QTL in the profile graphic to update", - selected= "Select QTL in the profile graphic to update") - - updatePickerInput(session, "haplo_exclude", - label = "Exclude haplotypes (optional)", - choices = "Select QTL in the profile graphic to update", - selected= "Select QTL in the profile graphic to update") - } - } else { - dframe <- NULL - updatePickerInput(session, "haplo", - label = "Select haplotypes", - choices = "Upload the QTL information in upload session to access this feature.", - selected= "Upload the QTL information in upload session to access this feature.") - - updatePickerInput(session, "haplo_exclude", - label = "Exclude haplotypes (optional)", - choices = "Upload the QTL information in upload session to access this feature.", - selected= "Upload the QTL information in upload session to access this feature.") - } - if(!is.null(dframe)){ - if(input$effects_design == "digenic" | input$effects_design == "circle") { - updatePickerInput(session, "haplo", - label = "Select haplotypes", - choices = "Select `bar` design to access this feature.", - selected= "Select `bar` design to access this feature.") - - updatePickerInput(session, "haplo_exclude", - label = "Exclude haplotypes (optional)", - choices = "Select `bar` design to access this feature.", - selected= "Select `bar` design to access this feature.") - } else { - haplo_choices <- paste0("Trait:", dframe$Trait, "_LG:", dframe$LG, "_Pos:", dframe$`Position (cM)`) - alleles <- effects.data()[[1]]$data$Alleles[!grepl("_",effects.data()[[1]]$data$Alleles)] - alleles <- rep(alleles, length(haplo_choices)) - haplo_choices <- rep(haplo_choices, each = length(alleles)/length(haplo_choices)) - haplo_choices <- paste0(haplo_choices, "_homolog:", alleles) - haplo_choices <- as.list(haplo_choices) - names(haplo_choices) <- unlist(haplo_choices) - updatePickerInput(session, "haplo", - label = "Select haplotypes", - choices = haplo_choices, - selected= haplo_choices[1:3]) - - updatePickerInput(session, "haplo_exclude", - label = "Exclude haplotypes (optional)", - choices = haplo_choices, - selected= NULL) - } - } - }) - - haplo_data <- eventReactive(input$haplo_submit, { - validate( - need(all(input$haplo != paste0("Feature not implemented for software: ", loadQTL()$software)), paste0("Feature not implemented for software: ", loadQTL()$software)), - need(all(input$haplo != "Click on `update available haplotype` to update"), "Click on `update available haplotype` to update"), - need(all(input$haplo != "Select QTL in the profile graphic to update"), "Select QTL in the profile graphic to update"), - need(all(input$haplo != "Select `bar` design to access this feature."), "Select `bar` design to access this feature.") - ) - - list.p <- select_haplo(input.haplo = as.list(input$haplo), - exclude.haplo = as.list(input$haplo_exclude), - probs = loadQTL()$probs, - selected_mks = loadQTL()$selected_mks, - effects.data = effects.data()) - p <- list.p[[1]] - inds <- list.p[[2]] - counts <- ceiling(length(p)/3) - if(counts == 0) counts <- 1 - size <- counts*450 - list(p, size, inds) - }) - - output$haplotypes <- renderPlot({ - withProgress(message = 'Working:', value = 0, { - incProgress(0.3, detail = paste("building graphic...")) - nrow.lst <- ceiling(length(haplo_data()[[1]])/3) - if(nrow.lst == 0) nrow.lst <- 1 - p.all <- ggarrange(plotlist = haplo_data()[[1]], ncol = 3, nrow = nrow.lst, common.legend = TRUE) - }) - p.all - }) - - output$plot_haplo.ui <- renderUI({ - plotOutput(ns("haplotypes"), height = haplo_data()[[2]]) - }) - - output$ind_names <- renderUI({ - x <- paste0("Number of individuals with selected haplotypes: ",length(haplo_data()[[3]])," ","
Individual's ID : ", paste(haplo_data()[[3]], collapse = ", ")) - HTML(x) - }) - - output$info <- DT::renderDataTable(server = FALSE, { - validate( - need(!is.null(loadQTL()), "Upload the QTL information in upload session to access this feature."), - need(!is.null(input$plot_brush), "Select at least one triangle on the bottom of the QTL profile graphic. The triangles refer to QTL peaks detected. You can click and brush your cursor to select more than one.") - ) - dframe <- try(brushedPoints(qtl.data()[[2]], input$plot_brush, xvar = "x", yvar = "y.dat")) - validate( - need(!inherits(dframe, "try-error"), "Select at least one triangle on the bottom of the QTL profile graphic. The triangles refer to QTL peaks detected. You can click and brush your cursor to select more than one.") - ) - dframe <- dframe[,-c(dim(dframe)[2]-1,dim(dframe)[2])] - if(loadQTL()$software == "QTLpoly"){ - colnames(dframe)[c(2,4,5,6,7)] <- c("Linkage group", "Lower interval (cM)", "Upper interval (cM)", "p-value", "h2") - } else if(loadQTL()$software == "diaQTL") { - colnames(dframe)[c(2,4,5,6)] <- c("Linkage group", "Lower interval (cM)", "Upper interval (cM)", "LL") - } else if(loadQTL()$software == "polyqtlR"){ - dframe <- dframe[,-c(4,5)] - colnames(dframe)[c(2,4)] <- c("Linkage group", "Threshold") - } - DT::datatable(dframe, extensions = 'Buttons', - options = list( - dom = 'Bfrtlp', - buttons = c('copy', 'csv', 'excel', 'pdf') - ), - class = "display") - }) - - # Breeding values - output$breeding_values <- DT::renderDataTable(server = FALSE, { - validate( - need(!is.null(loadQTL()), "Upload the QTL information in upload session to access this feature."), - need(loadQTL()$software == "QTLpoly", paste("Feature not implemented for software:",loadQTL()$software)), - need(!is.null(input$plot_brush), "Select at least one triangle on the bottom of the QTL profile graphic. The triangles refer to QTL peaks detected. You can click and brush your cursor to select more than one.") - ) - dframe <- try(brushedPoints(qtl.data()[[2]], input$plot_brush, xvar = "x", yvar = "y.dat")) - validate( - need(!inherits(dframe, "try-error"), "Select at least one triangle on the bottom of the QTL profile graphic. The triangles refer to QTL peaks detected. You can click and brush your cursor to select more than one.") - ) - pos <- split(dframe$`Position (cM)`, dframe$Trait) - dt <- breeding_values(loadQTL()$qtl_info, loadQTL()$probs, - loadQTL()$selected_mks, loadQTL()$blups, - loadQTL()$beta.hat, pos) - rownames(dt) <- NULL - DT::datatable(dt, extensions = 'Buttons', - options = list( - dom = 'Bfrtlp', - buttons = c('copy', 'csv', 'excel', 'pdf') - ), - class = "display") - }) - - # Download profile - # create filename - fn_downloadname <- reactive({ - seed <- sample(1:1000,1) - if(input$fformat=="png") filename <- paste0("profile","_",seed,".png") - if(input$fformat=="tiff") filename <- paste0("profile","_",seed,".tiff") - if(input$fformat=="jpeg") filename <- paste0("profile","_",seed,".jpg") - if(input$fformat=="pdf") filename <- paste0("profile","_",seed,".pdf") - if(input$fformat=="RData") filename <- paste0("profile","_",seed,".RData") - return(filename) - }) - - # download profile - fn_download <- function() - { - p <- only_plot_profile(pl.in = qtl.data()) - - if(input$fformat!="RData"){ - ggsave(p, filename = fn_downloadname(), - width = input$width_profile, height = input$height_profile, units = "mm", dpi = input$dpi_profile) - } else save(p, file = fn_downloadname()) - } - - observe({ - if (!is.null(loadQTL()) & input$width_profile > 1 & input$height_profile > 1 & input$dpi_profile > 1) { - Sys.sleep(1) - # enable the download button - shinyjs::enable("bn_download") - } else { - shinyjs::disable("bn_download") - } - }) - - # download handler - output$bn_download <- downloadHandler( - filename = fn_downloadname, - content = function(file) { - fn_download() - file.copy(fn_downloadname(), file, overwrite=T) - file.remove(fn_downloadname()) - } - ) - - # Download effects - # create filename - fn_downloadname_effects <- reactive({ - - seed <- sample(1:1000,1) - if(input$fformat_effects=="png") filename <- paste0("effects","_",seed,".png") - if(input$fformat_effects=="tiff") filename <- paste0("effects","_",seed,".tiff") - if(input$fformat_effects=="jpeg") filename <- paste0("effects","_",seed,".jpg") - if(input$fformat_effects=="pdf") filename <- paste0("effects","_",seed,".pdf") - if(input$fformat_effects=="RData") filename <- paste0("effects","_",seed,".RData") - return(filename) - }) - - # download - fn_download_effects <- function() - { - validate( - need(!is.null(input$plot_brush), "Select a point or region on QTL profile graphic.") - ) - - df <- brushedPoints(qtl.data()[[2]], input$plot_brush, xvar = "x", yvar = "y.dat") - - print(input$parents_name) - parents <- unlist(strsplit(input$parents_name, ",")) - parents <- gsub(" ", "", parents) - print(parents) - - data <- data_effects(qtl_info = loadQTL()$qtl_info, - effects = loadQTL()$effects, - pheno.col = as.character(df$Trait), - lgs = df$LG, - parents = parents, - position = df$`Position (cM)`, - groups = as.numeric(input$group), - software = loadQTL()$software, - design = input$effects_design) - - plots <- plot_effects(data, software = loadQTL()$software, design = input$effects_design) - - if(input$fformat_effects!="RData"){ - ggsave(plots, filename = fn_downloadname_effects(), height = input$height_effects, - width = input$width_effects, units = "mm", bg = "white", dpi = input$dpi_effects) - } else save(data, file = fn_downloadname_effects()) - } - - shinyjs::disable("bn_download_effects") - - # To make observeEvent watch more than one input - toListen <- reactive({ - list(input$plot_brush, input$plot_brush, input$width_effects, input$height_effects, input$dpi_effects) - }) - - observeEvent(toListen(),{ - df <- brushedPoints(qtl.data()[[2]], input$plot_brush, xvar = "x", yvar = "y.dat") - - if (dim(df)[1] > 0 & !is.null(loadQTL()) & !is.null(input$plot_brush) & input$width_effects > 1 & input$height_effects > 1 & input$dpi_effects > 1) { - Sys.sleep(1) - # enable the download button - shinyjs::enable("bn_download_effects") - } else { - shinyjs::disable("bn_download_effects") - } - }) - - # download handler - output$bn_download_effects <- downloadHandler( - filename = fn_downloadname_effects, - content = function(file) { - fn_download_effects() - file.copy(fn_downloadname_effects(), file, overwrite=T) - file.remove(fn_downloadname_effects()) - } - ) - - # Download haplotypes - shinyjs::disable("bn_download_haplo") - # create filename - fn_downloadname_haplo <- reactive({ - - seed <- sample(1:1000,1) - if(input$fformat_haplo=="png") filename <- paste0("haplotypes","_",seed,".png") - if(input$fformat_haplo=="tiff") filename <- paste0("haplotypes","_",seed,".tiff") - if(input$fformat_haplo=="jpeg") filename <- paste0("haplotypes","_",seed,".jpg") - if(input$fformat_haplo=="pdf") filename <- paste0("haplotypes","_",seed,".pdf") - if(input$fformat_haplo=="RData") filename <- paste0("haplotypes","_",seed,".RData") - return(filename) - }) - - # download - fn_download_haplo <- function() - { - p <- select_haplo(input$haplo, loadQTL()$probs, loadQTL()$selected_mks, effects.data()) - plots <- ggarrange(plotlist = p, ncol = 3, common.legend = TRUE) - - if(input$fformat_haplo!="RData"){ - ggsave(plots, filename = fn_downloadname_haplo(), height = input$height_haplo, - width = input$width_haplo, units = "mm", bg = "white", dpi = input$dpi_haplo) - } else save(p, file = fn_downloadname_haplo()) - } - - observe({ - if (input$haplo_submit & length(grep("Trait",input$haplo)) > 0 & !is.null(input$plot_brush) & input$height_haplo > 1 & input$width_haplo > 1 & input$dpi_haplo > 1) { - Sys.sleep(1) - # enable the download button - shinyjs::enable("bn_download_haplo") - } else { - shinyjs::disable("bn_download_haplo") - } - }) - - # download handler - output$bn_download_haplo <- downloadHandler( - filename = fn_downloadname_haplo, - content = function(file) { - fn_download_haplo() - file.copy(fn_downloadname_haplo(), file, overwrite=T) - file.remove(fn_downloadname_haplo()) - } - ) -} - -## To be copied in the UI -# mod_qtl_view_ui("qtl_view_ui_1") - -## To be copied in the server -# mod_qtl_view_server("qtl_view_ui_1") +#' qtl_view UI Function +#' +#' @description A shiny Module. +#' +#' @param id,input,output,session Internal parameters for {shiny}. +#' +#' @import shinydashboard +#' @import shinyWidgets +#' @importFrom shinyjs inlineCSS useShinyjs +#' +#' @noRd +#' +#' @importFrom shiny NS tagList +mod_qtl_view_ui <- function(id){ + ns <- NS(id) + tagList( + useShinyjs(), + extendShinyjs(text = jscode, functions = "collapse"), + fluidPage( + verticalLayout( + fluidRow( + column(width = 12, + div(style = "position:absolute;right:1em;", + div( + actionButton(ns("goUploads"), "Go to Input data", icon("arrow-circle-left", verify_fa = FALSE), class = "btn btn-primary"), + actionButton(ns("goGenes"), label = div("Go to Genome", icon("arrow-circle-right", verify_fa = FALSE)), class = "btn btn-primary")) + ) + ), + tags$h2(tags$b("VIEWqtl")), br(), hr(), + column(6, + column(12, + box( + background = "light-blue", + "Required inputs (*)", br(), + ) + ), + column(6, + box(width = 12, solidHeader = TRUE, status="info", title = "Select linkage group/s *", + pickerInput(ns("group"), + label = h6("Linkage group/s:"), + choices = "This will be updated", + selected = "This will be updated", + options = list( + `actions-box` = TRUE, + size = 10, + `selected-text-format` = "count > 3" + ), + multiple = TRUE) + ) + ), + column(6, + box(width = 12, solidHeader = TRUE, status="info", title = "Select phenotype/s *", + pickerInput(ns("phenotypes"), + label = h6("Phenotype/s:"), + choices = "This will be updated", + selected = "This will be updated", + options = list( + `actions-box` = TRUE, + size = 10, + `selected-text-format` = "count > 3" + ), + multiple = TRUE) + ) + ) + ), + column(12, + box(id = ns("box_profile"), width = 12, solidHeader = TRUE, collapsible = TRUE, collapsed = FALSE, status="primary", title = actionLink(inputId = ns("profileID"), label = "QTL profile"), + column(12, + box( + background = "light-blue", + "* QTL analysis files or viewpoly object or example dataset (check `Input data` tab)" + ) + ), + column(12, + column(3, + useShinyjs(), + tags$head(tags$style(".butt{background-color:#add8e6; border-color: #add8e6; color: #337ab7;}")), + downloadButton(ns('bn_download'), "Download", class = "butt") + ), + column(3, + radioButtons(ns("fformat"), "File type", choices=c("png","tiff","jpeg","pdf", "RData"), selected = "png", inline = T) + ), + column(2, + numericInput(ns("width_profile"), "Width (mm)", value = 180), + ), + column(2, + numericInput(ns("height_profile"), "Height (mm)", value = 120), + ), + column(2, + numericInput(ns("dpi_profile"), "DPI", value = 300) + )), br(), + column(12, + hr(), + plotOutput(ns("plot_qtl"), + click=ns("plot_click"), brush = ns("plot_brush")) + ), + box(id = ns("box_effects"), width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("effectsID"), label = "Effects"), + column(12, + box( + background = "light-blue", + "* QTL analysis files or viewpoly object or example dataset (check `Input data` tab)", br(), + "* Selection of QTL/s (triangle/s at the bottom of QTL profile graphic)" + ) + ), + div(style = "position:absolute;right:3em;", + radioButtons(ns("effects_design"), "Design", + choices = c("Additive (bar)" = "bar", "Additive (circle)" = "circle", "Alleles combination" = "digenic"), + selected = "bar") + ), br(), br(), + column(3, + downloadButton(ns('bn_download_effects'), "Download", class = "butt") + ), + + column(3, + numericInput(ns("width_effects"), "Width (mm)", value = 180), + ), + column(3, + numericInput(ns("height_effects"), "Height (mm)", value = 120), + ), + column(3, + numericInput(ns("dpi_effects"), "DPI", value = 300) + ), br(), + column(12, + column(6, + radioButtons(ns("fformat_effects"), "File type", choices=c("png","tiff","jpeg","pdf", "RData"), selected = "png", inline = T) + ), + column(6, + textInput(ns("parents_name"), "Parents name", value = "P1, P2") + ), + ), + column(12, + hr(), + uiOutput(ns("plot.ui")) + ) + ), br(), + box(id = ns("box_haplo"),width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("haploID"), label = "Progeny haplotypes"), + column(12, + box( + background = "light-blue", + "* QTLpoly analysis files or viewpoly object or example dataset (check `Input data` tab)", br(), + "* Selection of QTL/s (triangle/s at the bottom of QTL profile graphic)" + ) + ), + column(12, + actionBttn(ns("haplo_update"), style = "jelly", color = "royal", size = "sm", label = "update available haplotypes", icon = icon("refresh", verify_fa = FALSE)), + br(), br(), + pickerInput(ns("haplo"), + label = h6("Select haplotypes*"), + choices = "Click on `update available haplotype` to update", + selected = "Click on `update available haplotype` to update", + options = pickerOptions( + size = 15, + `selected-text-format` = "count > 3", + `live-search`=TRUE, + actionsBox = TRUE, + dropupAuto = FALSE, + dropdownAlignRight = TRUE + ), + multiple = TRUE), br(), + pickerInput(ns("haplo_exclude"), + label = h6("Exclude haplotypes (optional)"), + choices = "Click on `update available haplotype` to update", + selected = "Click on `update available haplotype` to update", + options = pickerOptions( + size = 15, + `selected-text-format` = "count > 3", + `live-search`=TRUE, + actionsBox = TRUE, + dropupAuto = FALSE, + dropdownAlignRight = TRUE + ), + multiple = TRUE), br(), + actionBttn(ns("haplo_submit"), style = "jelly", color = "royal", size = "sm", label = "submit selected haplotypes*", icon = icon("share-square", verify_fa = FALSE)), + br(), hr()), + column(3, + downloadButton(ns('bn_download_haplo'), "Download", class = "butt") + ), + column(3, + radioButtons(ns("fformat_haplo"), "File type", choices=c("png","tiff","jpeg","pdf", "RData"), selected = "png", inline = T) + ), + column(2, + numericInput(ns("width_haplo"), "Width (mm)", value = 180), + ), + column(2, + numericInput(ns("height_haplo"), "Height (mm)", value = 120), + ), + column(2, + numericInput(ns("dpi_haplo"), "DPI", value = 300) + ), br(), + column(12, + hr(), + htmlOutput(ns("ind_names")), hr(), + uiOutput(ns("plot_haplo.ui")) + ) + ), + box(id = ns("box_bree"), width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("breeID"), label = "Breeding values"), + column(12, + box( + background = "light-blue", + "* QTLpoly analysis files or viewpoly object or example dataset (check `Input data` tab)", br(), + "* Selection of QTL/s (triangle/s at the bottom of QTL profile graphic)" + ) + ), + column(12, + DT::dataTableOutput(ns("breeding_values")) + ) + ), br(), br(), + box(id = ns("box_summary"),width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("summaryID"), label = "QTL summary"), + column(12, + box( + background = "light-blue", + "* QTL analysis files or viewpoly object or example dataset (check `Input data` tab)", br(), + "* Selection of QTL/s (triangle/s at the bottom of QTL profile graphic)" + ) + ), + column(12, + DT::dataTableOutput(ns("info")) + ) + ) + ) + ) + ) + ) + ) + ) +} + +#' qtl_view Server Functions +#' +#' @importFrom ggpubr ggarrange +#' @import shinydashboard +#' @importFrom shinyjs js +#' +#' @noRd +mod_qtl_view_server <- function(input, output, session, + loadMap, loadQTL, + parent_session){ + ns <- session$ns + + #Collapse boxes + observeEvent(input$profileID, { + js$collapse(ns("box_profile")) + }) + + observeEvent(input$effectsID, { + js$collapse(ns("box_effects")) + }) + + observeEvent(input$haploID, { + js$collapse(ns("box_haplo")) + }) + + observeEvent(input$breeID, { + js$collapse(ns("box_bree")) + }) + + observeEvent(input$summaryID, { + js$collapse(ns("box_summary")) + }) + + observe({ + # Dynamic linkage group number + if(!is.null(loadMap())){ + group_choices <- as.list(1:length(loadMap()$d.p1)) + names(group_choices) <- 1:length(loadMap()$d.p1) + } else if(!is.null(loadQTL())){ + group_choices <- as.list(1:length(unique(loadQTL()$selected_mks$LG))) + names(group_choices) <- 1:length(unique(loadQTL()$selected_mks$LG)) + } else { + group_choices <- as.list("Upload map or QTL data in `upload` session.") + names(group_choices) <- "Upload map or QTL data in `upload` session." + } + + if(length(group_choices) < 5) the_choice <- group_choices[[1]] else the_choice <- group_choices[[5]] + + updatePickerInput(session, "group", + label="Linkage group/s:", + choices = group_choices, + selected= the_choice) + + + # Dynamic QTL + if(!is.null(loadQTL())){ + pheno_choices <- as.list(unique(loadQTL()$profile$pheno)) + names(pheno_choices) <- unique(loadQTL()$profile$pheno) + + updatePickerInput(session, "phenotypes", + label = "Phenotype/s:", + choices = pheno_choices, + selected=unlist(pheno_choices)[1]) + } else { + updatePickerInput(session, "phenotypes", + label = "Phenotype/s:", + choices = "Upload QTL information to update", + selected= "Upload QTL information to update") + } + }) + + observeEvent(input$goGenes, { + updateTabsetPanel(session = parent_session, inputId = "viewpoly", + selected = "genes") + }) + + observeEvent(input$goUploads, { + updateTabsetPanel(session = parent_session, inputId = "viewpoly", + selected = "upload") + }) + + qtl.data <- reactive({ + validate( + need(length(input$phenotypes) != 0 & input$phenotypes != "Upload QTL information to update", "Select at least one phenotype"), + need(length(input$group) != 0 & input$group != "Upload map or QTL data in `upload` session.", "Select at least one linkage group"), + need(!is.null(loadQTL()), "Upload the QTL information in upload session to access this feature.") + ) + idx <- which(unique(loadQTL()$profile$pheno) %in% input$phenotypes) + + withProgress(message = 'Working:', value = 0, { + incProgress(0.3, detail = paste("building graphic...")) + pl <- plot_profile(profile = loadQTL()$profile, + qtl_info = loadQTL()$qtl_info, + selected_mks = loadQTL()$selected_mks, + pheno.col = idx, + lgs.id = as.numeric(input$group), + by_range=F, plot = F) + }) + }) + + output$plot_qtl <- renderPlot({ + withProgress(message = 'Working:', value = 0, { + incProgress(0.3, detail = paste("building graphic...")) + only_plot_profile(pl.in = qtl.data()) + }) + }) + + effects.data <- reactive({ + validate( + need(!is.null(loadQTL()), "Upload the QTL information in upload session to access this feature."), + need(!is.null(input$plot_brush), "Select at least one triangle on the bottom of the QTL profile graphic. The triangles refer to QTL peaks detected. You can click and brush your cursor to select more than one.") + ) + df <- try(brushedPoints(qtl.data()[[2]], input$plot_brush, xvar = "x", yvar = "y.dat")) + validate( + need(dim(df)[1] > 0, "Select at least one triangle on the bottom of the QTL profile graphic. The triangles refer to QTL peaks detected. You can click and brush your cursor to select more than one.") + ) + + parents <- unlist(strsplit(input$parents_name, ",")) + parents <- gsub(" ", "", parents) + + withProgress(message = 'Working:', value = 0, { + incProgress(0.5, detail = paste("Getting data...")) + data <- data_effects(qtl_info = loadQTL()$qtl_info, + effects = loadQTL()$effects, + pheno.col = as.character(df$Trait), + lgs = df$LG, + position = df$`Position (cM)`, + groups = as.numeric(input$group), + software = loadQTL()$software, + design = input$effects_design, + parents = parents) + }) + }) + + output$effects <- renderPlot({ + withProgress(message = 'Working:', value = 0, { + incProgress(0.5, detail = paste("building graphic...")) + plot_effects(effects.data(), software = loadQTL()$software, design = input$effects_design) + }) + }) + + plotHeight <- reactive({ + + validate( + need(!is.null(loadQTL()), "Upload the QTL information in upload session to access this feature."), + need(!is.null(input$plot_brush), "Select at least one triangle on the bottom of the QTL profile graphic. The triangles refer to QTL peaks detected. You can click and brush your cursor to select more than one.") + ) + dframe <- try(brushedPoints(qtl.data()[[2]], input$plot_brush, xvar = "x", yvar = "y.dat")) + validate( + need(!inherits(dframe, "try-error"), "Select at least one triangle on the bottom of the QTL profile graphic. The triangles refer to QTL peaks detected. You can click and brush your cursor to select more than one.") + ) + counts <- nrow(dframe) + counts <- ceiling(counts/4) + if(counts == 0) counts <- 1 + if(loadQTL()$software == "polyqtlR") { + size <- counts*650 + } else if(input$effects_design == "bar" | input$effects_design == "digenic"){ + size <- counts*350 + } else if(input$effects_design == "circle"){ + counts <- length(unique(dframe$LG)) + counts <- ceiling(counts/2) + if(counts == 0) counts <- 1 + size <- counts*500 + } + size + }) + + output$plot.ui <- renderUI({ + withProgress(message = 'Working:', value = 0, { + incProgress(0.5, detail = paste("building graphic...")) + plotOutput(ns("effects"), height = plotHeight()) + }) + }) + + observeEvent(input$haplo_update,{ + if(!is.null(loadQTL())){ + if(loadQTL()$software == "polyqtlR" | loadQTL()$software == "diaQTL") { + dframe <- NULL + updatePickerInput(session, "haplo", + label = "Select haplotypes", + choices = paste0("Feature not implemented for software: ", loadQTL()$software), + selected= paste0("Feature not implemented for software: ", loadQTL()$software)) + + updatePickerInput(session, "haplo_exclude", + label = "Exclude haplotypes (optional)", + choices = paste0("Feature not implemented for software: ", loadQTL()$software), + selected= paste0("Feature not implemented for software: ", loadQTL()$software)) + } else if(!is.null(input$plot_brush)){ + dframe <- brushedPoints(qtl.data()[[2]], input$plot_brush, xvar = "x", yvar = "y.dat") + } else { + dframe <- NULL + updatePickerInput(session, "haplo", + label = "Select haplotypes", + choices = "Select QTL in the profile graphic to update", + selected= "Select QTL in the profile graphic to update") + + updatePickerInput(session, "haplo_exclude", + label = "Exclude haplotypes (optional)", + choices = "Select QTL in the profile graphic to update", + selected= "Select QTL in the profile graphic to update") + } + } else { + dframe <- NULL + updatePickerInput(session, "haplo", + label = "Select haplotypes", + choices = "Upload the QTL information in upload session to access this feature.", + selected= "Upload the QTL information in upload session to access this feature.") + + updatePickerInput(session, "haplo_exclude", + label = "Exclude haplotypes (optional)", + choices = "Upload the QTL information in upload session to access this feature.", + selected= "Upload the QTL information in upload session to access this feature.") + } + if(!is.null(dframe)){ + if(input$effects_design == "digenic" | input$effects_design == "circle") { + updatePickerInput(session, "haplo", + label = "Select haplotypes", + choices = "Select `bar` design to access this feature.", + selected= "Select `bar` design to access this feature.") + + updatePickerInput(session, "haplo_exclude", + label = "Exclude haplotypes (optional)", + choices = "Select `bar` design to access this feature.", + selected= "Select `bar` design to access this feature.") + } else { + haplo_choices <- paste0("Trait:", dframe$Trait, "_LG:", dframe$LG, "_Pos:", dframe$`Position (cM)`) + alleles <- effects.data()[[1]]$data$Alleles[!grepl("_",effects.data()[[1]]$data$Alleles)] + alleles <- rep(alleles, length(haplo_choices)) + haplo_choices <- rep(haplo_choices, each = length(alleles)/length(haplo_choices)) + haplo_choices <- paste0(haplo_choices, "_homolog:", alleles) + haplo_choices <- as.list(haplo_choices) + names(haplo_choices) <- unlist(haplo_choices) + updatePickerInput(session, "haplo", + label = "Select haplotypes", + choices = haplo_choices, + selected= haplo_choices[1:3]) + + updatePickerInput(session, "haplo_exclude", + label = "Exclude haplotypes (optional)", + choices = haplo_choices, + selected= NULL) + } + } + }) + + haplo_data <- eventReactive(input$haplo_submit, { + validate( + need(all(input$haplo != paste0("Feature not implemented for software: ", loadQTL()$software)), paste0("Feature not implemented for software: ", loadQTL()$software)), + need(all(input$haplo != "Click on `update available haplotype` to update"), "Click on `update available haplotype` to update"), + need(all(input$haplo != "Select QTL in the profile graphic to update"), "Select QTL in the profile graphic to update"), + need(all(input$haplo != "Select `bar` design to access this feature."), "Select `bar` design to access this feature.") + ) + + list.p <- select_haplo(input.haplo = as.list(input$haplo), + exclude.haplo = as.list(input$haplo_exclude), + probs = loadQTL()$probs, + selected_mks = loadQTL()$selected_mks, + effects.data = effects.data()) + p <- list.p[[1]] + inds <- list.p[[2]] + counts <- ceiling(length(p)/3) + if(counts == 0) counts <- 1 + size <- counts*450 + list(p, size, inds) + }) + + output$haplotypes <- renderPlot({ + withProgress(message = 'Working:', value = 0, { + incProgress(0.3, detail = paste("building graphic...")) + nrow.lst <- ceiling(length(haplo_data()[[1]])/3) + if(nrow.lst == 0) nrow.lst <- 1 + p.all <- ggarrange(plotlist = haplo_data()[[1]], ncol = 3, nrow = nrow.lst, common.legend = TRUE) + }) + p.all + }) + + output$plot_haplo.ui <- renderUI({ + plotOutput(ns("haplotypes"), height = haplo_data()[[2]]) + }) + + output$ind_names <- renderUI({ + x <- paste0("Number of individuals with selected haplotypes: ",length(haplo_data()[[3]])," ","
Individual's ID : ", paste(haplo_data()[[3]], collapse = ", ")) + HTML(x) + }) + + output$info <- DT::renderDataTable(server = FALSE, { + validate( + need(!is.null(loadQTL()), "Upload the QTL information in upload session to access this feature."), + need(!is.null(input$plot_brush), "Select at least one triangle on the bottom of the QTL profile graphic. The triangles refer to QTL peaks detected. You can click and brush your cursor to select more than one.") + ) + dframe <- try(brushedPoints(qtl.data()[[2]], input$plot_brush, xvar = "x", yvar = "y.dat")) + validate( + need(!inherits(dframe, "try-error"), "Select at least one triangle on the bottom of the QTL profile graphic. The triangles refer to QTL peaks detected. You can click and brush your cursor to select more than one.") + ) + dframe <- dframe[,-c(dim(dframe)[2]-1,dim(dframe)[2])] + if(loadQTL()$software == "QTLpoly"){ + colnames(dframe)[c(2,4,5,6,7)] <- c("Linkage group", "Lower interval (cM)", "Upper interval (cM)", "p-value", "h2") + } else if(loadQTL()$software == "diaQTL") { + colnames(dframe)[c(2,4,5,6)] <- c("Linkage group", "Lower interval (cM)", "Upper interval (cM)", "LL") + } else if(loadQTL()$software == "polyqtlR"){ + dframe <- dframe[,-c(4,5)] + colnames(dframe)[c(2,4)] <- c("Linkage group", "Threshold") + } + DT::datatable(dframe, extensions = 'Buttons', + options = list( + dom = 'Bfrtlp', + buttons = c('copy', 'csv', 'excel', 'pdf') + ), + class = "display") + }) + + # Breeding values + output$breeding_values <- DT::renderDataTable(server = FALSE, { + validate( + need(!is.null(loadQTL()), "Upload the QTL information in upload session to access this feature."), + need(loadQTL()$software == "QTLpoly", paste("Feature not implemented for software:",loadQTL()$software)), + need(!is.null(input$plot_brush), "Select at least one triangle on the bottom of the QTL profile graphic. The triangles refer to QTL peaks detected. You can click and brush your cursor to select more than one.") + ) + dframe <- try(brushedPoints(qtl.data()[[2]], input$plot_brush, xvar = "x", yvar = "y.dat")) + validate( + need(!inherits(dframe, "try-error"), "Select at least one triangle on the bottom of the QTL profile graphic. The triangles refer to QTL peaks detected. You can click and brush your cursor to select more than one.") + ) + pos <- split(dframe$`Position (cM)`, dframe$Trait) + dt <- breeding_values(loadQTL()$qtl_info, loadQTL()$probs, + loadQTL()$selected_mks, loadQTL()$blups, + loadQTL()$beta.hat, pos) + rownames(dt) <- NULL + DT::datatable(dt, extensions = 'Buttons', + options = list( + dom = 'Bfrtlp', + buttons = c('copy', 'csv', 'excel', 'pdf') + ), + class = "display") + }) + + # Download profile + # create filename + fn_downloadname <- reactive({ + seed <- sample(1:1000,1) + if(input$fformat=="png") filename <- paste0("profile","_",seed,".png") + if(input$fformat=="tiff") filename <- paste0("profile","_",seed,".tiff") + if(input$fformat=="jpeg") filename <- paste0("profile","_",seed,".jpg") + if(input$fformat=="pdf") filename <- paste0("profile","_",seed,".pdf") + if(input$fformat=="RData") filename <- paste0("profile","_",seed,".RData") + return(filename) + }) + + # download profile + fn_download <- function() + { + p <- only_plot_profile(pl.in = qtl.data()) + + if(input$fformat!="RData"){ + ggsave(p, filename = fn_downloadname(), + width = input$width_profile, height = input$height_profile, units = "mm", dpi = input$dpi_profile) + } else save(p, file = fn_downloadname()) + } + + observe({ + if (!is.null(loadQTL()) & input$width_profile > 1 & input$height_profile > 1 & input$dpi_profile > 1) { + Sys.sleep(1) + # enable the download button + shinyjs::enable("bn_download") + } else { + shinyjs::disable("bn_download") + } + }) + + # download handler + output$bn_download <- downloadHandler( + filename = fn_downloadname, + content = function(file) { + fn_download() + file.copy(fn_downloadname(), file, overwrite=T) + file.remove(fn_downloadname()) + } + ) + + # Download effects + # create filename + fn_downloadname_effects <- reactive({ + + seed <- sample(1:1000,1) + if(input$fformat_effects=="png") filename <- paste0("effects","_",seed,".png") + if(input$fformat_effects=="tiff") filename <- paste0("effects","_",seed,".tiff") + if(input$fformat_effects=="jpeg") filename <- paste0("effects","_",seed,".jpg") + if(input$fformat_effects=="pdf") filename <- paste0("effects","_",seed,".pdf") + if(input$fformat_effects=="RData") filename <- paste0("effects","_",seed,".RData") + return(filename) + }) + + # download + fn_download_effects <- function() + { + validate( + need(!is.null(input$plot_brush), "Select a point or region on QTL profile graphic.") + ) + + df <- brushedPoints(qtl.data()[[2]], input$plot_brush, xvar = "x", yvar = "y.dat") + + print(input$parents_name) + parents <- unlist(strsplit(input$parents_name, ",")) + parents <- gsub(" ", "", parents) + print(parents) + + data <- data_effects(qtl_info = loadQTL()$qtl_info, + effects = loadQTL()$effects, + pheno.col = as.character(df$Trait), + lgs = df$LG, + parents = parents, + position = df$`Position (cM)`, + groups = as.numeric(input$group), + software = loadQTL()$software, + design = input$effects_design) + + plots <- plot_effects(data, software = loadQTL()$software, design = input$effects_design) + + if(input$fformat_effects!="RData"){ + ggsave(plots, filename = fn_downloadname_effects(), height = input$height_effects, + width = input$width_effects, units = "mm", bg = "white", dpi = input$dpi_effects) + } else save(data, file = fn_downloadname_effects()) + } + + shinyjs::disable("bn_download_effects") + + # To make observeEvent watch more than one input + toListen <- reactive({ + list(input$plot_brush, input$plot_brush, input$width_effects, input$height_effects, input$dpi_effects) + }) + + observeEvent(toListen(),{ + df <- brushedPoints(qtl.data()[[2]], input$plot_brush, xvar = "x", yvar = "y.dat") + + if (dim(df)[1] > 0 & !is.null(loadQTL()) & !is.null(input$plot_brush) & input$width_effects > 1 & input$height_effects > 1 & input$dpi_effects > 1) { + Sys.sleep(1) + # enable the download button + shinyjs::enable("bn_download_effects") + } else { + shinyjs::disable("bn_download_effects") + } + }) + + # download handler + output$bn_download_effects <- downloadHandler( + filename = fn_downloadname_effects, + content = function(file) { + fn_download_effects() + file.copy(fn_downloadname_effects(), file, overwrite=T) + file.remove(fn_downloadname_effects()) + } + ) + + # Download haplotypes + shinyjs::disable("bn_download_haplo") + # create filename + fn_downloadname_haplo <- reactive({ + + seed <- sample(1:1000,1) + if(input$fformat_haplo=="png") filename <- paste0("haplotypes","_",seed,".png") + if(input$fformat_haplo=="tiff") filename <- paste0("haplotypes","_",seed,".tiff") + if(input$fformat_haplo=="jpeg") filename <- paste0("haplotypes","_",seed,".jpg") + if(input$fformat_haplo=="pdf") filename <- paste0("haplotypes","_",seed,".pdf") + if(input$fformat_haplo=="RData") filename <- paste0("haplotypes","_",seed,".RData") + return(filename) + }) + + # download + fn_download_haplo <- function() + { + p <- select_haplo(input$haplo, loadQTL()$probs, loadQTL()$selected_mks, effects.data()) + plots <- ggarrange(plotlist = p, ncol = 3, common.legend = TRUE) + + if(input$fformat_haplo!="RData"){ + ggsave(plots, filename = fn_downloadname_haplo(), height = input$height_haplo, + width = input$width_haplo, units = "mm", bg = "white", dpi = input$dpi_haplo) + } else save(p, file = fn_downloadname_haplo()) + } + + observe({ + if (input$haplo_submit & length(grep("Trait",input$haplo)) > 0 & !is.null(input$plot_brush) & input$height_haplo > 1 & input$width_haplo > 1 & input$dpi_haplo > 1) { + Sys.sleep(1) + # enable the download button + shinyjs::enable("bn_download_haplo") + } else { + shinyjs::disable("bn_download_haplo") + } + }) + + # download handler + output$bn_download_haplo <- downloadHandler( + filename = fn_downloadname_haplo, + content = function(file) { + fn_download_haplo() + file.copy(fn_downloadname_haplo(), file, overwrite=T) + file.remove(fn_downloadname_haplo()) + } + ) +} + +## To be copied in the UI +# mod_qtl_view_ui("qtl_view_ui_1") + +## To be copied in the server +# mod_qtl_view_server("qtl_view_ui_1") diff --git a/R/mod_upload.R b/R/mod_upload.R index 3d3c755..85af65d 100644 --- a/R/mod_upload.R +++ b/R/mod_upload.R @@ -1,1130 +1,1147 @@ -#' upload UI Function -#' -#' @description A shiny Module. -#' -#' @param id,input,output,session Internal parameters for {shiny}. -#' -#' @noRd -#' -#' @importFrom shinyjs inlineCSS useShinyjs -#' @importFrom hidecan get_example_data GWAS_data_from_gwaspoly GWAS_data DE_data CAN_data -#' @importFrom shiny NS tagList -mod_upload_ui <- function(id){ - ns <- NS(id) - tagList( - fluidRow( - column(width = 12, - div(style = "position:absolute;right:1em;", - div( - actionButton(ns("goAbout"), "Go to About",icon("arrow-circle-left", verify_fa = FALSE), class = "btn btn-primary"), - actionButton(ns("goQTL"), label = div("Go to QTL", icon("arrow-circle-right", verify_fa = FALSE)), class = "btn btn-primary")), br(), - div(style = "position:absolute;right:0em;", - actionButton(ns("reset_all"), "Reset all",icon("undo-alt", verify_fa = FALSE), class = "btn btn-danger")) - ), - tags$h2(tags$b("Input data")), br(), - "Use this module to select an example dataset or to upload yours.", br(), br() - ), br(), - column(width = 12, - fluidPage( - box(id= ns("box_example"), width = 12, solidHeader = TRUE, collapsible = TRUE, collapsed = FALSE, status="primary", title = actionLink(inputId = ns("exampleID"), label = tags$b("Available example datasets")), - radioButtons(ns("example_map"), label = p("They contain the entire linkage map and QTL analysis but just a subset of individuals."), - choices = c("Potato - Atlantic x B1829-5" = "tetra_map"), - selected = "tetra_map"), br(), br(), hr(), - tags$p("Access complete example datasets ", - tags$a(href= "https://www.polyploids.org/input-tests","here")) - ) - ) - ), br(), - column(width = 12, - fluidPage( - box(id = ns("box_map"), width = 12, solidHeader = TRUE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("mapID"), label = tags$b("Upload linkage map files")), - div(style = "position:absolute;right:1em;", - actionBttn(ns("reset_map"), style = "jelly", color = "royal", size = "sm", label = "reset", icon = icon("undo-alt", verify_fa = FALSE)) - ), br(), br(), - box(id = ns("box_mappoly"),width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("mappolyID"), label = tags$b("Upload MAPpoly output")), - tags$p("Access further information about how to build a linkage maps with MAPpoly ", - tags$a(href= "https://rpubs.com/mmollin/tetra_mappoly_vignette","here")), br(), - tags$p("Access a example code of how to obtain these inputs using MAPpoly functions ", - tags$a(href= "https://cristianetaniguti.github.io/viewpoly_vignettes/VIEWpoly_tutorial.html#Upload_linkage_map_files","here")), - hr(), - div(style = "position:absolute;right:1em;", - actionBttn(ns("submit_mappoly"), style = "jelly", color = "royal", size = "sm", label = "submit MAPpoly", icon = icon("share-square", verify_fa = FALSE)), - ), br(), br(), - tags$p("Object of class `mappoly.map`."), - fileInput(ns("mappoly_in"), label = h6("File: my_mappoly_list.RData"), multiple = F), - ), - box(id = ns("box_polymap"),width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary",title = actionLink(inputId = ns("polymapID"), label = tags$b("Upload polymapR output")), - tags$p("Access further information about how to build a linkage maps with polymapR ", - tags$a(href= "https://cran.r-project.org/web/packages/polymapR/vignettes/Vignette_polymapR.html","here")), br(), - tags$p("Access a example code of how to obtain these inputs using polymapR functions ", - tags$a(href= "https://cristianetaniguti.github.io/viewpoly_vignettes/VIEWpoly_tutorial.html#Upload_linkage_map_files","here")), - hr(), - div(style = "position:absolute;right:1em;", - actionBttn(ns("submit_polymapR"), style = "jelly", color = "royal", size = "sm", label = "submit polymapR", icon = icon("share-square", verify_fa = FALSE)), - ), br(), br(), - p("Indicates whether the genotype input is discrete or probabilistic."), - prettyRadioButtons( - inputId = ns("input.type"), - label = "Data type:", - choices = c("discrete" = "discrete", "probabilistic" = "probabilistic"), - selected = "discrete", - inline = TRUE, - status = "info", - fill = TRUE - ), br(), - p("Indicates the dataset specie ploidy."), - prettyRadioButtons( - inputId = ns("ploidy"), - label = "Ploidy:", - choices = c(4, 6), - selected = 4, - inline = TRUE, - status = "info", - fill = TRUE - ), br(), - fileInput(ns("polymapR.dataset"), label = h6("File: polymapR.dataset.RData"), multiple = F), - fileInput(ns("polymapR.map"), label = h6("File: polymapR.map.RData"), multiple = F), - ), - box(id = ns("box_onemap"),width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("onemapID"), label = tags$b("Upload OneMap output")), - tags$p("Access further information about how to build a linkage maps for diploid outcrossing populations with OneMap ", - tags$a(href= "https://cristianetaniguti.github.io/Tutorials/onemap/vignettes_highres/Outcrossing_Populations.html","here")), br(), - tags$p("Access further information about how to build a linkage maps for diploid inbred based populations with OneMap ", - tags$a(href= "https://cristianetaniguti.github.io/Tutorials/onemap/vignettes_highres/Inbred_Based_Populations.html","here")), br(), - tags$p("Access a example code of how to obtain these inputs using OneMap functions ", - tags$a(href= "https://cristianetaniguti.github.io/viewpoly_vignettes/VIEWpoly_tutorial.html#Upload_linkage_map_files","here")), - hr(), - div(style = "position:absolute;right:1em;", - actionBttn(ns("submit_onemap"), style = "jelly", color = "royal", size = "sm", label = "submit OneMap", icon = icon("share-square", verify_fa = FALSE)), - ), br(), br(), - tags$p("Object of class `viewmap`."), - fileInput(ns("onemap_in"), label = h6("File: my_onemap_map.RData"), multiple = F), - ), - box(id = ns("box_mapst"), width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary",title = actionLink(inputId = ns("mapstID"), label = tags$b("Upload linkage map files with standard format (.csv, .tsv or .tsv.gz)")), - div(style = "position:absolute;right:1em;", - actionBttn(ns("submit_map_custom"), style = "jelly", color = "royal", size = "sm", label = "submit map custom", icon = icon("share-square", verify_fa = FALSE)), - ), br(), br(), - fileInput(ns("dosages"), label = h6("File: dosages.tsv"), multiple = F), - fileInput(ns("genetic_map"), label = h6("File: genetic_map.tsv"), multiple = F), - fileInput(ns("phases"), label = h6("File: phases.tsv"), multiple = F), - p("Upload here an TSV file with table with three columns: 1) marker ID; 2) genome position; 3) chromosome"), - fileInput(ns("mks.pos"), label = h6("File: marker information"), multiple = F), - "Check the input file formats with the example files:", br(), - radioButtons(ns("downloadType_map"), "", - choices = c("dosages.tsv" = "dosages", - "genetic_map.tsv" = "genetic_map", - "phases.tsv" = "phases"), - inline = TRUE), br(), br(), - downloadButton(ns("downloadData_map"), "Download"), - ), - ) - ) - ), br(), - column(width = 12, - fluidPage( - box(id = ns("box_qtl"),width = 12, solidHeader = TRUE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("qtlID"), label = tags$b("Upload QTL analysis files")), - div(style = "position:absolute;right:1em;", - actionBttn(ns("reset_qtl"), style = "jelly", color = "royal", size = "sm", label = "reset", icon = icon("undo-alt", verify_fa = FALSE)) - ), br(), br(), - box(id= ns("box_qtlpoly"), width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("qtlpolyID"), label = tags$b("Upload QTLpoly output")), - div(style = "position:absolute;right:1em;", - actionBttn(ns("submit_qtlpoly"), style = "jelly", color = "royal", size = "sm", label = "submit QTLpoly", icon = icon("share-square", verify_fa = FALSE)), - ), br(), br(), - tags$p("Access further information about how to perform QTL analysis with QTLpoly ", - tags$a(href= "https://guilherme-pereira.github.io/QTLpoly/1-tutorial","here")), br(), - tags$p("Access a example code of how to obtain these inputs using QTLpoly functions ", - tags$a(href= "https://cristianetaniguti.github.io/viewpoly_vignettes/VIEWpoly_tutorial.html#Upload_QTL_analysis_files","here")), - hr(), - fileInput(ns("qtlpoly_data"), label = h6("File: QTLpoly_data.RData", br(), br(),"Object of class: qtlpoly.data"), multiple = F), - fileInput(ns("qtlpoly_remim.mod"), label = h6("File: QTLpoly_remim.mod.RData", br(), br(), "Object of class: qtlpoly.remim"), multiple = F), - fileInput(ns("qtlpoly_est.effects"), label = h6("File: QTLpoly_est.effects.RData", br(), br(),"Object of class: qtlpoly.effects"), multiple = F), - fileInput(ns("qtlpoly_fitted.mod"), label = h6("File: QTLpoly_fitted.mod.RData", br(), br(), "Object of class: qtlpoly.fitted"), multiple = F), - ), - box(id = ns("box_diaqtl"), width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("diaqtlID"), label = tags$b("Upload diaQTL output")), - div(style = "position:absolute;right:1em;", - actionBttn(ns("submit_diaQTL"), style = "jelly", color = "royal", size = "sm", label = "submit diaQTL", icon = icon("share-square", verify_fa = FALSE)), - ), br(), br(), - tags$p("Access further information about how to perform QTL analysis with diaQTL ", - tags$a(href= "https://jendelman.github.io/diaQTL/diaQTL_Vignette.html","here")), br(), - tags$p("Access a example code of how to obtain these inputs using diaQTL functions ", - tags$a(href= "https://cristianetaniguti.github.io/viewpoly_vignettes/VIEWpoly_tutorial.html#Upload_QTL_analysis_files","here")), - hr(), - fileInput(ns("diaQTL_scan1"), label = h6("File: diaQTL_scan1_list.RData"), multiple = F), - fileInput(ns("diaQTL_scan1.summaries"), label = h6("File: diaQTL_scan1.summaries_list.RData"), multiple = F), - fileInput(ns("diaQTL_BayesCI"), label = h6("File: diaQTL_BayesCI_list.RData"), multiple = F), - fileInput(ns("diaQTL_fitQTL"), label = h6("File: diaQTL_fitQTL_list.RData"), multiple = F), - ), - box(id = ns("box_polyqtl"),width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("polyqtlID"), label = tags$b("Upload polyqtlR output")), - div(style = "position:absolute;right:1em;", - actionBttn(ns("submit_polyqtlR"), style = "jelly", color = "royal", size = "sm", label = "submit polyqtlR", icon = icon("share-square", verify_fa = FALSE)), - ), br(), br(), - tags$p("Access further information about how to perform QTL analysis with polyqtlR ", - tags$a(href= "https://cran.r-project.org/web/packages/polyqtlR/vignettes/polyqtlR_vignette.html","here")), br(), - tags$p("Access a example code of how to obtain these inputs using polyqtlR functions ", - tags$a(href= "https://cristianetaniguti.github.io/viewpoly_vignettes/VIEWpoly_tutorial.html#Upload_QTL_analysis_files","here")), - hr(), - fileInput(ns("polyqtlR_effects"), label = h6("File: polyqtlR_effects.RData"), multiple = F), hr(), - fileInput(ns("polyqtlR_qtl_info"), label = h6("File: polyqtlR_qtl_info.RData"), multiple = F), - fileInput(ns("polyqtlR_QTLscan_list"), label = h6("File: polyqtlR_QTLscan_list.RData"), multiple = F), - ), - box(id = ns("box_qtlst"),width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("qtlstID"), label = tags$b("Upload QTL analysis results with standard format (.csv, .tsv or .tsv.gz)")), - div(style = "position:absolute;right:1em;", - actionBttn(ns("submit_qtl_custom"), style = "jelly", color = "royal", size = "sm", label = "submit QTL custom", icon = icon("share-square", verify_fa = FALSE)), - ), br(), br(), - fileInput(ns("selected_mks"), label = h6("File: selected_mks.tsv"), multiple = F), - fileInput(ns("qtl_info"), label = h6("File: qtl_info.tsv"), multiple = F), - fileInput(ns("blups"), label = h6("File: blups.tsv"), multiple = F), - fileInput(ns("beta.hat"), label = h6("File: beta.hat.tsv"), multiple = F), - fileInput(ns("profile"), label = h6("File: profile.tsv"), multiple = F), - fileInput(ns("effects"), label = h6("File: effects.tsv"), multiple = F), - fileInput(ns("probs"), label = h6("File: probs.tsv"), multiple = F), - "Check the input format with the example file:", br(), br(), - radioButtons(ns("downloadType_qtl"), "", - choices = c("selected_mks.tsv" = "selected_mks", - "qtl_info.tsv" = "qtl_info", - "blups.tsv" = "blups", - "beta.hat.tsv" = "beta.hat", - "profile.tsv" = "profile", - "effects.tsv" = "effects", - "probs.tsv" = "probs"), - inline = TRUE), br(), br(), - downloadButton(ns("downloadData_qtl"), "Download"), - - ) - ) - ) - ), br(), - column(width = 12, - fluidPage( - box(id = ns("box_genome"),width = 12, solidHeader = TRUE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("genomeID"), label = tags$b("Upload Genome Browser files")), - tags$p("Access further information about the files expected in this section ", - tags$a(href= "https://gmod.github.io/JBrowseR/articles/creating-urls.html","here")), br(), - - column(6, - tags$h5(tags$b("Upload genome information")), - box( - width = NULL, background = "red", - "Warning! The uploaded .fasta, .gff3, .vcf, .bam, .cram, .wig genome version must be the same one used to build the genetic map" - ) - ), - column(6, - div(style = "position:absolute;right:1em;", - actionBttn(ns("reset_genome"), style = "jelly", color = "royal", size = "sm", label = "reset", icon = icon("undo-alt", verify_fa = FALSE)), br(),br(), - actionBttn(ns("submit_genome"), style = "jelly", color = "royal", size = "sm", label = "submit", icon = icon("share-square", verify_fa = FALSE)), br(),br(), - ), - ), br(), br(), - column(12, - br(), - tags$h5(tags$b("Upload .fasta/.fasta.gz and .fasta.fai/.fasta.gz.fai,.fasta.gz.gzi file with assembly information. Using this option, a local HTTP server will be generated.")), - fileInput(ns("fasta"), label = h6("Files: genome_v2.fasta.gz, genome_v2.fasta.gz.fai, genome_v2.fasta.gz.gzi"), multiple = T), - p("or"), - tags$h5(tags$b("Add the URL of the hosted FASTA file location. The loading procedure is more efficient using this option.")), - textInput(ns("fasta_server"), label = h6("https://jbrowse.org/genomes/sars-cov2/fasta/sars-cov2.fa.gz"), value = NULL), - br(), hr(), - tags$h5(tags$b("Upload .gff3/.gff3.gz and .gff3.tbi/.gff3.gz.tbi file with annotation information")), - fileInput(ns("gff3"), label = h6("Files: genome_v2.gff3.gz, genome_v2.gff3.gz.tbi"), multiple = T), - p("or"), - tags$h5(tags$b("Add the URL of the hosted GFF3 file location. The loading procedure is more efficient using this option.")), - textInput(ns("gff3_server"), label = h6("https://jbrowse.org/genomes/sars-cov2/sars-cov2-annotations.sorted.gff.gz"), value = NULL), - br(), hr(), - tags$h5(tags$b("Upload VCF file with variants information")), - fileInput(ns("vcf"), label = h6("Files: markers.vcf, markers.vcf.tbi"), multiple = T), - p("or"), - tags$h5(tags$b("Add the URL of the hosted VCF file location. The loading procedure is more efficient using this option.")), - textInput(ns("vcf_server"), label = h6("https://some/path/file.vcf"), value = NULL), - br(), hr(), - tags$h5(tags$b("Upload .bam and .bam.bai or .cram and .cram.crai file with alignment information")), - fileInput(ns("align"), label = h6("Files: all_ind.bam, all_ind.bam.bai"), multiple = T), - p("or"), - tags$h5(tags$b("Add the URL of the hosted BAM or CRAM file location. The loading procedure is more efficient using this option.")), - textInput(ns("align_server"), label = h6("https://some/path/file.bam"), value = NULL), - br(), hr(), - tags$h5(tags$b("Upload .wig file with bigWig information")), - fileInput(ns("wig"), label = h6("File: data.wig"), multiple = F), - p("or"), - tags$h5(tags$b("Add the URL of the hosted WIG file location. The loading procedure is more efficient using this option.")), - textInput(ns("wig_server"), label = h6("https://some/path/file.wig"), value = NULL), - ) - ) - ) - ), - column(width = 12, - fluidPage( - box(id = ns("box_hidecan"),width = 12, solidHeader = TRUE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("hidecanID"), label = tags$b("Upload Hidecan files")), - tags$p("Access further information about the files expected in this section ", - tags$a(href= "https://plantandfoodresearch.github.io/hidecan/","here")), br(), - - div(style = "position:absolute;right:1em;", - actionBttn(ns("reset_hidecan"), style = "jelly", color = "royal", size = "sm", label = "reset", icon = icon("undo-alt", verify_fa = FALSE)), - actionBttn(ns("submit_hidecan"), style = "jelly", color = "royal", size = "sm", label = "submit HIDECAN", icon = icon("share-square", verify_fa = FALSE)), - ), br(), br(), - box(id= ns("box_gwaspoly"), width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("gwaspolyID"), label = tags$b("Upload GWAS output")), - div(style = "position:absolute;right:1em;", - ), br(), br(), - p("Object of class GWASpoly.thresh obtained with the GWASpoly::set.threshold():"), br(), - fileInput(ns("gwaspoly"), label = h6("File: gwaspoly_res_thr.rda"), multiple = F), - p("or"), - fileInput(ns("gwas"), label = h6("File: gwas.csv"), multiple = T) - ), - box(id= ns("box_gwas_de"), width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("gwasID"), label = tags$b("Upload differential expression (DE) and candidate genes (CAN) files")), - div(style = "position:absolute;right:1em;", - ), br(), br(), - fileInput(ns("de"), label = h6("File: DE.csv"), multiple = T), - fileInput(ns("can"), label = h6("File: CAN.csv"), multiple = T) - ) - ) - ) - ), - column(width = 12, - fluidPage( - box(id = ns("box_viewpoly"),width = 12, solidHeader = TRUE, collapsible = TRUE, collapsed = TRUE, status="info", title = actionLink(inputId = ns("viewpolyID"), label = tags$b("Download VIEWpoly dataset")), - p("The uploaded data are converted to the viewpoly format. It keeps the map and the QTL information. Genome information is not stored."), br(), - textInput(ns("data.name"), label = p("Define the dataset name. Do not use spaces between words."), value = "dataset_name"), br(), - tags$head(tags$style(".butt{background-color:#add8e6; border-color: #add8e6; color: #337ab7;}")), - useShinyjs(), - downloadButton(ns('export_viewpoly'), "Download", class = "butt") - ) - ) - ), - column(width = 12, - fluidPage( - box(id = ns("box_viewpolyup"),width = 12, solidHeader = TRUE, collapsible = TRUE, collapsed = FALSE, status="info", title = actionLink(inputId = ns("viewpolyupID"), label = tags$b("Upload VIEWpoly dataset")), - column(8, - radioButtons(ns("viewpoly_env"), width = 500, label = "Check one of the availables datasets:", - choices = "There is no VIEWpoly object in your R environment. Load VIEWpoly object or convert other formats below.", - selected = "There is no VIEWpoly object in your R environment. Load VIEWpoly object or convert other formats below."), br(), - ), - column(4, - div(style = "position:absolute;right:1em;", - actionBttn(ns("reset_viewpoly"), style = "jelly", color = "royal", size = "sm", label = "reset", icon = icon("undo-alt", verify_fa = FALSE)), br(), br(), - actionBttn(ns("submit_viewpoly"), style = "jelly", color = "royal", size = "sm", label = "submit VIEWpoly file", icon = icon("share-square", verify_fa = FALSE)) - ) - ), - column(12, - br(), br(), hr(), - p("Upload VIEWpoly RData file here:"), - fileInput(ns("viewpoly_input"), label = h6("File: dataset_name.RData"), multiple = F) - ) - ) - ) - ) - ) - ) -} - -#' upload Server Functions -#' -#' @import vroom -#' @importFrom shinyjs js -#' @importFrom utils packageVersion -#' -#' @noRd -mod_upload_server <- function(input, output, session, parent_session){ - ns <- session$ns - - - #Collapse boxes - observeEvent(input$exampleID, { - js$collapse(ns("box_example")) - }) - - observeEvent(input$mapID, { - js$collapse(ns("box_map")) - }) - - observeEvent(input$mappolyID, { - js$collapse(ns("box_mappoly")) - }) - - observeEvent(input$onemapID, { - js$collapse(ns("box_onemap")) - }) - - observeEvent(input$polymapID, { - js$collapse(ns("box_polymap")) - }) - - observeEvent(input$mapstID, { - js$collapse(ns("box_mapst")) - }) - - observeEvent(input$qtlID, { - js$collapse(ns("box_qtl")) - }) - - observeEvent(input$qtlpolyID, { - js$collapse(ns("box_qtlpoly")) - }) - - observeEvent(input$diaqtlID, { - js$collapse(ns("box_diaqtl")) - }) - - observeEvent(input$polyqtlID, { - js$collapse(ns("box_polyqtl")) - }) - - observeEvent(input$qtlstID, { - js$collapse(ns("box_qtlst")) - }) - - observeEvent(input$genomeID, { - js$collapse(ns("box_genome")) - }) - - observeEvent(input$hidecanID, { - js$collapse(ns("box_hidecan")) - }) - - observeEvent(input$viewpolyID, { - js$collapse(ns("box_viewpoly")) - }) - - observeEvent(input$viewpolyupID, { - js$collapse(ns("box_viewpolyup")) - }) - - # Check environment - observe({ - Objs <- Filter(function(x) inherits(get(x), 'viewpoly' ), ls(envir = .GlobalEnv) ) - if(length(Objs) > 0){ - dataset_choices <- as.list(Objs) - names(dataset_choices) <- Objs - updateRadioButtons(session, "viewpoly_env", - label="Check one of the availables datasets:", - choices = dataset_choices, - selected= character(0)) - } else { - updateRadioButtons(session, "viewpoly_env", - label="Check one of the availables datasets:", - choices = "There is no viewpoly object in your R environment. Load view viewpoly object or convert formats below", - selected= character(0)) - } - }) - - # Format examples - output$downloadData_map <- downloadHandler( - filename = function() { - paste0(input$downloadType_map, ".tsv") - }, - content = function(file) { - if(input$downloadType_map == "dosages") { - filetemp <- vroom(system.file("ext/dosage.tsv.gz", package = "viewpoly")) - } else if(input$downloadType_map == "phases") { - filetemp <- vroom(system.file("ext/phases.tsv.gz", package = "viewpoly")) - } else if(input$downloadType_map == "genetic_map") { - filetemp <- vroom(system.file("ext/map.tsv.gz", package = "viewpoly")) - } - vroom_write(filetemp, file = file) - } - ) - - output$downloadData_qtl <- downloadHandler( - filename = function() { - paste0(input$downloadType_qtl, ".tsv") - }, - content = function(file) { - if(input$downloadType_qtl == "qtl_info") { - filetemp <- vroom(system.file("ext/qtl_info.tsv.gz", package = "viewpoly")) - } else if(input$downloadType_qtl == "blups") { - filetemp <- vroom(system.file("ext/blups.tsv.gz", package = "viewpoly")) - } else if(input$downloadType_qtl == "beta.hat") { - filetemp <- vroom(system.file("ext/beta.hat.tsv.gz", package = "viewpoly")) - } else if(input$downloadType_qtl == "profile.hat") { - filetemp <- vroom(system.file("ext/profile.tsv.gz", package = "viewpoly")) - } else if(input$downloadType_qtl == "effects.hat") { - filetemp <- vroom(system.file("ext/effects.tsv.gz", package = "viewpoly")) - } else if(input$downloadType_qtl == "probs") { - filetemp <- vroom(system.file("ext/probs.tsv.gz", package = "viewpoly")) - } - vroom_write(filetemp, file = file) - } - ) - - observeEvent(input$goQTL, { - updateTabsetPanel(session = parent_session, inputId = "viewpoly", - selected = "qtl") - }) - - observeEvent(input$goAbout, { - updateTabsetPanel(session = parent_session, inputId = "viewpoly", - selected = "about") - }) - - # Reset buttons - values <- reactiveValues( - upload_state_map = 0, - upload_state_mappoly = 0, - upload_state_onemap = 0, - upload_state_polymapR = 0, - upload_state_map_custom = 0, - upload_state_qtl = 0, - upload_state_qtlpoly = 0, - upload_state_diaQTL = 0, - upload_state_polyqtlR = 0, - upload_state_qtl_custom = 0, - upload_state_genome = 0, - upload_state_hidecan = 0 - ) - - observeEvent(input$reset_all, { - values$upload_state_viewpoly <- 'reset' - values$upload_state_map <- 'reset' - values$upload_state_mappoly = 0 - values$upload_state_onemap = 0 - values$upload_state_polymapR = 0 - values$upload_state_map_custom = 0 - values$upload_state_qtl <- 'reset' - values$upload_state_qtlpoly = 0 - values$upload_state_diaQTL = 0 - values$upload_state_polyqtlR = 0 - values$upload_state_qtl_custom = 0 - values$upload_state_genome <- 'reset' - values$upload_state_hidecan <- 'reset' - }) - - observeEvent(input$reset_viewpoly, { - values$upload_state_viewpoly <- 'reset' - }) - - observeEvent(input$reset_map, { - values$upload_state_map <- 'reset' - values$upload_state_mappoly = 0 - values$upload_state_onemap = 0 - values$upload_state_polymapR = 0 - values$upload_state_map_custom = 0 - }) - - observeEvent(input$reset_qtl, { - values$upload_state_qtl <- 'reset' - values$upload_state_qtlpoly = 0 - values$upload_state_diaQTL = 0 - values$upload_state_polyqtlR = 0 - values$upload_state_qtl_custom = 0 - }) - - observeEvent(input$reset_genome, { - values$upload_state_genome <- 'reset' - }) - - observeEvent(input$reset_hidecan, { - values$upload_state_hidecan <- 'reset' - }) - - observeEvent(input$submit_viewpoly, { - values$upload_state_viewpoly <- 'uploaded' - }) - - observeEvent(input$submit_mappoly, { - values$upload_state_mappoly <- 'uploaded' - values$upload_state_map <- 0 - }) - - observeEvent(input$submit_onemap, { - values$upload_state_onemap <- 'uploaded' - values$upload_state_map <- 0 - }) - - observeEvent(input$submit_polymapR, { - values$upload_state_polymapR <- 'uploaded' - values$upload_state_map <- 0 - }) - - observeEvent(input$submit_map_custom, { - values$upload_state_map_custom <- 'uploaded' - values$upload_state_map <- 0 - }) - - observeEvent(input$submit_qtlpoly, { - values$upload_state_qtlpoly <- 'uploaded' - values$upload_state_qtl = 0 - }) - - observeEvent(input$submit_diaQTL, { - values$upload_state_diaQTL <- 'uploaded' - values$upload_state_qtl = 0 - }) - - observeEvent(input$submit_polyqtlR, { - values$upload_state_polyqtlR <- 'uploaded' - values$upload_state_qtl = 0 - }) - - observeEvent(input$submit_qtl_custom, { - values$upload_state_qtl_custom <- 'uploaded' - values$upload_state_qtl = 0 - }) - - observeEvent(input$submit_genome, { - values$upload_state_genome <- 'uploaded' - }) - - observeEvent(input$submit_hidecan, { - values$upload_state_hidecan <- 'uploaded' - }) - - input_map <- reactive({ - if (values$upload_state_map == 0 & - values$upload_state_mappoly == 0 & - values$upload_state_onemap == 0 & - values$upload_state_polymapR == 0 & - values$upload_state_map_custom == 0) { - return(NULL) - } else if (values$upload_state_map == 'reset') { - return(NULL) - } else if(values$upload_state_mappoly == "uploaded"){ - validate( - need(!is.null(input$mappoly_in), "Upload mappoly file before submit") - ) - return(list(mappoly_in = input$mappoly_in)) - } else if(values$upload_state_onemap == "uploaded"){ - validate( - need(!is.null(input$onemap_in), "Upload onemap file before submit") - ) - return(list(onemap_in = input$onemap_in)) - } else if(values$upload_state_polymapR == "uploaded"){ - validate( - need(!is.null(input$polymapR.dataset), "Upload polymapR dataset file before submit"), - need(!is.null(input$polymapR.map), "Upload polymapR map file before submit") - ) - return(list(polymapR.dataset = input$polymapR.dataset, - polymapR.map = input$polymapR.map, - input.type = input$input.type, - ploidy = as.numeric(input$ploidy))) - } else if(values$upload_state_map_custom == "uploaded"){ - validate( - need(!is.null(input$dosages), "Upload custom dosages file before submit"), - need(!is.null(input$phases), "Upload custom phases file before submit"), - need(!is.null(input$genetic_map), "Upload custom genetic map file before submit") - ) - return(list(dosages = input$dosages, - phases = input$phases, - genetic_map = input$genetic_map)) - } - }) - - input_qtl <- reactive({ - if (values$upload_state_qtl == 0 & - values$upload_state_qtlpoly == 0 & - values$upload_state_diaQTL == 0 & - values$upload_state_polyqtlR == 0 & - values$upload_state_qtl_custom == 0) { - return(NULL) - } else if (values$upload_state_qtl == 'reset') { - return(NULL) - } else if(values$upload_state_qtl_custom == "uploaded"){ - validate( - need(!is.null(input$dosages), "Upload custom selected markers file before submit"), - need(!is.null(input$phases), "Upload custom QTL info file before submit"), - need(!is.null(input$blups), "Upload custom BLUPs file before submit"), - need(!is.null(input$beta.hat), "Upload custom beta hat file before submit"), - need(!is.null(input$profile), "Upload custom QTL profile file before submit"), - need(!is.null(input$effects), "Upload custom effects file before submit"), - need(!is.null(input$probs), "Upload custom genotype probabilities file before submit") - ) - return(list(selected_mks = input$selected_mks, - qtl_info = input$qtl_info, - blups = input$blups, - beta.hat = input$beta.hat, - profile = input$profile, - effects = input$effects, - probs = input$probs)) - } else if(values$upload_state_qtlpoly == "uploaded"){ - validate( - need(!is.null(input$qtlpoly_data), "Upload QTLpoly data file before submit"), - need(!is.null(input$qtlpoly_remim.mod), "Upload QTLpoly remim.mod file before submit"), - need(!is.null(input$qtlpoly_est.effects), "Upload QTLpoly estimated effects file before submit"), - need(!is.null(input$qtlpoly_fitted.mod), "Upload QTLpoly fitted.mod file before submit") - ) - return(list( - qtlpoly_data = input$qtlpoly_data, - qtlpoly_remim.mod = input$qtlpoly_remim.mod, - qtlpoly_est.effects = input$qtlpoly_est.effects, - qtlpoly_fitted.mod = input$qtlpoly_fitted.mod)) - } else if(values$upload_state_diaQTL == "uploaded"){ - validate( - need(!is.null(input$diaQTL_scan1), "Upload diaQTL scan1 file before submit"), - need(!is.null(input$diaQTL_scan1.summaries), "Upload diaQTL scan1.summaries file before submit"), - need(!is.null(input$diaQTL_fitQTL), "Upload diaQTL fitQTL file before submit"), - need(!is.null(input$diaQTL_BayesCI), "Upload diaQTL BayesCI file before submit") - ) - return(list( - diaQTL_scan1 = input$diaQTL_scan1, - diaQTL_scan1.summaries = input$diaQTL_scan1.summaries, - diaQTL_fitQTL = input$diaQTL_fitQTL, - diaQTL_BayesCI = input$diaQTL_BayesCI - )) - } else if(values$upload_state_polyqtlR == "uploaded"){ - validate( - need(!is.null(input$qtlpoly_data), "Upload polyqtlR scan list file before submit"), - need(!is.null(input$qtlpoly_remim.mod), "Upload polyqtlR QTL info file before submit"), - need(!is.null(input$qtlpoly_est.effects), "Upload polyqtlR estimated effects file before submit") - ) - return(list( - polyqtlR_QTLscan_list = input$polyqtlR_QTLscan_list, - polyqtlR_qtl_info = input$polyqtlR_qtl_info, - polyqtlR_effects = input$polyqtlR_effects - )) - } - }) - - input_genome <- reactive({ - withProgress(message = 'Working:', value = 0, { - incProgress(0.1, detail = paste("Uploading fasta path...")) - if (is.null(values$upload_state_genome)) { - return(NULL) - } else if (values$upload_state_genome == 'reset') { - return(NULL) - } else if(values$upload_state_genome == "uploaded"){ - validate( - need(!is.null(input$fasta) | !is.null(input$fasta_server), "Upload reference genome (FASTA) file before submit.") - ) - return(list(fasta = input$fasta, - fasta_server = input$fasta_server, - gff3 = input$gff3, - gff3_server = input$gff3_server, - vcf = input$vcf, - vcf_server = input$vcf_server, - align = input$align, - align_server = input$align_server, - wig = input$wig, - wig_server = input$wig_server)) - } - }) - }) - - input_hidecan <- reactive({ - if (values$upload_state_hidecan == 0) { - return(NULL) - } else if (values$upload_state_hidecan == 'reset') { - return(NULL) - } else if(values$upload_state_hidecan == "uploaded"){ - validate( - need(!all(c(is.null(input$gwas),is.null(input$gwaspoly))), "Upload GWAS results file before submit") - ) - if(!is.null(input$gwaspoly)) { - temp <- load(input$gwaspoly$datapath) - gwaspoly <- get(temp) - gwaspoly <- GWAS_data_from_gwaspoly(gwaspoly) - - } else gwaspoly <- NULL - - return(list(GWASpoly = gwaspoly, - GWAS = {if(!is.null(input$gwas)) read_input_hidecan(input$gwas, GWAS_data) else list()}, - DE = {if(!is.null(input$de)) read_input_hidecan(input$de, DE_data) else list()}, - CAN = {if(!is.null(input$can)) read_input_hidecan(input$can, CAN_data) else list()})) - } - }) - - # Wait system for the uploads - loadExample = reactive({ - if(is.null(input_map()$dosages) & is.null(input_map()$phases) & is.null(input_map()$genetic_map) & - is.null(input_map()$mappoly_in) & - is.null(input_map()$onemap_in) & - is.null(input_map()$polymapR.dataset) & - is.null(input_map()$polymapR.map) & - is.null(input_qtl()$selected_mks) & - is.null(input_qtl()$qtl_info) & - is.null(input_qtl()$blups) & - is.null(input_qtl()$beta.hat) & - is.null(input_qtl()$profile) & - is.null(input_qtl()$effects) & - is.null(input_qtl()$probs) & - is.null(input_qtl()$qtlpoly_data) & - is.null(input_qtl()$qtlpoly_remim.mod) & - is.null(input_qtl()$qtlpoly_est.effects) & - is.null(input_qtl()$qtlpoly_fitted.mod) & - is.null(input_qtl()$diaQTL_data) & - is.null(input_qtl()$diaQTL_scan1) & - is.null(input_qtl()$diaQTL_scan1.summaries) & - is.null(input_qtl()$diaQTL_fitQTL) & - is.null(input_qtl()$diaQTL_BayesCI) & - is.null(input_qtl()$polyqtlR_QTLscan_list) & - is.null(input_qtl()$polyqtlR_qtl_info) & - is.null(input_qtl()$polyqtlR_effects) & - is.null(input_genome()$fasta) & - is.null(input_genome()$fasta_server) & - is.null(input_genome()$gff3) & - is.null(input_genome()$gff3_server) & - is.null(input_genome()$vcf) & - is.null(input_genome()$vcf_server) & - is.null(input_genome()$align) & - is.null(input_genome()$align_server) & - is.null(input_genome()$wig) & - is.null(input_genome()$wig_server) & - is.null(input$viewpoly_input) & - is.null(input$viewpoly_env)) - withProgress(message = 'Working:', value = 0, { - incProgress(0.5, detail = paste("Uploading example map data...")) - prepare_examples(input$example_map) - }) - else NULL - }) - - # Load hidecan example - loadHidecanExample = reactive({ - if(is.null(input_hidecan()$gwas) & is.null(input_hidecan()$de) & is.null(input_hidecan()$can)) - withProgress(message = 'Working:', value = 0, { - incProgress(0.5, detail = paste("Uploading example map data...")) - x <- get_example_data() - - list("GWAS" = list(GWAS_data(x[["GWAS"]])), - "DE" = list(DE_data(x[["DE"]])), - "CAN" = list(CAN_data(x[["CAN"]]))) - }) - else NULL - }) - - loadViewpoly = reactive({ - withProgress(message = 'Working:', value = 0, { - incProgress(0.1, detail = paste("Uploading viewpoly file...")) - if (is.null(values$upload_state_viewpoly)) { - return(NULL) - } else if (values$upload_state_viewpoly == 'reset') { - return(NULL) - } else if(values$upload_state_viewpoly == "uploaded"){ - if(is.null(input$viewpoly_input) & is.null(input$viewpoly_env)){ - warning("Upload a viewpoly dataset or select one available in your R environment before submit.") - viewpoly.obj <- NULL - } else if(!is.null(input$viewpoly_input)){ - temp <- load(input$viewpoly_input$datapath) - viewpoly.obj <- get(temp) - } else if(!is.null(input$viewpoly_env)) { - viewpoly.obj = get(input$viewpoly_env) - } - return(viewpoly.obj) - } - }) - }) - - loadMap_custom = reactive({ - if(!(is.null(input_map()$dosages) & is.null(input_map()$phases) & is.null(input_map()$genetic_map))){ - req(input_map()$dosages, input_map()$phases, input_map()$genetic_map) - withProgress(message = 'Working:', value = 0, { - incProgress(0.5, detail = paste("Uploading custom map data...")) - prepare_map_custom_files(input_map()$dosages, - input_map()$phases, - input_map()$genetic_map) - }) - } else NULL - }) - - loadMap_mappoly = reactive({ - - if(!is.null(input_map()$mappoly_in)){ - withProgress(message = 'Working:', value = 0, { - incProgress(0.3, detail = paste("Uploading MAPpoly data...")) - prepare_MAPpoly(input_map()$mappoly_in) - }) - } else NULL - }) - - loadMap_onemap = reactive({ - - if(!is.null(input_map()$onemap_in)){ - withProgress(message = 'Working:', value = 0, { - incProgress(0.3, detail = paste("Uploading OneMap data...")) - temp <- load(input_map()$onemap_in$datapath) - viewmap <- get(temp) - viewmap - }) - } else NULL - }) - - loadMap_polymapR = reactive({ - if(!(is.null(input_map()$polymapR.dataset) & - is.null(input_map()$polymapR.map))) { - req(input_map()$polymapR.dataset, input_map()$polymapR.map) - withProgress(message = 'Working:', value = 0, { - incProgress(0.1, detail = paste("Uploading polymapR data...")) - prepare_polymapR(input_map()$polymapR.dataset, input_map()$polymapR.map, - input$input.type, as.numeric(input$ploidy)) - }) - } else NULL - }) - - loadQTL_custom = reactive({ - if(!(is.null(input_qtl()$selected_mks) & - is.null(input_qtl()$qtl_info) & - is.null(input_qtl()$blups) & - is.null(input_qtl()$beta.hat) & - is.null(input_qtl()$profile) & - is.null(input_qtl()$effects) & - is.null(input_qtl()$probs))) { - req(input_qtl()$selected_mks, input_qtl()$qtl_info, input_qtl()$blups, - input_qtl()$beta.hat, input_qtl()$profile, input_qtl()$effects, - input_qtl()$probs) - withProgress(message = 'Working:', value = 0, { - incProgress(0.5, detail = paste("Uploading custom QTL data...")) - prepare_qtl_custom_files(input_qtl()$selected_mks, - input_qtl()$qtl_info, - input_qtl()$blups, - input_qtl()$beta.hat, - input_qtl()$profile, - input_qtl()$effects, - input_qtl()$probs) - }) - } else NULL - }) - - loadQTL_qtlpoly = reactive({ - if(!(is.null(input_qtl()$qtlpoly_data) & - is.null(input_qtl()$qtlpoly_remim.mod) & - is.null(input_qtl()$qtlpoly_est.effects) & - is.null(input_qtl()$qtlpoly_fitted.mod))) { - - req(input_qtl()$qtlpoly_data, - input_qtl()$qtlpoly_remim.mod, - input_qtl()$qtlpoly_est.effects, - input_qtl()$qtlpoly_fitted.mod) - - withProgress(message = 'Working:', value = 0, { - incProgress(0.3, detail = paste("Uploading QTLpoly data...")) - prepare_QTLpoly(input_qtl()$qtlpoly_data, - input_qtl()$qtlpoly_remim.mod, - input_qtl()$qtlpoly_est.effects, - input_qtl()$qtlpoly_fitted.mod) - }) - } else NULL - }) - - loadQTL_diaQTL = reactive({ - if(!(is.null(input_qtl()$diaQTL_scan1) & - is.null(input_qtl()$diaQTL_scan1.summaries) & - is.null(input_qtl()$diaQTL_fitQTL) & - is.null(input_qtl()$diaQTL_BayesCI))) { - - req(input_qtl()$diaQTL_scan1, - input_qtl()$diaQTL_scan1.summaries, - input_qtl()$diaQTL_fitQTL, - input_qtl()$diaQTL_BayesCI) - - withProgress(message = 'Working:', value = 0, { - incProgress(0.3, detail = paste("Uploading diaQTL data...")) - prepare_diaQTL(input_qtl()$diaQTL_scan1, - input_qtl()$diaQTL_scan1.summaries, - input_qtl()$diaQTL_fitQTL, - input_qtl()$diaQTL_BayesCI) - }) - } else NULL - }) - - loadQTL_polyqtlR = reactive({ - if(!(is.null(input_qtl()$polyqtlR_QTLscan_list) & - is.null(input_qtl()$polyqtlR_qtl_info) & - is.null(input_qtl()$polyqtlR_effects))) { - - req(input_qtl()$polyqtlR_QTLscan_list, - input_qtl()$polyqtlR_qtl_info, - input_qtl()$polyqtlR_effects) - - withProgress(message = 'Working:', value = 0, { - incProgress(0.3, detail = paste("Uploading polyqtlR data...")) - prepare_polyqtlR(input_qtl()$polyqtlR_QTLscan_list, - input_qtl()$polyqtlR_qtl_info, - input_qtl()$polyqtlR_effects) - }) - } else NULL - }) - - temp_dir <- reactive(tempdir()) - - loadJBrowse_fasta = reactive({ - withProgress(message = 'Working:', value = 0, { - incProgress(0.1, detail = paste("Uploading fasta path...")) - if(!is.null(input_genome()$fasta) & !is.null(loadMap())){ - # keep fasta name - for(i in 1:length(input_genome()$fasta$datapath)){ - print(file.path(temp_dir(), input_genome()$fasta$name)) - - file.rename(input_genome()$fasta$datapath[i], - file.path(temp_dir(), input_genome()$fasta$name[i])) - } - file.path(temp_dir(), sort(input_genome()$fasta$name)[1]) - } else if(!is.null(input_genome()$fasta_server) & !is.null(loadMap())) { - input_genome()$fasta_server - } else if(!is.null(input_genome()$fasta) | !is.null(input_genome()$fasta_server)) { - warning("Load map data first to use this feature.") - } else if(!is.null(loadExample())){ - loadExample()$fasta - } else NULL - }) - }) - - loadJBrowse_gff3 = reactive({ - withProgress(message = 'Working:', value = 0, { - incProgress(0.1, detail = paste("Uploading gff3 path...")) - if(!is.null(input_genome()$gff3)){ - for(i in 1:length(input_genome()$gff3$datapath)){ - file.rename(input_genome()$gff3$datapath[i], - file.path(temp_dir(), input_genome()$gff3$name[i])) - } - file.path(temp_dir(), input_genome()$gff3$name[1]) - } else if(!is.null(input_genome()$gff3_server)) { - input_genome()$gff3_server - } else if(!is.null(loadExample())){ - loadExample()$gff3 - } else NULL - }) - }) - - loadJBrowse_vcf = reactive({ - withProgress(message = 'Working:', value = 0, { - incProgress(0.1, detail = paste("Uploading VCF path...")) - if(!is.null(input_genome()$vcf)) { - for(i in 1:length(input_genome()$vcf$datapath)){ - file.rename(input_genome()$vcf$datapath[i], - file.path(temp_dir(), input_genome()$vcf$name[i])) - } - file.path(temp_dir(), input_genome()$vcf$name[1]) - } else if(!is.null(input_genome()$vcf_server)) { - input_genome()$vcf_server - } else NULL - }) - }) - - loadJBrowse_align = reactive({ - withProgress(message = 'Working:', value = 0, { - incProgress(0.1, detail = paste("Uploading BAM or CRAM alignment data path...")) - if(!is.null(input_genome()$align)) { - for(i in 1:length(input_genome()$align$datapath)){ - file.rename(input_genome()$align$datapath[i], - file.path(temp_dir(), input_genome()$align$name[i])) - } - file.path(temp_dir(), input_genome()$align$name[1]) - } else if(!is.null(input_genome()$align_server)) { - input_genome()$align_server - } else NULL - }) - }) - - loadJBrowse_wig = reactive({ - withProgress(message = 'Working:', value = 0, { - incProgress(0.1, detail = paste("Uploading bigWig data path...")) - if(!is.null(input_genome()$wig)) { - for(i in 1:length(input_genome()$wig$datapath)){ - file.rename(input_genome()$wig$datapath[i], - file.path(temp_dir(), input_genome()$wig$name[i])) - } - file.path(temp_dir(), input_genome()$wig$name[1]) - } else if(!is.null(input_genome()$wig_server)) { - input_genome()$wig_server - } else NULL - }) - }) - - loadMap = reactive({ - if(is.null(loadExample()) & - is.null(loadMap_custom()) & - is.null(loadMap_mappoly()) & - is.null(loadMap_onemap()) & - is.null(loadMap_polymapR()) & - is.null(loadViewpoly())){ - warning("Select one of the options in `upload` session") - return(NULL) - } else if(!is.null(loadViewpoly())){ - return(loadViewpoly()$map) - } else if(!is.null(loadMap_custom())){ - return(loadMap_custom()) - } else if(!is.null(loadMap_mappoly())){ - return(loadMap_mappoly()) - } else if(!is.null(loadMap_onemap())){ - return(loadMap_onemap()) - } else if(!is.null(loadMap_polymapR())){ - return(loadMap_polymapR()) - } else if(!is.null(loadExample())){ - return(loadExample()$map) - } - }) - - loadQTL = reactive({ - if(is.null(loadExample()) & - is.null(loadQTL_custom()) & - is.null(loadQTL_qtlpoly()) & - is.null(loadQTL_diaQTL()) & - is.null(loadQTL_polyqtlR()) & - is.null(loadViewpoly())){ - warning("Select one of the options in `upload` session") - return(NULL) - } else if(!is.null(loadViewpoly())){ - return(loadViewpoly()$qtl) - } else if(!is.null(loadQTL_custom())){ - return(loadQTL_custom()) - } else if(!is.null(loadQTL_qtlpoly())){ - return(loadQTL_qtlpoly()) - } else if(!is.null(loadQTL_diaQTL())){ - return(loadQTL_diaQTL()) - } else if(!is.null(loadQTL_polyqtlR())){ - return(loadQTL_polyqtlR()) - } else if(!is.null(loadExample())){ - return(loadExample()$qtl) - } - }) - - loadHidecan = reactive({ - if(is.null(loadHidecanExample()) & - is.null(input_hidecan()) & - is.null(loadViewpoly())){ - warning("Select one of the options in `upload` session") - return(NULL) - } else if(!is.null(loadViewpoly())){ - return(loadViewpoly()$hidecan) - } else if(!is.null(input_hidecan())){ - return(input_hidecan()) - } else if(!is.null(loadHidecanExample())){ - return(loadHidecanExample()) - } - }) - - observe({ - if (!is.null(loadMap()) | !is.null(loadQTL())) { - Sys.sleep(1) - # enable the download button - shinyjs::enable("export_viewpoly") - } else { - shinyjs::disable("export_viewpoly") - } - }) - - output$export_viewpoly <- downloadHandler( - filename = function() { - paste0("viewpoly.RData") - }, - content = function(file) { - withProgress(message = 'Working:', value = 0, { - incProgress(0.1, detail = paste("Saving viewpoly object...")) - validate( - need(!is.null(loadMap()) | !is.null(loadQTL()), "For exporting VIEWpoly dataset it is required to load - linkage map or QTL data in the above boxes."), - ) - obj <- structure(list(map = loadMap(), - qtl = loadQTL(), - fasta = NULL, # It would save only the temporary path - gff3 = NULL, - vcf = NULL, - align = NULL, - wig = NULL, - hidecan = loadHidecan(), - version = packageVersion("viewpoly")), - class = "viewpoly") - assign(input$data.name, obj) - incProgress(0.5, detail = paste("Saving viewpoly object...")) - }) - save(list = input$data.name, file = file) - } - ) - - return(list(loadMap = reactive(loadMap()), - loadQTL = reactive(loadQTL()), - loadJBrowse_fasta = reactive(loadJBrowse_fasta()), - loadJBrowse_gff3 = reactive(loadJBrowse_gff3()), - loadJBrowse_vcf = reactive(loadJBrowse_vcf()), - loadJBrowse_align = reactive(loadJBrowse_align()), - loadJBrowse_wig = reactive(loadJBrowse_wig()), - loadHidecan = reactive(loadHidecan()))) -} - -## To be copied in the UI -# mod_upload_ui("upload_ui_1") - -## To be copied in the server -# mod_upload_server("upload_ui_1") +#' upload UI Function +#' +#' @description A shiny Module. +#' +#' @param id,input,output,session Internal parameters for {shiny}. +#' +#' @noRd +#' +#' @importFrom shinyjs inlineCSS useShinyjs +#' @importFrom hidecan get_example_data GWAS_data_from_gwaspoly GWAS_data DE_data CAN_data +#' @importFrom shiny NS tagList +mod_upload_ui <- function(id){ + ns <- NS(id) + tagList( + fluidRow( + column(width = 12, + div(style = "position:absolute;right:1em;", + div( + actionButton(ns("goAbout"), "Go to About",icon("arrow-circle-left", verify_fa = FALSE), class = "btn btn-primary"), + actionButton(ns("goQTL"), label = div("Go to QTL", icon("arrow-circle-right", verify_fa = FALSE)), class = "btn btn-primary")), br(), + div(style = "position:absolute;right:0em;", + actionButton(ns("reset_all"), "Reset all",icon("undo-alt", verify_fa = FALSE), class = "btn btn-danger")) + ), + tags$h2(tags$b("Input data")), br(), + "Use this module to select an example dataset or to upload yours.", br(), br() + ), br(), + column(width = 12, + fluidPage( + box(id= ns("box_example"), width = 12, solidHeader = TRUE, collapsible = TRUE, collapsed = FALSE, status="primary", title = actionLink(inputId = ns("exampleID"), label = tags$b("Available example datasets")), + radioButtons(ns("example_map"), label = p("They contain the entire linkage map and QTL analysis but just a subset of individuals."), + choices = c("Potato - Atlantic x B1829-5" = "tetra_map"), + selected = "tetra_map"), br(), br(), hr(), + tags$p("Access complete example datasets ", + tags$a(href= "https://www.polyploids.org/input-tests","here")) + ) + ) + ), br(), + column(width = 12, + fluidPage( + box(id = ns("box_map"), width = 12, solidHeader = TRUE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("mapID"), label = tags$b("Upload linkage map files")), + div(style = "position:absolute;right:1em;", + actionBttn(ns("reset_map"), style = "jelly", color = "royal", size = "sm", label = "reset", icon = icon("undo-alt", verify_fa = FALSE)) + ), br(), br(), + box(id = ns("box_mappoly"),width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("mappolyID"), label = tags$b("Upload MAPpoly output")), + tags$p("Access further information about how to build a linkage maps with MAPpoly ", + tags$a(href= "https://rpubs.com/mmollin/tetra_mappoly_vignette","here")), br(), + tags$p("Access a example code of how to obtain these inputs using MAPpoly functions ", + tags$a(href= "https://cristianetaniguti.github.io/viewpoly_vignettes/VIEWpoly_tutorial.html#Upload_linkage_map_files","here")), + hr(), + div(style = "position:absolute;right:1em;", + actionBttn(ns("submit_mappoly"), style = "jelly", color = "royal", size = "sm", label = "submit MAPpoly", icon = icon("share-square", verify_fa = FALSE)), + ), br(), br(), + tags$p("Object of class `mappoly.map`."), + fileInput(ns("mappoly_in"), label = h6("File: my_mappoly_list.RData"), multiple = F), + ), + box(id = ns("box_polymap"),width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary",title = actionLink(inputId = ns("polymapID"), label = tags$b("Upload polymapR output")), + tags$p("Access further information about how to build a linkage maps with polymapR ", + tags$a(href= "https://cran.r-project.org/web/packages/polymapR/vignettes/Vignette_polymapR.html","here")), br(), + tags$p("Access a example code of how to obtain these inputs using polymapR functions ", + tags$a(href= "https://cristianetaniguti.github.io/viewpoly_vignettes/VIEWpoly_tutorial.html#Upload_linkage_map_files","here")), + hr(), + div(style = "position:absolute;right:1em;", + actionBttn(ns("submit_polymapR"), style = "jelly", color = "royal", size = "sm", label = "submit polymapR", icon = icon("share-square", verify_fa = FALSE)), + ), br(), br(), + p("Indicates whether the genotype input is discrete or probabilistic."), + prettyRadioButtons( + inputId = ns("input.type"), + label = "Data type:", + choices = c("discrete" = "discrete", "probabilistic" = "probabilistic"), + selected = "discrete", + inline = TRUE, + status = "info", + fill = TRUE + ), br(), + p("Indicates the dataset specie ploidy."), + prettyRadioButtons( + inputId = ns("ploidy"), + label = "Ploidy:", + choices = c(4, 6), + selected = 4, + inline = TRUE, + status = "info", + fill = TRUE + ), br(), + fileInput(ns("polymapR.dataset"), label = h6("File: polymapR.dataset.RData"), multiple = F), + fileInput(ns("polymapR.map"), label = h6("File: polymapR.map.RData"), multiple = F), + ), + box(id = ns("box_onemap"),width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("onemapID"), label = tags$b("Upload OneMap output")), + tags$p("Access further information about how to build a linkage maps for diploid outcrossing populations with OneMap ", + tags$a(href= "https://cristianetaniguti.github.io/Tutorials/onemap/vignettes_highres/Outcrossing_Populations.html","here")), br(), + tags$p("Access further information about how to build a linkage maps for diploid inbred based populations with OneMap ", + tags$a(href= "https://cristianetaniguti.github.io/Tutorials/onemap/vignettes_highres/Inbred_Based_Populations.html","here")), br(), + tags$p("Access a example code of how to obtain these inputs using OneMap functions ", + tags$a(href= "https://cristianetaniguti.github.io/viewpoly_vignettes/VIEWpoly_tutorial.html#Upload_linkage_map_files","here")), + hr(), + div(style = "position:absolute;right:1em;", + actionBttn(ns("submit_onemap"), style = "jelly", color = "royal", size = "sm", label = "submit OneMap", icon = icon("share-square", verify_fa = FALSE)), + ), br(), br(), + tags$p("Object of class `viewmap`."), + fileInput(ns("onemap_in"), label = h6("File: my_onemap_map.RData"), multiple = F), + ), + box(id = ns("box_mapst"), width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary",title = actionLink(inputId = ns("mapstID"), label = tags$b("Upload linkage map files with standard format (.csv, .tsv or .tsv.gz)")), + div(style = "position:absolute;right:1em;", + actionBttn(ns("submit_map_custom"), style = "jelly", color = "royal", size = "sm", label = "submit map custom", icon = icon("share-square", verify_fa = FALSE)), + ), br(), br(), + fileInput(ns("dosages"), label = h6("File: dosages.tsv"), multiple = F), + fileInput(ns("genetic_map"), label = h6("File: genetic_map.tsv"), multiple = F), + fileInput(ns("phases"), label = h6("File: phases.tsv"), multiple = F), + p("Upload here an TSV file with table with three columns: 1) marker ID; 2) genome position; 3) chromosome"), + fileInput(ns("mks.pos"), label = h6("File: marker information"), multiple = F), + "Check the input file formats with the example files:", br(), + radioButtons(ns("downloadType_map"), "", + choices = c("dosages.tsv" = "dosages", + "genetic_map.tsv" = "genetic_map", + "phases.tsv" = "phases"), + inline = TRUE), br(), br(), + downloadButton(ns("downloadData_map"), "Download"), + ), + ) + ) + ), br(), + column(width = 12, + fluidPage( + box(id = ns("box_qtl"),width = 12, solidHeader = TRUE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("qtlID"), label = tags$b("Upload QTL analysis files")), + div(style = "position:absolute;right:1em;", + actionBttn(ns("reset_qtl"), style = "jelly", color = "royal", size = "sm", label = "reset", icon = icon("undo-alt", verify_fa = FALSE)) + ), br(), br(), + box(id= ns("box_qtlpoly"), width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("qtlpolyID"), label = tags$b("Upload QTLpoly output")), + div(style = "position:absolute;right:1em;", + actionBttn(ns("submit_qtlpoly"), style = "jelly", color = "royal", size = "sm", label = "submit QTLpoly", icon = icon("share-square", verify_fa = FALSE)), + ), br(), br(), + tags$p("Access further information about how to perform QTL analysis with QTLpoly ", + tags$a(href= "https://guilherme-pereira.github.io/QTLpoly/1-tutorial","here")), br(), + tags$p("Access a example code of how to obtain these inputs using QTLpoly functions ", + tags$a(href= "https://cristianetaniguti.github.io/viewpoly_vignettes/VIEWpoly_tutorial.html#Upload_QTL_analysis_files","here")), + hr(), + fileInput(ns("qtlpoly_data"), label = h6("File: QTLpoly_data.RData", br(), br(),"Object of class: qtlpoly.data"), multiple = F), + fileInput(ns("qtlpoly_remim.mod"), label = h6("File: QTLpoly_remim.mod.RData", br(), br(), "Object of class: qtlpoly.remim"), multiple = F), + fileInput(ns("qtlpoly_est.effects"), label = h6("File: QTLpoly_est.effects.RData", br(), br(),"Object of class: qtlpoly.effects"), multiple = F), + fileInput(ns("qtlpoly_fitted.mod"), label = h6("File: QTLpoly_fitted.mod.RData", br(), br(), "Object of class: qtlpoly.fitted"), multiple = F), + ), + box(id = ns("box_diaqtl"), width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("diaqtlID"), label = tags$b("Upload diaQTL output")), + div(style = "position:absolute;right:1em;", + actionBttn(ns("submit_diaQTL"), style = "jelly", color = "royal", size = "sm", label = "submit diaQTL", icon = icon("share-square", verify_fa = FALSE)), + ), br(), br(), + tags$p("Access further information about how to perform QTL analysis with diaQTL ", + tags$a(href= "https://jendelman.github.io/diaQTL/diaQTL_Vignette.html","here")), br(), + tags$p("Access a example code of how to obtain these inputs using diaQTL functions ", + tags$a(href= "https://cristianetaniguti.github.io/viewpoly_vignettes/VIEWpoly_tutorial.html#Upload_QTL_analysis_files","here")), + hr(), + fileInput(ns("diaQTL_scan1"), label = h6("File: diaQTL_scan1_list.RData"), multiple = F), + fileInput(ns("diaQTL_scan1.summaries"), label = h6("File: diaQTL_scan1.summaries_list.RData"), multiple = F), + fileInput(ns("diaQTL_BayesCI"), label = h6("File: diaQTL_BayesCI_list.RData"), multiple = F), + fileInput(ns("diaQTL_fitQTL"), label = h6("File: diaQTL_fitQTL_list.RData"), multiple = F), + ), + box(id = ns("box_polyqtl"),width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("polyqtlID"), label = tags$b("Upload polyqtlR output")), + div(style = "position:absolute;right:1em;", + actionBttn(ns("submit_polyqtlR"), style = "jelly", color = "royal", size = "sm", label = "submit polyqtlR", icon = icon("share-square", verify_fa = FALSE)), + ), br(), br(), + tags$p("Access further information about how to perform QTL analysis with polyqtlR ", + tags$a(href= "https://cran.r-project.org/web/packages/polyqtlR/vignettes/polyqtlR_vignette.html","here")), br(), + tags$p("Access a example code of how to obtain these inputs using polyqtlR functions ", + tags$a(href= "https://cristianetaniguti.github.io/viewpoly_vignettes/VIEWpoly_tutorial.html#Upload_QTL_analysis_files","here")), + hr(), + fileInput(ns("polyqtlR_effects"), label = h6("File: polyqtlR_effects.RData"), multiple = F), hr(), + fileInput(ns("polyqtlR_qtl_info"), label = h6("File: polyqtlR_qtl_info.RData"), multiple = F), + fileInput(ns("polyqtlR_QTLscan_list"), label = h6("File: polyqtlR_QTLscan_list.RData"), multiple = F), + ), + box(id = ns("box_qtlst"),width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("qtlstID"), label = tags$b("Upload QTL analysis results with standard format (.csv, .tsv or .tsv.gz)")), + div(style = "position:absolute;right:1em;", + actionBttn(ns("submit_qtl_custom"), style = "jelly", color = "royal", size = "sm", label = "submit QTL custom", icon = icon("share-square", verify_fa = FALSE)), + ), br(), br(), + fileInput(ns("selected_mks"), label = h6("File: selected_mks.tsv"), multiple = F), + fileInput(ns("qtl_info"), label = h6("File: qtl_info.tsv"), multiple = F), + fileInput(ns("blups"), label = h6("File: blups.tsv"), multiple = F), + fileInput(ns("beta.hat"), label = h6("File: beta.hat.tsv"), multiple = F), + fileInput(ns("profile"), label = h6("File: profile.tsv"), multiple = F), + fileInput(ns("effects"), label = h6("File: effects.tsv"), multiple = F), + fileInput(ns("probs"), label = h6("File: probs.tsv"), multiple = F), + "Check the input format with the example file:", br(), br(), + radioButtons(ns("downloadType_qtl"), "", + choices = c("selected_mks.tsv" = "selected_mks", + "qtl_info.tsv" = "qtl_info", + "blups.tsv" = "blups", + "beta.hat.tsv" = "beta.hat", + "profile.tsv" = "profile", + "effects.tsv" = "effects", + "probs.tsv" = "probs"), + inline = TRUE), br(), br(), + downloadButton(ns("downloadData_qtl"), "Download"), + + ) + ) + ) + ), br(), + column(width = 12, + fluidPage( + box(id = ns("box_genome"),width = 12, solidHeader = TRUE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("genomeID"), label = tags$b("Upload Genome Browser files")), + tags$p("Access further information about the files expected in this section ", + tags$a(href= "https://gmod.github.io/JBrowseR/articles/creating-urls.html","here")), br(), + + column(6, + tags$h5(tags$b("Upload genome information")), + box( + width = NULL, background = "red", + "Warning! The uploaded .fasta, .gff3, .vcf, .bam, .cram, .wig genome version must be the same one used to build the genetic map" + ) + ), + column(6, + div(style = "position:absolute;right:1em;", + actionBttn(ns("reset_genome"), style = "jelly", color = "royal", size = "sm", label = "reset", icon = icon("undo-alt", verify_fa = FALSE)), br(),br(), + actionBttn(ns("submit_genome"), style = "jelly", color = "royal", size = "sm", label = "submit", icon = icon("share-square", verify_fa = FALSE)), br(),br(), + ), + ), br(), br(), + column(12, + br(), + tags$h5(tags$b("Upload .fasta/.fasta.gz and .fasta.fai/.fasta.gz.fai,.fasta.gz.gzi file with assembly information. Using this option, a local HTTP server will be generated.")), + fileInput(ns("fasta"), label = h6("Files: genome_v2.fasta.gz, genome_v2.fasta.gz.fai, genome_v2.fasta.gz.gzi"), multiple = T), + p("or"), + tags$h5(tags$b("Add the URL of the hosted FASTA file location. The loading procedure is more efficient using this option.")), + textInput(ns("fasta_server"), label = h6("https://jbrowse.org/genomes/sars-cov2/fasta/sars-cov2.fa.gz"), value = NULL), + br(), hr(), + tags$h5(tags$b("Upload .gff3/.gff3.gz and .gff3.tbi/.gff3.gz.tbi file with annotation information")), + fileInput(ns("gff3"), label = h6("Files: genome_v2.gff3.gz, genome_v2.gff3.gz.tbi"), multiple = T), + p("or"), + tags$h5(tags$b("Add the URL of the hosted GFF3 file location. The loading procedure is more efficient using this option.")), + textInput(ns("gff3_server"), label = h6("https://jbrowse.org/genomes/sars-cov2/sars-cov2-annotations.sorted.gff.gz"), value = NULL), + br(), hr(), + tags$h5(tags$b("Upload VCF file with variants information")), + fileInput(ns("vcf"), label = h6("Files: markers.vcf, markers.vcf.tbi"), multiple = T), + p("or"), + tags$h5(tags$b("Add the URL of the hosted VCF file location. The loading procedure is more efficient using this option.")), + textInput(ns("vcf_server"), label = h6("https://some/path/file.vcf"), value = NULL), + br(), hr(), + tags$h5(tags$b("Upload .bam and .bam.bai or .cram and .cram.crai file with alignment information")), + fileInput(ns("align"), label = h6("Files: all_ind.bam, all_ind.bam.bai"), multiple = T), + p("or"), + tags$h5(tags$b("Add the URL of the hosted BAM or CRAM file location. The loading procedure is more efficient using this option.")), + textInput(ns("align_server"), label = h6("https://some/path/file.bam"), value = NULL), + br(), hr(), + tags$h5(tags$b("Upload .wig file with bigWig information")), + fileInput(ns("wig"), label = h6("File: data.wig"), multiple = F), + p("or"), + tags$h5(tags$b("Add the URL of the hosted WIG file location. The loading procedure is more efficient using this option.")), + textInput(ns("wig_server"), label = h6("https://some/path/file.wig"), value = NULL), + ) + ) + ) + ), + column(width = 12, + fluidPage( + box(id = ns("box_hidecan"),width = 12, solidHeader = TRUE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("hidecanID"), label = tags$b("Upload Hidecan files")), + tags$p("Access further information about the files expected in this section ", + tags$a(href= "https://plantandfoodresearch.github.io/hidecan/","here")), br(), + + div(style = "position:absolute;right:1em;", + actionBttn(ns("reset_hidecan"), style = "jelly", color = "royal", size = "sm", label = "reset", icon = icon("undo-alt", verify_fa = FALSE)), + actionBttn(ns("submit_hidecan"), style = "jelly", color = "royal", size = "sm", label = "submit HIDECAN", icon = icon("share-square", verify_fa = FALSE)), + ), br(), br(), + box(id= ns("box_gwaspoly"), width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("gwaspolyID"), label = tags$b("Upload GWAS output")), + div(style = "position:absolute;right:1em;", + ), br(), br(), + p("Object of class GWASpoly.thresh obtained with the GWASpoly::set.threshold():"), br(), + fileInput(ns("gwaspoly"), label = h6("File: gwaspoly_res_thr.rda"), multiple = T), + p("or"), + fileInput(ns("gwas"), label = h6("File: gwas.csv"), multiple = T) + ), + box(id= ns("box_gwas_de"), width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("gwasID"), label = tags$b("Upload differential expression (DE) and candidate genes (CAN) files")), + div(style = "position:absolute;right:1em;", + ), br(), br(), + fileInput(ns("de"), label = h6("File: DE.csv"), multiple = T), + fileInput(ns("can"), label = h6("File: CAN.csv"), multiple = T) + ) + ) + ) + ), + column(width = 12, + fluidPage( + box(id = ns("box_viewpoly"),width = 12, solidHeader = TRUE, collapsible = TRUE, collapsed = TRUE, status="info", title = actionLink(inputId = ns("viewpolyID"), label = tags$b("Download VIEWpoly dataset")), + p("The uploaded data are converted to the viewpoly format. It keeps the map and the QTL information. Genome information is not stored."), br(), + textInput(ns("data.name"), label = p("Define the dataset name. Do not use spaces between words."), value = "dataset_name"), br(), + tags$head(tags$style(".butt{background-color:#add8e6; border-color: #add8e6; color: #337ab7;}")), + useShinyjs(), + downloadButton(ns('export_viewpoly'), "Download", class = "butt") + ) + ) + ), + column(width = 12, + fluidPage( + box(id = ns("box_viewpolyup"),width = 12, solidHeader = TRUE, collapsible = TRUE, collapsed = FALSE, status="info", title = actionLink(inputId = ns("viewpolyupID"), label = tags$b("Upload VIEWpoly dataset")), + column(8, + radioButtons(ns("viewpoly_env"), width = 500, label = "Check one of the availables datasets:", + choices = "There is no VIEWpoly object in your R environment. Load VIEWpoly object or convert other formats below.", + selected = "There is no VIEWpoly object in your R environment. Load VIEWpoly object or convert other formats below."), br(), + ), + column(4, + div(style = "position:absolute;right:1em;", + actionBttn(ns("reset_viewpoly"), style = "jelly", color = "royal", size = "sm", label = "reset", icon = icon("undo-alt", verify_fa = FALSE)), br(), br(), + actionBttn(ns("submit_viewpoly"), style = "jelly", color = "royal", size = "sm", label = "submit VIEWpoly file", icon = icon("share-square", verify_fa = FALSE)) + ) + ), + column(12, + br(), br(), hr(), + p("Upload VIEWpoly RData file here:"), + fileInput(ns("viewpoly_input"), label = h6("File: dataset_name.RData"), multiple = F) + ) + ) + ) + ) + ) + ) +} + +#' upload Server Functions +#' +#' @import vroom +#' @importFrom shinyjs js +#' @importFrom utils packageVersion +#' +#' @noRd +mod_upload_server <- function(input, output, session, parent_session){ + ns <- session$ns + + + #Collapse boxes + observeEvent(input$exampleID, { + js$collapse(ns("box_example")) + }) + + observeEvent(input$mapID, { + js$collapse(ns("box_map")) + }) + + observeEvent(input$mappolyID, { + js$collapse(ns("box_mappoly")) + }) + + observeEvent(input$onemapID, { + js$collapse(ns("box_onemap")) + }) + + observeEvent(input$polymapID, { + js$collapse(ns("box_polymap")) + }) + + observeEvent(input$mapstID, { + js$collapse(ns("box_mapst")) + }) + + observeEvent(input$qtlID, { + js$collapse(ns("box_qtl")) + }) + + observeEvent(input$qtlpolyID, { + js$collapse(ns("box_qtlpoly")) + }) + + observeEvent(input$diaqtlID, { + js$collapse(ns("box_diaqtl")) + }) + + observeEvent(input$polyqtlID, { + js$collapse(ns("box_polyqtl")) + }) + + observeEvent(input$qtlstID, { + js$collapse(ns("box_qtlst")) + }) + + observeEvent(input$genomeID, { + js$collapse(ns("box_genome")) + }) + + observeEvent(input$hidecanID, { + js$collapse(ns("box_hidecan")) + }) + + observeEvent(input$viewpolyID, { + js$collapse(ns("box_viewpoly")) + }) + + observeEvent(input$viewpolyupID, { + js$collapse(ns("box_viewpolyup")) + }) + + # Check environment + observe({ + Objs <- Filter(function(x) inherits(get(x), 'viewpoly' ), ls(envir = .GlobalEnv) ) + if(length(Objs) > 0){ + dataset_choices <- as.list(Objs) + names(dataset_choices) <- Objs + updateRadioButtons(session, "viewpoly_env", + label="Check one of the availables datasets:", + choices = dataset_choices, + selected= character(0)) + } else { + updateRadioButtons(session, "viewpoly_env", + label="Check one of the availables datasets:", + choices = "There is no viewpoly object in your R environment. Load view viewpoly object or convert formats below", + selected= character(0)) + } + }) + + # Format examples + output$downloadData_map <- downloadHandler( + filename = function() { + paste0(input$downloadType_map, ".tsv") + }, + content = function(file) { + if(input$downloadType_map == "dosages") { + filetemp <- vroom(system.file("ext/dosage.tsv.gz", package = "viewpoly")) + } else if(input$downloadType_map == "phases") { + filetemp <- vroom(system.file("ext/phases.tsv.gz", package = "viewpoly")) + } else if(input$downloadType_map == "genetic_map") { + filetemp <- vroom(system.file("ext/map.tsv.gz", package = "viewpoly")) + } + vroom_write(filetemp, file = file) + } + ) + + output$downloadData_qtl <- downloadHandler( + filename = function() { + paste0(input$downloadType_qtl, ".tsv") + }, + content = function(file) { + if(input$downloadType_qtl == "qtl_info") { + filetemp <- vroom(system.file("ext/qtl_info.tsv.gz", package = "viewpoly")) + } else if(input$downloadType_qtl == "blups") { + filetemp <- vroom(system.file("ext/blups.tsv.gz", package = "viewpoly")) + } else if(input$downloadType_qtl == "beta.hat") { + filetemp <- vroom(system.file("ext/beta.hat.tsv.gz", package = "viewpoly")) + } else if(input$downloadType_qtl == "profile.hat") { + filetemp <- vroom(system.file("ext/profile.tsv.gz", package = "viewpoly")) + } else if(input$downloadType_qtl == "effects.hat") { + filetemp <- vroom(system.file("ext/effects.tsv.gz", package = "viewpoly")) + } else if(input$downloadType_qtl == "probs") { + filetemp <- vroom(system.file("ext/probs.tsv.gz", package = "viewpoly")) + } + vroom_write(filetemp, file = file) + } + ) + + observeEvent(input$goQTL, { + updateTabsetPanel(session = parent_session, inputId = "viewpoly", + selected = "qtl") + }) + + observeEvent(input$goAbout, { + updateTabsetPanel(session = parent_session, inputId = "viewpoly", + selected = "about") + }) + + # Reset buttons + values <- reactiveValues( + upload_state_map = 0, + upload_state_mappoly = 0, + upload_state_onemap = 0, + upload_state_polymapR = 0, + upload_state_map_custom = 0, + upload_state_qtl = 0, + upload_state_qtlpoly = 0, + upload_state_diaQTL = 0, + upload_state_polyqtlR = 0, + upload_state_qtl_custom = 0, + upload_state_genome = 0, + upload_state_hidecan = 0 + ) + + observeEvent(input$reset_all, { + values$upload_state_viewpoly <- 'reset' + values$upload_state_map <- 'reset' + values$upload_state_mappoly = 0 + values$upload_state_onemap = 0 + values$upload_state_polymapR = 0 + values$upload_state_map_custom = 0 + values$upload_state_qtl <- 'reset' + values$upload_state_qtlpoly = 0 + values$upload_state_diaQTL = 0 + values$upload_state_polyqtlR = 0 + values$upload_state_qtl_custom = 0 + values$upload_state_genome <- 'reset' + values$upload_state_hidecan <- 'reset' + }) + + observeEvent(input$reset_viewpoly, { + values$upload_state_viewpoly <- 'reset' + }) + + observeEvent(input$reset_map, { + values$upload_state_map <- 'reset' + values$upload_state_mappoly = 0 + values$upload_state_onemap = 0 + values$upload_state_polymapR = 0 + values$upload_state_map_custom = 0 + }) + + observeEvent(input$reset_qtl, { + values$upload_state_qtl <- 'reset' + values$upload_state_qtlpoly = 0 + values$upload_state_diaQTL = 0 + values$upload_state_polyqtlR = 0 + values$upload_state_qtl_custom = 0 + }) + + observeEvent(input$reset_genome, { + values$upload_state_genome <- 'reset' + }) + + observeEvent(input$reset_hidecan, { + values$upload_state_hidecan <- 'reset' + }) + + observeEvent(input$submit_viewpoly, { + values$upload_state_viewpoly <- 'uploaded' + }) + + observeEvent(input$submit_mappoly, { + values$upload_state_mappoly <- 'uploaded' + values$upload_state_map <- 0 + }) + + observeEvent(input$submit_onemap, { + values$upload_state_onemap <- 'uploaded' + values$upload_state_map <- 0 + }) + + observeEvent(input$submit_polymapR, { + values$upload_state_polymapR <- 'uploaded' + values$upload_state_map <- 0 + }) + + observeEvent(input$submit_map_custom, { + values$upload_state_map_custom <- 'uploaded' + values$upload_state_map <- 0 + }) + + observeEvent(input$submit_qtlpoly, { + values$upload_state_qtlpoly <- 'uploaded' + values$upload_state_qtl = 0 + }) + + observeEvent(input$submit_diaQTL, { + values$upload_state_diaQTL <- 'uploaded' + values$upload_state_qtl = 0 + }) + + observeEvent(input$submit_polyqtlR, { + values$upload_state_polyqtlR <- 'uploaded' + values$upload_state_qtl = 0 + }) + + observeEvent(input$submit_qtl_custom, { + values$upload_state_qtl_custom <- 'uploaded' + values$upload_state_qtl = 0 + }) + + observeEvent(input$submit_genome, { + values$upload_state_genome <- 'uploaded' + }) + + observeEvent(input$submit_hidecan, { + values$upload_state_hidecan <- 'uploaded' + }) + + input_map <- reactive({ + if (values$upload_state_map == 0 & + values$upload_state_mappoly == 0 & + values$upload_state_onemap == 0 & + values$upload_state_polymapR == 0 & + values$upload_state_map_custom == 0) { + return(NULL) + } else if (values$upload_state_map == 'reset') { + return(NULL) + } else if(values$upload_state_mappoly == "uploaded"){ + validate( + need(!is.null(input$mappoly_in), "Upload mappoly file before submit") + ) + return(list(mappoly_in = input$mappoly_in)) + } else if(values$upload_state_onemap == "uploaded"){ + validate( + need(!is.null(input$onemap_in), "Upload onemap file before submit") + ) + return(list(onemap_in = input$onemap_in)) + } else if(values$upload_state_polymapR == "uploaded"){ + validate( + need(!is.null(input$polymapR.dataset), "Upload polymapR dataset file before submit"), + need(!is.null(input$polymapR.map), "Upload polymapR map file before submit") + ) + return(list(polymapR.dataset = input$polymapR.dataset, + polymapR.map = input$polymapR.map, + input.type = input$input.type, + ploidy = as.numeric(input$ploidy))) + } else if(values$upload_state_map_custom == "uploaded"){ + validate( + need(!is.null(input$dosages), "Upload custom dosages file before submit"), + need(!is.null(input$phases), "Upload custom phases file before submit"), + need(!is.null(input$genetic_map), "Upload custom genetic map file before submit") + ) + return(list(dosages = input$dosages, + phases = input$phases, + genetic_map = input$genetic_map)) + } + }) + + input_qtl <- reactive({ + if (values$upload_state_qtl == 0 & + values$upload_state_qtlpoly == 0 & + values$upload_state_diaQTL == 0 & + values$upload_state_polyqtlR == 0 & + values$upload_state_qtl_custom == 0) { + return(NULL) + } else if (values$upload_state_qtl == 'reset') { + return(NULL) + } else if(values$upload_state_qtl_custom == "uploaded"){ + validate( + need(!is.null(input$dosages), "Upload custom selected markers file before submit"), + need(!is.null(input$phases), "Upload custom QTL info file before submit"), + need(!is.null(input$blups), "Upload custom BLUPs file before submit"), + need(!is.null(input$beta.hat), "Upload custom beta hat file before submit"), + need(!is.null(input$profile), "Upload custom QTL profile file before submit"), + need(!is.null(input$effects), "Upload custom effects file before submit"), + need(!is.null(input$probs), "Upload custom genotype probabilities file before submit") + ) + return(list(selected_mks = input$selected_mks, + qtl_info = input$qtl_info, + blups = input$blups, + beta.hat = input$beta.hat, + profile = input$profile, + effects = input$effects, + probs = input$probs)) + } else if(values$upload_state_qtlpoly == "uploaded"){ + validate( + need(!is.null(input$qtlpoly_data), "Upload QTLpoly data file before submit"), + need(!is.null(input$qtlpoly_remim.mod), "Upload QTLpoly remim.mod file before submit"), + need(!is.null(input$qtlpoly_est.effects), "Upload QTLpoly estimated effects file before submit"), + need(!is.null(input$qtlpoly_fitted.mod), "Upload QTLpoly fitted.mod file before submit") + ) + return(list( + qtlpoly_data = input$qtlpoly_data, + qtlpoly_remim.mod = input$qtlpoly_remim.mod, + qtlpoly_est.effects = input$qtlpoly_est.effects, + qtlpoly_fitted.mod = input$qtlpoly_fitted.mod)) + } else if(values$upload_state_diaQTL == "uploaded"){ + validate( + need(!is.null(input$diaQTL_scan1), "Upload diaQTL scan1 file before submit"), + need(!is.null(input$diaQTL_scan1.summaries), "Upload diaQTL scan1.summaries file before submit"), + need(!is.null(input$diaQTL_fitQTL), "Upload diaQTL fitQTL file before submit"), + need(!is.null(input$diaQTL_BayesCI), "Upload diaQTL BayesCI file before submit") + ) + return(list( + diaQTL_scan1 = input$diaQTL_scan1, + diaQTL_scan1.summaries = input$diaQTL_scan1.summaries, + diaQTL_fitQTL = input$diaQTL_fitQTL, + diaQTL_BayesCI = input$diaQTL_BayesCI + )) + } else if(values$upload_state_polyqtlR == "uploaded"){ + validate( + need(!is.null(input$qtlpoly_data), "Upload polyqtlR scan list file before submit"), + need(!is.null(input$qtlpoly_remim.mod), "Upload polyqtlR QTL info file before submit"), + need(!is.null(input$qtlpoly_est.effects), "Upload polyqtlR estimated effects file before submit") + ) + return(list( + polyqtlR_QTLscan_list = input$polyqtlR_QTLscan_list, + polyqtlR_qtl_info = input$polyqtlR_qtl_info, + polyqtlR_effects = input$polyqtlR_effects + )) + } + }) + + input_genome <- reactive({ + withProgress(message = 'Working:', value = 0, { + incProgress(0.1, detail = paste("Uploading fasta path...")) + if (is.null(values$upload_state_genome)) { + return(NULL) + } else if (values$upload_state_genome == 'reset') { + return(NULL) + } else if(values$upload_state_genome == "uploaded"){ + validate( + need(!is.null(input$fasta) | !is.null(input$fasta_server), "Upload reference genome (FASTA) file before submit.") + ) + return(list(fasta = input$fasta, + fasta_server = input$fasta_server, + gff3 = input$gff3, + gff3_server = input$gff3_server, + vcf = input$vcf, + vcf_server = input$vcf_server, + align = input$align, + align_server = input$align_server, + wig = input$wig, + wig_server = input$wig_server)) + } + }) + }) + + input_hidecan <- reactive({ + if (values$upload_state_hidecan == 0) { + return(NULL) + } else if (values$upload_state_hidecan == 'reset') { + return(NULL) + } else if(values$upload_state_hidecan == "uploaded"){ + validate( + need(!all(c(is.null(input$gwas),is.null(input$gwaspoly))), "Upload GWAS results file before submit") + ) + + if(!is.null(input$gwaspoly)) { + + for(i in 1:length(input$gwaspoly$datapath)){ + temp <- load(input$gwaspoly$datapath[i]) + gwaspoly_temp <- get(temp) + gwaspoly_list <- GWAS_data_from_gwaspoly(gwaspoly_temp) + + if(i == 1) gwaspoly <- gwaspoly_list else { + if(!all(gwaspoly$chrom_length == gwaspoly_list$chrom_length)) { + # If same chromosome but different chromosomes length - keep the maximum + if(all(gwaspoly$chrom_length$chromosome == gwaspoly_list$chrom_length$chromosome)){ + idx <- which(gwaspoly$chrom_length$length < gwaspoly_list$chrom_length$length) + if(length(idx) > 0) + gwaspoly$chrom_length$length[idx] <- gwaspoly_list$chrom_length$length[idx] + } else stop("Not same reference genome used") + } + gwaspoly$gwas_data_list <- c(gwaspoly$gwas_data_list, gwaspoly_list$gwas_data_list) + gwaspoly$gwas_data_thr_list <- c(gwaspoly$gwas_data_thr_list, gwaspoly_list$gwas_data_thr_list) + } + } + + } else gwaspoly <- NULL + + return(list(GWASpoly = gwaspoly, + GWAS = {if(!is.null(input$gwas)) read_input_hidecan(input$gwas, GWAS_data) else list()}, + DE = {if(!is.null(input$de)) read_input_hidecan(input$de, DE_data) else list()}, + CAN = {if(!is.null(input$can)) read_input_hidecan(input$can, CAN_data) else list()})) + } + }) + + # Wait system for the uploads + loadExample = reactive({ + if(is.null(input_map()$dosages) & is.null(input_map()$phases) & is.null(input_map()$genetic_map) & + is.null(input_map()$mappoly_in) & + is.null(input_map()$onemap_in) & + is.null(input_map()$polymapR.dataset) & + is.null(input_map()$polymapR.map) & + is.null(input_qtl()$selected_mks) & + is.null(input_qtl()$qtl_info) & + is.null(input_qtl()$blups) & + is.null(input_qtl()$beta.hat) & + is.null(input_qtl()$profile) & + is.null(input_qtl()$effects) & + is.null(input_qtl()$probs) & + is.null(input_qtl()$qtlpoly_data) & + is.null(input_qtl()$qtlpoly_remim.mod) & + is.null(input_qtl()$qtlpoly_est.effects) & + is.null(input_qtl()$qtlpoly_fitted.mod) & + is.null(input_qtl()$diaQTL_data) & + is.null(input_qtl()$diaQTL_scan1) & + is.null(input_qtl()$diaQTL_scan1.summaries) & + is.null(input_qtl()$diaQTL_fitQTL) & + is.null(input_qtl()$diaQTL_BayesCI) & + is.null(input_qtl()$polyqtlR_QTLscan_list) & + is.null(input_qtl()$polyqtlR_qtl_info) & + is.null(input_qtl()$polyqtlR_effects) & + is.null(input_genome()$fasta) & + is.null(input_genome()$fasta_server) & + is.null(input_genome()$gff3) & + is.null(input_genome()$gff3_server) & + is.null(input_genome()$vcf) & + is.null(input_genome()$vcf_server) & + is.null(input_genome()$align) & + is.null(input_genome()$align_server) & + is.null(input_genome()$wig) & + is.null(input_genome()$wig_server) & + is.null(input$viewpoly_input) & + is.null(input$viewpoly_env)) + withProgress(message = 'Working:', value = 0, { + incProgress(0.5, detail = paste("Uploading example map data...")) + prepare_examples(input$example_map) + }) + else NULL + }) + + # Load hidecan example + loadHidecanExample = reactive({ + if(is.null(input_hidecan()$gwas) & is.null(input_hidecan()$de) & is.null(input_hidecan()$can)) + withProgress(message = 'Working:', value = 0, { + incProgress(0.5, detail = paste("Uploading example map data...")) + x <- get_example_data() + + list("GWAS" = list(GWAS_data(x[["GWAS"]])), + "DE" = list(DE_data(x[["DE"]])), + "CAN" = list(CAN_data(x[["CAN"]]))) + }) + else NULL + }) + + loadViewpoly = reactive({ + withProgress(message = 'Working:', value = 0, { + incProgress(0.1, detail = paste("Uploading viewpoly file...")) + if (is.null(values$upload_state_viewpoly)) { + return(NULL) + } else if (values$upload_state_viewpoly == 'reset') { + return(NULL) + } else if(values$upload_state_viewpoly == "uploaded"){ + if(is.null(input$viewpoly_input) & is.null(input$viewpoly_env)){ + warning("Upload a viewpoly dataset or select one available in your R environment before submit.") + viewpoly.obj <- NULL + } else if(!is.null(input$viewpoly_input)){ + temp <- load(input$viewpoly_input$datapath) + viewpoly.obj <- get(temp) + } else if(!is.null(input$viewpoly_env)) { + viewpoly.obj = get(input$viewpoly_env) + } + return(viewpoly.obj) + } + }) + }) + + loadMap_custom = reactive({ + if(!(is.null(input_map()$dosages) & is.null(input_map()$phases) & is.null(input_map()$genetic_map))){ + req(input_map()$dosages, input_map()$phases, input_map()$genetic_map) + withProgress(message = 'Working:', value = 0, { + incProgress(0.5, detail = paste("Uploading custom map data...")) + prepare_map_custom_files(input_map()$dosages, + input_map()$phases, + input_map()$genetic_map) + }) + } else NULL + }) + + loadMap_mappoly = reactive({ + + if(!is.null(input_map()$mappoly_in)){ + withProgress(message = 'Working:', value = 0, { + incProgress(0.3, detail = paste("Uploading MAPpoly data...")) + prepare_MAPpoly(input_map()$mappoly_in) + }) + } else NULL + }) + + loadMap_onemap = reactive({ + + if(!is.null(input_map()$onemap_in)){ + withProgress(message = 'Working:', value = 0, { + incProgress(0.3, detail = paste("Uploading OneMap data...")) + temp <- load(input_map()$onemap_in$datapath) + viewmap <- get(temp) + viewmap + }) + } else NULL + }) + + loadMap_polymapR = reactive({ + if(!(is.null(input_map()$polymapR.dataset) & + is.null(input_map()$polymapR.map))) { + req(input_map()$polymapR.dataset, input_map()$polymapR.map) + withProgress(message = 'Working:', value = 0, { + incProgress(0.1, detail = paste("Uploading polymapR data...")) + prepare_polymapR(input_map()$polymapR.dataset, input_map()$polymapR.map, + input$input.type, as.numeric(input$ploidy)) + }) + } else NULL + }) + + loadQTL_custom = reactive({ + if(!(is.null(input_qtl()$selected_mks) & + is.null(input_qtl()$qtl_info) & + is.null(input_qtl()$blups) & + is.null(input_qtl()$beta.hat) & + is.null(input_qtl()$profile) & + is.null(input_qtl()$effects) & + is.null(input_qtl()$probs))) { + req(input_qtl()$selected_mks, input_qtl()$qtl_info, input_qtl()$blups, + input_qtl()$beta.hat, input_qtl()$profile, input_qtl()$effects, + input_qtl()$probs) + withProgress(message = 'Working:', value = 0, { + incProgress(0.5, detail = paste("Uploading custom QTL data...")) + prepare_qtl_custom_files(input_qtl()$selected_mks, + input_qtl()$qtl_info, + input_qtl()$blups, + input_qtl()$beta.hat, + input_qtl()$profile, + input_qtl()$effects, + input_qtl()$probs) + }) + } else NULL + }) + + loadQTL_qtlpoly = reactive({ + if(!(is.null(input_qtl()$qtlpoly_data) & + is.null(input_qtl()$qtlpoly_remim.mod) & + is.null(input_qtl()$qtlpoly_est.effects) & + is.null(input_qtl()$qtlpoly_fitted.mod))) { + + req(input_qtl()$qtlpoly_data, + input_qtl()$qtlpoly_remim.mod, + input_qtl()$qtlpoly_est.effects, + input_qtl()$qtlpoly_fitted.mod) + + withProgress(message = 'Working:', value = 0, { + incProgress(0.3, detail = paste("Uploading QTLpoly data...")) + prepare_QTLpoly(input_qtl()$qtlpoly_data, + input_qtl()$qtlpoly_remim.mod, + input_qtl()$qtlpoly_est.effects, + input_qtl()$qtlpoly_fitted.mod) + }) + } else NULL + }) + + loadQTL_diaQTL = reactive({ + if(!(is.null(input_qtl()$diaQTL_scan1) & + is.null(input_qtl()$diaQTL_scan1.summaries) & + is.null(input_qtl()$diaQTL_fitQTL) & + is.null(input_qtl()$diaQTL_BayesCI))) { + + req(input_qtl()$diaQTL_scan1, + input_qtl()$diaQTL_scan1.summaries, + input_qtl()$diaQTL_fitQTL, + input_qtl()$diaQTL_BayesCI) + + withProgress(message = 'Working:', value = 0, { + incProgress(0.3, detail = paste("Uploading diaQTL data...")) + prepare_diaQTL(input_qtl()$diaQTL_scan1, + input_qtl()$diaQTL_scan1.summaries, + input_qtl()$diaQTL_fitQTL, + input_qtl()$diaQTL_BayesCI) + }) + } else NULL + }) + + loadQTL_polyqtlR = reactive({ + if(!(is.null(input_qtl()$polyqtlR_QTLscan_list) & + is.null(input_qtl()$polyqtlR_qtl_info) & + is.null(input_qtl()$polyqtlR_effects))) { + + req(input_qtl()$polyqtlR_QTLscan_list, + input_qtl()$polyqtlR_qtl_info, + input_qtl()$polyqtlR_effects) + + withProgress(message = 'Working:', value = 0, { + incProgress(0.3, detail = paste("Uploading polyqtlR data...")) + prepare_polyqtlR(input_qtl()$polyqtlR_QTLscan_list, + input_qtl()$polyqtlR_qtl_info, + input_qtl()$polyqtlR_effects) + }) + } else NULL + }) + + temp_dir <- reactive(tempdir()) + + loadJBrowse_fasta = reactive({ + withProgress(message = 'Working:', value = 0, { + incProgress(0.1, detail = paste("Uploading fasta path...")) + if(!is.null(input_genome()$fasta) & !is.null(loadMap())){ + # keep fasta name + for(i in 1:length(input_genome()$fasta$datapath)){ + print(file.path(temp_dir(), input_genome()$fasta$name)) + + file.rename(input_genome()$fasta$datapath[i], + file.path(temp_dir(), input_genome()$fasta$name[i])) + } + file.path(temp_dir(), sort(input_genome()$fasta$name)[1]) + } else if(!is.null(input_genome()$fasta_server) & !is.null(loadMap())) { + input_genome()$fasta_server + } else if(!is.null(input_genome()$fasta) | !is.null(input_genome()$fasta_server)) { + warning("Load map data first to use this feature.") + } else if(!is.null(loadExample())){ + loadExample()$fasta + } else NULL + }) + }) + + loadJBrowse_gff3 = reactive({ + withProgress(message = 'Working:', value = 0, { + incProgress(0.1, detail = paste("Uploading gff3 path...")) + if(!is.null(input_genome()$gff3)){ + for(i in 1:length(input_genome()$gff3$datapath)){ + file.rename(input_genome()$gff3$datapath[i], + file.path(temp_dir(), input_genome()$gff3$name[i])) + } + file.path(temp_dir(), input_genome()$gff3$name[1]) + } else if(!is.null(input_genome()$gff3_server)) { + input_genome()$gff3_server + } else if(!is.null(loadExample())){ + loadExample()$gff3 + } else NULL + }) + }) + + loadJBrowse_vcf = reactive({ + withProgress(message = 'Working:', value = 0, { + incProgress(0.1, detail = paste("Uploading VCF path...")) + if(!is.null(input_genome()$vcf)) { + for(i in 1:length(input_genome()$vcf$datapath)){ + file.rename(input_genome()$vcf$datapath[i], + file.path(temp_dir(), input_genome()$vcf$name[i])) + } + file.path(temp_dir(), input_genome()$vcf$name[1]) + } else if(!is.null(input_genome()$vcf_server)) { + input_genome()$vcf_server + } else NULL + }) + }) + + loadJBrowse_align = reactive({ + withProgress(message = 'Working:', value = 0, { + incProgress(0.1, detail = paste("Uploading BAM or CRAM alignment data path...")) + if(!is.null(input_genome()$align)) { + for(i in 1:length(input_genome()$align$datapath)){ + file.rename(input_genome()$align$datapath[i], + file.path(temp_dir(), input_genome()$align$name[i])) + } + file.path(temp_dir(), input_genome()$align$name[1]) + } else if(!is.null(input_genome()$align_server)) { + input_genome()$align_server + } else NULL + }) + }) + + loadJBrowse_wig = reactive({ + withProgress(message = 'Working:', value = 0, { + incProgress(0.1, detail = paste("Uploading bigWig data path...")) + if(!is.null(input_genome()$wig)) { + for(i in 1:length(input_genome()$wig$datapath)){ + file.rename(input_genome()$wig$datapath[i], + file.path(temp_dir(), input_genome()$wig$name[i])) + } + file.path(temp_dir(), input_genome()$wig$name[1]) + } else if(!is.null(input_genome()$wig_server)) { + input_genome()$wig_server + } else NULL + }) + }) + + loadMap = reactive({ + if(is.null(loadExample()) & + is.null(loadMap_custom()) & + is.null(loadMap_mappoly()) & + is.null(loadMap_onemap()) & + is.null(loadMap_polymapR()) & + is.null(loadViewpoly())){ + warning("Select one of the options in `upload` session") + return(NULL) + } else if(!is.null(loadViewpoly())){ + return(loadViewpoly()$map) + } else if(!is.null(loadMap_custom())){ + return(loadMap_custom()) + } else if(!is.null(loadMap_mappoly())){ + return(loadMap_mappoly()) + } else if(!is.null(loadMap_onemap())){ + return(loadMap_onemap()) + } else if(!is.null(loadMap_polymapR())){ + return(loadMap_polymapR()) + } else if(!is.null(loadExample())){ + return(loadExample()$map) + } + }) + + loadQTL = reactive({ + if(is.null(loadExample()) & + is.null(loadQTL_custom()) & + is.null(loadQTL_qtlpoly()) & + is.null(loadQTL_diaQTL()) & + is.null(loadQTL_polyqtlR()) & + is.null(loadViewpoly())){ + warning("Select one of the options in `upload` session") + return(NULL) + } else if(!is.null(loadViewpoly())){ + return(loadViewpoly()$qtl) + } else if(!is.null(loadQTL_custom())){ + return(loadQTL_custom()) + } else if(!is.null(loadQTL_qtlpoly())){ + return(loadQTL_qtlpoly()) + } else if(!is.null(loadQTL_diaQTL())){ + return(loadQTL_diaQTL()) + } else if(!is.null(loadQTL_polyqtlR())){ + return(loadQTL_polyqtlR()) + } else if(!is.null(loadExample())){ + return(loadExample()$qtl) + } + }) + + loadHidecan = reactive({ + if(is.null(loadHidecanExample()) & + is.null(input_hidecan()) & + is.null(loadViewpoly())){ + warning("Select one of the options in `upload` session") + return(NULL) + } else if(!is.null(loadViewpoly())){ + return(loadViewpoly()$hidecan) + } else if(!is.null(input_hidecan())){ + return(input_hidecan()) + } else if(!is.null(loadHidecanExample())){ + return(loadHidecanExample()) + } + }) + + observe({ + if (!is.null(loadMap()) | !is.null(loadQTL())) { + Sys.sleep(1) + # enable the download button + shinyjs::enable("export_viewpoly") + } else { + shinyjs::disable("export_viewpoly") + } + }) + + output$export_viewpoly <- downloadHandler( + filename = function() { + paste0("viewpoly.RData") + }, + content = function(file) { + withProgress(message = 'Working:', value = 0, { + incProgress(0.1, detail = paste("Saving viewpoly object...")) + validate( + need(!is.null(loadMap()) | !is.null(loadQTL()), "For exporting VIEWpoly dataset it is required to load + linkage map or QTL data in the above boxes."), + ) + obj <- structure(list(map = loadMap(), + qtl = loadQTL(), + fasta = NULL, # It would save only the temporary path + gff3 = NULL, + vcf = NULL, + align = NULL, + wig = NULL, + hidecan = loadHidecan(), + version = packageVersion("viewpoly")), + class = "viewpoly") + assign(input$data.name, obj) + incProgress(0.5, detail = paste("Saving viewpoly object...")) + }) + save(list = input$data.name, file = file) + } + ) + + return(list(loadMap = reactive(loadMap()), + loadQTL = reactive(loadQTL()), + loadJBrowse_fasta = reactive(loadJBrowse_fasta()), + loadJBrowse_gff3 = reactive(loadJBrowse_gff3()), + loadJBrowse_vcf = reactive(loadJBrowse_vcf()), + loadJBrowse_align = reactive(loadJBrowse_align()), + loadJBrowse_wig = reactive(loadJBrowse_wig()), + loadHidecan = reactive(loadHidecan()))) +} + +## To be copied in the UI +# mod_upload_ui("upload_ui_1") + +## To be copied in the server +# mod_upload_server("upload_ui_1") diff --git a/man/draw_map_shiny.Rd b/man/draw_map_shiny.Rd index def4b28..a58098e 100644 --- a/man/draw_map_shiny.Rd +++ b/man/draw_map_shiny.Rd @@ -21,6 +21,8 @@ draw_map_shiny( \arguments{ \item{left.lim}{covered window in the linkage map start position} +\item{right.lim}{covered window in the linkage map end position} + \item{ch}{linkage group ID} \item{ph.p1}{list containing a data.frame for each group with parent 1 estimated phases. The data.frame contain the columns: @@ -40,8 +42,6 @@ draw_map_shiny( \item{software}{character defined from each software it comes from} -\item{rigth.lim}{covered window in the linkage map end position} - \item{maps}{list containing a vector for each linkage group markers with marker positions (named with marker names)} } \value{ diff --git a/man/map_summary.Rd b/man/map_summary.Rd index 7b4ff48..02e0de3 100644 --- a/man/map_summary.Rd +++ b/man/map_summary.Rd @@ -10,6 +10,8 @@ map_summary(left.lim = 0, right.lim = 5, ch = 1, maps, d.p1, d.p2) \arguments{ \item{left.lim}{covered window in the linkage map start position} +\item{right.lim}{covered window in the linkage map end position} + \item{ch}{linkage group ID} \item{maps}{list containing a vector for each linkage group markers with marker positions (named with marker names)} @@ -20,8 +22,6 @@ map_summary(left.lim = 0, right.lim = 5, ch = 1, maps, d.p1, d.p2) 4) numerical vector with dosage} \item{d.p2}{list containing a data.frame for each group with parent 2 dosages. See d.p1 parameter description} - -\item{rigth.lim}{covered window in the linkage map end position} } \value{ list with linkage map information: doses; number snps by group; cM per snp; map size; number of linkage groups diff --git a/man/prepare_hidecan_examples.Rd b/man/prepare_hidecan_examples.Rd deleted file mode 100644 index 732ba9a..0000000 --- a/man/prepare_hidecan_examples.Rd +++ /dev/null @@ -1,18 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/functions_upload.R -\name{prepare_hidecan_examples} -\alias{prepare_hidecan_examples} -\title{Upload hidecan example files} -\usage{ -prepare_hidecan_examples(example) -} -\arguments{ -\item{example}{character indicating the example dataset selected} -} -\value{ -object of class \code{viewpoly} -} -\description{ -Upload hidecan example files -} -\keyword{internal} diff --git a/tests/testthat/test-hidecan.R b/tests/testthat/test-hidecan.R new file mode 100644 index 0000000..7c59b0d --- /dev/null +++ b/tests/testthat/test-hidecan.R @@ -0,0 +1,111 @@ +# test_that("Tests HIDECAN",{ +# +# library(hidecan) +# gwaspoly_file <- system.file("extdata/gwaspoly_res_thr.rda", package = "hidecan") +# gwaspoly_file <- "~/Documents/Sweetpotato_Phill_GBS_DArT/GWAS_results/NormalizedBLUE_fb_DArTag_viewpoly.RData" +# +# input <- list() +# input$gwaspoly$datapath <- c(gwaspoly_file, gwaspoly_file2, gwaspoly_file4) +# input$gwaspoly$datapath <- gwaspoly_file +# +# for(i in 1:length(input$gwaspoly$datapath)){ +# temp <- load(input$gwaspoly$datapath[i]) +# gwaspoly_temp <- get(temp) +# gwaspoly_list <- hidecan::GWAS_data_from_gwaspoly(gwaspoly_temp) +# +# if(i == 1) gwaspoly <- gwaspoly_list else { +# if(!all(gwaspoly$chrom_length == gwaspoly_list$chrom_length)) { +# # If same chromosome but different chromosomes length - keep the maximum +# if(all(gwaspoly$chrom_length$chromosome == gwaspoly_list$chrom_length$chromosome)){ +# idx <- which(gwaspoly$chrom_length$length < gwaspoly_list$chrom_length$length) +# if(length(idx) > 0) +# gwaspoly$chrom_length$length[idx] <- gwaspoly_list$chrom_length$length[idx] +# } else stop("Not same reference genome used") +# } +# gwaspoly$gwas_data_list <- c(gwaspoly$gwas_data_list, gwaspoly_list$gwas_data_list) +# gwaspoly$gwas_data_thr_list <- c(gwaspoly$gwas_data_thr_list, gwaspoly_list$gwas_data_thr_list) +# } +# } +# +# # Merging gwaspoly objects +# +# custom_files <- get_example_data() +# loadHidecan <- list("GWASpoly" = gwaspoly, +# "GWAS" = list(GWAS_data(custom_files[["GWAS"]])), +# "DE" = list(DE_data(custom_files[["DE"]])), +# "CAN" = list(CAN_data(custom_files[["CAN"]]))) +# +# x <- loadHidecan[["GWASpoly"]]$gwas_data_thr_list +# +# csv_names_gwas <- names(loadHidecan[["GWAS"]]) +# +# chrom_length <- combine_chrom_length( +# loadHidecan[["GWASpoly"]][["gwas_data_list"]] +# ) +# +# hidecan_data <- list(x, chrom_length) +# +# +# ## Function to create a name for each dataset to use when choosing which +# ## dataset should be plotted +# make_names_hidecan_data <- function(hidecan_list){ +# +# data_type_labels <- c("GWAS_data_thr" = "GWAS data", +# "DE_data_thr" = "DE data", +# "CAN_data_thr" = "Candidate genes list") +# +# labels <- sapply(hidecan_list, function(x){class(x)[[1]]}) +# +# labels <- paste0( +# data_type_labels[labels], +# " (", +# names(hidecan_list), +# ")" +# ) +# +# labels <- sub(" ( )", "", labels, fixed = TRUE) +# +# labels +# } +# +# track_choices <- as.list(make_names_hidecan_data(hidecan_data[[1]])) +# names(track_choices) <- make_names_hidecan_data(hidecan_data[[1]]) +# +# x <- hidecan_data[[1]] +# #x <- x[match(input$tracks, make_names_hidecan_data(x))] +# +# #x <- lapply(x, function(y) y[which(y$chromosome %in% input$chrom),]) +# +# chrom_length <- hidecan_data[[2]] +# #chrom_length <- chrom_length[match(input$chrom, chrom_length$chromosome),] +# +# x <- x[-which(sapply(x, nrow) == 0)] +# +# str(x) +# if(all(sapply(x, nrow) == 0)) stop("No QTL found") +# print(chrom_length) +# +# p <- create_hidecan_plot(x, +# chrom_length, +# colour_genes_by_score = TRUE, +# remove_empty_chrom = TRUE, +# title = NULL, +# subtitle = NULL, +# n_rows = NULL, +# n_cols = 2, +# legend_position = "none", +# point_size = 3, +# label_size = 3.5, +# label_padding = 0.15) +# p +# +# input$ncols <- 2 +# n.chr <- length(unique(p$data$chromosome)) +# ## Also use the number of tracks on the y axis +# n.ytracks <- length(unique(p$data$dataset)) +# +# size <- (n.ytracks * n.chr/input$ncols)*80 +# +# size +# +# }) \ No newline at end of file diff --git a/tests/testthat/test-tetra_example.R b/tests/testthat/test-tetra_example.R index 0c91872..d129a74 100644 --- a/tests/testthat/test-tetra_example.R +++ b/tests/testthat/test-tetra_example.R @@ -1,219 +1,219 @@ -test_that("tetra example",{ - source(system.file("ext/functions4tests.R", package = "viewpoly")) - - # upload examples - viewpoly_obj <- prepare_examples("tetra_map") - - expect_equal(check_viewpoly(viewpoly_obj),0) - - check_viewmap_values(viewpoly_obj$map, - c(14, 132, 139, 157, 34), - c(36, 167, 164, 109), - 50502.07) - - check_viewqtl_qtlpoly_values(viewpoly_obj$qtl, - 116504, - 5.418909, - -1.067457e-11, - 299.6155, - 0.000160791, - 2.340129e-12, - 1) - - # VIEWmap tests - qtl_profile_plot <- plot_profile(profile = viewpoly_obj$qtl$profile, - qtl_info = viewpoly_obj$qtl$qtl_info, - selected_mks = viewpoly_obj$qtl$selected_mks, - pheno.col = 2:3, - lgs.id = 2, - by_range = TRUE, - range.min = 30, - range.max = 120, - plot=TRUE, - software = NULL) - - expect_equal(sum(qtl_profile_plot$data$SIG, na.rm = TRUE), 84.46874, tolerance = 0.0001) - - maps <- lapply(viewpoly_obj$map$maps, function(x) { - y <- x$l.dist - names(y) <- x$mk.names - y - }) - - vdiffr::expect_doppelganger("linkage map draw", draw_map_shiny(left.lim = 1, - right.lim = 50, - ch = 1, - d.p1 = viewpoly_obj$map$d.p1, - d.p2 = viewpoly_obj$map$d.p2, - maps = maps, - ph.p1 = viewpoly_obj$map$ph.p1, - ph.p2 = viewpoly_obj$map$ph.p2, - snp.names = FALSE, software = "mappoly")) - - vdiffr::expect_doppelganger("linkage map draw names", draw_map_shiny(left.lim = 1, - right.lim = 50, - ch = 1, - d.p1 = viewpoly_obj$map$d.p1, - d.p2 = viewpoly_obj$map$d.p2, - maps = maps, - ph.p1 = viewpoly_obj$map$ph.p1, - ph.p2 = viewpoly_obj$map$ph.p2, - snp.names = TRUE, software = "mappoly")) - - vdiffr::expect_doppelganger("plot map list", plot_map_list(viewpoly_obj$map)) - - # Get max size each chromosome - expect_equal(map_summary(left.lim = 1, - right.lim = 50, - ch = 3, - maps = maps, - d.p1 = viewpoly_obj$map$d.p1, - d.p2 = viewpoly_obj$map$d.p2)[[5]], 134.073, tolerance = 0.0001) - - # Map summary table - summary_table <- summary_maps(viewpoly_obj$map, software = "mappoly") - expect_equal(sum(as.numeric(summary_table$`Map length (cM)`)), 3259.98) - expect_equal(sum(as.numeric(summary_table$Simplex)), 2450) - expect_equal(sum(as.numeric(summary_table$`Double-simplex`)), 1820) - expect_equal(sum(as.numeric(summary_table$`Max gap`)), 80.51) - - #VIEWqtl tests - vdiffr::expect_doppelganger("qtl plot", plot_profile(viewpoly_obj$qtl$profile, - viewpoly_obj$qtl$qtl_info, - viewpoly_obj$qtl$selected_mks, - pheno.col = 2, - lgs.id = 2, - by_range = FALSE, - plot=TRUE, - software = NULL)) - - # by range - qtl_profile_data <- plot_profile(viewpoly_obj$qtl$profile, - viewpoly_obj$qtl$qtl_info, - viewpoly_obj$qtl$selected_mks, - pheno.col = 2, - lgs.id = 2, - by_range = TRUE, - range.min = 30, - range.max = 120, - plot=FALSE, - software = NULL) - - expect_equal(sum(qtl_profile_data$lines$SIG, na.rm = TRUE), 43.81917, tolerance = 0.001) - expect_equal(sum(qtl_profile_data$lines$`Position (cM)`), 8000.109, tolerance = 0.001) - expect_equal(as.numeric(qtl_profile_data$points$PVAL), 0.000141, tolerance = 0.001) - expect_equal(as.numeric(qtl_profile_data$points$H2), 0.17, tolerance = 0.001) - expect_equal(as.numeric(qtl_profile_data$points$INF), 41, tolerance = 0.001) - expect_equal(as.numeric(qtl_profile_data$points$SUP), 119, tolerance = 0.001) - - # export data - qtl_profile_data <- plot_profile(viewpoly_obj$qtl$profile, - viewpoly_obj$qtl$qtl_info, - viewpoly_obj$qtl$selected_mks, - pheno.col = 2, - lgs.id = 2, - by_range = FALSE, - range.min = NULL, - range.max = NULL, - plot=FALSE, - software = NULL) - - expect_equal(sum(qtl_profile_data$lines$SIG), 292.883, tolerance = 0.001) - expect_equal(sum(qtl_profile_data$lines$`Position (cM)`), 8000.109, tolerance = 0.001) - expect_equal(as.numeric(qtl_profile_data$points$PVAL), 0.000141, tolerance = 0.001) - expect_equal(as.numeric(qtl_profile_data$points$H2), 0.17, tolerance = 0.001) - expect_equal(as.numeric(qtl_profile_data$points$INF), 41, tolerance = 0.001) - expect_equal(as.numeric(qtl_profile_data$points$SUP), 119, tolerance = 0.001) - - # plot exported data - p <- only_plot_profile(qtl_profile_data) - expect_equal(sum(p$data$SIG), 292.883, tolerance = 0.001) - - # effects graphics - p <- data_effects(qtl_info = viewpoly_obj$qtl$qtl_info, - effects = viewpoly_obj$qtl$effects, - pheno.col = "SG06", - lgs = 2, - groups = 2, - position = 77, - software = "QTLpoly", - design = "circle") - - vdiffr::expect_doppelganger("effects circle", plot_effects(data_effects.obj = p, - software = "QTLpoly", - design = "circle")) - - expect_equal(sum(p[[1]]$data$Estimates), -0.0436829, tolerance = 0.001) - expect_equal(names(p[[1]]$data), - c("Estimates", "Alleles", "Parent", "Effects", "pheno", "qtl_id", "LG", "Pos", "unique.id"), - tolerance = 0.001) - - p <- data_effects(qtl_info = viewpoly_obj$qtl$qtl_info, - effects = viewpoly_obj$qtl$effects, - pheno.col = "SG06", - lgs = 2, - groups = 2, - position = 77, - software = "QTLpoly", - design = "digenic") - - expect_equal(sum(p[[1]]$data$z), 1.528847e-14, tolerance = 0.001) - expect_equal(names(p[[1]]$data), - c("x", "y", "z"), - tolerance = 0.001) - - vdiffr::expect_doppelganger("effects digenic", plot_effects(p, "QTLpoly", "digenic")) - - p <- data_effects(qtl_info = viewpoly_obj$qtl$qtl_info, - effects = viewpoly_obj$qtl$effects, - pheno.col = "SG06", - lgs = 2, - groups = 2, - position = 77, - software = "QTLpoly", - design = "bar") - - expect_equal(sum(p[[1]]$data$Estimates), 2.184058e-15, tolerance = 0.001) - expect_equal(names(p[[1]]$data), - c("Estimates", "Alleles", "Parent", "Effects"), - tolerance = 0.001) - - vdiffr::expect_doppelganger("effects bar", plot_effects(p, "QTLpoly", "bar")) - - # breeding values table - pos <- split(viewpoly_obj$qtl$qtl_info[1:3,]$Pos, viewpoly_obj$qtl$qtl_info[1:3,]$pheno) - breed.values <- breeding_values(viewpoly_obj$qtl$qtl_info, - viewpoly_obj$qtl$probs, - viewpoly_obj$qtl$selected_mks, - viewpoly_obj$qtl$blups, - viewpoly_obj$qtl$beta.hat, - pos) - - expect_equal(sum(breed.values$PY06), 5.26) - expect_equal(sum(breed.values$SG06), 5.36) - - # get and plot homologs prob - data.prob <- calc_homologprob(probs = viewpoly_obj$qtl$probs, - viewpoly_obj$qtl$selected_mks, - 1:5) - - expect_equal(sum(data.prob$homoprob$probability), 14900, tolerance = 0.001) - - input.haplo <- c("Trait:SG06_LG:2_Pos:77_homolog:P1.1") - p1.list <- select_haplo(input.haplo, - viewpoly_obj$qtl$probs, - viewpoly_obj$qtl$selected_mks, - effects.data = p) - - p1 <- p1.list[[1]] - expect_equal(sum(p1[[1]]$data$probability), 507.9996, tolerance = 0.0001) - expect_equal(sum(p1[[2]]$data$probability), 508.001, tolerance = 0.0001) - expect_equal(sum(p1[[3]]$data$probability), 508.0009, tolerance = 0.0001) - - # VIEWgenome tests - p <- plot_cm_mb(viewpoly_obj$map, 1, 1,50) - - expect_equal(sum(p$data$l.dist), 50502.07, tolerance = 0.001) - -}) - +test_that("tetra example",{ + source(system.file("ext/functions4tests.R", package = "viewpoly")) + + # upload examples + viewpoly_obj <- prepare_examples("tetra_map") + + expect_equal(check_viewpoly(viewpoly_obj),0) + + check_viewmap_values(viewpoly_obj$map, + c(14, 132, 139, 157, 34), + c(36, 167, 164, 109), + 50502.07) + + check_viewqtl_qtlpoly_values(viewpoly_obj$qtl, + 116504, + 5.418909, + -1.067457e-11, + 299.6155, + 0.000160791, + 2.340129e-12, + 1) + + # VIEWmap tests + qtl_profile_plot <- plot_profile(profile = viewpoly_obj$qtl$profile, + qtl_info = viewpoly_obj$qtl$qtl_info, + selected_mks = viewpoly_obj$qtl$selected_mks, + pheno.col = 2:3, + lgs.id = 2, + by_range = TRUE, + range.min = 30, + range.max = 120, + plot=TRUE, + software = NULL) + + expect_equal(sum(qtl_profile_plot$data$SIG, na.rm = TRUE), 84.46874, tolerance = 0.0001) + + maps <- lapply(viewpoly_obj$map$maps, function(x) { + y <- x$l.dist + names(y) <- x$mk.names + y + }) + + # vdiffr::expect_doppelganger("linkage map draw", draw_map_shiny(left.lim = 1, + # right.lim = 50, + # ch = 1, + # d.p1 = viewpoly_obj$map$d.p1, + # d.p2 = viewpoly_obj$map$d.p2, + # maps = maps, + # ph.p1 = viewpoly_obj$map$ph.p1, + # ph.p2 = viewpoly_obj$map$ph.p2, + # snp.names = FALSE, software = "mappoly")) + # + # vdiffr::expect_doppelganger("linkage map draw names", draw_map_shiny(left.lim = 1, + # right.lim = 50, + # ch = 1, + # d.p1 = viewpoly_obj$map$d.p1, + # d.p2 = viewpoly_obj$map$d.p2, + # maps = maps, + # ph.p1 = viewpoly_obj$map$ph.p1, + # ph.p2 = viewpoly_obj$map$ph.p2, + # snp.names = TRUE, software = "mappoly")) + # + # vdiffr::expect_doppelganger("plot map list", plot_map_list(viewpoly_obj$map)) + + # Get max size each chromosome + expect_equal(map_summary(left.lim = 1, + right.lim = 50, + ch = 3, + maps = maps, + d.p1 = viewpoly_obj$map$d.p1, + d.p2 = viewpoly_obj$map$d.p2)[[5]], 134.073, tolerance = 0.0001) + + # Map summary table + summary_table <- summary_maps(viewpoly_obj$map, software = "mappoly") + expect_equal(sum(as.numeric(summary_table$`Map length (cM)`)), 3259.98) + expect_equal(sum(as.numeric(summary_table$Simplex)), 2450) + expect_equal(sum(as.numeric(summary_table$`Double-simplex`)), 1820) + expect_equal(sum(as.numeric(summary_table$`Max gap`)), 80.51) + + #VIEWqtl tests + # vdiffr::expect_doppelganger("qtl plot", plot_profile(viewpoly_obj$qtl$profile, + # viewpoly_obj$qtl$qtl_info, + # viewpoly_obj$qtl$selected_mks, + # pheno.col = 2, + # lgs.id = 2, + # by_range = FALSE, + # plot=TRUE, + # software = NULL)) + + # by range + qtl_profile_data <- plot_profile(viewpoly_obj$qtl$profile, + viewpoly_obj$qtl$qtl_info, + viewpoly_obj$qtl$selected_mks, + pheno.col = 2, + lgs.id = 2, + by_range = TRUE, + range.min = 30, + range.max = 120, + plot=FALSE, + software = NULL) + + expect_equal(sum(qtl_profile_data$lines$SIG, na.rm = TRUE), 43.81917, tolerance = 0.001) + expect_equal(sum(qtl_profile_data$lines$`Position (cM)`), 8000.109, tolerance = 0.001) + expect_equal(as.numeric(qtl_profile_data$points$PVAL), 0.000141, tolerance = 0.001) + expect_equal(as.numeric(qtl_profile_data$points$H2), 0.17, tolerance = 0.001) + expect_equal(as.numeric(qtl_profile_data$points$INF), 41, tolerance = 0.001) + expect_equal(as.numeric(qtl_profile_data$points$SUP), 119, tolerance = 0.001) + + # export data + qtl_profile_data <- plot_profile(viewpoly_obj$qtl$profile, + viewpoly_obj$qtl$qtl_info, + viewpoly_obj$qtl$selected_mks, + pheno.col = 2, + lgs.id = 2, + by_range = FALSE, + range.min = NULL, + range.max = NULL, + plot=FALSE, + software = NULL) + + expect_equal(sum(qtl_profile_data$lines$SIG), 292.883, tolerance = 0.001) + expect_equal(sum(qtl_profile_data$lines$`Position (cM)`), 8000.109, tolerance = 0.001) + expect_equal(as.numeric(qtl_profile_data$points$PVAL), 0.000141, tolerance = 0.001) + expect_equal(as.numeric(qtl_profile_data$points$H2), 0.17, tolerance = 0.001) + expect_equal(as.numeric(qtl_profile_data$points$INF), 41, tolerance = 0.001) + expect_equal(as.numeric(qtl_profile_data$points$SUP), 119, tolerance = 0.001) + + # plot exported data + p <- only_plot_profile(qtl_profile_data) + expect_equal(sum(p$data$SIG), 292.883, tolerance = 0.001) + + # effects graphics + p <- data_effects(qtl_info = viewpoly_obj$qtl$qtl_info, + effects = viewpoly_obj$qtl$effects, + pheno.col = "SG06", + lgs = 2, + groups = 2, + position = 77, + software = "QTLpoly", + design = "circle") + + # vdiffr::expect_doppelganger("effects circle", plot_effects(data_effects.obj = p, + # software = "QTLpoly", + # design = "circle")) + + expect_equal(sum(p[[1]]$data$Estimates), -0.0436829, tolerance = 0.001) + expect_equal(names(p[[1]]$data), + c("Estimates", "Alleles", "Parent", "Effects", "pheno", "qtl_id", "LG", "Pos", "unique.id"), + tolerance = 0.001) + + p <- data_effects(qtl_info = viewpoly_obj$qtl$qtl_info, + effects = viewpoly_obj$qtl$effects, + pheno.col = "SG06", + lgs = 2, + groups = 2, + position = 77, + software = "QTLpoly", + design = "digenic") + + expect_equal(sum(p[[1]]$data$z), 1.528847e-14, tolerance = 0.001) + expect_equal(names(p[[1]]$data), + c("x", "y", "z"), + tolerance = 0.001) + + # vdiffr::expect_doppelganger("effects digenic", plot_effects(p, "QTLpoly", "digenic")) + + p <- data_effects(qtl_info = viewpoly_obj$qtl$qtl_info, + effects = viewpoly_obj$qtl$effects, + pheno.col = "SG06", + lgs = 2, + groups = 2, + position = 77, + software = "QTLpoly", + design = "bar") + + expect_equal(sum(p[[1]]$data$Estimates), 2.184058e-15, tolerance = 0.001) + expect_equal(names(p[[1]]$data), + c("Estimates", "Alleles", "Parent", "Effects"), + tolerance = 0.001) + + # vdiffr::expect_doppelganger("effects bar", plot_effects(p, "QTLpoly", "bar")) + + # breeding values table + pos <- split(viewpoly_obj$qtl$qtl_info[1:3,]$Pos, viewpoly_obj$qtl$qtl_info[1:3,]$pheno) + breed.values <- breeding_values(viewpoly_obj$qtl$qtl_info, + viewpoly_obj$qtl$probs, + viewpoly_obj$qtl$selected_mks, + viewpoly_obj$qtl$blups, + viewpoly_obj$qtl$beta.hat, + pos) + + expect_equal(sum(breed.values$PY06), 5.26) + expect_equal(sum(breed.values$SG06), 5.36) + + # get and plot homologs prob + data.prob <- calc_homologprob(probs = viewpoly_obj$qtl$probs, + viewpoly_obj$qtl$selected_mks, + 1:5) + + expect_equal(sum(data.prob$homoprob$probability), 14900, tolerance = 0.001) + + input.haplo <- c("Trait:SG06_LG:2_Pos:77_homolog:P1.1") + p1.list <- select_haplo(input.haplo, + viewpoly_obj$qtl$probs, + viewpoly_obj$qtl$selected_mks, + effects.data = p) + + p1 <- p1.list[[1]] + expect_equal(sum(p1[[1]]$data$probability), 507.9996, tolerance = 0.0001) + expect_equal(sum(p1[[2]]$data$probability), 508.001, tolerance = 0.0001) + expect_equal(sum(p1[[3]]$data$probability), 508.0009, tolerance = 0.0001) + + # VIEWgenome tests + p <- plot_cm_mb(viewpoly_obj$map, 1, 1,50) + + expect_equal(sum(p$data$l.dist), 50502.07, tolerance = 0.001) + +}) + diff --git a/viewpoly.Rproj b/viewpoly.Rproj index fec809a..eaa6b81 100644 --- a/viewpoly.Rproj +++ b/viewpoly.Rproj @@ -1,18 +1,18 @@ -Version: 1.0 - -RestoreWorkspace: Default -SaveWorkspace: Default -AlwaysSaveHistory: Default - -EnableCodeIndexing: Yes -UseSpacesForTab: Yes -NumSpacesForTab: 2 -Encoding: UTF-8 - -RnwWeave: Sweave -LaTeX: pdfLaTeX - -BuildType: Package -PackageUseDevtools: Yes -PackageInstallArgs: --no-multiarch --with-keep.source -PackageRoxygenize: rd,collate,namespace +Version: 1.0 + +RestoreWorkspace: Default +SaveWorkspace: Default +AlwaysSaveHistory: Default + +EnableCodeIndexing: Yes +UseSpacesForTab: Yes +NumSpacesForTab: 2 +Encoding: UTF-8 + +RnwWeave: Sweave +LaTeX: pdfLaTeX + +BuildType: Package +PackageUseDevtools: Yes +PackageInstallArgs: --no-multiarch --with-keep.source +PackageRoxygenize: rd,collate,namespace