inst/application/server.r
In rmsharp/nprcmanager: Genetic Tools for Colony Management
`%then%` <- rlang::`%||%`
library(nprcgenekeepr)
library(futile.logger)
library(ggplot2)
library(stringi)
suppressMessages(library(DT))
shinyServer(function(input, output, session) {
errorLst <- getEmptyErrorLst()
nprcgenekeeprLog <- paste0(getSiteInfo()$homeDir, "nprcgenekeepr.log")
flog.logger("nprcgenekeepr", INFO,
appender = appender.file(nprcgenekeeprLog))
#############################################################################
# Functions for handling initial pedigree upload and QC
# source("../application/sreactiveGetSelectedBreeders.R")
getSelectedBreeders <- reactive({
input$getData # This button starts it all
if (input$debugger) {
flog.threshold(DEBUG, name = "nprcgenekeepr")
} else {
flog.threshold(INFO, name = "nprcgenekeepr")
}
isolate({
flog.debug(paste0("1st. input$fileContent: ", input$fileContent,
"; input$fileType: ", input$fileType,
"; input$separator: ", input$separator),
name = "nprcgenekeepr")
sep <- input$separator
if (input$fileContent == "pedFile") {
pedigreeFile <- input$pedigreeFileOne
flog.debug(paste0("pedigreeFile - pedigreeFile$name: ",
pedigreeFile$name,
"; pedigreeFile$datapath: ", pedigreeFile$datapath),
name = "nprcgenekeepr")
} else if (input$fileContent == "commonPedGenoFile") {
pedigreeFile <- input$pedigreeFileTwo
flog.debug(paste0("pedigreeFileTwo - pedigreeFile$name: ",
pedigreeFile$name,
"; pedigreeFile$datapath: ", pedigreeFile$datapath),
name = "nprcgenekeepr")
} else if (input$fileContent == "separatePedGenoFile") {
pedigreeFile <- input$pedigreeFileThree
genotypeFile <- input$genotypeFile
flog.debug(paste0("pedigreeFileThree - pedigreeFile$name: ",
pedigreeFile$name, "; ",
"; pedigreeFile$datapath: ", pedigreeFile$datapath,
"; genotypeFile$name: ", genotypeFile$name,
"; genotypeFile$datapath: ", genotypeFile$datapath),
name = "nprcgenekeepr")
} else if (input$fileContent == "focalAnimals") {
pedigreeFile <- input$breederFile
flog.debug(paste0("breederFile - pedigreeFile$name: ",
pedigreeFile$name, "; ",
"pedigreeFile$datapath: ", pedigreeFile$datapath),
name = "nprcgenekeepr")
} else {
stop("Data source was not defined.")
}
# The minParentAge -- numeric values to set the minimum age in years for
# an animal to have an offspring. Defaults to 2 years. The check is not
# performed for animals with missing birth dates. See qcStudbook().
flog.debug("sep: %s", sep, name = "nprcgenekeepr")
minParentAge <- tryCatch(as.numeric(input$minParentAge),
warning = function(cond) {
return(NULL)
},
error = function(cond) {
return(NULL)
}
)
globalMinParentAge <<- minParentAge
flog.debug(paste0("minParentAge: ", minParentAge),
name = "nprcgenekeepr")
# pedigreeFile and breederFile will be NULL initially.
# After the user selects a file, it will be a filepath.
if (is.null(pedigreeFile)) {
return(NULL)
}
flog.debug(paste0("before Load pedigree table ",
input$fileContent),
name = "nprcgenekeepr")
# Load pedigree table
if (input$fileContent == "focalAnimals") {
flog.debug(paste0("before getFocalAnimalPed: ", pedigreeFile$name),
name = "nprcgenekeepr")
breederPed <- getFocalAnimalPed(pedigreeFile$datapath, sep = sep)
if (is.element("nprckeepErr", class(breederPed))) {
errorLst <- breederPed
breederPed <- NULL
} else if (is.null(breederPed)) {
flog.debug(paste0("after getFocalAnimalPed: ", pedigreeFile$name,
"; NULL was returned by getFocalAnimalPed ",
"function"),
name = "nprcgenekeepr")
} else {
flog.debug(paste0("after getFocalAnimalPed: ", pedigreeFile$name,
"; contents rows: ", nrow(breederPed),
", columns: ", ncol(breederPed), "; col names: '",
paste(names(breederPed), collapse = "', '"), "'",
sep = ""),
name = "nprcgenekeepr")
}
} else {
breederPed <- getPedigree(pedigreeFile$datapath, sep = sep)
flog.debug(paste0("after getPedigree pedigreeFile$name: ",
pedigreeFile$name,
"; contents rows: ", nrow(breederPed),
", columns: ", ncol(breederPed), "; col names: '",
paste(names(breederPed), collapse = "', '"), "'",
sep = ""),
name = "nprcgenekeepr")
}
if (is.null(input$fileContent)) {
stop("Did not expect input$fileContent to be NULL")
} else if (input$fileContent == "separatePedGenoFile") {
# Load pedigree table
flog.debug(paste0("before getGenotypes genotypeFile$datapath: ",
genotypeFile$datapath,
"; contents rows: ", nrow(breederPed),
", columns: ", ncol(breederPed), "; col names: '",
paste(names(breederPed), collapse = "', '"), "'",
sep = ""),
name = "nprcgenekeepr")
genotype <- getGenotypes(genotypeFile$datapath, sep = sep)
flog.debug(paste0("genotype$name: ", genotype$name,
"; contents rows: ", nrow(genotype),
", columns: ", ncol(genotype), "; col names: '",
paste(names(genotype), collapse = "', '"), "'",
sep = ""),
name = "nprcgenekeepr")
genotype <- tryCatch(checkGenotypeFile(genotype),
warning = function(cond) {
return(NULL)
},
error = function(cond) {
return(NULL)
},
finally = {
flog.debug(paste0(" tryCatch checkGenotype ",
"file. ", geterrmessage()),
name = "nprcgenekeepr")
}
)
breederPed <- addGenotype(breederPed, genotype)
flog.debug(paste0("After addGenotype - genotypeFile$name: ",
genotypeFile$name,
"; contents rows: ", nrow(breederPed),
", columns: ", ncol(breederPed), "; col names: '",
paste(names(breederPed), collapse = "', '"), "'",
sep = ""),
name = "nprcgenekeepr")
} else {
flog.debug(paste0("Setting genotype to NULL."),
name = "nprcgenekeepr")
genotype <- NULL
}
flog.debug(paste0("Data files may have been read.\n",
"contents rows: ", nrow(breederPed),
", columns: ", ncol(breederPed), "; col names: '",
paste(names(breederPed), collapse = "', '"), "'",
sep = ""),
name = "nprcgenekeepr")
if (!is.null(minParentAge)) {
flog.debug(paste0("Before qcStudbook.\n",
"contents rows: ", nrow(breederPed),
", columns: ", ncol(breederPed), "; col names: '",
paste(names(breederPed), collapse = "', '"), "'",
sep = ""),
name = "nprcgenekeepr")
if (!checkErrorLst(errorLst)) {
errorLst <- tryCatch(
qcStudbook(breederPed, minParentAge, reportChanges = FALSE,
reportErrors = TRUE),
warning = function(cond) {return(NULL)},
error = function(cond) {return(NULL)})
}
removeTab(inputId = "tab_pages", target = "Changed Columns")
removeTab(inputId = "tab_pages", target = "Error List")
if (checkErrorLst(errorLst)) {
insertTab(inputId = "tab_pages",
getErrorTab(errorLst, pedigreeFile$name), target = "Input",
position = "before", select = TRUE)
breederPed <- NULL
} else {
if (checkChangedColsLst(errorLst$changedCols)) {
insertTab(inputId = "tab_pages",
getChangedColsTab(errorLst, pedigreeFile$name),
target = "Input",
position = "before", select = FALSE)
}
breederPed <- tryCatch(qcStudbook(breederPed, minParentAge),
warning = function(cond) {return(NULL)},
error = function(cond) {return(NULL)})
flog.debug(paste0("After qcStudbook.\n",
"contents rows: ", nrow(breederPed),
", columns: ", ncol(breederPed), "; col names: '",
paste(names(breederPed), collapse = "', '"), "'",
sep = ""),
name = "nprcgenekeepr")
}
}
flog.debug(paste0("before validate()."),
name = "nprcgenekeepr")
validate(need(!is.null(minParentAge),
paste0(" Error uploading data. ",
geterrmessage())) %then%
need(!is.null(breederPed), paste0(" Error uploading data. ",
geterrmessage()))
)
if (!is.null(breederPed)) {
updateTabsetPanel(session, "tab_pages", selected = "Pedigree Browser")
}
flog.debug(paste0("After validate(); nrow(breederPed) = ",
nrow(breederPed), "; ncol(breederPed): ",
ncol(breederPed)), name = "nprcgenekeepr")
breederPed
})
})
# Load and QA-QC the pedigree once a file has been specified
getPed <- reactive({
flog.debug(paste0("In ped <- reactive()\n"), name = "nprcgenekeepr")
if (is.null(getSelectedBreeders())) {
return(NULL)
}
flog.debug(paste0("In ped <- reactive() and ",
"!is.null(getSelectedBreeders()) == TRUE\n"),
name = "nprcgenekeepr")
ped <- getSelectedBreeders()
flog.debug(paste0("column names: '", paste(names(ped), collapse = "', '"),
"'"), name = "nprcgenekeepr")
flog.debug(" - after ped <- getSelectedBreeders() before tryCatch with ",
"setPopulation.", name = "nprcgenekeepr")
ped <- tryCatch({
ped <- getSelectedBreeders()
flog.debug(paste0("column names: '", paste(names(ped),
collapse = "', '"),
"'"), name = "nprcgenekeepr")
flog.debug(" - in tryCatch before setPopulation.",
name = "nprcgenekeepr")
## setPopulation adds the population column if not already present
## setPopulation indicates all id to be in the population if
## specifyFocalAnimals() is NULL
## otherwise ids returned by specifyFocalAnimals() are set to TRUE and
## others become FALSE
ped <- setPopulation(ped, specifyFocalAnimals())
flog.debug(paste0("column names: '", paste0(names(ped),
collapse = "', '"),
"'"), name = "nprcgenekeepr")
flog.debug(paste0("setPopulation() called\n"),
name = "nprcgenekeepr")
if (input$trim) {
probands <- ped$id[ped$population]
ped <- trimPedigree(probands, ped, removeUninformative = FALSE,
addBackParents = FALSE)
#ped <- trimPedigree(probands, ped, removeUninformative = TRUE,
# addBackParents = TRUE)
flog.debug(paste0("trimPedigree() called\n"),
name = "nprcgenekeepr")
}
ped["pedNum"] <- findPedigreeNumber(ped$id, ped$sire, ped$dam)
ped["gen"] <- findGeneration(ped$id, ped$sire, ped$dam)
ped
},
error = function(cond) {
return(FALSE)
})
validate(
need(ped, geterrmessage())
)
return(ped)
})
# Changing the active tab to the "Pedigree Browser" tab
observe({
status <- getSelectedBreeders()
if (!is.null(status))
updateTabsetPanel(session, "tab_pages", selected = "Pedigree Browser")
})
# Creating the pedigree table to be displayed on the Pedigree Browser tab
output$pedigree <- DT::renderDataTable(DT::datatable({
if (is.null(getPed())) {
return(NULL)
}
# convert columns to "character" so xtables displays them properly
ped <- toCharacter(getPed())
if (!input$uid) {
ped <- ped[!grepl("^U", ped$id, ignore.case = TRUE), ]
ped$sire[grepl("^U", ped$sire, ignore.case = TRUE)] <- NA
ped$dam[grepl("^U", ped$dam, ignore.case = TRUE)] <- NA
}
names(ped) <- headerDisplayNames(names(ped))
ped
}
)
)
specifyFocalAnimals <- eventReactive(input$specifyFocalAnimal, {
ped <- unlist(strsplit(input$focalAnimalIds, "[ ,;\t\n]"))
if (!is.null(input$focalAnimalUpdate)) {
if (!input$clearFocalAnimals) {
focalAnimalUpdate <- input$focalAnimalUpdate
flog.debug(paste0("focalAnimalUpdate - focalAnimalUpdate$name: ",
focalAnimalUpdate$name, "; ",
"focalAnimalUpdate$datapath: ",
focalAnimalUpdate$datapath),
name = "nprcgenekeepr")
} else {
focalAnimalUpdate <-
list(name = "emptyFocalAnimals.csv",
datapath = system.file("extdata", "emptyFocalAnimals.csv",
package = "nprcgenekeepr"))
flog.debug(paste0("focalAnimalUpdate - focalAnimalUpdate$name: ",
focalAnimalUpdate$name, "; ",
"focalAnimalUpdate$datapath: ",
focalAnimalUpdate$datapath),
name = "nprcgenekeepr")
}
focalAnimalUpdateDf <- unlist(read.table(focalAnimalUpdate$datapath,
header = TRUE,
sep = ",",
stringsAsFactors = FALSE,
na.strings = c("", "NA"),
check.names = FALSE))
flog.debug(paste0("focalAnimalUpdate - focalAnimalUpdateDf: ",
focalAnimalUpdateDf),
name = "nprcgenekeepr")
updateTextAreaInput(session, "focalAnimalIds",
label = paste0(focalAnimalUpdateDf),
value = paste0(focalAnimalUpdateDf))
ped <- focalAnimalUpdateDf
}
if (length(ped) == 0) {
return(NULL)
} else{
return(ped)
}
},
ignoreNULL = FALSE)
# Download handler to download the full or trimmed pedigree
output$downloadPedigree <- downloadHandler(
filename = function() {
paste("Pedigree", ".csv", sep = "")
},
content = function(file) {
write.csv(getPed(), file, na = "", row.names = FALSE)
}
)
#############################################################################
# Functions for handling the genetic value analysis generation
geneticValue <- eventReactive(input$analysis, {
if (is.null(getPed())) {
return(NULL)
}
# Ensuring the pedigree has been trimmed
# (if there are too many animals, the program will crash)
ped <- getPed()
probands <- ped$id[ped$population]
ped <- trimPedigree(probands, ped, removeUninformative = FALSE,
addBackParents = FALSE)
validate(
need(length(probands) != 0, "Error: No population specified")
)
# Setting up the progress bar
progress <- shiny::Progress$new()
on.exit(progress$close())
updateProgress <- function(n = 1, detail = NULL, value = 0, reset = FALSE) {
if (reset) {
progress$set(detail = detail, value = value)
} else{
progress$inc(amount = 1 / n)
}
}
#
return(reportGV(ped, guIter = input$iterations,
guThresh = as.integer(input$threshold),
byID = TRUE,
updateProgress = updateProgress))
})
# Returns the geneticValue() report
rpt <- reactive({
if (is.null(geneticValue())) {
return(NULL)
}
return(geneticValue()[["report"]])
})
# Functions for displaying the Genetic Value Analysis
gvaView <- reactive({
if (is.null(rpt())) {
return(NULL)
}
if (input$view == 0) {
return(rpt())
} else{
ids <- unlist(strsplit(isolate(input$viewIds), "[ ,;\t\n]"))
ids <- ids[stri_trim(ids) != ""]
if (length(ids) == 0) {
return(rpt())
} else{
return(filterReport(ids, rpt()))
}
}
})
output$gva <- DT::renderDataTable(DT::datatable({
if (is.null(rpt())) {
return(NULL)
}
g <- gvaView()
g$indivMeanKin <- round(g$indivMeanKin, 5)
g$zScores <- round(g$zScores, 2)
g$gu <- round(g$gu, 5)
g <- toCharacter(g)
names(g) <- headerDisplayNames(names(g))
return(g)
}))
# Download handlers for all or a subset of the Genetic Value Analysis
output$downloadGVAFull <- downloadHandler(
filename = function() {
paste("GVA_full", ".csv", sep = "")
},
content = function(file) {
write.csv(rpt(), file, na = "", row.names = FALSE)
}
)
output$downloadGVASubset <- downloadHandler(
filename = function() {
paste("GVA_subset", ".csv", sep = "")
},
content = function(file) {
write.csv(gvaView(), file, na = "", row.names = FALSE)
}
)
#############################################################################
# Functions for handling printing summary statistics and outputting the
# kinship matrix
kmat <- reactive({
if (is.null(geneticValue())) {
return(NULL)
}
return(geneticValue()[["kinship"]])
})
# Download handler for the kinship matrix
output$downloadKinship <- downloadHandler(
filename = function() {
paste("Kinship", ".csv", sep = "")
},
content = function(file) {
write.csv(kmat(), file, na = "")
}
)
output$summaryStats <- renderText({
if (is.null(geneticValue())) {
return(NULL)
}
f <- geneticValue()[["total"]]
nmf <- geneticValue()[["nMaleFounders"]]
nff <- geneticValue()[["nFemaleFounders"]]
fe <- geneticValue()[["fe"]]
fg <- geneticValue()[["fg"]]
mk <- summary(rpt()[, "indivMeanKin"])
gu <- summary(rpt()[, "gu"])
fe_title_txt <- JS(paste("Founder equivalents estimates the expected number
of equally contributing founders that would be
required to produce the observed genetic diversity
in the current population. $f_e = 1 / \\sigma;(p_{i_{2}})$"))
# </MATH>Where <MATH>p<sub>i</sub></MATH>is the proportion of the genes of
# the living,
# descendant population contributed by founder <MATH>i</MATH>."))
founder <- htmltools::withTags(table(
class = "display",
thead(
tr(
th("Known Founders"),
th("Known Female Founders"),
th("Known Male Founders"),
th(JS("Founder Equivalents")),
th("Founder Genome Equivalents"))),
tbody(td(as.character(f)), td(as.character(nff)), td(as.character(nmf)),
td(as.character(round(fe, digits = 2))),
td(as.character(round(fg, digits = 2))))))
header <- paste("<tr>",
"<th></th>",
"<th>Min</th>",
"<th>1st Quartile</th>",
"<th>Mean</th>",
"<th>Median</th>",
"<th>3rd Quartile</th>",
"<th>Max</th>",
"</tr>")
k <- paste("<tr>",
"<td>Mean Kinship</td>",
"<td>", as.character(round(mk["Min."], 4)), "</td>",
"<td>", as.character(round(mk["1st Qu."], 4)), "</td>",
"<td>", as.character(round(mk["Mean"], 4)), "</td>",
"<td>", as.character(round(mk["Median"], 4)), "</td>",
"<td>", as.character(round(mk["3rd Qu."], 4)), "</td>",
"<td>", as.character(round(mk["Max."], 4)), "</td>",
"</tr>")
g <- paste("<tr>",
"<td>Genome Uniqueness</td>",
"<td>", as.character(round(gu["Min."], 4)), "</td>",
"<td>", as.character(round(gu["1st Qu."], 4)), "</td>",
"<td>", as.character(round(gu["Mean"], 4)), "</td>",
"<td>", as.character(round(gu["Median"], 4)), "</td>",
"<td>", as.character(round(gu["3rd Qu."], 4)), "</td>",
"<td>", as.character(round(gu["Max."], 4)), "</td>",
"</tr>")
return(paste(founder, "<br>", "<br>", "<table>", header, k, g, "</table>"))
})
mkHistogram <- function() {
mk <- rpt()[, "indivMeanKin"]
avg <- mean(mk, na.rm = TRUE)
# std.dev <- sd(mk, na.rm = TRUE)
# upper <- avg + (2 * std.dev)
# lower <- avg - (2 * std.dev)
brx <- pretty(range(mk), 25)
ggplot(data.frame(mk = mk), aes(x = mk, y=..density..)) +
geom_histogram(bins = 25, color="darkblue", fill="lightblue",
breaks = brx) +
theme_classic() +
xlab("Kinship") + ylab("Frequency") +
ggtitle("Distribution of Individual Mean Kinship Coefficients") +
geom_vline(aes(xintercept = avg, color = "red"), linetype = "dashed",
show.legend = FALSE)# +
}
output$mkHist <- renderPlot({
if (is.null(rpt())) {
return(NULL)
}
mkHistogram()
})
zscoreHistogram <- function() {
z <- rpt()[, "zScores"]
avg <- mean(z, na.rm = TRUE)
# std.dev <- sd(z, na.rm = TRUE)
# upper <- avg + (2 * std.dev)
# lower <- avg - (2 * std.dev)
brx <- pretty(range(z), 25)
ggplot(data.frame(z = z), aes(x = z, y=..density..)) +
geom_histogram(bins = 25, color="darkblue", fill="lightblue",
breaks = brx) +
theme_classic() +
xlab("Z-Score") + ylab("Frequency") +
ggtitle("Distribution of Mean Kinship Coefficients Z-scores") +
geom_vline(aes(xintercept = avg, color = "red"), linetype = "dashed",
show.legend = FALSE)# +
}
output$zscoreHist <- renderPlot({
if (is.null(rpt())) {
return(NULL)
}
zscoreHistogram()
})
guHistogram <- function() {
gu <- rpt()[, "gu"]
avg <- mean(gu, na.rm = TRUE)
# std.dev <- sd(gu, na.rm = TRUE)
# upper <- avg + (2 * std.dev)
# lower <- avg - (2 * std.dev)
brx <- pretty(range(gu), 25)
ggplot(data.frame(gu = gu), aes(x = gu, y=..density..)) +
geom_histogram(color="darkblue", fill="lightblue", breaks = brx) +
theme_classic() +
xlab("Genome Uniqueness Score") + ylab("Frequency") +
ggtitle("Distribution of Genome Uniqueness") +
geom_vline(aes(xintercept = avg, color = "red"), linetype = "dashed",
show.legend = FALSE)
}
output$guHist <- renderPlot({
if (is.null(rpt())) {
return(NULL)
}
guHistogram()
})
meanKinshipBoxPlot <- function() {
gu <- rpt()[, "indivMeanKin"]
ggplot(data.frame(gu = gu), aes(x = 0, y = gu)) +
geom_boxplot(color="darkblue", fill="lightblue", notch = FALSE,
outlier.color = "red", outlier.shape = 1) +
theme_classic() + geom_jitter(width = 0.2) + coord_flip() +
ylab("Kinship") +
ggtitle("Boxplot of Individual Mean Kinship Coefficients") +
xlab("")
}
output$mkBox <- renderPlot({
if (is.null(rpt())) {
return(NULL)
}
meanKinshipBoxPlot()
})
zscoreBoxPlot <- function() {
gu <- rpt()[, "zScores"]
ggplot(data.frame(gu = gu), aes(x = 0, y = gu)) +
geom_boxplot(color="darkblue", fill="lightblue", notch = FALSE,
outlier.color = "red", outlier.shape = 1) +
theme_classic() + geom_jitter(width = 0.2) + coord_flip() +
ylab("Z-Score") +
ggtitle("Boxplot of Mean Kinship Coefficients Z-scores") +
xlab("")
}
output$zscoreBox <- renderPlot({
if (is.null(rpt())) {
return(NULL)
}
zscoreBoxPlot()
})
guBoxPlot <- function() {
gu <- rpt()[, "gu"]
ggplot(data.frame(gu = gu), aes(x = 0, y = gu)) +
geom_boxplot(color="darkblue", fill="lightblue", notch = FALSE,
outlier.color = "red", outlier.shape = 1) +
theme_classic() + geom_jitter(width = 0.2) + coord_flip() +
ylab("Genome Uniquness") + ggtitle("Boxplot of Genome Uniqueness") +
xlab("")
}
output$guBox <- renderPlot({
if (is.null(rpt())) {
return(NULL)
}
guBoxPlot()
})
box_and_whisker_desc <- paste0("The upper whisker extends from the hinge to
the largest value no further than 1.5 * IQR
from the hinge (where IQR is the
inter-quartile range, or distance between
the first and third quartiles). The lower
whisker extends from the hinge to the
smallest value at most 1.5 * IQR of the
hinge. Data beyond the end of the whiskers
are called \"outlying\" points and are plotted
individually.")
addPopover(session, "mkBox", "Mean Kinship Coefficients",
content = box_and_whisker_desc,
placement = "bottom", trigger = "hover", options = NULL)
addPopover(session, "zscoreBox", "Z-scores",
content = box_and_whisker_desc,
placement = "bottom", trigger = "hover", options = NULL)
addPopover(session, "guBox", "Genetic Uniqueness",
content = box_and_whisker_desc,
placement = "bottom", trigger = "hover", options = NULL)
# ##
# output$relations <- eventReactive(input$displayRelations, {
# DT::renderDataTable(DT::datatable({
# if (is.null(kmat())) {
# return(NULL)
# }
# j <- nrow(kmat()) * ncol(kmat())
# # Setting up the progress bar
# progress <- shiny::Progress$new()
# on.exit(progress$close())
# progress$set(message = "Finding Relationship Designations", value = 0)
# updateProgress <- function() {
# progress$inc(amount = 1 / j)
# }
#
# kin <- convertRelationships(kmat(), getPed(),
# updateProgress = updateProgress)
#
# progress$set(message = "Preparing Table", value = 1)
# r <- makeRelationClassesTable(kin)
#
# toCharacter(r)
# })
# )})
# Download handler for the male founders
output$downloadMaleFounders <- downloadHandler(
filename = function() {
paste("maleFounders", ".csv", sep = "")
},
content = function(file) {
mf <- geneticValue()[["maleFounders"]]
write.csv(mf, file, na = "")
}
)
# Download handler for the male founders
output$downloadFemaleFounders <- downloadHandler(
filename = function() {
paste("femaleFounders", ".csv", sep = "")
},
content = function(file) {
ff <- geneticValue()[["femaleFounders"]]
write.csv(ff, file, na = "")
}
)
# Download handler for the first-order relationships
output$downloadFirstOrder <- downloadHandler(
filename = function() {
paste("FirstOrder", ".csv", sep = "")
},
content = function(file) {
ped <- getPed()
r <- countFirstOrder(ped, ids = ped$id[ped$population])
write.csv(r, file, na = "")
}
)
output$downloadRelations <- downloadHandler(
filename = function() {
paste("Relations", ".csv", sep = "")
},
content = function(file) {
ped <- getPed()
probands <- ped$id[ped$population]
r <- convertRelationships(kmat(), getPed(), ids = probands)
write.csv()
}
)
## Save plots
output$downloadMeanKinshipCoefficientHistogram <- downloadHandler(
filename = "meanKinshipCoefficientHistogram.png",
content = function(file) {
device <- function(..., width, height) {
grDevices::png(..., width = width, height = height,
res = 300, units = "in")
}
ggsave(file, plot = mkHistogram(), device = "png")
}
)
output$downloadZScoreHistogram <- downloadHandler(
filename = "meanKinshipCoefficientsZscoreHistogram.png",
content = function(file) {
device <- function(..., width, height) {
grDevices::png(..., width = width, height = height,
res = 300, units = "in")
}
ggsave(file, plot = zscoreHistogram(), device = "png")
}
)
output$downloadGenomeUniquenessHistogram <- downloadHandler(
filename = "geneticUniquenessHistogram.png",
content = function(file) {
device <- function(..., width, height) {
grDevices::png(..., width = width, height = height,
res = 300, units = "in")
}
ggsave(file, plot = guHistogram(), device = "png")
}
)
output$downloadMeanKinshipCoefficientBoxPlot <- downloadHandler(
filename = "meanKinshipCoefficientsBox.png",
content = function(file) {
device <- function(..., width, height) {
grDevices::png(..., width = width, height = height,
res = 300, units = "in")
}
ggsave(file, plot = meanKinshipBoxPlot(), device = "png")
}
)
output$downloadZScoreBoxPlot <- downloadHandler(
filename = "meanKinshipCoefficientsZscoresBox.png",
content = function(file) {
device <- function(..., width, height) {
grDevices::png(..., width = width, height = height,
res = 300, units = "in")
}
ggsave(file, plot = zscoreBoxPlot(), device = "png")
}
)
output$downloadGenomeUniquenessBoxPlot <- downloadHandler(
filename = "geneticUniquenessBox.png",
content = function(file) {
device <- function(..., width, height) {
grDevices::png(..., width = width, height = height,
res = 300, units = "in")
}
ggsave(file, plot = guBoxPlot(), device = "png")
}
)
# ### Display Founders
# # Creating the male founder table for display on the Summary Statistics tab
# output$maleFounders <- DT::renderDataTable(DT::datatable({
# if (is.null(geneticValue()[["maleFounders"]])) {
# return(NULL)
# }
# # convert columns to "character" so xtables displays them properly
# ped <- toCharacter(geneticValue()[["maleFounders"]])
# names(ped) <- headerDisplayNames(names(ped))
# ped
# }))
# # Creating the male founder table for display on the Summary Statistics tab
# output$femaleFounders <- DT::renderDataTable(DT::datatable({
# if (is.null(geneticValue()[["femaleFounders"]])) {
# return(NULL)
# }
# # convert columns to "character" so xtables displays them properly
# ped <- toCharacter(geneticValue()[["femaleFounders"]])
# names(ped) <- headerDisplayNames(names(ped))
# ped
# }))
#
#
#############################################################################
# Functions for handling the breeding group formation process
textAreaWidget <- eventReactive(input$seedAnimals,{
seedAnimalList <- lapply(1:input$numGp, function(i) {
inputName <- paste0("curGrp", i)
textInputRow <-function (inputId,value) {
textAreaInput(inputId = inputName, paste0("Seed animals ", i),
value = "", rows = 5, cols = 20, resize = "both")
}
column(2, offset = 0, textInputRow(inputName, ""))
})
do.call(tagList, seedAnimalList)}, ignoreInit = FALSE)
getCurrentGroups <- reactive({
currentGroups <- vapply(seq_len(input$numGp), function(i){character(0)},
character(0))
for (i in 1:(input$numGp)) {
inputName <- paste0("curGrp", i)
if (is.null(input[[inputName]])) # seed animal option is not selected
break
currentGroups[[i]] <-
stri_remove_empty(unlist(strsplit(input[[inputName]], "[, \t\n]")))
}
currentGroups
})
output$currentGroups <- renderUI({textAreaWidget()})
output$getCurrentGroups <- renderText({getCurrentGroups()})
textMinParentAge <- eventReactive(input$group_formation_rb,{
minParentAgeLine <-
checkboxInput("useMinParentAge",
label = paste0("Animals will be grouped with the mother ",
"below the minimum parent age of ",
globalMinParentAge, "."),
value = FALSE)
do.call(tagList, list(minParentAgeLine))}, ignoreInit = FALSE)
output$minParentAge <- renderUI({textMinParentAge()})
bg <- eventReactive(input$grpSim, {
if (is.null(rpt())) {
return(NULL)
}
currentGroups <- getCurrentGroups()
currentGroupIds <- unlist(currentGroups)
ped <- getPed()
# Filter out unknown animals added into ped
ped <- removeUnknownAnimals(ped)
ids <- character(0)
if (input$group_formation_rb == "candidates")
ids <- unlist(strsplit(input$grpIds, "[, \t\n]"))
if (length(ids) > 0) {
ped <- resetGroup(ped, ids)
candidates <- ids
} else{
candidates <- getGrpIds()
}
# Assume an animal that is in the group can't also be a candidate
if (length(currentGroupIds) > 0) {
candidates <- setdiff(candidates, currentGroupIds)
}
# Filter out low-value animals if desired
useLv <- input$group_formation_rb != "high-value"
if (!useLv) {
rpt <- rpt()
lv <- rpt$id[rpt$value == "low value"]
candidates <- setdiff(candidates, lv)
}
candidates <- intersect(candidates, ped$id)
harem <- input$group_sex_rb == "harems"
validate(
need(length(candidates == 0), "No candidates defined"),
need(!(length(setdiff(candidates, ped$id)) > 0),
paste("Group candidates present that are",
"not in the provided pedigree\n",
paste(setdiff(candidates, ped$id), sep = "\n"))),
need(!(length(setdiff(currentGroupIds, ped$id)) > 0),
paste("Current group members present that",
"are not in the provided pedigree\n",
paste(setdiff(currentGroupIds, ped$id), sep = "\n")))
)
ignore <- input$ffRel
ignore <- if (ignore) list(c("F", "F")) else NULL
threshold <- input$kinThresh
if (input$useMinParentAge) {
minAge <- globalMinParentAge
output$minParentAge <- renderText({paste0(minAge)})
} else {
minAge <- input$minAge
}
withKin <- input$withKin
iter <- input$gpIter
numGp <- ({
input$numGp
})
sexRatio <- input$sexRatio
# Setting up the progress bar
progress <- shiny::Progress$new()
on.exit(progress$close())
progress$set(message = "Generating Groups", value = 0)
n <- 1
updateProgress <- function() {
progress$inc(amount = 1 / iter, detail = paste("Iteration:", n))
n <<- n + 1
}
grp <- groupAddAssign(candidates = candidates,
currentGroups = currentGroups,
kmat = kmat(),
ped = ped,
threshold = threshold,
ignore = ignore,
minAge = minAge,
iter = iter,
numGp = numGp,
harem = harem, sexRatio,
withKin = withKin,
updateProgress = updateProgress)
return(grp)
})
getGrpIds <- reactive({
ped <- getPed()
ped <- ped[is.na(ped$exit) & !is.na(ped$birth), ]
if ("group" %in% colnames(ped)) {
return(ped$id[ped$group])
} else{
return(ped$id[ped$population])
}
})
# Functions to handle breeding group display
observe({
if (!is.null(bg())) {
x <- length(bg()$group)
if (x > 1) {
gp <- list()
for (i in 1:(x - 1)) {
gp[paste("Group", as.character(i))] <- i
}
gp["Unused"] <- x
updateSelectInput(session, "viewGrp",
label = "Enter the group to view:",
choices = gp, selected = 1)
} else if (x == 1) {
updateSelectInput(session, "viewGrp",
label = "Enter the group to view:",
choices = list("Unused" = 1), selected = 1)
} else{
updateSelectInput(session, "viewGrp",
label = "Enter the group to view:",
choices = list(" " = 1), selected = 1)
}
}
})
bgGroupView <- reactive({
if (is.null(bg())) {
return(NULL)
}
i <- withinIntegerRange(input$viewGrp, minimum = 1,
maximum = input$numGp)[1]
gp <- bg()$group[[i]]
ped <- getPed()
gp <- addSexAndAgeToGroup(gp, ped)
gp$age <- round(gp$age, 1)
colnames(gp) <- c("Ego ID", "Sex", "Age in Years")
if (nrow(gp) == 0) {
return(NULL)
} else {
return(gp[order(gp$`Ego ID`), , drop = FALSE])
}
})
bgGroupKinView <- reactive({
if (is.null(bg()$groupKin)) {
return(NULL)
}
i <- as.numeric(input$viewGrp)
kmat <- bg()$groupKin[[i]]
kmat <- as.data.frame(round(kmat, 6))
if (nrow(kmat) == 0) {
return(NULL)
} else{
return(kmat)
}
})
output$breedingGroups <- DT::renderDataTable(DT::datatable({
if (is.null(bg())) {
return(NULL)
}
return(bgGroupView())
}))
output$breedingGroupKin <- DT::renderDataTable(DT::datatable({
if (is.null(bg()$groupKin)) {
return(NULL)
}
return(bgGroupKinView())
}))
# Download handler for the current group
output$downloadGroup <- downloadHandler(
filename = getDatedFilename(paste0("Group-", input$viewGrp, ".csv")),
content = function(file) {
write.csv(bgGroupView(), file, na = "", row.names = FALSE)
},
contentType = "text/csv"
)
output$downloadGroupKin <- downloadHandler(
filename = getDatedFilename(paste0("GroupKin-", input$viewGrp, ".csv")),
content = function(file) {
write.csv(bgGroupKinView(), file, na = "", row.names = TRUE)
},
contentType = "text/csv"
)
#############################################################################
# Function to handle display of pyramid plot
flog.debug("before renderPlot(getPyramidPlot(ped)))", name = "nprcgenekeepr")
output$pyramidPlot <- renderPlot(getPyramidPlot(getPed()))
flog.debug("after renderPlot(getPyramidPlot(ped)))", name = "nprcgenekeepr")
})
rmsharp/nprcmanager documentation built on April 24, 2021, 3:13 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
`%then%` <- rlang::`%||%`
library(nprcgenekeepr)
library(futile.logger)
library(ggplot2)
library(stringi)
suppressMessages(library(DT))
shinyServer(function(input, output, session) {
errorLst <- getEmptyErrorLst()
nprcgenekeeprLog <- paste0(getSiteInfo()$homeDir, "nprcgenekeepr.log")
flog.logger("nprcgenekeepr", INFO,
appender = appender.file(nprcgenekeeprLog))
#############################################################################
# Functions for handling initial pedigree upload and QC
# source("../application/sreactiveGetSelectedBreeders.R")
getSelectedBreeders <- reactive({
input$getData # This button starts it all
if (input$debugger) {
flog.threshold(DEBUG, name = "nprcgenekeepr")
} else {
flog.threshold(INFO, name = "nprcgenekeepr")
}
isolate({
flog.debug(paste0("1st. input$fileContent: ", input$fileContent,
"; input$fileType: ", input$fileType,
"; input$separator: ", input$separator),
name = "nprcgenekeepr")
sep <- input$separator
if (input$fileContent == "pedFile") {
pedigreeFile <- input$pedigreeFileOne
flog.debug(paste0("pedigreeFile - pedigreeFile$name: ",
pedigreeFile$name,
"; pedigreeFile$datapath: ", pedigreeFile$datapath),
name = "nprcgenekeepr")
} else if (input$fileContent == "commonPedGenoFile") {
pedigreeFile <- input$pedigreeFileTwo
flog.debug(paste0("pedigreeFileTwo - pedigreeFile$name: ",
pedigreeFile$name,
"; pedigreeFile$datapath: ", pedigreeFile$datapath),
name = "nprcgenekeepr")
} else if (input$fileContent == "separatePedGenoFile") {
pedigreeFile <- input$pedigreeFileThree
genotypeFile <- input$genotypeFile
flog.debug(paste0("pedigreeFileThree - pedigreeFile$name: ",
pedigreeFile$name, "; ",
"; pedigreeFile$datapath: ", pedigreeFile$datapath,
"; genotypeFile$name: ", genotypeFile$name,
"; genotypeFile$datapath: ", genotypeFile$datapath),
name = "nprcgenekeepr")
} else if (input$fileContent == "focalAnimals") {
pedigreeFile <- input$breederFile
flog.debug(paste0("breederFile - pedigreeFile$name: ",
pedigreeFile$name, "; ",
"pedigreeFile$datapath: ", pedigreeFile$datapath),
name = "nprcgenekeepr")
} else {
stop("Data source was not defined.")
}
# The minParentAge -- numeric values to set the minimum age in years for
# an animal to have an offspring. Defaults to 2 years. The check is not
# performed for animals with missing birth dates. See qcStudbook().
flog.debug("sep: %s", sep, name = "nprcgenekeepr")
minParentAge <- tryCatch(as.numeric(input$minParentAge),
warning = function(cond) {
return(NULL)
},
error = function(cond) {
return(NULL)
}
)
globalMinParentAge <<- minParentAge
flog.debug(paste0("minParentAge: ", minParentAge),
name = "nprcgenekeepr")
# pedigreeFile and breederFile will be NULL initially.
# After the user selects a file, it will be a filepath.
if (is.null(pedigreeFile)) {
return(NULL)
}
flog.debug(paste0("before Load pedigree table ",
input$fileContent),
name = "nprcgenekeepr")
# Load pedigree table
if (input$fileContent == "focalAnimals") {
flog.debug(paste0("before getFocalAnimalPed: ", pedigreeFile$name),
name = "nprcgenekeepr")
breederPed <- getFocalAnimalPed(pedigreeFile$datapath, sep = sep)
if (is.element("nprckeepErr", class(breederPed))) {
errorLst <- breederPed
breederPed <- NULL
} else if (is.null(breederPed)) {
flog.debug(paste0("after getFocalAnimalPed: ", pedigreeFile$name,
"; NULL was returned by getFocalAnimalPed ",
"function"),
name = "nprcgenekeepr")
} else {
flog.debug(paste0("after getFocalAnimalPed: ", pedigreeFile$name,
"; contents rows: ", nrow(breederPed),
", columns: ", ncol(breederPed), "; col names: '",
paste(names(breederPed), collapse = "', '"), "'",
sep = ""),
name = "nprcgenekeepr")
}
} else {
breederPed <- getPedigree(pedigreeFile$datapath, sep = sep)
flog.debug(paste0("after getPedigree pedigreeFile$name: ",
pedigreeFile$name,
"; contents rows: ", nrow(breederPed),
", columns: ", ncol(breederPed), "; col names: '",
paste(names(breederPed), collapse = "', '"), "'",
sep = ""),
name = "nprcgenekeepr")
}
if (is.null(input$fileContent)) {
stop("Did not expect input$fileContent to be NULL")
} else if (input$fileContent == "separatePedGenoFile") {
# Load pedigree table
flog.debug(paste0("before getGenotypes genotypeFile$datapath: ",
genotypeFile$datapath,
"; contents rows: ", nrow(breederPed),
", columns: ", ncol(breederPed), "; col names: '",
paste(names(breederPed), collapse = "', '"), "'",
sep = ""),
name = "nprcgenekeepr")
genotype <- getGenotypes(genotypeFile$datapath, sep = sep)
flog.debug(paste0("genotype$name: ", genotype$name,
"; contents rows: ", nrow(genotype),
", columns: ", ncol(genotype), "; col names: '",
paste(names(genotype), collapse = "', '"), "'",
sep = ""),
name = "nprcgenekeepr")
genotype <- tryCatch(checkGenotypeFile(genotype),
warning = function(cond) {
return(NULL)
},
error = function(cond) {
return(NULL)
},
finally = {
flog.debug(paste0(" tryCatch checkGenotype ",
"file. ", geterrmessage()),
name = "nprcgenekeepr")
}
)
breederPed <- addGenotype(breederPed, genotype)
flog.debug(paste0("After addGenotype - genotypeFile$name: ",
genotypeFile$name,
"; contents rows: ", nrow(breederPed),
", columns: ", ncol(breederPed), "; col names: '",
paste(names(breederPed), collapse = "', '"), "'",
sep = ""),
name = "nprcgenekeepr")
} else {
flog.debug(paste0("Setting genotype to NULL."),
name = "nprcgenekeepr")
genotype <- NULL
}
flog.debug(paste0("Data files may have been read.\n",
"contents rows: ", nrow(breederPed),
", columns: ", ncol(breederPed), "; col names: '",
paste(names(breederPed), collapse = "', '"), "'",
sep = ""),
name = "nprcgenekeepr")
if (!is.null(minParentAge)) {
flog.debug(paste0("Before qcStudbook.\n",
"contents rows: ", nrow(breederPed),
", columns: ", ncol(breederPed), "; col names: '",
paste(names(breederPed), collapse = "', '"), "'",
sep = ""),
name = "nprcgenekeepr")
if (!checkErrorLst(errorLst)) {
errorLst <- tryCatch(
qcStudbook(breederPed, minParentAge, reportChanges = FALSE,
reportErrors = TRUE),
warning = function(cond) {return(NULL)},
error = function(cond) {return(NULL)})
}
removeTab(inputId = "tab_pages", target = "Changed Columns")
removeTab(inputId = "tab_pages", target = "Error List")
if (checkErrorLst(errorLst)) {
insertTab(inputId = "tab_pages",
getErrorTab(errorLst, pedigreeFile$name), target = "Input",
position = "before", select = TRUE)
breederPed <- NULL
} else {
if (checkChangedColsLst(errorLst$changedCols)) {
insertTab(inputId = "tab_pages",
getChangedColsTab(errorLst, pedigreeFile$name),
target = "Input",
position = "before", select = FALSE)
}
breederPed <- tryCatch(qcStudbook(breederPed, minParentAge),
warning = function(cond) {return(NULL)},
error = function(cond) {return(NULL)})
flog.debug(paste0("After qcStudbook.\n",
"contents rows: ", nrow(breederPed),
", columns: ", ncol(breederPed), "; col names: '",
paste(names(breederPed), collapse = "', '"), "'",
sep = ""),
name = "nprcgenekeepr")
}
}
flog.debug(paste0("before validate()."),
name = "nprcgenekeepr")
validate(need(!is.null(minParentAge),
paste0(" Error uploading data. ",
geterrmessage())) %then%
need(!is.null(breederPed), paste0(" Error uploading data. ",
geterrmessage()))
)
if (!is.null(breederPed)) {
updateTabsetPanel(session, "tab_pages", selected = "Pedigree Browser")
}
flog.debug(paste0("After validate(); nrow(breederPed) = ",
nrow(breederPed), "; ncol(breederPed): ",
ncol(breederPed)), name = "nprcgenekeepr")
breederPed
})
})
# Load and QA-QC the pedigree once a file has been specified
getPed <- reactive({
flog.debug(paste0("In ped <- reactive()\n"), name = "nprcgenekeepr")
if (is.null(getSelectedBreeders())) {
return(NULL)
}
flog.debug(paste0("In ped <- reactive() and ",
"!is.null(getSelectedBreeders()) == TRUE\n"),
name = "nprcgenekeepr")
ped <- getSelectedBreeders()
flog.debug(paste0("column names: '", paste(names(ped), collapse = "', '"),
"'"), name = "nprcgenekeepr")
flog.debug(" - after ped <- getSelectedBreeders() before tryCatch with ",
"setPopulation.", name = "nprcgenekeepr")
ped <- tryCatch({
ped <- getSelectedBreeders()
flog.debug(paste0("column names: '", paste(names(ped),
collapse = "', '"),
"'"), name = "nprcgenekeepr")
flog.debug(" - in tryCatch before setPopulation.",
name = "nprcgenekeepr")
## setPopulation adds the population column if not already present
## setPopulation indicates all id to be in the population if
## specifyFocalAnimals() is NULL
## otherwise ids returned by specifyFocalAnimals() are set to TRUE and
## others become FALSE
ped <- setPopulation(ped, specifyFocalAnimals())
flog.debug(paste0("column names: '", paste0(names(ped),
collapse = "', '"),
"'"), name = "nprcgenekeepr")
flog.debug(paste0("setPopulation() called\n"),
name = "nprcgenekeepr")
if (input$trim) {
probands <- ped$id[ped$population]
ped <- trimPedigree(probands, ped, removeUninformative = FALSE,
addBackParents = FALSE)
#ped <- trimPedigree(probands, ped, removeUninformative = TRUE,
# addBackParents = TRUE)
flog.debug(paste0("trimPedigree() called\n"),
name = "nprcgenekeepr")
}
ped["pedNum"] <- findPedigreeNumber(ped$id, ped$sire, ped$dam)
ped["gen"] <- findGeneration(ped$id, ped$sire, ped$dam)
ped
},
error = function(cond) {
return(FALSE)
})
validate(
need(ped, geterrmessage())
)
return(ped)
})
# Changing the active tab to the "Pedigree Browser" tab
observe({
status <- getSelectedBreeders()
if (!is.null(status))
updateTabsetPanel(session, "tab_pages", selected = "Pedigree Browser")
})
# Creating the pedigree table to be displayed on the Pedigree Browser tab
output$pedigree <- DT::renderDataTable(DT::datatable({
if (is.null(getPed())) {
return(NULL)
}
# convert columns to "character" so xtables displays them properly
ped <- toCharacter(getPed())
if (!input$uid) {
ped <- ped[!grepl("^U", ped$id, ignore.case = TRUE), ]
ped$sire[grepl("^U", ped$sire, ignore.case = TRUE)] <- NA
ped$dam[grepl("^U", ped$dam, ignore.case = TRUE)] <- NA
}
names(ped) <- headerDisplayNames(names(ped))
ped
}
)
)
specifyFocalAnimals <- eventReactive(input$specifyFocalAnimal, {
ped <- unlist(strsplit(input$focalAnimalIds, "[ ,;\t\n]"))
if (!is.null(input$focalAnimalUpdate)) {
if (!input$clearFocalAnimals) {
focalAnimalUpdate <- input$focalAnimalUpdate
flog.debug(paste0("focalAnimalUpdate - focalAnimalUpdate$name: ",
focalAnimalUpdate$name, "; ",
"focalAnimalUpdate$datapath: ",
focalAnimalUpdate$datapath),
name = "nprcgenekeepr")
} else {
focalAnimalUpdate <-
list(name = "emptyFocalAnimals.csv",
datapath = system.file("extdata", "emptyFocalAnimals.csv",
package = "nprcgenekeepr"))
flog.debug(paste0("focalAnimalUpdate - focalAnimalUpdate$name: ",
focalAnimalUpdate$name, "; ",
"focalAnimalUpdate$datapath: ",
focalAnimalUpdate$datapath),
name = "nprcgenekeepr")
}
focalAnimalUpdateDf <- unlist(read.table(focalAnimalUpdate$datapath,
header = TRUE,
sep = ",",
stringsAsFactors = FALSE,
na.strings = c("", "NA"),
check.names = FALSE))
flog.debug(paste0("focalAnimalUpdate - focalAnimalUpdateDf: ",
focalAnimalUpdateDf),
name = "nprcgenekeepr")
updateTextAreaInput(session, "focalAnimalIds",
label = paste0(focalAnimalUpdateDf),
value = paste0(focalAnimalUpdateDf))
ped <- focalAnimalUpdateDf
}
if (length(ped) == 0) {
return(NULL)
} else{
return(ped)
}
},
ignoreNULL = FALSE)
# Download handler to download the full or trimmed pedigree
output$downloadPedigree <- downloadHandler(
filename = function() {
paste("Pedigree", ".csv", sep = "")
},
content = function(file) {
write.csv(getPed(), file, na = "", row.names = FALSE)
}
)
#############################################################################
# Functions for handling the genetic value analysis generation
geneticValue <- eventReactive(input$analysis, {
if (is.null(getPed())) {
return(NULL)
}
# Ensuring the pedigree has been trimmed
# (if there are too many animals, the program will crash)
ped <- getPed()
probands <- ped$id[ped$population]
ped <- trimPedigree(probands, ped, removeUninformative = FALSE,
addBackParents = FALSE)
validate(
need(length(probands) != 0, "Error: No population specified")
)
# Setting up the progress bar
progress <- shiny::Progress$new()
on.exit(progress$close())
updateProgress <- function(n = 1, detail = NULL, value = 0, reset = FALSE) {
if (reset) {
progress$set(detail = detail, value = value)
} else{
progress$inc(amount = 1 / n)
}
}
#
return(reportGV(ped, guIter = input$iterations,
guThresh = as.integer(input$threshold),
byID = TRUE,
updateProgress = updateProgress))
})
# Returns the geneticValue() report
rpt <- reactive({
if (is.null(geneticValue())) {
return(NULL)
}
return(geneticValue()[["report"]])
})
# Functions for displaying the Genetic Value Analysis
gvaView <- reactive({
if (is.null(rpt())) {
return(NULL)
}
if (input$view == 0) {
return(rpt())
} else{
ids <- unlist(strsplit(isolate(input$viewIds), "[ ,;\t\n]"))
ids <- ids[stri_trim(ids) != ""]
if (length(ids) == 0) {
return(rpt())
} else{
return(filterReport(ids, rpt()))
}
}
})
output$gva <- DT::renderDataTable(DT::datatable({
if (is.null(rpt())) {
return(NULL)
}
g <- gvaView()
g$indivMeanKin <- round(g$indivMeanKin, 5)
g$zScores <- round(g$zScores, 2)
g$gu <- round(g$gu, 5)
g <- toCharacter(g)
names(g) <- headerDisplayNames(names(g))
return(g)
}))
# Download handlers for all or a subset of the Genetic Value Analysis
output$downloadGVAFull <- downloadHandler(
filename = function() {
paste("GVA_full", ".csv", sep = "")
},
content = function(file) {
write.csv(rpt(), file, na = "", row.names = FALSE)
}
)
output$downloadGVASubset <- downloadHandler(
filename = function() {
paste("GVA_subset", ".csv", sep = "")
},
content = function(file) {
write.csv(gvaView(), file, na = "", row.names = FALSE)
}
)
#############################################################################
# Functions for handling printing summary statistics and outputting the
# kinship matrix
kmat <- reactive({
if (is.null(geneticValue())) {
return(NULL)
}
return(geneticValue()[["kinship"]])
})
# Download handler for the kinship matrix
output$downloadKinship <- downloadHandler(
filename = function() {
paste("Kinship", ".csv", sep = "")
},
content = function(file) {
write.csv(kmat(), file, na = "")
}
)
output$summaryStats <- renderText({
if (is.null(geneticValue())) {
return(NULL)
}
f <- geneticValue()[["total"]]
nmf <- geneticValue()[["nMaleFounders"]]
nff <- geneticValue()[["nFemaleFounders"]]
fe <- geneticValue()[["fe"]]
fg <- geneticValue()[["fg"]]
mk <- summary(rpt()[, "indivMeanKin"])
gu <- summary(rpt()[, "gu"])
fe_title_txt <- JS(paste("Founder equivalents estimates the expected number
of equally contributing founders that would be
required to produce the observed genetic diversity
in the current population. $f_e = 1 / \\sigma;(p_{i_{2}})$"))
# </MATH>Where <MATH>p<sub>i</sub></MATH>is the proportion of the genes of
# the living,
# descendant population contributed by founder <MATH>i</MATH>."))
founder <- htmltools::withTags(table(
class = "display",
thead(
tr(
th("Known Founders"),
th("Known Female Founders"),
th("Known Male Founders"),
th(JS("Founder Equivalents")),
th("Founder Genome Equivalents"))),
tbody(td(as.character(f)), td(as.character(nff)), td(as.character(nmf)),
td(as.character(round(fe, digits = 2))),
td(as.character(round(fg, digits = 2))))))
header <- paste("<tr>",
"<th></th>",
"<th>Min</th>",
"<th>1st Quartile</th>",
"<th>Mean</th>",
"<th>Median</th>",
"<th>3rd Quartile</th>",
"<th>Max</th>",
"</tr>")
k <- paste("<tr>",
"<td>Mean Kinship</td>",
"<td>", as.character(round(mk["Min."], 4)), "</td>",
"<td>", as.character(round(mk["1st Qu."], 4)), "</td>",
"<td>", as.character(round(mk["Mean"], 4)), "</td>",
"<td>", as.character(round(mk["Median"], 4)), "</td>",
"<td>", as.character(round(mk["3rd Qu."], 4)), "</td>",
"<td>", as.character(round(mk["Max."], 4)), "</td>",
"</tr>")
g <- paste("<tr>",
"<td>Genome Uniqueness</td>",
"<td>", as.character(round(gu["Min."], 4)), "</td>",
"<td>", as.character(round(gu["1st Qu."], 4)), "</td>",
"<td>", as.character(round(gu["Mean"], 4)), "</td>",
"<td>", as.character(round(gu["Median"], 4)), "</td>",
"<td>", as.character(round(gu["3rd Qu."], 4)), "</td>",
"<td>", as.character(round(gu["Max."], 4)), "</td>",
"</tr>")
return(paste(founder, "<br>", "<br>", "<table>", header, k, g, "</table>"))
})
mkHistogram <- function() {
mk <- rpt()[, "indivMeanKin"]
avg <- mean(mk, na.rm = TRUE)
# std.dev <- sd(mk, na.rm = TRUE)
# upper <- avg + (2 * std.dev)
# lower <- avg - (2 * std.dev)
brx <- pretty(range(mk), 25)
ggplot(data.frame(mk = mk), aes(x = mk, y=..density..)) +
geom_histogram(bins = 25, color="darkblue", fill="lightblue",
breaks = brx) +
theme_classic() +
xlab("Kinship") + ylab("Frequency") +
ggtitle("Distribution of Individual Mean Kinship Coefficients") +
geom_vline(aes(xintercept = avg, color = "red"), linetype = "dashed",
show.legend = FALSE)# +
}
output$mkHist <- renderPlot({
if (is.null(rpt())) {
return(NULL)
}
mkHistogram()
})
zscoreHistogram <- function() {
z <- rpt()[, "zScores"]
avg <- mean(z, na.rm = TRUE)
# std.dev <- sd(z, na.rm = TRUE)
# upper <- avg + (2 * std.dev)
# lower <- avg - (2 * std.dev)
brx <- pretty(range(z), 25)
ggplot(data.frame(z = z), aes(x = z, y=..density..)) +
geom_histogram(bins = 25, color="darkblue", fill="lightblue",
breaks = brx) +
theme_classic() +
xlab("Z-Score") + ylab("Frequency") +
ggtitle("Distribution of Mean Kinship Coefficients Z-scores") +
geom_vline(aes(xintercept = avg, color = "red"), linetype = "dashed",
show.legend = FALSE)# +
}
output$zscoreHist <- renderPlot({
if (is.null(rpt())) {
return(NULL)
}
zscoreHistogram()
})
guHistogram <- function() {
gu <- rpt()[, "gu"]
avg <- mean(gu, na.rm = TRUE)
# std.dev <- sd(gu, na.rm = TRUE)
# upper <- avg + (2 * std.dev)
# lower <- avg - (2 * std.dev)
brx <- pretty(range(gu), 25)
ggplot(data.frame(gu = gu), aes(x = gu, y=..density..)) +
geom_histogram(color="darkblue", fill="lightblue", breaks = brx) +
theme_classic() +
xlab("Genome Uniqueness Score") + ylab("Frequency") +
ggtitle("Distribution of Genome Uniqueness") +
geom_vline(aes(xintercept = avg, color = "red"), linetype = "dashed",
show.legend = FALSE)
}
output$guHist <- renderPlot({
if (is.null(rpt())) {
return(NULL)
}
guHistogram()
})
meanKinshipBoxPlot <- function() {
gu <- rpt()[, "indivMeanKin"]
ggplot(data.frame(gu = gu), aes(x = 0, y = gu)) +
geom_boxplot(color="darkblue", fill="lightblue", notch = FALSE,
outlier.color = "red", outlier.shape = 1) +
theme_classic() + geom_jitter(width = 0.2) + coord_flip() +
ylab("Kinship") +
ggtitle("Boxplot of Individual Mean Kinship Coefficients") +
xlab("")
}
output$mkBox <- renderPlot({
if (is.null(rpt())) {
return(NULL)
}
meanKinshipBoxPlot()
})
zscoreBoxPlot <- function() {
gu <- rpt()[, "zScores"]
ggplot(data.frame(gu = gu), aes(x = 0, y = gu)) +
geom_boxplot(color="darkblue", fill="lightblue", notch = FALSE,
outlier.color = "red", outlier.shape = 1) +
theme_classic() + geom_jitter(width = 0.2) + coord_flip() +
ylab("Z-Score") +
ggtitle("Boxplot of Mean Kinship Coefficients Z-scores") +
xlab("")
}
output$zscoreBox <- renderPlot({
if (is.null(rpt())) {
return(NULL)
}
zscoreBoxPlot()
})
guBoxPlot <- function() {
gu <- rpt()[, "gu"]
ggplot(data.frame(gu = gu), aes(x = 0, y = gu)) +
geom_boxplot(color="darkblue", fill="lightblue", notch = FALSE,
outlier.color = "red", outlier.shape = 1) +
theme_classic() + geom_jitter(width = 0.2) + coord_flip() +
ylab("Genome Uniquness") + ggtitle("Boxplot of Genome Uniqueness") +
xlab("")
}
output$guBox <- renderPlot({
if (is.null(rpt())) {
return(NULL)
}
guBoxPlot()
})
box_and_whisker_desc <- paste0("The upper whisker extends from the hinge to
the largest value no further than 1.5 * IQR
from the hinge (where IQR is the
inter-quartile range, or distance between
the first and third quartiles). The lower
whisker extends from the hinge to the
smallest value at most 1.5 * IQR of the
hinge. Data beyond the end of the whiskers
are called \"outlying\" points and are plotted
individually.")
addPopover(session, "mkBox", "Mean Kinship Coefficients",
content = box_and_whisker_desc,
placement = "bottom", trigger = "hover", options = NULL)
addPopover(session, "zscoreBox", "Z-scores",
content = box_and_whisker_desc,
placement = "bottom", trigger = "hover", options = NULL)
addPopover(session, "guBox", "Genetic Uniqueness",
content = box_and_whisker_desc,
placement = "bottom", trigger = "hover", options = NULL)
# ##
# output$relations <- eventReactive(input$displayRelations, {
# DT::renderDataTable(DT::datatable({
# if (is.null(kmat())) {
# return(NULL)
# }
# j <- nrow(kmat()) * ncol(kmat())
# # Setting up the progress bar
# progress <- shiny::Progress$new()
# on.exit(progress$close())
# progress$set(message = "Finding Relationship Designations", value = 0)
# updateProgress <- function() {
# progress$inc(amount = 1 / j)
# }
#
# kin <- convertRelationships(kmat(), getPed(),
# updateProgress = updateProgress)
#
# progress$set(message = "Preparing Table", value = 1)
# r <- makeRelationClassesTable(kin)
#
# toCharacter(r)
# })
# )})
# Download handler for the male founders
output$downloadMaleFounders <- downloadHandler(
filename = function() {
paste("maleFounders", ".csv", sep = "")
},
content = function(file) {
mf <- geneticValue()[["maleFounders"]]
write.csv(mf, file, na = "")
}
)
# Download handler for the male founders
output$downloadFemaleFounders <- downloadHandler(
filename = function() {
paste("femaleFounders", ".csv", sep = "")
},
content = function(file) {
ff <- geneticValue()[["femaleFounders"]]
write.csv(ff, file, na = "")
}
)
# Download handler for the first-order relationships
output$downloadFirstOrder <- downloadHandler(
filename = function() {
paste("FirstOrder", ".csv", sep = "")
},
content = function(file) {
ped <- getPed()
r <- countFirstOrder(ped, ids = ped$id[ped$population])
write.csv(r, file, na = "")
}
)
output$downloadRelations <- downloadHandler(
filename = function() {
paste("Relations", ".csv", sep = "")
},
content = function(file) {
ped <- getPed()
probands <- ped$id[ped$population]
r <- convertRelationships(kmat(), getPed(), ids = probands)
write.csv()
}
)
## Save plots
output$downloadMeanKinshipCoefficientHistogram <- downloadHandler(
filename = "meanKinshipCoefficientHistogram.png",
content = function(file) {
device <- function(..., width, height) {
grDevices::png(..., width = width, height = height,
res = 300, units = "in")
}
ggsave(file, plot = mkHistogram(), device = "png")
}
)
output$downloadZScoreHistogram <- downloadHandler(
filename = "meanKinshipCoefficientsZscoreHistogram.png",
content = function(file) {
device <- function(..., width, height) {
grDevices::png(..., width = width, height = height,
res = 300, units = "in")
}
ggsave(file, plot = zscoreHistogram(), device = "png")
}
)
output$downloadGenomeUniquenessHistogram <- downloadHandler(
filename = "geneticUniquenessHistogram.png",
content = function(file) {
device <- function(..., width, height) {
grDevices::png(..., width = width, height = height,
res = 300, units = "in")
}
ggsave(file, plot = guHistogram(), device = "png")
}
)
output$downloadMeanKinshipCoefficientBoxPlot <- downloadHandler(
filename = "meanKinshipCoefficientsBox.png",
content = function(file) {
device <- function(..., width, height) {
grDevices::png(..., width = width, height = height,
res = 300, units = "in")
}
ggsave(file, plot = meanKinshipBoxPlot(), device = "png")
}
)
output$downloadZScoreBoxPlot <- downloadHandler(
filename = "meanKinshipCoefficientsZscoresBox.png",
content = function(file) {
device <- function(..., width, height) {
grDevices::png(..., width = width, height = height,
res = 300, units = "in")
}
ggsave(file, plot = zscoreBoxPlot(), device = "png")
}
)
output$downloadGenomeUniquenessBoxPlot <- downloadHandler(
filename = "geneticUniquenessBox.png",
content = function(file) {
device <- function(..., width, height) {
grDevices::png(..., width = width, height = height,
res = 300, units = "in")
}
ggsave(file, plot = guBoxPlot(), device = "png")
}
)
# ### Display Founders
# # Creating the male founder table for display on the Summary Statistics tab
# output$maleFounders <- DT::renderDataTable(DT::datatable({
# if (is.null(geneticValue()[["maleFounders"]])) {
# return(NULL)
# }
# # convert columns to "character" so xtables displays them properly
# ped <- toCharacter(geneticValue()[["maleFounders"]])
# names(ped) <- headerDisplayNames(names(ped))
# ped
# }))
# # Creating the male founder table for display on the Summary Statistics tab
# output$femaleFounders <- DT::renderDataTable(DT::datatable({
# if (is.null(geneticValue()[["femaleFounders"]])) {
# return(NULL)
# }
# # convert columns to "character" so xtables displays them properly
# ped <- toCharacter(geneticValue()[["femaleFounders"]])
# names(ped) <- headerDisplayNames(names(ped))
# ped
# }))
#
#
#############################################################################
# Functions for handling the breeding group formation process
textAreaWidget <- eventReactive(input$seedAnimals,{
seedAnimalList <- lapply(1:input$numGp, function(i) {
inputName <- paste0("curGrp", i)
textInputRow <-function (inputId,value) {
textAreaInput(inputId = inputName, paste0("Seed animals ", i),
value = "", rows = 5, cols = 20, resize = "both")
}
column(2, offset = 0, textInputRow(inputName, ""))
})
do.call(tagList, seedAnimalList)}, ignoreInit = FALSE)
getCurrentGroups <- reactive({
currentGroups <- vapply(seq_len(input$numGp), function(i){character(0)},
character(0))
for (i in 1:(input$numGp)) {
inputName <- paste0("curGrp", i)
if (is.null(input[[inputName]])) # seed animal option is not selected
break
currentGroups[[i]] <-
stri_remove_empty(unlist(strsplit(input[[inputName]], "[, \t\n]")))
}
currentGroups
})
output$currentGroups <- renderUI({textAreaWidget()})
output$getCurrentGroups <- renderText({getCurrentGroups()})
textMinParentAge <- eventReactive(input$group_formation_rb,{
minParentAgeLine <-
checkboxInput("useMinParentAge",
label = paste0("Animals will be grouped with the mother ",
"below the minimum parent age of ",
globalMinParentAge, "."),
value = FALSE)
do.call(tagList, list(minParentAgeLine))}, ignoreInit = FALSE)
output$minParentAge <- renderUI({textMinParentAge()})
bg <- eventReactive(input$grpSim, {
if (is.null(rpt())) {
return(NULL)
}
currentGroups <- getCurrentGroups()
currentGroupIds <- unlist(currentGroups)
ped <- getPed()
# Filter out unknown animals added into ped
ped <- removeUnknownAnimals(ped)
ids <- character(0)
if (input$group_formation_rb == "candidates")
ids <- unlist(strsplit(input$grpIds, "[, \t\n]"))
if (length(ids) > 0) {
ped <- resetGroup(ped, ids)
candidates <- ids
} else{
candidates <- getGrpIds()
}
# Assume an animal that is in the group can't also be a candidate
if (length(currentGroupIds) > 0) {
candidates <- setdiff(candidates, currentGroupIds)
}
# Filter out low-value animals if desired
useLv <- input$group_formation_rb != "high-value"
if (!useLv) {
rpt <- rpt()
lv <- rpt$id[rpt$value == "low value"]
candidates <- setdiff(candidates, lv)
}
candidates <- intersect(candidates, ped$id)
harem <- input$group_sex_rb == "harems"
validate(
need(length(candidates == 0), "No candidates defined"),
need(!(length(setdiff(candidates, ped$id)) > 0),
paste("Group candidates present that are",
"not in the provided pedigree\n",
paste(setdiff(candidates, ped$id), sep = "\n"))),
need(!(length(setdiff(currentGroupIds, ped$id)) > 0),
paste("Current group members present that",
"are not in the provided pedigree\n",
paste(setdiff(currentGroupIds, ped$id), sep = "\n")))
)
ignore <- input$ffRel
ignore <- if (ignore) list(c("F", "F")) else NULL
threshold <- input$kinThresh
if (input$useMinParentAge) {
minAge <- globalMinParentAge
output$minParentAge <- renderText({paste0(minAge)})
} else {
minAge <- input$minAge
}
withKin <- input$withKin
iter <- input$gpIter
numGp <- ({
input$numGp
})
sexRatio <- input$sexRatio
# Setting up the progress bar
progress <- shiny::Progress$new()
on.exit(progress$close())
progress$set(message = "Generating Groups", value = 0)
n <- 1
updateProgress <- function() {
progress$inc(amount = 1 / iter, detail = paste("Iteration:", n))
n <<- n + 1
}
grp <- groupAddAssign(candidates = candidates,
currentGroups = currentGroups,
kmat = kmat(),
ped = ped,
threshold = threshold,
ignore = ignore,
minAge = minAge,
iter = iter,
numGp = numGp,
harem = harem, sexRatio,
withKin = withKin,
updateProgress = updateProgress)
return(grp)
})
getGrpIds <- reactive({
ped <- getPed()
ped <- ped[is.na(ped$exit) & !is.na(ped$birth), ]
if ("group" %in% colnames(ped)) {
return(ped$id[ped$group])
} else{
return(ped$id[ped$population])
}
})
# Functions to handle breeding group display
observe({
if (!is.null(bg())) {
x <- length(bg()$group)
if (x > 1) {
gp <- list()
for (i in 1:(x - 1)) {
gp[paste("Group", as.character(i))] <- i
}
gp["Unused"] <- x
updateSelectInput(session, "viewGrp",
label = "Enter the group to view:",
choices = gp, selected = 1)
} else if (x == 1) {
updateSelectInput(session, "viewGrp",
label = "Enter the group to view:",
choices = list("Unused" = 1), selected = 1)
} else{
updateSelectInput(session, "viewGrp",
label = "Enter the group to view:",
choices = list(" " = 1), selected = 1)
}
}
})
bgGroupView <- reactive({
if (is.null(bg())) {
return(NULL)
}
i <- withinIntegerRange(input$viewGrp, minimum = 1,
maximum = input$numGp)[1]
gp <- bg()$group[[i]]
ped <- getPed()
gp <- addSexAndAgeToGroup(gp, ped)
gp$age <- round(gp$age, 1)
colnames(gp) <- c("Ego ID", "Sex", "Age in Years")
if (nrow(gp) == 0) {
return(NULL)
} else {
return(gp[order(gp$`Ego ID`), , drop = FALSE])
}
})
bgGroupKinView <- reactive({
if (is.null(bg()$groupKin)) {
return(NULL)
}
i <- as.numeric(input$viewGrp)
kmat <- bg()$groupKin[[i]]
kmat <- as.data.frame(round(kmat, 6))
if (nrow(kmat) == 0) {
return(NULL)
} else{
return(kmat)
}
})
output$breedingGroups <- DT::renderDataTable(DT::datatable({
if (is.null(bg())) {
return(NULL)
}
return(bgGroupView())
}))
output$breedingGroupKin <- DT::renderDataTable(DT::datatable({
if (is.null(bg()$groupKin)) {
return(NULL)
}
return(bgGroupKinView())
}))
# Download handler for the current group
output$downloadGroup <- downloadHandler(
filename = getDatedFilename(paste0("Group-", input$viewGrp, ".csv")),
content = function(file) {
write.csv(bgGroupView(), file, na = "", row.names = FALSE)
},
contentType = "text/csv"
)
output$downloadGroupKin <- downloadHandler(
filename = getDatedFilename(paste0("GroupKin-", input$viewGrp, ".csv")),
content = function(file) {
write.csv(bgGroupKinView(), file, na = "", row.names = TRUE)
},
contentType = "text/csv"
)
#############################################################################
# Function to handle display of pyramid plot
flog.debug("before renderPlot(getPyramidPlot(ped)))", name = "nprcgenekeepr")
output$pyramidPlot <- renderPlot(getPyramidPlot(getPed()))
flog.debug("after renderPlot(getPyramidPlot(ped)))", name = "nprcgenekeepr")
})
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.