Nothing
#' INTERNAL CONVERSION TOOLS FOR GENETIC DATA
#' @param X Input
#' @param ncod Number of digits coding each allele
#' (e.g., 1: x, 2: xx, 3: xxx, etc.). If NULL, ncod will we
#' obtained from the ploidy and the maximum number of characters
#' in the data cells.
#' @param sep.in Separator in the input
#' @param sep.out Separator in the output
#' @param ploidy Ploidy of the data.
#' @param chk.names Defalult TRUE. The function make checks of individuals
#' and loci names during conversion.
#' @param chk.plocod Defalult TRUE. The function checks coherence
#' in ploidy and number of digits coding alleles for loci data during conversion.
#' @keywords internal
#--------------------------------------------------------------------#
#-LOCUS MATRIX TO:
# locus matrix to allele matrix
# locus matrix to locus matrix
# locus matrix to locus list
# locus matrix to allele list
#-ALLELE MATRIX TO:
# allele matrix to locus matrix
# allele matrix to locus list
# allele matrix to allele list
#-LOCUS LIST TO:
# locus list to locus list
# locus list to allele list
# locus list to allele matrix
# locus list to locus matrix
#-ALLELE LIST TO:
# allele list to locus list
# allele list to locus matrix
# allele list to allele matrix
#--------------------------------------------------------------------#
# locus matrix to allele matrix
int.loc2al <- function(X,
ncod = NULL,
ploidy = 2,
sep.in = "",
sep.out = NULL,
chk.names = TRUE,
chk.plocod = TRUE) {
nind <- nrow(X)
nloc <- ncol(X)
X <- as.matrix(X, rownames.force = TRUE)
mode(X) <- "character"
# X <- gsub(sep.in, "", X)
if(chk.names) {
X <- int.check.colnames(X)
X <- int.check.rownames(X)
}
coldata <- int.loc2loc(X, ncod = ncod,
ploidy = ploidy,
sep.in = sep.in,
sep.out = "/",
chk.names = FALSE,
chk.plocod = chk.plocod)
# unfolding and creating a matrix with one allele per column
coldata[is.na(coldata)]<- paste(rep(NA, ploidy), collapse = "/")
coldata <- as.vector(t(coldata))
coldata <- unlist(strsplit(coldata, "/"))
coldata <- matrix(coldata, ncol = ploidy * nloc, nrow = nind, byrow = TRUE)
coldata[coldata == "NA"] <- NA
# column names configuration
if(ploidy != 1) {
nombres <- lapply(colnames(X),
function(x) paste(rep(x, ploidy), 1:ploidy, sep = "."))
nombres <- unlist(nombres)
} else {
nombres <- colnames(X)
}
#output mode
# no.numeric <- grep("[^[:digit:]]", coldata)
# if(length(no.numeric) == 0) {
# suppressWarnings(mode(coldata) <- "numeric")
# }
coldata <- aue.rmspaces(coldata)
coldata <- gsub("(NA)+", NA, coldata)
#coldata <- matrix(coldata, nrow = nind)
colnames(coldata) <- nombres
rownames(coldata) <- rownames(X)
coldata
}
#--------------------------------------------------------------------#
# allele matrix to locus matrix
int.al2loc <- function(X,
ncod = NULL,
ploidy,
sep.in = NULL,
sep.out = "",
chk.names = TRUE,
chk.plocod) {
X <- as.matrix(X, rownames.force = TRUE)
mode(X) <- "character"
if(ploidy != 1) {
nloc <- ncol(X) / ploidy
} else {
nloc <- ncol(X)
}
nom <- gsub("[.][^.]*$", "", colnames(X))
nom <- unique(nom)
if(chk.names) {
X <- int.check.colnames(X)
X <- int.check.rownames(X)
nom <- int.check.vnames(nom, len.X = nloc)
}
xseq <- aue.seqlist(1, ploidy * nloc, by = ploidy)
X.list <- lapply(1:ncol(xseq),
function(i) {
apply(X[, xseq[, i], drop = FALSE],
1,
function(y) paste(y, sep = "", collapse = sep.out)
)
})
X <- do.call(cbind, X.list)
X <- gsub("(NA)+", NA, X)
colnames(X) <- nom
X
}
#--------------------------------------------------------------------#
# locus matrix to locus matrix
int.loc2loc <- function(X,
ncod = NULL,
ploidy = 2,
sep.in = "",
sep.out = "",
chk.names = TRUE,
chk.plocod = TRUE) {
X <- as.matrix(X, rownames.force = TRUE)
mode(X) <- "character"
# X <- gsub(sep.in, "", X)
# control and configuration
if(length(sep.out) != 1) {
stop("sep.out must be a character of length 1")
}
if(chk.names) {
X <- int.check.colnames(X)
X <- int.check.rownames(X)
}
if(chk.plocod) {
ncod <- int.check.ncod(X, ploidy = ploidy, ncod = ncod, sep = sep.in)
}
# separate alleles with the character "sep.out"
if(sep.in != sep.out) {
if(sep.in == "") {
X <- gsub(paste("([[:alnum:]]{",ncod,"})",sep = ""),
paste("\\1", meta2char(sep.out), sep = ""), X)
X <- sub(paste(meta2char(sep.out), "$", sep = ""), "", X)
} else {
X <- gsub(sep.in, sep.out, X)
}
}
X[is.na(X)] <- paste(rep("NA", ploidy), sep.out, collapse = "", sep = "")
X <- sub(paste(meta2char(sep.out), "$", sep = ""), "", X)
X <- gsub("(NA)+", NA, X)
X
}
#--------------------------------------------------------------------#
# locus matrix to locus list
int.loc2list <- function(X,
ncod = NULL,
ploidy,
sep.in = "",
sep.out = "",
chk.names = TRUE,
chk.plocod = TRUE) {
#matrix contol included loc2loc
X <- int.loc2loc(X, ncod = ncod, ploidy = ploidy,
sep.in = sep.in, sep.out = sep.out,
chk.names = chk.names, chk.plocod = chk.plocod)
X.list <- list()
for(i in 1:ncol(X)) {
X.list[[i]] <- X[, i, drop = FALSE]
}
names(X.list) <- colnames(X)
X.list
}
#--------------------------------------------------------------------#
# allele matrix to locus list
int.al2list <- function(X, ncod = NULL, ploidy, sep.out = "", sep.in = NULL) {
X <- int.al2loc(X, ploidy = ploidy, sep.out = sep.out)
X.list <- list()
for(i in 1:ncol(X)) {
X.list[[i]] <- X[, i, drop = FALSE]
}
names(X.list) <- colnames(X)
X.list
}
#--------------------------------------------------------------------#
# locus matrix to allele list
int.loc2listal <- function(X,
ncod = NULL,
ploidy,
sep.in = "",
sep.out = NULL,
chk.names = TRUE,
chk.plocod = TRUE) {
nloc <- ncol(X)
#- to columns
listnames <- colnames(X)
if(chk.names) {
listnames <- int.check.vnames(listnames, len.X = ncol(X))
}
X <- int.loc2al(X, ncod = ncod, ploidy = ploidy, chk.names = FALSE,
chk.plocod = chk.plocod, sep.in = sep.in, sep.out = sep.out )
X.list <- list()
xseq <- aue.seqlist(1, ploidy * nloc, by = ploidy)
for(i in 1:ncol(xseq)) {
X.list[[i]] <- X[, xseq[, i], drop = FALSE]
}
names(X.list) <- listnames
X.list
}
#--------------------------------------------------------------------#
# allele matrix to allele list
int.al2listal <- function(X,
ncod = NULL,
ploidy,
sep.in = NULL,
sep.out = NULL,
chk.names = TRUE,
chk.plocod) {
if(ploidy != 1) {
nloc <- ncol(X) / ploidy
} else {
nloc <- ncol(X)
}
listnames <- gsub("[.][^.]*$", "", colnames(X))
listnames <- unique(listnames)
if(chk.names) {
listnames <- int.check.vnames(listnames, len.X = nloc)
}
X.list <- list()
xseq <- aue.seqlist(1, ploidy * nloc, by = ploidy)
for(i in 1:ncol(xseq)) {
X.list[[i]] <- X[, xseq[, i], drop = FALSE]
}
names(X.list) <- listnames
X.list
}
#--------------------------------------------------------------------#
# locus list to locus list
int.list2list <- function(X,
ncod = NULL,
ploidy = 2,
sep.in = "",
sep.out = "",
chk.names = TRUE,
chk.plocod = TRUE) {
out <- lapply(X, function(x) int.loc2loc(x,
ncod = ncod,
ploidy = ploidy,
sep.in = sep.in,
sep.out = sep.out,
chk.names = chk.names,
chk.plocod = chk.plocod))
out
}
#--------------------------------------------------------------------#
# locus list to allele list
int.list2listal <- function(X,
ncod = NULL,
ploidy = 2,
sep.in = "",
sep.out = NULL,
chk.names = TRUE,
chk.plocod) {
out <- lapply(X, function(x) int.loc2al(x,
ncod = ncod,
ploidy = ploidy,
sep.in = sep.in,
chk.names = chk.names))
out
}
#--------------------------------------------------------------------#
# allele list to locus list
int.listal2list <- function(X,
ncod = NULL,
ploidy = 2,
sep.in = NULL,
sep.out = "",
chk.names = NULL,
chk.plocod) {
out <- lapply(X,
function(x) {
tmp <- apply(x, 1, paste, sep = sep.out)
tmp <- gsub("(NA)+", NA, tmp)
tmp
})
out
}
#--------------------------------------------------------------------#
# locus list to locus matrix
int.list2loc <- function(X,
ncod = NULL,
ploidy = 2,
sep.in = "",
sep.out = "",
chk.names = TRUE,
chk.plocod = TRUE) {
out <- do.call(cbind, data)
out <- int.loc2loc(data, ncod = ncod, ploidy = ploidy,
sep.in = sep.in, sep.out = sep.out,
chk.names = chk.names, chk.plocod = chk.plocod)
out
}
#--------------------------------------------------------------------#
# locus list to allele matrix
int.list2al <- function(X,
ncod = NULL,
ploidy = 2,
sep.in = "",
sep.out = NULL,
chk.names = TRUE,
chk.plocod = TRUE) {
X <- do.call(cbind, X)
X<- int.loc2loc(X, ncod = ncod, ploidy = ploidy,
sep.in = sep.in, sep.out = "",
chk.names = chk.names, chk.plocod = chk.plocod)
X <- int.loc2al(X, ncod = ncod, ploidy = ploidy,
chk.names = FALSE)
X
}
#--------------------------------------------------------------------#
# allele list to locus matrix
int.listal2loc <- function(X,
ncod = NULL,
ploidy = 2,
sep.in = NULL,
sep.out = "",
chk.names = TRUE,
chk.plocod) {
X <- do.call(cbind, X)
X <- int.al2loc(data, ploidy = ploidy, sep.out = sep.out, chk.names = chk.names)
X
}
#--------------------------------------------------------------------#
# allele list to allele matrix
int.listal2al <- function(X,
ncod = NULL,
ploidy = NULL,
sep.in = NULL,
sep.out = NULL,
chk.names = NULL,
chk.plocod) {
do.call(cbind, X)
}
#--------------------------------------------------------------------#
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.