From fe792e39e05575082f3f12e367d804d85238f08b Mon Sep 17 00:00:00 2001 From: Cristianetaniguti Date: Thu, 29 Jun 2023 11:12:17 -0500 Subject: [PATCH 01/14] onemap bi --- R/functions_map.R | 43 ++++++++++++++++++++++------------------ R/mod_map_view.R | 11 +++++------ R/mod_upload.R | 46 +++++++++++++++++++++++++++++++++++++++++++ inst/ext/include.html | 1 - www/include.html | 1 - 5 files changed, 75 insertions(+), 27 deletions(-) delete mode 100644 inst/ext/include.html delete mode 100644 www/include.html diff --git a/R/functions_map.R b/R/functions_map.R index 79e9458..0469142 100644 --- a/R/functions_map.R +++ b/R/functions_map.R @@ -19,23 +19,25 @@ #' #' @return graphic representing selected section of a linkage group #' +#' @import RColorBrewer +#' #' @keywords internal draw_map_shiny<-function(left.lim = 0, right.lim = 5, ch = 1, - maps, ph.p1, ph.p2, d.p1, d.p2, snp.names=TRUE) + maps.dist, ph.p1, ph.p2, d.p1, d.p2, snp.names=TRUE) { par <- lines <- points <- axis <- mtext <- text <- NULL ch <- as.numeric(ch) ploidy <- dim(ph.p1[[1]])[2] # if(is.character(ch)) # ch <- as.numeric(strsplit(ch, split = " ")[[1]][3]) - var.col <- c("#E41A1C", "#377EB8", "#4DAF4A", "#984EA3") - names(var.col) <- c("A", "T", "C", "G") - dark2 <- c("#1B9E77", "#D95F02", "#7570B3", "#E7298A", "#66A61E", "#E6AB02", "#A6761D", "#666666") - d.col<-c(NA, dark2[1:ploidy]) + alleles <- sort(unique(as.vector(unlist(ph.p1[[1]])))) + if(length(alleles) < 3) var.col <- c("#E41A1C", "#377EB8") else var.col <- brewer.pal(length(alleles), "Set1") + names(var.col) <- alleles + if(ploidy < 3) d.col <- c(NA, "#1B9E77", "#D95F02") else d.col<-c(NA, brewer.pal(ploidy, "Dark2")) names(d.col) <- 0:ploidy d.col[1]<-NA - x <- maps[[ch]] - lab <- names(maps[[ch]]) + 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]] @@ -47,10 +49,13 @@ draw_map_shiny<-function(left.lim = 0, right.lim = 5, ch = 1, id.right<-rev(which(x2==min(x2)))[1] par(mai = c(0.5,0.15,0,0)) curx<-x[id.left:id.right] - plot(x = curx, + 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(.25, 4.5), + 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") @@ -59,9 +64,9 @@ draw_map_shiny<-function(left.lim = 0, right.lim = 5, ch = 1, xlab = "", ylab = "", pch = "|", cex=1.5, ylim = c(0,2)) - axis(side = 1) - mtext(text = "Distance (cM)", side = 1, adj = 1) - #Parent 1 + 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") @@ -71,9 +76,9 @@ draw_map_shiny<-function(left.lim = 0, right.lim = 5, ch = 1, pch = 15, cex = 2) } - mtext(text = "Parent 2", side = 2, at = mean(zy), line = -3, font = 4) + mtext(text = "Parent 2", side = 2, at = mean(zy), line = -3, font = 4, padj =1) for(i in 1:ploidy) - mtext(letters[12:7][i], at = zy[i], side = 2, line = -4, font = 1) + 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) @@ -84,7 +89,7 @@ draw_map_shiny<-function(left.lim = 0, right.lim = 5, ch = 1, corners = par("usr") par(xpd = TRUE) text(x = corners[1]+.5, y = mean(zy[ploidy]+0.05+(1:ploidy/20)), "Doses") - #Parent 2 + #Parent 1 zy<-zy+1.1 for(i in 1:ploidy) { @@ -109,10 +114,10 @@ draw_map_shiny<-function(left.lim = 0, right.lim = 5, ch = 1, 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) - # legend("bottomleft", legend=c("A", "T", "C", "G", "-"), - # fill =c(var.col, "white"), - # box.lty=0, bg="transparent") + 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. diff --git a/R/mod_map_view.R b/R/mod_map_view.R index fff7760..eaed30f 100644 --- a/R/mod_map_view.R +++ b/R/mod_map_view.R @@ -119,7 +119,6 @@ mod_map_view_ui <- function(id){ column(12, hr(), plotOutput(ns("plot_map"), height = "500px"), br(), - includeHTML(system.file(package = "viewpoly", "ext/include.html")), br(), br(), box(id = ns("box_phaplo"),width = 12, solidHeader = FALSE, collapsible = TRUE, collapsed = TRUE, status="primary", title = actionLink(inputId = ns("phaploID"), label = "Parents haplotypes table"), DT::dataTableOutput(ns("parents_haplo")) ) @@ -248,7 +247,7 @@ mod_map_view_server <- function(input, output, session, for(i in 1:length(command)) seqs[[i]] <- eval(parse(text = command[i])) - maps <- lapply(loadMap()$maps, function(x) { + maps.dist <- lapply(loadMap()$maps, function(x) { y <- x$l.dist names(y) <- x$mk.names y @@ -256,7 +255,7 @@ mod_map_view_server <- function(input, output, session, max_updated <- map_summary(left.lim = input$range[1], right.lim = input$range[2], - ch = input$group, maps = maps, + ch = input$group, maps = maps.dist, d.p1 = loadMap()$d.p1, d.p2 = loadMap()$d.p2)[[5]] qtls_pos <- Reduce(union, seqs) @@ -339,7 +338,7 @@ mod_map_view_server <- function(input, output, session, validate( need(!is.null(loadMap()$ph.p1), "Upload map information in the upload session to access this feature.") ) - maps <- lapply(loadMap()$maps, function(x) { + maps.dist <- lapply(loadMap()$maps, function(x) { y <- x$l.dist names(y) <- x$mk.names y @@ -349,14 +348,14 @@ mod_map_view_server <- function(input, output, session, ch = input$group, d.p1 = loadMap()$d.p1, d.p2 = loadMap()$d.p2, - maps = maps, + maps.dist = maps.dist, ph.p1 = loadMap()$ph.p1, ph.p2 = loadMap()$ph.p2, snp.names = input$op) max_updated = reactive({ map_summary(left.lim = input$range[1], right.lim = input$range[2], - ch = input$group, maps = maps, + ch = input$group, maps = maps.dist, d.p1 = loadMap()$d.p1, d.p2 = loadMap()$d.p2)[[5]] }) diff --git a/R/mod_upload.R b/R/mod_upload.R index 235dfac..9ce9312 100644 --- a/R/mod_upload.R +++ b/R/mod_upload.R @@ -85,6 +85,18 @@ mod_upload_ui <- function(id){ 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 with OneMap ", + tags$a(href= "https://cristianetaniguti.github.io/htmls/Outcrossing_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)), @@ -321,6 +333,10 @@ mod_upload_server <- function(input, output, session, parent_session){ js$collapse(ns("box_mappoly")) }) + observeEvent(input$onemapID, { + js$collapse(ns("box_onemap")) + }) + observeEvent(input$polymapID, { js$collapse(ns("box_polymap")) }) @@ -436,6 +452,7 @@ mod_upload_server <- function(input, output, session, parent_session){ 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, @@ -451,6 +468,7 @@ mod_upload_server <- function(input, output, session, parent_session){ 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' @@ -469,6 +487,7 @@ mod_upload_server <- function(input, output, session, parent_session){ 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 }) @@ -498,6 +517,11 @@ mod_upload_server <- function(input, output, session, parent_session){ 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 @@ -539,6 +563,7 @@ mod_upload_server <- function(input, output, session, parent_session){ 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) @@ -549,6 +574,11 @@ mod_upload_server <- function(input, output, session, parent_session){ 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"), @@ -687,6 +717,7 @@ mod_upload_server <- function(input, output, session, parent_session){ 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) & @@ -785,6 +816,18 @@ mod_upload_server <- function(input, output, session, parent_session){ } 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))) { @@ -969,6 +1012,7 @@ mod_upload_server <- function(input, output, session, parent_session){ 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") @@ -979,6 +1023,8 @@ mod_upload_server <- function(input, output, session, parent_session){ 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())){ diff --git a/inst/ext/include.html b/inst/ext/include.html deleted file mode 100644 index bf76d20..0000000 --- a/inst/ext/include.html +++ /dev/null @@ -1 +0,0 @@ -

diff --git a/www/include.html b/www/include.html deleted file mode 100644 index bf76d20..0000000 --- a/www/include.html +++ /dev/null @@ -1 +0,0 @@ -

