#!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!#
#!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!#
#!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!#
#!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!#
#!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!#
#
# 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.
#
#!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!#
#!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!#
#!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!#
#!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!#
#!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!#
#==============================================================================#
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#
# Below are methods for the MLG class. I will break up the sections into generic
# methods that are needed for them to make sense in the R world and custom
# generic methods that aren't generic in R, but need to be to make these work.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#
#==============================================================================#
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#
# GENERIC METHODS
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#
#==============================================================================#
#' Methods used for MLG objects
#'
#' Default methods for accessing and subsetting MLG objects.
#'
#' @rdname MLG-method
#' @param .Object a character, "MLG"
#' @param mlg a vector where each element assigns the multilocus genotype of
#' that individual in the data set.
#' @keywords internal
#' @docType methods
#' @seealso \code{\linkS4class{MLG}} \code{\linkS4class{genclone}}
#' \code{\linkS4class{snpclone}} \code{\link{visible}}
#' \code{\link{unique,MLG-method}} \code{\link{levels,MLG-method}}
#'
#' @author Zhian N. Kamvar
#==============================================================================#
setMethod(
f = "initialize",
signature("MLG"),
definition = function(.Object, mlg){
if (missing(mlg)){
return(.Object)
}
if (is.vector(mlg)){
mlg <- data.frame(list(expanded = mlg, original = mlg,
contracted = mlg, custom = factor(mlg)))
} else if (class(mlg) %in% "MLG"){
return(mlg)
}
slot(.Object, "cutoff") <- c(expanded = 0.0, contracted = 0.0)
slot(.Object, "mlg") <- mlg
slot(.Object, "visible") <- "original"
slot(.Object, "distname") <- "diss.dist"
slot(.Object, "distenv") <- .GlobalEnv
slot(.Object, "distargs") <- list()
slot(.Object, "distalgo") <- "farthest_neighbor"
return(.Object)
}
)
#==============================================================================#
#' @rdname MLG-method
#' @param x an MLG object
#' @param i a vector of integers or logical values to index the MLG vector.
#' @param all a logical value indicating whether or not to return the subset of
#' all MLG values or only the numeric.
#==============================================================================#
setMethod(
f = "[",
signature = "MLG",
definition = function(x, i, j, ..., all = FALSE, drop = TRUE){
if (missing(i)) i <- TRUE
if (missing(j) & all){ # Retain the state of the MLG object,
x@mlg <- x@mlg[i, ] # but return the subset rows.
return(x)
} else if (missing(j)){
j <- x@visible
}
return(x@mlg[i, j, ..., drop = drop])
}
)
#==============================================================================#
#' @rdname MLG-method
#' @param j One of
#' \itemize{
#' \item "original"
#' \item "expanded"
#' \item "contracted"
#' \item "custom"
#' }
#' @param value the vector of MLGs to replace. \strong{For internal use only}.
#==============================================================================#
setReplaceMethod(
f = "[",
signature = "MLG",
definition = function(x, i, j, value){
if (missing(j)) j <- x@visible
if (missing(i)) i <- TRUE
x@mlg[i, j] <- value
return(x)
}
)
#==============================================================================#
#' @rdname MLG-method
#' @param object an MLG object.
#==============================================================================#
setMethod(
f = "show",
signature("MLG"),
definition = function(object){
if (nrow(object@mlg) == 0){
print("an empty MLG object")
return()
}
cutoff <- ifelse(!object@visible %in% c("original", "custom"),
paste(" mlgs with a cutoff of", object@cutoff[object@visible]),
" mlgs")
dist <- ifelse(object@visible != "contracted",
".",
paste(" based on the function", object@distname))
cat(length(object), " ", object@visible, cutoff, dist, "\n", sep = "")
print(object@mlg[[object@visible]])
}
)
#==============================================================================#
#' @rdname MLG-method
#==============================================================================#
setMethod(
f = "length",
signature("MLG"),
definition = function(x){
callGeneric(x@mlg[[x@visible]])
})
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#
# MATH METHODS
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#
#==============================================================================#
#' @rdname MLG-method
#' @param e1 an MLG object
#' @param e2 a number
#==============================================================================#
setMethod(
f = "Ops",
signature = "MLG",
definition = function(e1, e2){
callGeneric(e1@mlg[[e1@visible]], e2)
}
)
#==============================================================================#
#' @rdname MLG-method
#==============================================================================#
setMethod(
f = "Math",
signature = "MLG",
definition = function(x){
callGeneric(x@mlg[[x@visible]])
}
)
#==============================================================================#
#' @rdname MLG-method
#' @param digits the number of digits to retain
#==============================================================================#
setMethod(
f = "Math2",
signature = "MLG",
definition = function(x, digits){
callGeneric(x@mlg[[x@visible]], digits)
}
)
#==============================================================================#
#' @rdname MLG-method
#' @param ... passed on to summary methods
#' @param na.rm passed on to summary methods
#==============================================================================#
setMethod(
f = "Summary",
signature = "MLG",
definition = function(x, ..., na.rm = FALSE){
callGeneric(x@mlg[[x@visible]], ..., na.rm)
}
)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#
# SHOULD BE BUT AREN'T GENERIC METHODS
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#
setGeneric("unique")
#==============================================================================#
#' Unique and Duplicated implementations for MLG objects
#'
#' internal use
#'
#' @rdname unique-methods
#' @aliases unique,MLG-method
#' @aliases unique,MLG,ANY-method
#' @param incomparables vector of values that cannot be compared
#' @param ... options passed on to the base function \link{unique} or \link{duplicated}.
#' @export
#' @keywords internal
#' @seealso \code{\link{visible}} \code{\linkS4class{MLG}}
#' \code{\link{genclone}} \code{\link{snpclone}}
#' \code{\link{initialize,MLG-method}} \code{\link{levels,MLG-method}}
#'
#' @docType methods
#==============================================================================#
setMethod(
f = "unique",
signature("MLG"),
definition = function(x, incomparables = FALSE, ...){
unique(x@mlg[[x@visible]], incomparables, ...)
}
)
setGeneric("duplicated")
#==============================================================================#
#' @rdname unique-methods
#' @aliases duplicated,MLG-method
#' @export
#' @docType methods
#==============================================================================#
setMethod(
f = "duplicated",
signature("MLG"),
definition = function(x, incomparables = FALSE, ...){
duplicated(x@mlg[[x@visible]], incomparables, ...)
}
)
setGeneric("levels")
#==============================================================================#
#' Unique and Duplicated implementations for MLG objects
#'
#' internal use
#'
#' @rdname levels-methods
#' @aliases levels,MLG-method
#' @param x an MLG object
#' @return a character vector showing the levels of custom MLGs or NULL if the
#' visible slot is not set to "custom"
#' @export
#' @keywords internal
#' @seealso \code{\link{visible}} \code{\linkS4class{MLG}}
#' \code{\link{genclone}} \code{\link{snpclone}}
#'
#' @docType methods
#==============================================================================#
setMethod(
f = "levels",
signature("MLG"),
definition = function(x){
return(levels(x[]))
}
)
setGeneric("levels<-")
#==============================================================================#
#' @rdname levels-methods
#' @aliases levels<-,MLG-method
#' @export
#' @docType methods
#==============================================================================#
setMethod(
f = "levels<-",
signature("MLG"),
definition = function(x, value){
if (x@visible != "custom"){
warning("Cannot assign levels unless you have custom MLGs.", .immediate = TRUE)
} else {
levels(x@mlg[[x@visible]]) <- value
}
return(x)
}
)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#
# ACCESSORS
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#
#==============================================================================#
#' Accessors for the MLG object
#'
#' \strong{This documentation is for developers of poppr.} The accessors here
#' are preferred over accessing the elements via the @@ symbol. Please use these
#' in your code when accessing MLG objects.
#'
#' @param x an MLG object
#' @param value see details
#' @return see details
#' @details These accessors are intended for internal use only. They only affect
#' MLG objects, not genind objects. Only visible and MLG2df are general for
#' all forms of MLG. The distargs and cutoff are specific for use in
#' mlg.filter or any function that offers filtering as an option. The argument
#' "value" will always take the type defined in the \code{\linkS4class{MLG}}
#' class.
#'
#' @rdname MLG-accessors
#' @aliases visible,MLG-method
#' @export
#' @keywords internal
#' @seealso \code{\link{MLG}} \code{\linkS4class{genclone}}
#' \code{\linkS4class{genlight}} \code{\link{initialize,MLG-method}}
#' \code{\link{levels,MLG-method}} \code{\link{unique,MLG-method}}
#'
#' @examples
#'
#' \dontrun{
#' # These examples will simply show you what you can do with these
#' set.seed(5000)
#' (x <- sample(10, 20, replace = TRUE))
#' (m <- new("MLG", x))
#'
#' # Visibility ------------------------------
#' visible(m) # original
#' visible(m) <- "contracted"
#' m # shows contracted MLGS
#'
#' # Conversion to data frame ----------------
#' MLG2df(m) # Grab the internal data frame
#'
#' # Distance function handling --------------
#' distname(m) # nei.dist
#' distargs(m) # list()
#' distalgo(m) # farthest
#' cutoff(m)
#'
#' distname(m) <- substitute("diss.dist")
#' distargs(m) <- list(percent = TRUE)
#' distalgo(m) <- "average"
#' cutoff(m)["contracted"] <- 0.2
#'
#' }
#==============================================================================#
setGeneric("visible", function(x) {
standardGeneric("visible")
})
setMethod(
f = "visible",
signature(x = "MLG"),
definition = function(x) {
return(x@visible)
})
#==============================================================================#
#' @rdname MLG-accessors
#' @aliases visible<-,MLG-method
#' @export
#==============================================================================#
setGeneric("visible<-", function(x, value) {
standardGeneric("visible<-")
})
setMethod(
f = "visible<-",
signature(x = "MLG"),
definition = function(x, value) {
x@visible <- value
return(x)
})
#==============================================================================#
#' @rdname MLG-accessors
#' @aliases MLG2df,MLG-method
#' @export
#==============================================================================#
setGeneric("MLG2df", function(x) {
standardGeneric("MLG2df")
})
setMethod(
f = "MLG2df",
signature(x = "MLG"),
definition = function(x) {
x@mlg
})
#==============================================================================#
#' @rdname MLG-accessors
#' @aliases distname,MLG-method
#' @export
#==============================================================================#
setGeneric("distname", function(x) {
standardGeneric("distname")
})
setMethod(
f = "distname",
signature(x = "MLG"),
definition = function(x) {
x@distname
})
#==============================================================================#
#' @rdname MLG-accessors
#' @aliases distenv,MLG-method
#' @export
#==============================================================================#
setGeneric("distenv", function(x) {
standardGeneric("distenv")
})
setMethod(
f = "distenv",
signature(x = "MLG"),
definition = function(x) {
x@distenv
})
#==============================================================================#
#' @rdname MLG-accessors
#' @aliases distname<-,MLG-method
#' @export
#==============================================================================#
setGeneric("distname<-", function(x, value) {
standardGeneric("distname<-")
})
setMethod(
f = "distname<-",
signature(x = "MLG"),
definition = function(x, value) {
x@distname <- value
return(x)
})
#==============================================================================#
#' @rdname MLG-accessors
#' @aliases distenv<-,MLG-method
#' @export
#==============================================================================#
setGeneric("distenv<-", function(x, value) {
standardGeneric("distenv<-")
})
setMethod(
f = "distenv<-",
signature(x = "MLG"),
definition = function(x, value) {
x@distenv <- value
return(x)
})
#==============================================================================#
#' @rdname MLG-accessors
#' @aliases distargs,MLG-method
#' @export
#==============================================================================#
setGeneric("distargs", function(x) {
standardGeneric("distargs")
})
setMethod(
f = "distargs",
signature(x = "MLG"),
definition = function(x) {
x@distargs
})
#==============================================================================#
#' @rdname MLG-accessors
#' @aliases distargs<-,MLG-method
#' @export
#==============================================================================#
setGeneric("distargs<-", function(x, value) {
standardGeneric("distargs<-")
})
setMethod(
f = "distargs<-",
signature(x = "MLG"),
definition = function(x, value) {
x@distargs <- value
return(x)
})
#==============================================================================#
#' @rdname MLG-accessors
#' @aliases distalgo,MLG-method
#' @export
#==============================================================================#
setGeneric("distalgo", function(x) {
standardGeneric("distalgo")
})
setMethod(
f = "distalgo",
signature(x = "MLG"),
definition = function(x) {
x@distalgo
})
#==============================================================================#
#' @rdname MLG-accessors
#' @aliases distalgo<-,MLG-method
#' @export
#==============================================================================#
setGeneric("distalgo<-", function(x, value) {
standardGeneric("distalgo<-")
})
setMethod(
f = "distalgo<-",
signature(x = "MLG"),
definition = function(x, value) {
x@distalgo <- value
return(x)
})
#==============================================================================#
#' @rdname MLG-accessors
#' @aliases cutoff,MLG-method
#' @export
#==============================================================================#
setGeneric("cutoff", function(x) {
standardGeneric("cutoff")
})
setMethod(
f = "cutoff",
signature(x = "MLG"),
definition = function(x) {
x@cutoff
})
#==============================================================================#
#' @rdname MLG-accessors
#' @aliases cutoff<-,MLG-method
#' @export
#==============================================================================#
setGeneric("cutoff<-", function(x, value) {
standardGeneric("cutoff<-")
})
setMethod(
f = "cutoff<-",
signature(x = "MLG"),
definition = function(x, value) {
x@cutoff <- value
return(x)
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.