#!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!#
#!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!#
#!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!#
#!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!#
#!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!#
#
# This software was authored by Zhian N. Kamvar and Javier F. Tabima, graduate
# students at Oregon State University; Jonah C. Brooks, undergraduate student at
# Oregon State University; and Dr. Nik Grünwald, an employee of USDA-ARS.
#
# Permission to use, copy, modify, and distribute this software and its
# documentation for educational, research and non-profit purposes, without fee,
# and without a written agreement is hereby granted, provided that the statement
# above is incorporated into the material, giving appropriate attribution to the
# authors.
#
# Permission to incorporate this software into commercial products may be
# obtained by contacting USDA ARS and OREGON STATE UNIVERSITY Office for
# Commercialization and Corporate Development.
#
# The software program and documentation are supplied "as is", without any
# accompanying services from the USDA or the University. USDA ARS or the
# University do not warrant that the operation of the program will be
# uninterrupted or error-free. The end-user understands that the program was
# developed for research purposes and is advised not to rely exclusively on the
# program for any reason.
#
# IN NO EVENT SHALL USDA ARS OR OREGON STATE UNIVERSITY BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES, INCLUDING
# LOST PROFITS, ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION,
# EVEN IF THE OREGON STATE UNIVERSITY HAS BEEN ADVISED OF THE POSSIBILITY OF
# SUCH DAMAGE. USDA ARS OR OREGON STATE UNIVERSITY SPECIFICALLY DISCLAIMS ANY
# WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE AND ANY STATUTORY
# WARRANTY OF NON-INFRINGEMENT. THE SOFTWARE PROVIDED HEREUNDER IS ON AN "AS IS"
# BASIS, AND USDA ARS AND OREGON STATE UNIVERSITY HAVE NO OBLIGATIONS TO PROVIDE
# MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
#
#!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!#
#!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!#
#!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!#
#!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!#
#!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!#
#==============================================================================#
#' @method print ialist
#' @export
print.ialist <- function(x, ...){
cat("Index\n")
print(x$index)
cat("Samples\n")
if (nrow(x$samples) > 13){
print(utils::head(x$samples))
cat("...\n")
print(utils::tail(x$samples))
} else {
print(x$samples)
}
}
#' @method plot ialist
#' @export
plot.ialist <- function(x, y = NULL, ..., index = "rbarD", labsize = rel(3),
linesize = rel(1)){
poppr.plot(x$samples, pval = x$index[c(2, 4)], file = substitute(x),
observed = x$index[c(1, 3)], index = index, labsize = labsize,
linesize = linesize, ...)
}
#' @method print amova
#' @export
print.amova <- function(x, full = FALSE, ...)
{
if (all(names(x) %in% c("tab", "varcoef", "varcomp", "call"))){
PKG <- asNamespace("pegas")
} else {
PKG <- asNamespace("ade4")
}
PRINT <- get("print.amova", PKG, inherits = FALSE)
PRINT(x)
}
#' @method print popprtable
#' @export
print.popprtable <- function(x, ...){
call <- list(...)
if (length(call > 0) && names(call) %in% "digits"){
print.data.frame(x, ...)
} else {
print.data.frame(x, digits = 3, ...)
}
}
#' @method print locustable
#' @export
print.locustable <- function(x, ...){
call <- list(...)
if (length(call > 0) && names(call) %in% "digits"){
print.table(x, ...)
} else {
print.table(x, digits = 2, zero.print = ".", ...)
}
}
#' @method print pairia
#' @export
print.pairia <- function(x, ...){
print.locustable(x, ...)
}
#' @method plot pairia
#' @export
plot.pairia <- function(x, ..., index = "rbarD", low = "blue", high = "red",
limits = c(-0.2, 1)){
isrd <- index == "rbarD"
df.index <- x[, index, drop = TRUE]
theLoci <- strsplit(rownames(x), ":")
lnames <- unique(unlist(theLoci))
theTitle <- if (isrd) expression(paste(bar(r)[d])) else expression(paste(I[A]))
L1 <- factor(vapply(theLoci, "[[", character(1), 1), lnames)
L2 <- factor(vapply(theLoci, "[[", character(1), 2), rev(lnames))
df <- data.frame(value = df.index, L1 = L1, L2 = L2)
if (ncol(x) == 4) {
pval <- if (isrd) x[, "p.rD", drop = TRUE] else x[, "p.Ia", drop = TRUE]
dfp <- data.frame(pvalue = pval)
df <- cbind(df, dfp)
basic_plot <- ggplot(df, aes_string(x = "L1", y = "L2", fill = "value", label = "pvalue")) +
geom_tile() +
geom_text()
} else {
basic_plot <- ggplot(df, aes_string(x = "L1", y = "L2", fill = "value")) +
geom_tile()
}
basic_plot <- basic_plot +
scale_fill_gradient(low = low, high = high, limits = limits) +
scale_x_discrete(expand = c(0, -1)) +
scale_y_discrete(expand = c(0, -1)) +
theme(axis.title = element_blank(), title = element_text(size = rel(2))) +
myTheme +
labs(fill = theTitle)
print(basic_plot)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.