From 4a620c503368b8a189c9deb157414d8c63f00704 Mon Sep 17 00:00:00 2001 From: Cristianetaniguti Date: Sun, 17 Dec 2023 17:05:33 -0600 Subject: [PATCH 02/14] all marker types --- DESCRIPTION | 4 +- R/functions_map.R | 143 +++++++--- R/mod_map_view.R | 19 +- R/mod_upload.R | 6 +- man/draw_map_shiny.Rd | 9 +- man/summary_maps.Rd | 4 +- .../_snaps/tetra_example/effects-bar.svg | 124 --------- .../_snaps/tetra_example/effects-circle.svg | 84 ------ .../_snaps/tetra_example/effects-digenic.svg | 126 --------- .../_snaps/tetra_example/qtl-plot.svg | 75 ------ tests/testthat/test-MAPpoly.R | 4 +- tests/testthat/test-polymapR.R | 2 +- tests/testthat/test-tetra_example.R | 246 +++++++++--------- 13 files changed, 249 insertions(+), 597 deletions(-) delete mode 100644 tests/testthat/_snaps/tetra_example/effects-bar.svg delete mode 100644 tests/testthat/_snaps/tetra_example/effects-circle.svg delete mode 100644 tests/testthat/_snaps/tetra_example/effects-digenic.svg delete mode 100644 tests/testthat/_snaps/tetra_example/qtl-plot.svg diff --git a/DESCRIPTION b/DESCRIPTION index d348a95..c6b5dbd 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: viewpoly Title: A Shiny App to Visualize Genetic Maps and QTL Analysis in Polyploid Species -Version: 0.4.0 +Version: 0.4.1 Authors@R: c( person(given = "Cristiane", family = "Taniguti", @@ -72,7 +72,7 @@ URL: https://github.com/mmollina/viewpoly BugReports: https://github.com/mmollina/viewpoly/issues Encoding: UTF-8 LazyData: true -RoxygenNote: 7.1.2 +RoxygenNote: 7.2.3 Suggests: testthat (>= 3.0.0), shinytest, diff --git a/R/functions_map.R b/R/functions_map.R index 0469142..7e666bb 100644 --- a/R/functions_map.R +++ b/R/functions_map.R @@ -16,24 +16,32 @@ #' 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 #' -#' @import RColorBrewer -#' #' @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) + 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]) - alleles <- sort(unique(as.vector(unlist(ph.p1[[1]])))) - if(length(alleles) < 3) var.col <- c("#E41A1C", "#377EB8") else var.col <- brewer.pal(length(alleles), "Set1") + 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, brewer.pal(ploidy, "Dark2")) + + 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]] @@ -82,10 +90,12 @@ draw_map_shiny<-function(left.lim = 0, right.lim = 5, ch = 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) - 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) + 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") @@ -101,10 +111,12 @@ draw_map_shiny<-function(left.lim = 0, right.lim = 5, ch = 1, cex = 2) } mtext(text = "Parent 1", side = 2, at = mean(zy), line = -3, font = 4) - 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) + 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") @@ -171,6 +183,7 @@ map_summary<-function(left.lim = 0, right.lim = 5, ch = 1, #' 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 #' @@ -179,37 +192,83 @@ map_summary<-function(left.lim = 0, right.lim = 5, ch = 1, #' #' #' @keywords internal -summary_maps = function(viewmap){ - - 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) +summary_maps = function(viewmap, software = NULL){ max_gap <- sapply(viewmap$maps, function(x) max(diff(x$l.dist))) - 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))) + 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) } diff --git a/R/mod_map_view.R b/R/mod_map_view.R index eaed30f..e23a176 100644 --- a/R/mod_map_view.R +++ b/R/mod_map_view.R @@ -253,10 +253,8 @@ mod_map_view_server <- function(input, output, session, y }) - max_updated <- map_summary(left.lim = input$range[1], - right.lim = input$range[2], - ch = input$group, maps = maps.dist, - d.p1 = loadMap()$d.p1, d.p2 = loadMap()$d.p2)[[5]] + ch <- as.numeric(input$group) + max_updated <- as.numeric(maps.dist[[ch]][length(maps.dist[[ch]])]) qtls_pos <- Reduce(union, seqs) chr_all <- 0:max_updated @@ -351,13 +349,12 @@ mod_map_view_server <- function(input, output, session, maps.dist = maps.dist, ph.p1 = loadMap()$ph.p1, ph.p2 = loadMap()$ph.p2, - snp.names = input$op) + snp.names = input$op, software = loadMap()$software) max_updated = reactive({ - map_summary(left.lim = input$range[1], right.lim = input$range[2], - ch = input$group, maps = maps.dist, - d.p1 = loadMap()$d.p1, - d.p2 = loadMap()$d.p2)[[5]] + + ch <- as.numeric(input$group) + as.numeric(maps.dist[[ch]][length(maps.dist[[ch]])]) }) observeEvent(max_updated, { @@ -392,7 +389,7 @@ mod_map_view_server <- function(input, output, session, validate( need(!is.null(loadMap()$ph.p1), "Upload map information in the upload session to access this feature.") ) - summary <- summary_maps(loadMap()) + summary <- summary_maps(loadMap(), loadMap()$software) DT::datatable(summary, extensions = 'Buttons', options = list( scrollX = TRUE, @@ -499,7 +496,7 @@ mod_map_view_server <- function(input, output, session, maps = maps, ph.p1 = loadMap()$ph.p1, ph.p2 = loadMap()$ph.p2, - snp.names = input$op) + snp.names = input$op, software = loadMap()$software) dev.off() } diff --git a/R/mod_upload.R b/R/mod_upload.R index 9ce9312..d10cd20 100644 --- a/R/mod_upload.R +++ b/R/mod_upload.R @@ -86,8 +86,10 @@ mod_upload_ui <- function(id){ 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 with OneMap ", - tags$a(href= "https://cristianetaniguti.github.io/htmls/Outcrossing_Populations.html","here")), br(), + 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(), diff --git a/man/draw_map_shiny.Rd b/man/draw_map_shiny.Rd index d8c4f25..c95b3ee 100644 --- a/man/draw_map_shiny.Rd +++ b/man/draw_map_shiny.Rd @@ -9,12 +9,13 @@ draw_map_shiny( left.lim = 0, right.lim = 5, ch = 1, - maps, + maps.dist, ph.p1, ph.p2, d.p1, d.p2, - snp.names = TRUE + snp.names = TRUE, + software ) } \arguments{ @@ -22,8 +23,6 @@ draw_map_shiny( \item{ch}{linkage group ID} -\item{maps}{list containing a vector for each linkage group markers with marker positions (named with marker names)} - \item{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} @@ -40,6 +39,8 @@ draw_map_shiny( \item{snp.names}{logical TRUE/FALSE. If TRUE it includes the marker names in the plot} \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{ graphic representing selected section of a linkage group diff --git a/man/summary_maps.Rd b/man/summary_maps.Rd index 6069265..c9762ed 100644 --- a/man/summary_maps.Rd +++ b/man/summary_maps.Rd @@ -4,10 +4,12 @@ \alias{summary_maps} \title{Summary maps - adapted from MAPpoly} \usage{ -summary_maps(viewmap) +summary_maps(viewmap, software) } \arguments{ \item{viewmap}{a list of objects of class \code{viewmap}} + +\item{software}{character defined from each software it comes from} } \value{ a data frame containing a brief summary of all maps diff --git a/tests/testthat/_snaps/tetra_example/effects-bar.svg b/tests/testthat/_snaps/tetra_example/effects-bar.svg deleted file mode 100644 index 6a440fb..0000000 --- a/tests/testthat/_snaps/tetra_example/effects-bar.svg +++ /dev/null @@ -1,124 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -P1 - - - - - - - - - -P2 - - -P1.1 -P1.2 -P1.3 -P1.4 -P2.1 -P2.2 -P2.3 -P2.4 --1e-03 --5e-04 -0e+00 -5e-04 -1e-03 -Alleles -Estimates -LG: 2 Pos: 77 -SG06 - - diff --git a/tests/testthat/_snaps/tetra_example/effects-circle.svg b/tests/testthat/_snaps/tetra_example/effects-circle.svg deleted file mode 100644 index c2a8e67..0000000 --- a/tests/testthat/_snaps/tetra_example/effects-circle.svg +++ /dev/null @@ -1,84 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - --1 -0 -1 -P1.1 -P1.2 -P1.3 -P1.4 -P2.1 -P2.2 -P2.3 -P2.4 - - - - - - - -SG06/ LG:2/ Pos:77 -LG2 - - diff --git a/tests/testthat/_snaps/tetra_example/effects-digenic.svg b/tests/testthat/_snaps/tetra_example/effects-digenic.svg deleted file mode 100644 index ef70c2d..0000000 --- a/tests/testthat/_snaps/tetra_example/effects-digenic.svg +++ /dev/null @@ -1,126 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -P1.1 -P1.2 -P1.3 -P1.4 -P2.1 -P2.2 -P2.3 - - - - - - - - - - - - - - -P1.2 -P1.3 -P1.4 -P2.1 -P2.2 -P2.3 -P2.4 - - --0.001 -0.000 -0.001 - - - - - - -LG: 2 Pos: 77 -Trait: SG06 - - diff --git a/tests/testthat/_snaps/tetra_example/qtl-plot.svg b/tests/testthat/_snaps/tetra_example/qtl-plot.svg deleted file mode 100644 index d504377..0000000 --- a/tests/testthat/_snaps/tetra_example/qtl-plot.svg +++ /dev/null @@ -1,75 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -2 - - - - - - -0 -50 -100 - -1 -3 - - -Position (cM) -− -l -o -g -10 -( -P -) - -Trait - - -SG06 -Linkage group -qtl plot - - diff --git a/tests/testthat/test-MAPpoly.R b/tests/testthat/test-MAPpoly.R index b5cbbdd..12f25c1 100644 --- a/tests/testthat/test-MAPpoly.R +++ b/tests/testthat/test-MAPpoly.R @@ -29,10 +29,10 @@ test_that("Tests uploaded MAPpoly files",{ ch = 3, maps = maps, d.p1 = viewmap_mappoly$d.p1, - d.p2 = viewmap_mappoly$d.p2)[[5]], 134.073, tolerance = 0.0001) + d.p2 = viewmap_mappoly$d.p2)[[5]], 134.073, tolerance = 0.0001, ) # Map summary table - summary_table <- summary_maps(viewmap_mappoly) + summary_table <- summary_maps(viewmap_mappoly, 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) diff --git a/tests/testthat/test-polymapR.R b/tests/testthat/test-polymapR.R index b1ac063..71cf186 100644 --- a/tests/testthat/test-polymapR.R +++ b/tests/testthat/test-polymapR.R @@ -35,7 +35,7 @@ test_that("Tests uploaded polymapR files",{ d.p2 = viewmap_polymapr$d.p2)[[5]], 96.15, tolerance = 0.0001) # Map summary table - summary_table <- summary_maps(viewmap_polymapr) + summary_table <- summary_maps(viewmap_polymapr, software = "mappoly") expect_equal(sum(as.numeric(summary_table$`Map length (cM)`)), 2317.84) expect_equal(sum(as.numeric(summary_table$Simplex)), 2028) expect_equal(sum(as.numeric(summary_table$`Double-simplex`)), 802) diff --git a/tests/testthat/test-tetra_example.R b/tests/testthat/test-tetra_example.R index 3856c31..f958c7e 100644 --- a/tests/testthat/test-tetra_example.R +++ b/tests/testthat/test-tetra_example.R @@ -3,14 +3,14 @@ test_that("tetra example",{ # upload examples viewpoly_obj <- viewpoly:::prepare_examples("tetra_map") - + expect_equal(viewpoly:::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, @@ -19,201 +19,201 @@ test_that("tetra example",{ 0.000160791, 2.340129e-12, 1) - + # VIEWmap tests qtl_profile_plot <- viewpoly:::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) - + 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", viewpoly:::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)) - - vdiffr::expect_doppelganger("linkage map draw names", viewpoly:::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)) - + + 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", viewpoly:::plot_map_list(viewpoly_obj$map)) - + # Get max size each chromosome expect_equal(viewpoly:::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) - + 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 <- viewpoly:::summary_maps(viewpoly_obj$map) + 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", viewpoly:::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 <- viewpoly:::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 <- viewpoly:::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) - + 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 <- viewpoly:::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) - + 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 <- viewpoly:::only_plot_profile(qtl_profile_data) expect_equal(sum(p$data$SIG), 292.883, tolerance = 0.001) - + # effects graphics p <- viewpoly:::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") - + effects = viewpoly_obj$qtl$effects, + pheno.col = "SG06", + lgs = 2, + groups = 2, + position = 77, + software = "QTLpoly", + design = "circle") + vdiffr::expect_doppelganger("effects circle", viewpoly:::plot_effects(data_effects.obj = p, - software = "QTLpoly", - design = "circle")) - + 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 <- viewpoly:::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") - + 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", viewpoly:::plot_effects(p, "QTLpoly", "digenic")) - + p <- viewpoly:::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") - + 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", viewpoly:::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 <- viewpoly:::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) - + 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 <- viewpoly:::calc_homologprob(probs = viewpoly_obj$qtl$probs, - viewpoly_obj$qtl$selected_mks, - 1:5) - + 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 <- viewpoly:::select_haplo(input.haplo, - viewpoly_obj$qtl$probs, - viewpoly_obj$qtl$selected_mks, - effects.data = p) + 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 <- viewpoly:::plot_cm_mb(viewpoly_obj$map, 1, 1,50) - + expect_equal(sum(p$data$l.dist), 50502.07, tolerance = 0.001) - + }) From 37deebc02b304781c9d06715363ffd2ac4b87bee Mon Sep 17 00:00:00 2001 From: Cristianetaniguti Date: Sun, 17 Dec 2023 17:24:38 -0600 Subject: [PATCH 03/14] fix tests --- .github/workflows/check-standard.yml | 4 +- R/mod_map_view.R | 2 +- .../_snaps/tetra_example/effects-bar.svg | 124 + .../_snaps/tetra_example/effects-circle.svg | 84 + .../_snaps/tetra_example/effects-digenic.svg | 126 + .../tetra_example/linkage-map-draw-names.svg | 2341 +++++++++-------- .../_snaps/tetra_example/linkage-map-draw.svg | 2165 +++++++-------- .../_snaps/tetra_example/qtl-plot.svg | 75 + 8 files changed, 2676 insertions(+), 2245 deletions(-) create mode 100644 tests/testthat/_snaps/tetra_example/effects-bar.svg create mode 100644 tests/testthat/_snaps/tetra_example/effects-circle.svg create mode 100644 tests/testthat/_snaps/tetra_example/effects-digenic.svg create mode 100644 tests/testthat/_snaps/tetra_example/qtl-plot.svg diff --git a/.github/workflows/check-standard.yml b/.github/workflows/check-standard.yml index 3cc24bd..5bf79c9 100644 --- a/.github/workflows/check-standard.yml +++ b/.github/workflows/check-standard.yml @@ -42,11 +42,11 @@ jobs: - uses: actions/checkout@v2 - - uses: r-lib/actions/setup-r@v1 + - uses: r-lib/actions/setup-r@v2 with: r-version: ${{ matrix.config.r }} - - uses: r-lib/actions/setup-pandoc@v1 + - uses: r-lib/actions/setup-pandoc@v2 - name: Query dependencies run: | diff --git a/R/mod_map_view.R b/R/mod_map_view.R index e23a176..1f50938 100644 --- a/R/mod_map_view.R +++ b/R/mod_map_view.R @@ -493,7 +493,7 @@ mod_map_view_server <- function(input, output, session, ch = input$group, d.p1 = loadMap()$d.p1, d.p2 = loadMap()$d.p2, - maps = maps, + maps.dist = maps, ph.p1 = loadMap()$ph.p1, ph.p2 = loadMap()$ph.p2, snp.names = input$op, software = loadMap()$software) diff --git a/tests/testthat/_snaps/tetra_example/effects-bar.svg b/tests/testthat/_snaps/tetra_example/effects-bar.svg new file mode 100644 index 0000000..57ca226 --- /dev/null +++ b/tests/testthat/_snaps/tetra_example/effects-bar.svg @@ -0,0 +1,124 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +P1 + + + + + + + + + +P2 + + +P1.1 +P1.2 +P1.3 +P1.4 +P2.1 +P2.2 +P2.3 +P2.4 +-1e-03 +-5e-04 +0e+00 +5e-04 +1e-03 +Alleles +Estimates +LG: 2 Pos: 77 +SG06 + + diff --git a/tests/testthat/_snaps/tetra_example/effects-circle.svg b/tests/testthat/_snaps/tetra_example/effects-circle.svg new file mode 100644 index 0000000..8f135c7 --- /dev/null +++ b/tests/testthat/_snaps/tetra_example/effects-circle.svg @@ -0,0 +1,84 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-1 +0 +1 +P1.1 +P1.2 +P1.3 +P1.4 +P2.1 +P2.2 +P2.3 +P2.4 + + + + + + + +SG06/ LG:2/ Pos:77 +LG2 + + diff --git a/tests/testthat/_snaps/tetra_example/effects-digenic.svg b/tests/testthat/_snaps/tetra_example/effects-digenic.svg new file mode 100644 index 0000000..c2433ea --- /dev/null +++ b/tests/testthat/_snaps/tetra_example/effects-digenic.svg @@ -0,0 +1,126 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +P1.1 +P1.2 +P1.3 +P1.4 +P2.1 +P2.2 +P2.3 + + + + + + + + + + + + + + +P1.2 +P1.3 +P1.4 +P2.1 +P2.2 +P2.3 +P2.4 + + +-0.001 +0.000 +0.001 + + + + + + +LG: 2 Pos: 77 +Trait: SG06 + + diff --git a/tests/testthat/_snaps/tetra_example/linkage-map-draw-names.svg b/tests/testthat/_snaps/tetra_example/linkage-map-draw-names.svg index d6dc066..bfc711b 100644 --- a/tests/testthat/_snaps/tetra_example/linkage-map-draw-names.svg +++ b/tests/testthat/_snaps/tetra_example/linkage-map-draw-names.svg @@ -18,7 +18,7 @@ -curx +exten rep(0.5, length(curx)) @@ -27,1179 +27,1190 @@ - -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| + +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| - - - - - - - -0 -10 -20 -30 -40 -50 -Distance (cM) + + + + + + + +0 +10 +20 +30 +40 +50 +Distance (cM) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -Parent 2 -l -k -j -i +Parent 2 +h +g +f +e - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -Doses - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Parent 1 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Doses -c1_10915 -c2_36642 -c2_36660 -c2_36664 -c2_36668 -c2_36672 -c2_54804 -c2_54797 -c2_56714 -c2_6839 -c2_6906 -c2_6683 -c2_6684 -c2_6713 -c2_21097 -c2_21098 -c2_21100 -c1_6668 -c1_6674 -c2_21227 -c2_21233 -c1_6704 -c2_21236 -c2_21247 -c1_6123 -c1_6109 -c2_19261 -c1_6087 -c1_6083 -c1_6077 -c2_19420 -c2_51812 -c2_51811 -c2_51810 -c2_51806 -c2_51804 -c2_51803 -c2_51800 -c2_51797 -c2_51791 -c2_49938 -c2_49937 -c2_49935 -c2_56594 -c2_48051 -c2_48048 -c1_14211 -c2_56125 -c1_13304 -c2_45071 -c1_13318 -c2_45056 -c2_45061 -c2_45064 -c1_13289 -c1_13293 -c2_27876 -c2_27877 -c2_27878 -c2_27879 -c2_27880 -c2_27881 -c2_27882 -c2_27885 -c2_27887 -c1_8606 -c2_27893 -c2_27900 -c2_27899 -c2_27894 -c2_27918 -c2_53845 -c2_48155 -c2_48154 -c2_50011 -c2_50013 -c2_38354 -c2_52715 -c2_52709 -c2_52705 -c2_52704 -c1_12858 -c2_56359 -c1_16515 -c2_57284 -c2_45626 -c2_45637 -c2_51600 -d -c -b -a +Doses + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Parent 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Doses +c1_10915 +c2_36642 +c2_36660 +c2_36664 +c2_36668 +c2_36672 +c2_54804 +c2_54797 +c2_56714 +c2_6839 +c2_6906 +c2_6683 +c2_6684 +c2_6713 +c2_21097 +c2_21098 +c2_21100 +c1_6668 +c1_6674 +c2_21227 +c2_21233 +c1_6704 +c2_21236 +c2_21247 +c1_6123 +c1_6109 +c2_19261 +c1_6087 +c1_6083 +c1_6077 +c2_19420 +c2_51812 +c2_51811 +c2_51810 +c2_51806 +c2_51804 +c2_51803 +c2_51800 +c2_51797 +c2_51791 +c2_49938 +c2_49937 +c2_49935 +c2_56594 +c2_48051 +c2_48048 +c1_14211 +c2_56125 +c1_13304 +c2_45071 +c1_13318 +c2_45056 +c2_45061 +c2_45064 +c1_13289 +c1_13293 +c2_27876 +c2_27877 +c2_27878 +c2_27879 +c2_27880 +c2_27881 +c2_27882 +c2_27885 +c2_27887 +c1_8606 +c2_27893 +c2_27900 +c2_27899 +c2_27894 +c2_27918 +c2_53845 +c2_48155 +c2_48154 +c2_50011 +c2_50013 +c2_38354 +c2_52715 +c2_52709 +c2_52705 +c2_52704 +c1_12858 +c2_56359 +c1_16515 +c2_57284 +c2_45626 +c2_45637 +c2_51600 +d +c +b +a + + + + + + +C +G +T +A +- diff --git a/tests/testthat/_snaps/tetra_example/linkage-map-draw.svg b/tests/testthat/_snaps/tetra_example/linkage-map-draw.svg index 4ac5781..3048632 100644 --- a/tests/testthat/_snaps/tetra_example/linkage-map-draw.svg +++ b/tests/testthat/_snaps/tetra_example/linkage-map-draw.svg @@ -18,7 +18,7 @@ -curx +exten rep(0.5, length(curx)) @@ -27,1091 +27,1102 @@ - -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| -| + +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| +| - - - - - - - -0 -10 -20 -30 -40 -50 -Distance (cM) + + + + + + + +0 +10 +20 +30 +40 +50 +Distance (cM) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -Parent 2 -l -k -j -i +Parent 2 +h +g +f +e - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -Doses - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Parent 1 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Doses -d -c -b -a +Doses + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Parent 1 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +Doses +d +c +b +a + + + + + + +C +G +T +A +- diff --git a/tests/testthat/_snaps/tetra_example/qtl-plot.svg b/tests/testthat/_snaps/tetra_example/qtl-plot.svg new file mode 100644 index 0000000..253422e --- /dev/null +++ b/tests/testthat/_snaps/tetra_example/qtl-plot.svg @@ -0,0 +1,75 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +2 + + + + + + +0 +50 +100 + +1 +3 + + +Position (cM) +− +l +o +g +10 +( +P +) + +Trait + + +SG06 +Linkage group +qtl plot + + From 11e60bf20466fc998937c3d8ba82ac378ab41cdd Mon Sep 17 00:00:00 2001 From: Cristianetaniguti Date: Sun, 17 Dec 2023 18:24:16 -0600 Subject: [PATCH 04/14] disable autoload --- R/functions_qtl.R | 4 ++-- app.R | 2 +- tests/testthat/test-tetra_example.R | 14 +++++++------- 3 files changed, 10 insertions(+), 10 deletions(-) diff --git a/R/functions_qtl.R b/R/functions_qtl.R index 2052368..a2268fd 100644 --- a/R/functions_qtl.R +++ b/R/functions_qtl.R @@ -790,7 +790,7 @@ select_haplo <- function(input.haplo,probs, selected_mks, effects.data, exclude. homoprob_temp <- homoprob_temp[order(homoprob_temp$individual, homoprob_temp$homolog),] homoprob_temp <- homoprob_temp %>% group_by(map.position, LG, individual) %>% - summarise(best = which(probability > 0.5)) + reframe(best = which(probability > 0.5)) like.ind <- homoprob_temp$individual[which(homoprob_temp$best %in% idx)] if(length(like.ind) ==0) like.ind <- NA like.ind.all[[i]] <- like.ind @@ -816,7 +816,7 @@ select_haplo <- function(input.haplo,probs, selected_mks, effects.data, exclude. homoprob_temp <- homoprob_temp[order(homoprob_temp$individual, homoprob_temp$homolog),] homoprob_temp <- homoprob_temp %>% group_by(map.position, LG, individual) %>% - summarise(best = which(probability > 0.5)) + reframe(best = which(probability > 0.5)) like.ind <- homoprob_temp$individual[which(homoprob_temp$best %in% idx)] if(length(like.ind) ==0) like.ind <- NA like.ind.all[[i]] <- like.ind diff --git a/app.R b/app.R index b17f8a4..65a1a4f 100644 --- a/app.R +++ b/app.R @@ -3,5 +3,5 @@ # Or use the blue button on top of this file pkgload::load_all(export_all = FALSE,helpers = FALSE,attach_testthat = FALSE) -options( "golem.app.prod" = TRUE) +options( "golem.app.prod" = TRUE, shiny.autoload.r = FALSE) viewpoly::run_app() # add parameters here (if any) diff --git a/tests/testthat/test-tetra_example.R b/tests/testthat/test-tetra_example.R index f958c7e..125e74b 100644 --- a/tests/testthat/test-tetra_example.R +++ b/tests/testthat/test-tetra_example.R @@ -193,17 +193,17 @@ test_that("tetra example",{ expect_equal(sum(breed.values$SG06), 5.36) # get and plot homologs prob - data.prob <- viewpoly:::calc_homologprob(probs = viewpoly_obj$qtl$probs, - viewpoly_obj$qtl$selected_mks, - 1:5) + 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 <- viewpoly:::select_haplo(input.haplo, - viewpoly_obj$qtl$probs, - viewpoly_obj$qtl$selected_mks, - effects.data = p) + 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) From 4ac217535370c00a39e29e0ab2226dba85f2b83b Mon Sep 17 00:00:00 2001 From: Cristianetaniguti Date: Sun, 17 Dec 2023 22:31:59 -0600 Subject: [PATCH 05/14] change config --- .github/workflows/R-CMD-chek.yaml | 58 +++++++++++++++ .github/workflows/check-standard.yml | 102 --------------------------- .github/workflows/test-coverage.yaml | 36 ++++++++++ .gitignore | 1 - 4 files changed, 94 insertions(+), 103 deletions(-) create mode 100644 .github/workflows/R-CMD-chek.yaml delete mode 100644 .github/workflows/check-standard.yml create mode 100644 .github/workflows/test-coverage.yaml diff --git a/.github/workflows/R-CMD-chek.yaml b/.github/workflows/R-CMD-chek.yaml new file mode 100644 index 0000000..547cbd9 --- /dev/null +++ b/.github/workflows/R-CMD-chek.yaml @@ -0,0 +1,58 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/master/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: [main, add_hidecan] + pull_request: + branches: [main, add_hidecan] + +name: R-CMD-check + +jobs: + R-CMD-check: + runs-on: ${{ matrix.config.os }} + + name: ${{ matrix.config.os }} (${{ matrix.config.r }}) + + strategy: + fail-fast: false + matrix: + config: + - {os: macOS-latest, r: 'release'} + - {os: windows-latest, r: 'release'} + - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} + - {os: ubuntu-latest, r: 'release'} + - {os: ubuntu-latest, r: 'oldrel-1'} + + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + R_KEEP_PKG_SOURCE: yes + + steps: + - uses: actions/checkout@v2 + + - uses: r-lib/actions/setup-pandoc@v2 + + - uses: r-lib/actions/setup-r@v2 + with: + r-version: ${{ matrix.config.r }} + http-user-agent: ${{ matrix.config.http-user-agent }} + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: rcmdcheck curl vdiffr + + - uses: r-lib/actions/check-r-package@v2 + + - name: Show testthat output + if: always() + run: find check -name 'testthat.Rout*' -exec cat '{}' \; || true + shell: bash + + - name: Upload check results + if: failure() + uses: actions/upload-artifact@main + with: + name: ${{ runner.os }}-r${{ matrix.config.r }}-results + path: check \ No newline at end of file diff --git a/.github/workflows/check-standard.yml b/.github/workflows/check-standard.yml deleted file mode 100644 index 5bf79c9..0000000 --- a/.github/workflows/check-standard.yml +++ /dev/null @@ -1,102 +0,0 @@ -# For help debugging build failures open an issue on the RStudio community with the 'github-actions' tag. -# https://community.rstudio.com/new-topic?category=Package%20development&tags=github-actions -on: - push: - branches: - - main - - add_hidecan - - pull_request: - branches: - - main - - add_hidecan - -name: R-CMD-check - -jobs: - R-CMD-check: - runs-on: ${{ matrix.config.os }} - - name: ${{ matrix.config.os }} (${{ matrix.config.r }}) - - strategy: - fail-fast: false - matrix: - config: - - {os: windows-latest, r: 'release'} - - {os: macOS-latest, r: 'release'} - - {os: ubuntu-20.04, r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"} - - {os: ubuntu-20.04, r: 'devel', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest", http-user-agent: "R/4.1.0 (ubuntu-20.04) R (4.1.0 x86_64-pc-linux-gnu x86_64 linux-gnu) on GitHub Actions" } - - env: - R_REMOTES_NO_ERRORS_FROM_WARNINGS: true - RSPM: ${{ matrix.config.rspm }} - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - - steps: - # do not convert line feeds in windows - - name: Windows git setup - if: runner.os == 'Windows' - run: - git config --global core.autocrlf false - - - uses: actions/checkout@v2 - - - uses: r-lib/actions/setup-r@v2 - with: - r-version: ${{ matrix.config.r }} - - - uses: r-lib/actions/setup-pandoc@v2 - - - name: Query dependencies - run: | - install.packages('remotes') - saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2) - writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") - shell: Rscript {0} - - - name: Restore R package cache - uses: actions/cache@v2 - with: - path: ${{ env.R_LIBS_USER }} - key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} - restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- - - - name: Install system dependencies - if: runner.os == 'Linux' - run: | - while read -r cmd - do - eval sudo $cmd - done < <(Rscript -e 'writeLines(remotes::system_requirements("ubuntu", "20.04"))') - - name: Install dependencies - run: | - remotes::install_deps(dependencies = TRUE) - remotes::install_cran("curl") - remotes::install_cran("rcmdcheck") - remotes::install_cran("covr") - remotes::install_cran("webshot") - remotes::install_cran("vdiffr") - webshot::install_phantomjs() - webdriver::run_phantomjs(timeout = 15000) - shell: Rscript {0} - - - name: Check - env: - _R_CHECK_CRAN_INCOMING_REMOTE_: false - _R_CHECK_FORCE_SUGGESTS_: false - run: | - options(crayon.enabled = TRUE) - rcmdcheck::rcmdcheck(args = c("--no-manual", "--as-cran"), error_on = "error", check_dir = "check") - shell: Rscript {0} - - - name: Upload check results - if: failure() - uses: actions/upload-artifact@main - with: - name: ${{ runner.os }}-r${{ matrix.config.r }}-results - path: check - - - name: Test coverage - run: covr::codecov() - shell: Rscript {0} \ No newline at end of file diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml new file mode 100644 index 0000000..538c1f5 --- /dev/null +++ b/.github/workflows/test-coverage.yaml @@ -0,0 +1,36 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/master/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: [main, add_hidecan] + pull_request: + branches: [main, add_hidecan] + +name: test-coverage + +jobs: + test-coverage: + runs-on: ubuntu-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + + steps: + - uses: actions/checkout@v2 + + - uses: r-lib/actions/setup-pandoc@v2 + + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - uses: r-lib/actions/setup-renv@v2 + with: + extra-packages: covr + + - name: Install viewpoly + shell: bash + run: R CMD INSTALL --preclean . + + - name: Test coverage + run: covr::codecov() + shell: Rscript {0} \ No newline at end of file diff --git a/.gitignore b/.gitignore index 769beae..ff61d57 100644 --- a/.gitignore +++ b/.gitignore @@ -19,7 +19,6 @@ # RStudio files .Rproj.user/ -.github/ # produced vignettes vignettes/*.html From e48dfd5818b4da5ac1ee93ca7a26d24680b67848 Mon Sep 17 00:00:00 2001 From: Cristianetaniguti Date: Mon, 18 Dec 2023 10:59:59 -0600 Subject: [PATCH 06/14] increase timeout --- .github/workflows/test-coverage.yaml | 2 +- R/functions_qtl.R | 6 ++--- tests/testthat/test-MAPpoly.R | 3 ++- tests/testthat/test-QTLpoly.R | 1 + tests/testthat/test-diaQTL.R | 1 + tests/testthat/test-polymapR.R | 1 + tests/testthat/test-polyqtlR.R | 1 + tests/testthat/test-tetra_example.R | 34 ++++++++++++++-------------- 8 files changed, 27 insertions(+), 22 deletions(-) diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml index 538c1f5..bfab625 100644 --- a/.github/workflows/test-coverage.yaml +++ b/.github/workflows/test-coverage.yaml @@ -23,7 +23,7 @@ jobs: with: use-public-rspm: true - - uses: r-lib/actions/setup-renv@v2 + - uses: r-lib/actions/setup-r-dependencies@v2 with: extra-packages: covr diff --git a/R/functions_qtl.R b/R/functions_qtl.R index a2268fd..eebcb61 100644 --- a/R/functions_qtl.R +++ b/R/functions_qtl.R @@ -195,7 +195,7 @@ only_plot_profile <- function(pl.in){ 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", size=.5, alpha=0.8, na.rm = TRUE)} + #threshold + {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)) + @@ -466,9 +466,9 @@ data_effects <- function(qtl_info, effects, pheno.col = NULL, 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), size = 5) + + 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", size=.5, alpha=0.8, na.rm = TRUE)} + + {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)) + diff --git a/tests/testthat/test-MAPpoly.R b/tests/testthat/test-MAPpoly.R index 12f25c1..82660c4 100644 --- a/tests/testthat/test-MAPpoly.R +++ b/tests/testthat/test-MAPpoly.R @@ -4,6 +4,7 @@ test_that("Tests uploaded MAPpoly files",{ # upload MAPpoly temp <- tempfile() if(havingIP()){ + options(timeout=200) download.file("https://www.polyploids.org/sites/default/files/2022-04/tetra_MAPpoly_maps.RData", destfile = temp) temp.name <- load(temp) input.data <- get(temp.name) @@ -29,7 +30,7 @@ test_that("Tests uploaded MAPpoly files",{ ch = 3, maps = maps, d.p1 = viewmap_mappoly$d.p1, - d.p2 = viewmap_mappoly$d.p2)[[5]], 134.073, tolerance = 0.0001, ) + d.p2 = viewmap_mappoly$d.p2)[[5]], 134.073, tolerance = 0.0001) # Map summary table summary_table <- summary_maps(viewmap_mappoly, software = "mappoly") diff --git a/tests/testthat/test-QTLpoly.R b/tests/testthat/test-QTLpoly.R index d45c777..a33fdb4 100644 --- a/tests/testthat/test-QTLpoly.R +++ b/tests/testthat/test-QTLpoly.R @@ -9,6 +9,7 @@ test_that("Tests uploaded QTLpoly files",{ fitted.mod$datapath <- tempfile() if(havingIP()){ + options(timeout=200) download.file("https://www.polyploids.org/sites/default/files/2022-04/tetra_QTLpoly_effects.RData", destfile = est.effects$datapath) download.file("https://www.polyploids.org/sites/default/files/2022-04/tetra_QTLpoly_data.RData", destfile = input.data$datapath) download.file("https://www.polyploids.org/sites/default/files/2022-04/tetra_QTLpoly_remim.RData", destfile = remim.mod$datapath) diff --git a/tests/testthat/test-diaQTL.R b/tests/testthat/test-diaQTL.R index c7ec233..9b95914 100644 --- a/tests/testthat/test-diaQTL.R +++ b/tests/testthat/test-diaQTL.R @@ -9,6 +9,7 @@ test_that("Tests uploaded diaQTL files",{ BayesCI_list_temp$datapath <- tempfile() if(havingIP()){ + options(timeout=200) download.file("https://www.polyploids.org/sites/default/files/2022-04/tetra_diaQTL_BayesCI_list_0.RData", destfile = BayesCI_list_temp$datapath) download.file("https://www.polyploids.org/sites/default/files/2022-04/tetra_diaQTL_scan1_list.RData", destfile = scan1_list$datapath) download.file("https://www.polyploids.org/sites/default/files/2022-04/tetra_diaQTL_scan1_summaries_list.RData", destfile = scan1_summaries_list$datapath) diff --git a/tests/testthat/test-polymapR.R b/tests/testthat/test-polymapR.R index 71cf186..d993831 100644 --- a/tests/testthat/test-polymapR.R +++ b/tests/testthat/test-polymapR.R @@ -7,6 +7,7 @@ test_that("Tests uploaded polymapR files",{ polymapR.map$datapath <- tempfile() if(havingIP()){ + options(timeout=200) download.file("https://www.polyploids.org/sites/default/files/2022-04/tetra_polymapR_dataset.RData", destfile = input.data$datapath) download.file("https://www.polyploids.org/sites/default/files/2022-04/tetra_polymapR_map.RData", destfile = polymapR.map$datapath) diff --git a/tests/testthat/test-polyqtlR.R b/tests/testthat/test-polyqtlR.R index 93ef3af..4b96dd4 100644 --- a/tests/testthat/test-polyqtlR.R +++ b/tests/testthat/test-polyqtlR.R @@ -8,6 +8,7 @@ test_that("Tests uploaded polyqtlR files",{ polyqtlR_effects$datapath <- tempfile() if(havingIP()){ + options(timeout=200) download.file("https://www.polyploids.org/sites/default/files/2022-04/tetra_polyqtlR_qtl_info.RData", destfile = polyqtlR_qtl_info$datapath) download.file("https://www.polyploids.org/sites/default/files/2022-04/tetra_polyqtlR_QTLscan.RData", destfile = polyqtlR_QTLscan_list$datapath) download.file("https://www.polyploids.org/sites/default/files/2022-04/tetra_polyqtlR_effects.RData", destfile = polyqtlR_effects$datapath) diff --git a/tests/testthat/test-tetra_example.R b/tests/testthat/test-tetra_example.R index 125e74b..0c91872 100644 --- a/tests/testthat/test-tetra_example.R +++ b/tests/testthat/test-tetra_example.R @@ -2,9 +2,9 @@ test_that("tetra example",{ source(system.file("ext/functions4tests.R", package = "viewpoly")) # upload examples - viewpoly_obj <- viewpoly:::prepare_examples("tetra_map") + viewpoly_obj <- prepare_examples("tetra_map") - expect_equal(viewpoly:::check_viewpoly(viewpoly_obj),0) + expect_equal(check_viewpoly(viewpoly_obj),0) check_viewmap_values(viewpoly_obj$map, c(14, 132, 139, 157, 34), @@ -21,7 +21,7 @@ test_that("tetra example",{ 1) # VIEWmap tests - qtl_profile_plot <- viewpoly:::plot_profile(profile = viewpoly_obj$qtl$profile, + 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, @@ -60,10 +60,10 @@ test_that("tetra example",{ ph.p2 = viewpoly_obj$map$ph.p2, snp.names = TRUE, software = "mappoly")) - vdiffr::expect_doppelganger("plot map list", viewpoly:::plot_map_list(viewpoly_obj$map)) + vdiffr::expect_doppelganger("plot map list", plot_map_list(viewpoly_obj$map)) # Get max size each chromosome - expect_equal(viewpoly:::map_summary(left.lim = 1, + expect_equal(map_summary(left.lim = 1, right.lim = 50, ch = 3, maps = maps, @@ -78,7 +78,7 @@ test_that("tetra example",{ expect_equal(sum(as.numeric(summary_table$`Max gap`)), 80.51) #VIEWqtl tests - vdiffr::expect_doppelganger("qtl plot", viewpoly:::plot_profile(viewpoly_obj$qtl$profile, + vdiffr::expect_doppelganger("qtl plot", plot_profile(viewpoly_obj$qtl$profile, viewpoly_obj$qtl$qtl_info, viewpoly_obj$qtl$selected_mks, pheno.col = 2, @@ -88,7 +88,7 @@ test_that("tetra example",{ software = NULL)) # by range - qtl_profile_data <- viewpoly:::plot_profile(viewpoly_obj$qtl$profile, + qtl_profile_data <- plot_profile(viewpoly_obj$qtl$profile, viewpoly_obj$qtl$qtl_info, viewpoly_obj$qtl$selected_mks, pheno.col = 2, @@ -107,7 +107,7 @@ test_that("tetra example",{ expect_equal(as.numeric(qtl_profile_data$points$SUP), 119, tolerance = 0.001) # export data - qtl_profile_data <- viewpoly:::plot_profile(viewpoly_obj$qtl$profile, + qtl_profile_data <- plot_profile(viewpoly_obj$qtl$profile, viewpoly_obj$qtl$qtl_info, viewpoly_obj$qtl$selected_mks, pheno.col = 2, @@ -126,11 +126,11 @@ test_that("tetra example",{ expect_equal(as.numeric(qtl_profile_data$points$SUP), 119, tolerance = 0.001) # plot exported data - p <- viewpoly:::only_plot_profile(qtl_profile_data) + p <- only_plot_profile(qtl_profile_data) expect_equal(sum(p$data$SIG), 292.883, tolerance = 0.001) # effects graphics - p <- viewpoly:::data_effects(qtl_info = viewpoly_obj$qtl$qtl_info, + p <- data_effects(qtl_info = viewpoly_obj$qtl$qtl_info, effects = viewpoly_obj$qtl$effects, pheno.col = "SG06", lgs = 2, @@ -139,7 +139,7 @@ test_that("tetra example",{ software = "QTLpoly", design = "circle") - vdiffr::expect_doppelganger("effects circle", viewpoly:::plot_effects(data_effects.obj = p, + vdiffr::expect_doppelganger("effects circle", plot_effects(data_effects.obj = p, software = "QTLpoly", design = "circle")) @@ -148,7 +148,7 @@ test_that("tetra example",{ c("Estimates", "Alleles", "Parent", "Effects", "pheno", "qtl_id", "LG", "Pos", "unique.id"), tolerance = 0.001) - p <- viewpoly:::data_effects(qtl_info = viewpoly_obj$qtl$qtl_info, + p <- data_effects(qtl_info = viewpoly_obj$qtl$qtl_info, effects = viewpoly_obj$qtl$effects, pheno.col = "SG06", lgs = 2, @@ -162,9 +162,9 @@ test_that("tetra example",{ c("x", "y", "z"), tolerance = 0.001) - vdiffr::expect_doppelganger("effects digenic", viewpoly:::plot_effects(p, "QTLpoly", "digenic")) + vdiffr::expect_doppelganger("effects digenic", plot_effects(p, "QTLpoly", "digenic")) - p <- viewpoly:::data_effects(qtl_info = viewpoly_obj$qtl$qtl_info, + p <- data_effects(qtl_info = viewpoly_obj$qtl$qtl_info, effects = viewpoly_obj$qtl$effects, pheno.col = "SG06", lgs = 2, @@ -178,11 +178,11 @@ test_that("tetra example",{ c("Estimates", "Alleles", "Parent", "Effects"), tolerance = 0.001) - vdiffr::expect_doppelganger("effects bar", viewpoly:::plot_effects(p, "QTLpoly", "bar")) + 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 <- viewpoly:::breeding_values(viewpoly_obj$qtl$qtl_info, + breed.values <- breeding_values(viewpoly_obj$qtl$qtl_info, viewpoly_obj$qtl$probs, viewpoly_obj$qtl$selected_mks, viewpoly_obj$qtl$blups, @@ -211,7 +211,7 @@ test_that("tetra example",{ expect_equal(sum(p1[[3]]$data$probability), 508.0009, tolerance = 0.0001) # VIEWgenome tests - p <- viewpoly:::plot_cm_mb(viewpoly_obj$map, 1, 1,50) + p <- plot_cm_mb(viewpoly_obj$map, 1, 1,50) expect_equal(sum(p$data$l.dist), 50502.07, tolerance = 0.001) From a72412f3d1766b703f7025806de72f2f75242eb3 Mon Sep 17 00:00:00 2001 From: cristianetaniguti Date: Wed, 20 Dec 2023 12:05:57 -0600 Subject: [PATCH 07/14] still fix tests --- .github/workflows/R-CMD-chek.yaml | 114 ++++---- .github/workflows/test-coverage.yaml | 70 ++--- man/draw_map_shiny.Rd | 104 ++++---- man/summary_maps.Rd | 50 ++-- .../_snaps/tetra_example/effects-bar.svg | 248 ++++++++--------- .../_snaps/tetra_example/effects-circle.svg | 168 ++++++------ .../_snaps/tetra_example/effects-digenic.svg | 252 +++++++++--------- .../_snaps/tetra_example/qtl-plot.svg | 150 +++++------ 8 files changed, 578 insertions(+), 578 deletions(-) diff --git a/.github/workflows/R-CMD-chek.yaml b/.github/workflows/R-CMD-chek.yaml index 547cbd9..1f8efa6 100644 --- a/.github/workflows/R-CMD-chek.yaml +++ b/.github/workflows/R-CMD-chek.yaml @@ -1,58 +1,58 @@ -# Workflow derived from https://github.com/r-lib/actions/tree/master/examples -# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help -on: - push: - branches: [main, add_hidecan] - pull_request: - branches: [main, add_hidecan] - -name: R-CMD-check - -jobs: - R-CMD-check: - runs-on: ${{ matrix.config.os }} - - name: ${{ matrix.config.os }} (${{ matrix.config.r }}) - - strategy: - fail-fast: false - matrix: - config: - - {os: macOS-latest, r: 'release'} - - {os: windows-latest, r: 'release'} - - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} - - {os: ubuntu-latest, r: 'release'} - - {os: ubuntu-latest, r: 'oldrel-1'} - - env: - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - R_KEEP_PKG_SOURCE: yes - - steps: - - uses: actions/checkout@v2 - - - uses: r-lib/actions/setup-pandoc@v2 - - - uses: r-lib/actions/setup-r@v2 - with: - r-version: ${{ matrix.config.r }} - http-user-agent: ${{ matrix.config.http-user-agent }} - use-public-rspm: true - - - uses: r-lib/actions/setup-r-dependencies@v2 - with: - extra-packages: rcmdcheck curl vdiffr - - - uses: r-lib/actions/check-r-package@v2 - - - name: Show testthat output - if: always() - run: find check -name 'testthat.Rout*' -exec cat '{}' \; || true - shell: bash - - - name: Upload check results - if: failure() - uses: actions/upload-artifact@main - with: - name: ${{ runner.os }}-r${{ matrix.config.r }}-results +# Workflow derived from https://github.com/r-lib/actions/tree/master/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: [main, add_hidecan] + pull_request: + branches: [main, add_hidecan] + +name: R-CMD-check + +jobs: + R-CMD-check: + runs-on: ${{ matrix.config.os }} + + name: ${{ matrix.config.os }} (${{ matrix.config.r }}) + + strategy: + fail-fast: false + matrix: + config: + - {os: macOS-latest, r: 'release'} + - {os: windows-latest, r: 'release'} + - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} + - {os: ubuntu-latest, r: 'release'} + - {os: ubuntu-latest, r: 'oldrel-1'} + + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + R_KEEP_PKG_SOURCE: yes + + steps: + - uses: actions/checkout@v2 + + - uses: r-lib/actions/setup-pandoc@v2 + + - uses: r-lib/actions/setup-r@v2 + with: + r-version: ${{ matrix.config.r }} + http-user-agent: ${{ matrix.config.http-user-agent }} + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: rcmdcheck curl vdiffr + + - uses: r-lib/actions/check-r-package@v2 + + - name: Show testthat output + if: always() + run: find check -name 'testthat.Rout*' -exec cat '{}' \; || true + shell: bash + + - name: Upload check results + if: failure() + uses: actions/upload-artifact@main + with: + name: ${{ runner.os }}-r${{ matrix.config.r }}-results path: check \ No newline at end of file diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml index bfab625..3dc1b81 100644 --- a/.github/workflows/test-coverage.yaml +++ b/.github/workflows/test-coverage.yaml @@ -1,36 +1,36 @@ -# Workflow derived from https://github.com/r-lib/actions/tree/master/examples -# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help -on: - push: - branches: [main, add_hidecan] - pull_request: - branches: [main, add_hidecan] - -name: test-coverage - -jobs: - test-coverage: - runs-on: ubuntu-latest - env: - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - - steps: - - uses: actions/checkout@v2 - - - uses: r-lib/actions/setup-pandoc@v2 - - - uses: r-lib/actions/setup-r@v2 - with: - use-public-rspm: true - - - uses: r-lib/actions/setup-r-dependencies@v2 - with: - extra-packages: covr - - - name: Install viewpoly - shell: bash - run: R CMD INSTALL --preclean . - - - name: Test coverage - run: covr::codecov() +# Workflow derived from https://github.com/r-lib/actions/tree/master/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: [main, add_hidecan] + pull_request: + branches: [main, add_hidecan] + +name: test-coverage + +jobs: + test-coverage: + runs-on: ubuntu-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + + steps: + - uses: actions/checkout@v2 + + - uses: r-lib/actions/setup-pandoc@v2 + + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: covr + + - name: Install viewpoly + shell: bash + run: R CMD INSTALL --preclean . + + - name: Test coverage + run: covr::codecov() shell: Rscript {0} \ No newline at end of file diff --git a/man/draw_map_shiny.Rd b/man/draw_map_shiny.Rd index c95b3ee..4b95c6b 100644 --- a/man/draw_map_shiny.Rd +++ b/man/draw_map_shiny.Rd @@ -1,52 +1,52 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/functions_map.R -\name{draw_map_shiny} -\alias{draw_map_shiny} -\title{Draws linkage map, parents haplotypes and marker doses -Adapted from MAPpoly} -\usage{ -draw_map_shiny( - left.lim = 0, - right.lim = 5, - ch = 1, - maps.dist, - ph.p1, - ph.p2, - d.p1, - d.p2, - snp.names = TRUE, - software -) -} -\arguments{ -\item{left.lim}{covered window in the linkage map start 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: -1) Character vector with chromosome ID; 2) Character vector with marker ID; -3 to (ploidy number)*2 columns with each parents haplotypes} - -\item{ph.p2}{list containing a data.frame for each group with parent 2 estimated phases. See ph.p1 parameter description.} - -\item{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} - -\item{d.p2}{list containing a data.frame for each group with parent 2 dosages. See d.p1 parameter description} - -\item{snp.names}{logical TRUE/FALSE. If TRUE it includes the marker names in the plot} - -\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{ -graphic representing selected section of a linkage group -} -\description{ -Draws linkage map, parents haplotypes and marker doses -Adapted from MAPpoly -} -\keyword{internal} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/functions_map.R +\name{draw_map_shiny} +\alias{draw_map_shiny} +\title{Draws linkage map, parents haplotypes and marker doses +Adapted from MAPpoly} +\usage{ +draw_map_shiny( + left.lim = 0, + right.lim = 5, + ch = 1, + maps.dist, + ph.p1, + ph.p2, + d.p1, + d.p2, + snp.names = TRUE, + software +) +} +\arguments{ +\item{left.lim}{covered window in the linkage map start 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: +1) Character vector with chromosome ID; 2) Character vector with marker ID; +3 to (ploidy number)*2 columns with each parents haplotypes} + +\item{ph.p2}{list containing a data.frame for each group with parent 2 estimated phases. See ph.p1 parameter description.} + +\item{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} + +\item{d.p2}{list containing a data.frame for each group with parent 2 dosages. See d.p1 parameter description} + +\item{snp.names}{logical TRUE/FALSE. If TRUE it includes the marker names in the plot} + +\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{ +graphic representing selected section of a linkage group +} +\description{ +Draws linkage map, parents haplotypes and marker doses +Adapted from MAPpoly +} +\keyword{internal} diff --git a/man/summary_maps.Rd b/man/summary_maps.Rd index c9762ed..a4d26f9 100644 --- a/man/summary_maps.Rd +++ b/man/summary_maps.Rd @@ -1,25 +1,25 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/functions_map.R -\name{summary_maps} -\alias{summary_maps} -\title{Summary maps - adapted from MAPpoly} -\usage{ -summary_maps(viewmap, software) -} -\arguments{ -\item{viewmap}{a list of objects of class \code{viewmap}} - -\item{software}{character defined from each software it comes from} -} -\value{ -a data frame containing a brief summary of all maps -} -\description{ -This function generates a brief summary table -} -\author{ -Gabriel Gesteira, \email{gabrielgesteira@usp.br} - -Cristiane Taniguti, \email{chtaniguti@tamu.edu} -} -\keyword{internal} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/functions_map.R +\name{summary_maps} +\alias{summary_maps} +\title{Summary maps - adapted from MAPpoly} +\usage{ +summary_maps(viewmap, software) +} +\arguments{ +\item{viewmap}{a list of objects of class \code{viewmap}} + +\item{software}{character defined from each software it comes from} +} +\value{ +a data frame containing a brief summary of all maps +} +\description{ +This function generates a brief summary table +} +\author{ +Gabriel Gesteira, \email{gabrielgesteira@usp.br} + +Cristiane Taniguti, \email{chtaniguti@tamu.edu} +} +\keyword{internal} diff --git a/tests/testthat/_snaps/tetra_example/effects-bar.svg b/tests/testthat/_snaps/tetra_example/effects-bar.svg index 57ca226..6a440fb 100644 --- a/tests/testthat/_snaps/tetra_example/effects-bar.svg +++ b/tests/testthat/_snaps/tetra_example/effects-bar.svg @@ -1,124 +1,124 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -P1 - - - - - - - - - -P2 - - -P1.1 -P1.2 -P1.3 -P1.4 -P2.1 -P2.2 -P2.3 -P2.4 --1e-03 --5e-04 -0e+00 -5e-04 -1e-03 -Alleles -Estimates -LG: 2 Pos: 77 -SG06 - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +P1 + + + + + + + + + +P2 + + +P1.1 +P1.2 +P1.3 +P1.4 +P2.1 +P2.2 +P2.3 +P2.4 +-1e-03 +-5e-04 +0e+00 +5e-04 +1e-03 +Alleles +Estimates +LG: 2 Pos: 77 +SG06 + + diff --git a/tests/testthat/_snaps/tetra_example/effects-circle.svg b/tests/testthat/_snaps/tetra_example/effects-circle.svg index 8f135c7..c2a8e67 100644 --- a/tests/testthat/_snaps/tetra_example/effects-circle.svg +++ b/tests/testthat/_snaps/tetra_example/effects-circle.svg @@ -1,84 +1,84 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - --1 -0 -1 -P1.1 -P1.2 -P1.3 -P1.4 -P2.1 -P2.2 -P2.3 -P2.4 - - - - - - - -SG06/ LG:2/ Pos:77 -LG2 - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +-1 +0 +1 +P1.1 +P1.2 +P1.3 +P1.4 +P2.1 +P2.2 +P2.3 +P2.4 + + + + + + + +SG06/ LG:2/ Pos:77 +LG2 + + diff --git a/tests/testthat/_snaps/tetra_example/effects-digenic.svg b/tests/testthat/_snaps/tetra_example/effects-digenic.svg index c2433ea..ef70c2d 100644 --- a/tests/testthat/_snaps/tetra_example/effects-digenic.svg +++ b/tests/testthat/_snaps/tetra_example/effects-digenic.svg @@ -1,126 +1,126 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -P1.1 -P1.2 -P1.3 -P1.4 -P2.1 -P2.2 -P2.3 - - - - - - - - - - - - - - -P1.2 -P1.3 -P1.4 -P2.1 -P2.2 -P2.3 -P2.4 - - --0.001 -0.000 -0.001 - - - - - - -LG: 2 Pos: 77 -Trait: SG06 - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +P1.1 +P1.2 +P1.3 +P1.4 +P2.1 +P2.2 +P2.3 + + + + + + + + + + + + + + +P1.2 +P1.3 +P1.4 +P2.1 +P2.2 +P2.3 +P2.4 + + +-0.001 +0.000 +0.001 + + + + + + +LG: 2 Pos: 77 +Trait: SG06 + + diff --git a/tests/testthat/_snaps/tetra_example/qtl-plot.svg b/tests/testthat/_snaps/tetra_example/qtl-plot.svg index 253422e..d504377 100644 --- a/tests/testthat/_snaps/tetra_example/qtl-plot.svg +++ b/tests/testthat/_snaps/tetra_example/qtl-plot.svg @@ -1,75 +1,75 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -2 - - - - - - -0 -50 -100 - -1 -3 - - -Position (cM) -− -l -o -g -10 -( -P -) - -Trait - - -SG06 -Linkage group -qtl plot - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +2 + + + + + + +0 +50 +100 + +1 +3 + + +Position (cM) +− +l +o +g +10 +( +P +) + +Trait + + +SG06 +Linkage group +qtl plot + + From 2af5d3495bdc095e1919d08095beba0f18731e13 Mon Sep 17 00:00:00 2001 From: cristianetaniguti Date: Wed, 20 Dec 2023 13:17:57 -0600 Subject: [PATCH 08/14] skip tets on CI --- .gitignore | 1 + tests/testthat/test-MAPpoly.R | 4 +++- tests/testthat/test-QTLpoly.R | 1 + tests/testthat/test-diaQTL.R | 1 + tests/testthat/test-polymapR.R | 2 ++ tests/testthat/test-polyqtlR.R | 2 ++ 6 files changed, 10 insertions(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index ff61d57..5bdde51 100644 --- a/.gitignore +++ b/.gitignore @@ -4,6 +4,7 @@ # Session Data files .RData +data/*.RData # User-specific files .Ruserdata diff --git a/tests/testthat/test-MAPpoly.R b/tests/testthat/test-MAPpoly.R index 82660c4..f329590 100644 --- a/tests/testthat/test-MAPpoly.R +++ b/tests/testthat/test-MAPpoly.R @@ -1,11 +1,13 @@ test_that("Tests uploaded MAPpoly files",{ + skip_on_ci() # Large files to be downloaded, continuous integration fails because of download timeout + source(system.file("ext/functions4tests.R", package = "viewpoly")) # upload MAPpoly temp <- tempfile() if(havingIP()){ options(timeout=200) - download.file("https://www.polyploids.org/sites/default/files/2022-04/tetra_MAPpoly_maps.RData", destfile = temp) + download.file("https://Cristianetaniguti.github.io/viewpoly_vignettes/data/tetra_MAPpoly_maps.RData", destfile = temp) temp.name <- load(temp) input.data <- get(temp.name) viewmap_mappoly <- prepare_MAPpoly(input.data) diff --git a/tests/testthat/test-QTLpoly.R b/tests/testthat/test-QTLpoly.R index a33fdb4..6c74cf5 100644 --- a/tests/testthat/test-QTLpoly.R +++ b/tests/testthat/test-QTLpoly.R @@ -1,4 +1,5 @@ test_that("Tests uploaded QTLpoly files",{ + skip_on_ci() # Large files to be downloaded, continuous integration fails because of download timeout source(system.file("ext/functions4tests.R", package = "viewpoly")) # upload QTLpoly diff --git a/tests/testthat/test-diaQTL.R b/tests/testthat/test-diaQTL.R index 9b95914..92b04e3 100644 --- a/tests/testthat/test-diaQTL.R +++ b/tests/testthat/test-diaQTL.R @@ -1,4 +1,5 @@ test_that("Tests uploaded diaQTL files",{ + skip_on_ci() # Large files to be downloaded, continuous integration fails because of download timeout source(system.file("ext/functions4tests.R", package = "viewpoly")) # upload diaQTL diff --git a/tests/testthat/test-polymapR.R b/tests/testthat/test-polymapR.R index d993831..2a42fe9 100644 --- a/tests/testthat/test-polymapR.R +++ b/tests/testthat/test-polymapR.R @@ -1,4 +1,6 @@ test_that("Tests uploaded polymapR files",{ + skip_on_ci() # Large files to be downloaded, continuous integration fails because of download timeout + source(system.file("ext/functions4tests.R", package = "viewpoly")) # upload MAPpoly diff --git a/tests/testthat/test-polyqtlR.R b/tests/testthat/test-polyqtlR.R index 4b96dd4..5cd9e0a 100644 --- a/tests/testthat/test-polyqtlR.R +++ b/tests/testthat/test-polyqtlR.R @@ -1,4 +1,6 @@ test_that("Tests uploaded polyqtlR files",{ + skip_on_ci() # Large files to be downloaded, continuous integration fails because of download timeout + source(system.file("ext/functions4tests.R", package = "viewpoly")) # upload polyqtlR From 9ffaa088bb35b7a8d0c0ce35c26d0ed56a163eae Mon Sep 17 00:00:00 2001 From: cristianetaniguti Date: Wed, 20 Dec 2023 14:14:29 -0600 Subject: [PATCH 09/14] add phantom --- .github/workflows/test-coverage.yaml | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml index 3dc1b81..071a739 100644 --- a/.github/workflows/test-coverage.yaml +++ b/.github/workflows/test-coverage.yaml @@ -25,8 +25,15 @@ jobs: - uses: r-lib/actions/setup-r-dependencies@v2 with: - extra-packages: covr - + extra-packages: covr webshot + + + - name: Install dependencies + run: | + webshot::install_phantomjs() + webdriver::run_phantomjs(timeout = 15000) + shell: Rscript {0} + - name: Install viewpoly shell: bash run: R CMD INSTALL --preclean . From 30a035750412e6e853612e3c32b5737d17dcd212 Mon Sep 17 00:00:00 2001 From: cristianetaniguti Date: Wed, 20 Dec 2023 15:20:57 -0600 Subject: [PATCH 10/14] rm covr from branch --- .github/workflows/test-coverage.yaml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml index 071a739..a48ae6d 100644 --- a/.github/workflows/test-coverage.yaml +++ b/.github/workflows/test-coverage.yaml @@ -2,9 +2,9 @@ # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help on: push: - branches: [main, add_hidecan] + branches: [main] pull_request: - branches: [main, add_hidecan] + branches: [main] name: test-coverage @@ -25,7 +25,7 @@ jobs: - uses: r-lib/actions/setup-r-dependencies@v2 with: - extra-packages: covr webshot + extra-packages: covr webshot curl - name: Install dependencies From acf9466ca30c361c84295c35e3dcb15e32342763 Mon Sep 17 00:00:00 2001 From: cristianetaniguti Date: Wed, 20 Dec 2023 15:40:41 -0600 Subject: [PATCH 11/14] fix order fasta files --- R/mod_upload.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/R/mod_upload.R b/R/mod_upload.R index d10cd20..3d3c755 100644 --- a/R/mod_upload.R +++ b/R/mod_upload.R @@ -934,10 +934,12 @@ mod_upload_server <- function(input, output, session, parent_session){ 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(), input_genome()$fasta$name[1]) + 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)) { From 69c55bcdeeda80af5de50ffc264846f3dd5a66cf Mon Sep 17 00:00:00 2001 From: cristianetaniguti Date: Fri, 22 Dec 2023 11:03:48 -0600 Subject: [PATCH 12/14] fix parents names and exclude haplo --- R/functions_qtl.R | 155 +++++++++++++++------------------- R/mod_qtl_view.R | 17 ++-- tests/testthat/test-QTLpoly.R | 140 +++++++++++++++--------------- 3 files changed, 150 insertions(+), 162 deletions(-) diff --git a/R/functions_qtl.R b/R/functions_qtl.R index eebcb61..be1a498 100644 --- a/R/functions_qtl.R +++ b/R/functions_qtl.R @@ -250,12 +250,32 @@ data_effects <- function(qtl_info, effects, pheno.col = NULL, if(software == "QTLpoly"){ ploidy <- max(nchar(effects$haplo)) if(is.null(parents)) {# Multi-population still not implemented - p1 <- "P1" - p2 <- "P2" - } else { - p1 <- parents[1] - p2 <- parents[2] + 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]) @@ -322,41 +342,19 @@ data_effects <- function(qtl_info, effects, pheno.col = NULL, } 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 <- gsub("a", paste0(p1,".1x"), data$Alleles) - data$Alleles <- gsub("b", paste0(p1,".2x"), data$Alleles) - data$Alleles <- gsub("c", paste0(p1,".3x"), data$Alleles) - data$Alleles <- gsub("d", paste0(p1,".4x"), data$Alleles) - data$Alleles <- gsub("e", paste0(p2,".1x"), data$Alleles) - data$Alleles <- gsub("f", paste0(p2,".2x"), data$Alleles) - data$Alleles <- gsub("g", paste0(p2,".3x"), data$Alleles) - data$Alleles <- gsub("h", paste0(p2,".4x"), data$Alleles) - data$Alleles = substring(data$Alleles,1, nchar(data$Alleles)-1) } } 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 <- gsub("a", paste0(p1,".1x"), data$Alleles) - data$Alleles <- gsub("b", paste0(p1,".2x"), data$Alleles) - data$Alleles <- gsub("c", paste0(p1,".3x"), data$Alleles) - data$Alleles <- gsub("d", paste0(p1,".4x"), data$Alleles) - data$Alleles <- gsub("e", paste0(p1,".5x"), data$Alleles) - data$Alleles <- gsub("f", paste0(p1,".6x"), data$Alleles) - data$Alleles <- gsub("g", paste0(p2,".1x"), data$Alleles) - data$Alleles <- gsub("h", paste0(p2,".2x"), data$Alleles) - data$Alleles <- gsub("i", paste0(p2,".3x"), data$Alleles) - data$Alleles <- gsub("j", paste0(p2,".4x"), data$Alleles) - data$Alleles <- gsub("k", paste0(p2,".5x"), data$Alleles) - data$Alleles <- gsub("l", paste0(p2,".6x"), data$Alleles) - data$Alleles = substring(data$Alleles,1, nchar(data$Alleles)-1) } + 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))} + @@ -367,7 +365,7 @@ data_effects <- function(qtl_info, effects, pheno.col = NULL, 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)) + axis.text.x.bottom = element_text(hjust = 1, vjust = 0.5, angle = 90)) plots1[[q]] <- plot } else if(design == "digenic"){ @@ -772,74 +770,55 @@ plot.mappoly.homoprob <- function(x, stack = FALSE, lg = NULL, select_haplo <- function(input.haplo,probs, selected_mks, effects.data, exclude.haplo = NULL){ LG <- map.position <- individual <- probability <- NULL - # Include haplo - lgs <- sapply(strsplit(unlist(input.haplo), "_"),function(x) x[grep("LG", x)]) - lgs <- gsub("LG:", "", lgs) + 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) - pos <- sapply(strsplit(unlist(input.haplo), "_"),function(x) x[grep("Pos", x)]) - pos <- gsub("Pos:", "", pos) - homo <- sapply(strsplit(unlist(input.haplo), "_"),function(x) x[grep("homolog", x)]) - homo <- gsub("homolog:", "", homo) - alleles <- effects.data[[1]]$data$Alleles[!grepl("_",effects.data[[1]]$data$Alleles)] - alleles <- rep(alleles, length(homo)) - like.ind.all <- list() - for(i in 1:length(pos)){ - idx <- match(homo[i], sort(unique(alleles))) - homoprob_temp <- homo.dat$homoprob %>% - filter(round(map.position,2) %in% round(as.numeric(pos[i]),2)) %>% filter(LG %in% lgs[i]) - homoprob_temp <- homoprob_temp[order(homoprob_temp$individual, homoprob_temp$homolog),] - homoprob_temp <- homoprob_temp %>% - group_by(map.position, LG, individual) %>% - reframe(best = which(probability > 0.5)) - like.ind <- homoprob_temp$individual[which(homoprob_temp$best %in% idx)] - if(length(like.ind) ==0) like.ind <- NA - like.ind.all[[i]] <- like.ind - } - like.intersect <- Reduce(intersect, like.ind.all) + 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(marker, individual, LG) %>% 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 + # Exclude haplo if(!is.null(exclude.haplo)){ - lgs1 <- sapply(strsplit(unlist(exclude.haplo), "_"),function(x) x[grep("LG", x)]) - lgs1 <- gsub("LG:", "", lgs1) - homo.dat1 <- calc_homologprob(probs = probs, selected_mks = selected_mks, selected_lgs = lgs1) - pos1 <- sapply(strsplit(unlist(exclude.haplo), "_"),function(x) x[grep("Pos", x)]) - pos1 <- gsub("Pos:", "", pos1) - homo <- sapply(strsplit(unlist(exclude.haplo), "_"),function(x) x[grep("homolog", x)]) - homo <- gsub("homolog:", "", homo) - alleles <- effects.data[[1]]$data$Alleles[!grepl("_",effects.data[[1]]$data$Alleles)] - alleles <- rep(alleles, length(homo)) - like.ind.all <- list() - for(i in 1:length(pos1)){ - idx <- match(homo[i], sort(unique(alleles))) - homoprob_temp <- homo.dat1$homoprob %>% - filter(round(map.position,2) %in% round(as.numeric(pos1[i]),2)) %>% filter(LG %in% lgs1[i]) - homoprob_temp <- homoprob_temp[order(homoprob_temp$individual, homoprob_temp$homolog),] - homoprob_temp <- homoprob_temp %>% - group_by(map.position, LG, individual) %>% - reframe(best = which(probability > 0.5)) - like.ind <- homoprob_temp$individual[which(homoprob_temp$best %in% idx)] - if(length(like.ind) ==0) like.ind <- NA - like.ind.all[[i]] <- like.ind - } - like.intersect.exclude <- Reduce(intersect, like.ind.all) - like.intersect <- like.intersect[-which(like.intersect %in% like.intersect.exclude)] - # For vertical lines - idx <- which(paste0(round(homo.dat$homoprob$map.position,2), "_", homo.dat$homoprob$LG) %in% c(paste0(round(as.numeric(pos),2), "_", lgs), paste0(round(as.numeric(pos1),2), "_", lgs1))) - } else { - idx <- which(paste0(round(homo.dat$homoprob$map.position,2), "_", homo.dat$homoprob$LG) %in% paste0(round(as.numeric(pos),2), "_", lgs)) + 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(like.intersect) == 0 | all(is.na(like.intersect))) stop(safeError("No individual in the progeny was found containing the combination of all the selected homolog/s. Please, select another combination of homolog/s.")) + 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[idx] <- homo.dat$homoprob$map.position[idx] # vertical lines + 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(like.intersect)){ + for(i in 1:length(selected)){ p[[i]] <- plot.mappoly.homoprob(x = homo.dat, - lg = unique(as.numeric(lgs)), - ind = as.character(like.intersect)[i], - use.plotly = FALSE) + lg = unique(as.numeric(lgs)), + ind = as.character(selected)[i], + use.plotly = FALSE) } - return(list(p, inds = as.character(like.intersect))) + return(list(p, inds = as.character(selected))) } diff --git a/R/mod_qtl_view.R b/R/mod_qtl_view.R index 42c83d1..5f61723 100644 --- a/R/mod_qtl_view.R +++ b/R/mod_qtl_view.R @@ -342,7 +342,10 @@ mod_qtl_view_server <- function(input, output, session, 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...")) @@ -477,7 +480,11 @@ mod_qtl_view_server <- function(input, output, session, need(all(input$haplo != "Select `bar` design to access this feature."), "Select `bar` design to access this feature.") ) - list.p <- select_haplo(input$haplo, loadQTL()$probs, loadQTL()$selected_mks, effects.data(), exclude.haplo = input$haplo_exclude) + 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) @@ -620,10 +627,10 @@ mod_qtl_view_server <- function(input, output, session, df <- brushedPoints(qtl.data()[[2]], input$plot_brush, xvar = "x", yvar = "y.dat") - if(!grepl("Example" ,input$parents_name)) { - cat("here2") - parents <- unlist(strsplit(input$parents_name, ",")) - } else parents <- NULL + 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, diff --git a/tests/testthat/test-QTLpoly.R b/tests/testthat/test-QTLpoly.R index 6c74cf5..8e46414 100644 --- a/tests/testthat/test-QTLpoly.R +++ b/tests/testthat/test-QTLpoly.R @@ -1,14 +1,14 @@ test_that("Tests uploaded QTLpoly files",{ skip_on_ci() # Large files to be downloaded, continuous integration fails because of download timeout source(system.file("ext/functions4tests.R", package = "viewpoly")) - + # upload QTLpoly input.data <- remim.mod <- est.effects <- fitted.mod <- list() input.data$datapath <- tempfile() remim.mod$datapath <- tempfile() est.effects$datapath <- tempfile() fitted.mod$datapath <- tempfile() - + if(havingIP()){ options(timeout=200) download.file("https://www.polyploids.org/sites/default/files/2022-04/tetra_QTLpoly_effects.RData", destfile = est.effects$datapath) @@ -17,9 +17,9 @@ test_that("Tests uploaded QTLpoly files",{ download.file("https://www.polyploids.org/sites/default/files/2022-04/tetra_QTLpoly_fitted.RData", destfile = fitted.mod$datapath) viewqtl_qtlpoly <- prepare_QTLpoly(data = input.data, - remim.mod = remim.mod, - est.effects = est.effects, - fitted.mod = fitted.mod) + remim.mod = remim.mod, + est.effects = est.effects, + fitted.mod = fitted.mod) expect_equal(check_viewqtl(viewqtl_qtlpoly),0) @@ -35,29 +35,29 @@ test_that("Tests uploaded QTLpoly files",{ #VIEWqtl tests # plotly qtl_profile_plot <- plot_profile(viewqtl_qtlpoly$profile, - viewqtl_qtlpoly$qtl_info, - viewqtl_qtlpoly$selected_mks, - pheno.col = 2, - lgs.id = 2, - by_range = TRUE, - range.min = 30, - range.max = 120, - plot=TRUE, - software = NULL) + viewqtl_qtlpoly$qtl_info, + viewqtl_qtlpoly$selected_mks, + pheno.col = 2, + 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), 43.81917, tolerance = 0.0001) # by range qtl_profile_data <- plot_profile(viewqtl_qtlpoly$profile, - viewqtl_qtlpoly$qtl_info, - viewqtl_qtlpoly$selected_mks, - pheno.col = 2, - lgs.id = 2, - by_range = TRUE, - range.min = 30, - range.max = 120, - plot=FALSE, - software = NULL) + viewqtl_qtlpoly$qtl_info, + viewqtl_qtlpoly$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) @@ -68,15 +68,15 @@ test_that("Tests uploaded QTLpoly files",{ # export data qtl_profile_data <- plot_profile(viewqtl_qtlpoly$profile, - viewqtl_qtlpoly$qtl_info, - viewqtl_qtlpoly$selected_mks, - pheno.col = 2, - lgs.id = 2, - by_range = FALSE, - range.min = NULL, - range.max = NULL, - plot=FALSE, - software = NULL) + viewqtl_qtlpoly$qtl_info, + viewqtl_qtlpoly$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) @@ -91,13 +91,13 @@ test_that("Tests uploaded QTLpoly files",{ # effects graphics p <- data_effects(qtl_info = viewqtl_qtlpoly$qtl_info, - effects = viewqtl_qtlpoly$effects, - pheno.col = "SG06", - lgs = 2, - groups = 2, - position = 77, - software = "QTLpoly", - design = "circle") + effects = viewqtl_qtlpoly$effects, + pheno.col = "SG06", + lgs = 2, + groups = 2, + position = 77, + software = "QTLpoly", + design = "circle") expect_equal(sum(p[[1]]$data$Estimates), -0.0436829, tolerance = 0.001) expect_equal(names(p[[1]]$data), @@ -105,13 +105,13 @@ test_that("Tests uploaded QTLpoly files",{ tolerance = 0.001) p <- data_effects(qtl_info = viewqtl_qtlpoly$qtl_info, - effects = viewqtl_qtlpoly$effects, - pheno.col = "SG06", - lgs = 2, - groups = 2, - position = 77, - software = "QTLpoly", - design = "digenic") + effects = viewqtl_qtlpoly$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), @@ -119,13 +119,14 @@ test_that("Tests uploaded QTLpoly files",{ tolerance = 0.001) p <- data_effects(qtl_info = viewqtl_qtlpoly$qtl_info, - effects = viewqtl_qtlpoly$effects, - pheno.col = "SG06", - lgs = 2, - groups = 2, - position = 77, - software = "QTLpoly", - design = "bar") + effects = viewqtl_qtlpoly$effects, + pheno.col = "SG06", + lgs = 2, + groups = 2, + position = 77, + software = "QTLpoly", + design = "bar", + parents = c("doida", "doido")) expect_equal(sum(p[[1]]$data$Estimates), 2.184058e-15, tolerance = 0.001) expect_equal(names(p[[1]]$data), @@ -135,19 +136,19 @@ test_that("Tests uploaded QTLpoly files",{ # breeding values table pos <- split(viewqtl_qtlpoly$qtl_info[1:3,]$Pos, viewqtl_qtlpoly$qtl_info[1:3,]$pheno) breed.values <- breeding_values(viewqtl_qtlpoly$qtl_info, - viewqtl_qtlpoly$probs, - viewqtl_qtlpoly$selected_mks, - viewqtl_qtlpoly$blups, - viewqtl_qtlpoly$beta.hat, - pos) + viewqtl_qtlpoly$probs, + viewqtl_qtlpoly$selected_mks, + viewqtl_qtlpoly$blups, + viewqtl_qtlpoly$beta.hat, + pos) expect_equal(sum(breed.values$PY06), 155.63) expect_equal(sum(breed.values$SG06), 167.16) # get and plot homologs prob data.prob <- calc_homologprob(probs = viewqtl_qtlpoly$probs, - viewqtl_qtlpoly$selected_mks, - 1:5) + viewqtl_qtlpoly$selected_mks, + 1:5) expect_equal(sum(data.prob$homoprob$probability), 464880, tolerance = 0.001) @@ -155,20 +156,21 @@ test_that("Tests uploaded QTLpoly files",{ "Trait:SG06_LG:2_Pos:77_homolog:P1.3", "Trait:FM07_LG:5_Pos:26_homolog:P2.3") p1.list <- select_haplo(input.haplo, - viewqtl_qtlpoly$probs, - viewqtl_qtlpoly$selected_mks, - effects.data = p) + viewqtl_qtlpoly$probs, + viewqtl_qtlpoly$selected_mks, + effects.data = p) p1 <- p1.list[[1]] # Test exclude - input.haplo <- list("Trait:PY06_LG:5_Pos:29_homolog:P1.1") - exclude.haplo <- list("Trait:FM07_LG:5_Pos:26_homolog:P1.4") + input.haplo <- list("Trait:PY06_LG:5_Pos:29_homolog:P1.1", "Trait:PY06_LG:5_Pos:29_homolog:P1.3") + exclude.haplo <- list("Trait:PY06_LG:5_Pos:29_homolog:P2.1", "Trait:PY06_LG:5_Pos:29_homolog:P2.4") p1.list <- select_haplo(input.haplo = input.haplo, - exclude.haplo = exclude.haplo, - probs = viewqtl_qtlpoly$probs, - selected_mks = viewqtl_qtlpoly$selected_mks, - effects.data = p) + exclude.haplo = exclude.haplo, + probs = viewqtl_qtlpoly$probs, + selected_mks = viewqtl_qtlpoly$selected_mks, + effects.data = p) + p1 <- p1.list[[1]] expect_equal(sum(p1[[1]]$data$probability), 431.9998, tolerance = 0.0001) From 07a3ef2efeb13a7225e4f3cd7f8a375db1ecfa8d Mon Sep 17 00:00:00 2001 From: cristianetaniguti Date: Sat, 23 Dec 2023 12:13:22 -0600 Subject: [PATCH 13/14] fix test --- R/functions_qtl.R | 3 +- man/draw_map_shiny.Rd | 4 +- man/summary_maps.Rd | 2 +- tests/testthat/test-MAPpoly.R | 2 +- tests/testthat/test-QTLpoly.R | 136 +++++++++++++++++----------------- 5 files changed, 75 insertions(+), 72 deletions(-) diff --git a/R/functions_qtl.R b/R/functions_qtl.R index be1a498..2136239 100644 --- a/R/functions_qtl.R +++ b/R/functions_qtl.R @@ -342,13 +342,14 @@ data_effects <- function(qtl_info, effects, pheno.col = NULL, } 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$Alleles <- duo_new[match(data$Alleles, names(duo_new))] data$Parent <- factor(data$Parent, levels=unique(data$Parent)) if(design == "bar"){ if(software == "QTLpoly"){ diff --git a/man/draw_map_shiny.Rd b/man/draw_map_shiny.Rd index 4b95c6b..def4b28 100644 --- a/man/draw_map_shiny.Rd +++ b/man/draw_map_shiny.Rd @@ -15,7 +15,7 @@ draw_map_shiny( d.p1, d.p2, snp.names = TRUE, - software + software = NULL ) } \arguments{ @@ -38,6 +38,8 @@ draw_map_shiny( \item{snp.names}{logical TRUE/FALSE. If TRUE it includes the marker names in the plot} +\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)} diff --git a/man/summary_maps.Rd b/man/summary_maps.Rd index a4d26f9..e69ff5f 100644 --- a/man/summary_maps.Rd +++ b/man/summary_maps.Rd @@ -4,7 +4,7 @@ \alias{summary_maps} \title{Summary maps - adapted from MAPpoly} \usage{ -summary_maps(viewmap, software) +summary_maps(viewmap, software = NULL) } \arguments{ \item{viewmap}{a list of objects of class \code{viewmap}} diff --git a/tests/testthat/test-MAPpoly.R b/tests/testthat/test-MAPpoly.R index f329590..0a4a15f 100644 --- a/tests/testthat/test-MAPpoly.R +++ b/tests/testthat/test-MAPpoly.R @@ -7,7 +7,7 @@ test_that("Tests uploaded MAPpoly files",{ temp <- tempfile() if(havingIP()){ options(timeout=200) - download.file("https://Cristianetaniguti.github.io/viewpoly_vignettes/data/tetra_MAPpoly_maps.RData", destfile = temp) + download.file("https://www.polyploids.org/sites/default/files/2022-04/tetra_MAPpoly_maps.RData", destfile = temp) temp.name <- load(temp) input.data <- get(temp.name) viewmap_mappoly <- prepare_MAPpoly(input.data) diff --git a/tests/testthat/test-QTLpoly.R b/tests/testthat/test-QTLpoly.R index 8e46414..711686d 100644 --- a/tests/testthat/test-QTLpoly.R +++ b/tests/testthat/test-QTLpoly.R @@ -8,7 +8,7 @@ test_that("Tests uploaded QTLpoly files",{ remim.mod$datapath <- tempfile() est.effects$datapath <- tempfile() fitted.mod$datapath <- tempfile() - + if(havingIP()){ options(timeout=200) download.file("https://www.polyploids.org/sites/default/files/2022-04/tetra_QTLpoly_effects.RData", destfile = est.effects$datapath) @@ -17,9 +17,9 @@ test_that("Tests uploaded QTLpoly files",{ download.file("https://www.polyploids.org/sites/default/files/2022-04/tetra_QTLpoly_fitted.RData", destfile = fitted.mod$datapath) viewqtl_qtlpoly <- prepare_QTLpoly(data = input.data, - remim.mod = remim.mod, - est.effects = est.effects, - fitted.mod = fitted.mod) + remim.mod = remim.mod, + est.effects = est.effects, + fitted.mod = fitted.mod) expect_equal(check_viewqtl(viewqtl_qtlpoly),0) @@ -35,29 +35,29 @@ test_that("Tests uploaded QTLpoly files",{ #VIEWqtl tests # plotly qtl_profile_plot <- plot_profile(viewqtl_qtlpoly$profile, - viewqtl_qtlpoly$qtl_info, - viewqtl_qtlpoly$selected_mks, - pheno.col = 2, - lgs.id = 2, - by_range = TRUE, - range.min = 30, - range.max = 120, - plot=TRUE, - software = NULL) + viewqtl_qtlpoly$qtl_info, + viewqtl_qtlpoly$selected_mks, + pheno.col = 2, + 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), 43.81917, tolerance = 0.0001) # by range qtl_profile_data <- plot_profile(viewqtl_qtlpoly$profile, - viewqtl_qtlpoly$qtl_info, - viewqtl_qtlpoly$selected_mks, - pheno.col = 2, - lgs.id = 2, - by_range = TRUE, - range.min = 30, - range.max = 120, - plot=FALSE, - software = NULL) + viewqtl_qtlpoly$qtl_info, + viewqtl_qtlpoly$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) @@ -68,15 +68,15 @@ test_that("Tests uploaded QTLpoly files",{ # export data qtl_profile_data <- plot_profile(viewqtl_qtlpoly$profile, - viewqtl_qtlpoly$qtl_info, - viewqtl_qtlpoly$selected_mks, - pheno.col = 2, - lgs.id = 2, - by_range = FALSE, - range.min = NULL, - range.max = NULL, - plot=FALSE, - software = NULL) + viewqtl_qtlpoly$qtl_info, + viewqtl_qtlpoly$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) @@ -91,13 +91,13 @@ test_that("Tests uploaded QTLpoly files",{ # effects graphics p <- data_effects(qtl_info = viewqtl_qtlpoly$qtl_info, - effects = viewqtl_qtlpoly$effects, - pheno.col = "SG06", - lgs = 2, - groups = 2, - position = 77, - software = "QTLpoly", - design = "circle") + effects = viewqtl_qtlpoly$effects, + pheno.col = "SG06", + lgs = 2, + groups = 2, + position = 77, + software = "QTLpoly", + design = "circle") expect_equal(sum(p[[1]]$data$Estimates), -0.0436829, tolerance = 0.001) expect_equal(names(p[[1]]$data), @@ -105,13 +105,13 @@ test_that("Tests uploaded QTLpoly files",{ tolerance = 0.001) p <- data_effects(qtl_info = viewqtl_qtlpoly$qtl_info, - effects = viewqtl_qtlpoly$effects, - pheno.col = "SG06", - lgs = 2, - groups = 2, - position = 77, - software = "QTLpoly", - design = "digenic") + effects = viewqtl_qtlpoly$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), @@ -119,14 +119,14 @@ test_that("Tests uploaded QTLpoly files",{ tolerance = 0.001) p <- data_effects(qtl_info = viewqtl_qtlpoly$qtl_info, - effects = viewqtl_qtlpoly$effects, - pheno.col = "SG06", - lgs = 2, - groups = 2, - position = 77, - software = "QTLpoly", - design = "bar", - parents = c("doida", "doido")) + effects = viewqtl_qtlpoly$effects, + pheno.col = "SG06", + lgs = 2, + groups = 2, + position = 77, + software = "QTLpoly", + design = "bar", + parents = c("doida", "doido")) expect_equal(sum(p[[1]]$data$Estimates), 2.184058e-15, tolerance = 0.001) expect_equal(names(p[[1]]$data), @@ -136,29 +136,29 @@ test_that("Tests uploaded QTLpoly files",{ # breeding values table pos <- split(viewqtl_qtlpoly$qtl_info[1:3,]$Pos, viewqtl_qtlpoly$qtl_info[1:3,]$pheno) breed.values <- breeding_values(viewqtl_qtlpoly$qtl_info, - viewqtl_qtlpoly$probs, - viewqtl_qtlpoly$selected_mks, - viewqtl_qtlpoly$blups, - viewqtl_qtlpoly$beta.hat, - pos) + viewqtl_qtlpoly$probs, + viewqtl_qtlpoly$selected_mks, + viewqtl_qtlpoly$blups, + viewqtl_qtlpoly$beta.hat, + pos) expect_equal(sum(breed.values$PY06), 155.63) expect_equal(sum(breed.values$SG06), 167.16) # get and plot homologs prob data.prob <- calc_homologprob(probs = viewqtl_qtlpoly$probs, - viewqtl_qtlpoly$selected_mks, - 1:5) + viewqtl_qtlpoly$selected_mks, + 1:5) expect_equal(sum(data.prob$homoprob$probability), 464880, tolerance = 0.001) - input.haplo <- list("Trait:SG06_LG:2_Pos:77_homolog:P1.1", "Trait:FM07_LG:5_Pos:26_homolog:P1.3", + input.haplo <- list("Trait:SG06_LG:2_Pos:77_homolog:P1.1", "Trait:SG06_LG:2_Pos:77_homolog:P1.3", "Trait:FM07_LG:5_Pos:26_homolog:P2.3") p1.list <- select_haplo(input.haplo, - viewqtl_qtlpoly$probs, - viewqtl_qtlpoly$selected_mks, - effects.data = p) + viewqtl_qtlpoly$probs, + viewqtl_qtlpoly$selected_mks, + effects.data = p) p1 <- p1.list[[1]] # Test exclude @@ -166,10 +166,10 @@ test_that("Tests uploaded QTLpoly files",{ exclude.haplo <- list("Trait:PY06_LG:5_Pos:29_homolog:P2.1", "Trait:PY06_LG:5_Pos:29_homolog:P2.4") p1.list <- select_haplo(input.haplo = input.haplo, - exclude.haplo = exclude.haplo, - probs = viewqtl_qtlpoly$probs, - selected_mks = viewqtl_qtlpoly$selected_mks, - effects.data = p) + exclude.haplo = exclude.haplo, + probs = viewqtl_qtlpoly$probs, + selected_mks = viewqtl_qtlpoly$selected_mks, + effects.data = p) p1 <- p1.list[[1]] From 68261359fd5222821789bc333946d839aa28d0f8 Mon Sep 17 00:00:00 2001 From: Cristianetaniguti Date: Tue, 26 Dec 2023 10:51:19 -0600 Subject: [PATCH 14/14] easier select_haplo --- NAMESPACE | 2 + R/functions_map.R | 1 + R/functions_qtl.R | 3 +- .../_snaps/tetra_example/effects-bar.svg | 132 +++++++++--------- tests/testthat/test-QTLpoly.R | 23 ++- 5 files changed, 91 insertions(+), 70 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index ab228c5..21a0595 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -10,6 +10,7 @@ import(purrr) import(shiny) import(shinyWidgets) import(shinydashboard) +import(tidyr) import(vroom) importFrom(JBrowseR,JBrowseR) importFrom(JBrowseR,JBrowseROutput) @@ -33,6 +34,7 @@ importFrom(grDevices,col2rgb) importFrom(grDevices,hcl) importFrom(grDevices,hsv) importFrom(grDevices,rgb2hsv) +importFrom(graphics,legend) importFrom(hidecan,CAN_data) importFrom(hidecan,DE_data) importFrom(hidecan,GWAS_data) diff --git a/R/functions_map.R b/R/functions_map.R index 7e666bb..9536a10 100644 --- a/R/functions_map.R +++ b/R/functions_map.R @@ -19,6 +19,7 @@ #' @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, diff --git a/R/functions_qtl.R b/R/functions_qtl.R index 2136239..7532c99 100644 --- a/R/functions_qtl.R +++ b/R/functions_qtl.R @@ -766,6 +766,7 @@ plot.mappoly.homoprob <- function(x, stack = FALSE, lg = NULL, #' #' @return ggplot graphic #' +#' @import dplyr tidyr #' #' @keywords internal select_haplo <- function(input.haplo,probs, selected_mks, effects.data, exclude.haplo = NULL){ @@ -788,7 +789,7 @@ select_haplo <- function(input.haplo,probs, selected_mks, effects.data, exclude. subset <- homo.dat$homoprob[which(data_match %in% include),] subset <- subset[which(subset$probability > 0.5),] - counts <- subset %>% group_by(marker, individual, LG) %>% summarise(n = n()) + 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") diff --git a/tests/testthat/_snaps/tetra_example/effects-bar.svg b/tests/testthat/_snaps/tetra_example/effects-bar.svg index 6a440fb..a7e1a87 100644 --- a/tests/testthat/_snaps/tetra_example/effects-bar.svg +++ b/tests/testthat/_snaps/tetra_example/effects-bar.svg @@ -29,95 +29,95 @@ - - + + - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + - - + + - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + - - + + - -P1 + +P1 - - + + - -P2 + +P2 -P1.1 -P1.2 -P1.3 -P1.4 -P2.1 -P2.2 -P2.3 -P2.4 --1e-03 --5e-04 -0e+00 -5e-04 -1e-03 +P1.1 +P1.2 +P1.3 +P1.4 +P2.1 +P2.2 +P2.3 +P2.4 +-1e-03 +-5e-04 +0e+00 +5e-04 +1e-03 Alleles -Estimates +Estimates LG: 2 Pos: 77 SG06 diff --git a/tests/testthat/test-QTLpoly.R b/tests/testthat/test-QTLpoly.R index 711686d..d4ff55f 100644 --- a/tests/testthat/test-QTLpoly.R +++ b/tests/testthat/test-QTLpoly.R @@ -155,9 +155,26 @@ test_that("Tests uploaded QTLpoly files",{ input.haplo <- list("Trait:SG06_LG:2_Pos:77_homolog:P1.1", "Trait:SG06_LG:2_Pos:77_homolog:P1.3", "Trait:FM07_LG:5_Pos:26_homolog:P2.3") - p1.list <- select_haplo(input.haplo, - viewqtl_qtlpoly$probs, - viewqtl_qtlpoly$selected_mks, + # Plot all the verify + # inds <- unique(data.prob$homoprob$individual) + # p <- list() + # for(i in 1:length(inds)){ + # p[[i]] <- mappoly:::plot.mappoly.homoprob(x = data.prob, + # lg = c(2,5), + # ind = as.character(inds[i]), + # use.plotly = FALSE) + # } + # + # library(ggpubr) + # parts <- c(seq(20,158, 20), 158) + # for(i in 2:length(parts)){ + # p1 <- ggarrange(plotlist = p[(parts[i-1]-1):parts[i]], common.legend = T) + # ggsave(p1, filename = paste0("part",i, ".png"), width = 15, height = 16) + # } + + p1.list <- select_haplo(input.haplo, + probs = viewqtl_qtlpoly$probs, + selected_mks = viewqtl_qtlpoly$selected_mks, effects.data = p) p1 <- p1.list[[1]]