R 使用ACGT的SNP等位基因数据创建概率矩阵

给出8个样品（A1-A8）的以下数据：

如果每一列是一个样本，每一行是一个可能编码为A、C、G、T的标记，我希望计算每一行的概率，即4个等位基因中任何一个的起源。例如，第1行的上述数据的输出应为

   A C G T
A1 0 0 0 1/7
A2 0 0 0 1/7 
A3 0 0 0 1/7
A4 0 0 0 1/7
A5 0 0 0 1/7
A6 0 0 0 1/7
A7 0 0 0 1/7
A8 0 1 0 0

由于第1行中有7个样本具有T，因此每个样本的概率为1/7。因为只有A8拥有C，所以有100%的概率将C分配给A8。对于第3行，输出应为

   A C G T
A1 1/6 0 0 0
A2 1/6 0 0 0 
A3 1/6 0 0 0
A4 1/2 0 0 0
A5 1/2 0 0 0
A6 1/6 0 0 0
A7 1/6 0 0 0
A8 1/6 0 0 0

总输出应为i 8x4矩阵列表，其中i等于行数

一个可重复使用的代码示例是：

states <- c("A1","A2","A3","A4","A5","A6","A7","A8") # Define the names of the states
A1 <- c("T","T","A") # Set the alleles for state A1 across 3 SNPs
A2 <- c("T","C","A") # Set the alleles for state A2 across 3 SNPs
A3 <- c("T","T","A") # Set the alleles for state A3 across 3 SNPs
A4 <- c("T","T","G") # Set the alleles for state A4 across 3 SNPs
A5 <- c("T","T","G") # Set the alleles for state A5 across 3 SNPs
A6 <- c("T","T","A") # Set the alleles for state A6 across 3 SNPs
A7 <- c("T","T","A") # Set the alleles for state A7 across 3 SNPs
A8 <- c("C","C","A") # Set the alleles for state A8 across 3 SNPs
theemissionmatrix <- matrix(t(c(A1,A2,A3,A4,A5,A6,A7,A8)), 8, 3, byrow = TRUE) # Create an 8 x 3 matrix
rownames(theemissionmatrix) <- states
theemissionmatrix # Print out the data matrix
   [,1] [,2] [,3]
A1 "T"  "T"  "A" 
A2 "T"  "C"  "A" 
A3 "T"  "T"  "A" 
A4 "T"  "T"  "G" 
A5 "T"  "T"  "G" 
A6 "T"  "T"  "A" 
A7 "T"  "T"  "A" 
A8 "C"  "C"  "A" 

test <- cbind(theemissionmatrix[,1]=="A",theemissionmatrix[,1]=="C",theemissionmatrix[,1]=="G",theemissionmatrix[,1]=="T")
colnames(test) <- c("A","C","G","T")

test
    [,1]  [,2]  [,3]  [,4]
A1 FALSE FALSE FALSE  TRUE
A2 FALSE FALSE FALSE  TRUE
A3 FALSE FALSE FALSE  TRUE
A4 FALSE FALSE FALSE  TRUE
A5 FALSE FALSE FALSE  TRUE
A6 FALSE FALSE FALSE  TRUE
A7 FALSE FALSE FALSE  TRUE
A8 FALSE  TRUE FALSE FALSE

状态尝试以下操作：

#data
df <- read.table(text="
A1 A2 A3 A4 A5 A6 A7 A8
T T T T T T T C 
T C T T T T T C
A A A G G A A A", header=TRUE, as.is=T)

#ACGT
allele <- c("A","C","G","T")

#get counts: loop samples loop alleles
lapply(1:nrow(df),function(sample){
  sapply(c("A","C","G","T"),
         function(x){
           p <- as.numeric(df[sample,]==x) / sum(df[sample,]==x)
           #check if it is `not a number`
           ifelse(is.nan(p),0,p)
           })
  })

#数据
df以下是一些备选方案（从@zx8754的答案中的“df”开始）：

选项1:
melt
+
table
+
prop.table
当存在
NaN
值时，不会很好地显示

library(reshape2)
dfL <- melt(as.matrix(df))
Levs <- c("A", "C", "G", "T") 
dfL$value <- factor(dfL$value, Levs) ## Just to be sure

prop.table(table(dfL[c(2, 3, 1)]), c(2, 3))
# , , Var1 = 1
# 
#     value
# Var2 A         C G         T
#   A1   0.0000000   0.1428571
#   A2   0.0000000   0.1428571
#   A3   0.0000000   0.1428571
#   A4   0.0000000   0.1428571
#   A5   0.0000000   0.1428571
#   A6   0.0000000   0.1428571
#   A7   0.0000000   0.1428571
#   A8   1.0000000   0.0000000
# 
# , , Var1 = 2
# 
#     value
# Var2 A         C G         T
#   A1   0.0000000   0.1666667
#   A2   0.5000000   0.0000000
# ..... OUTPUT TRUNCATED

选项3：
lappy
+
table
在重新构造数据之后
完全停留在R底，这里有另一个选择

Levs <- c("A", "C", "G", "T")
out <- data.frame(N = names(df), t(df), row.names=NULL)
Rows <- setdiff(names(out), "N")
out[Rows] <- lapply(out[Rows], function(x) factor(x, Levs))
Tables <- lapply(seq_along(Rows), function(x) {
  A <- prop.table(table(out[, 1], out[, Rows[x]]), 2)
  A[is.nan(A)] <- 0
  A
})

Levs这里有一个基本的R方法，依赖于
split
、
table
和
sweep
：

res <- lapply(split(as.matrix(df), 1:nrow(df)), factor, levels=unique(unlist(df)))
lapply(res, function(row) sweep(sapply(levels(row), '==', row), 1, table(row)[row], FUN='/'))

res如果您提供……您会得到更快的响应。如果您感谢您的建议，我已经添加了一个可行的示例，并尝试了。@user2895292接受和/或向上投票有用的答案。非常感谢您，这对我尝试的少量行非常有效。现在，它运行于所有46K行，我将报告它的执行情况。非常感谢，这对于我尝试的少量行非常有效，并且匹配了zx8754方法的输出。现在，它正在为所有46K行运行，我将报告它的性能。
Levs <- c("A", "C", "G", "T")
out <- data.frame(N = names(df), t(df), row.names=NULL)
Rows <- setdiff(names(out), "N")
out[Rows] <- lapply(out[Rows], function(x) factor(x, Levs))
Tables <- lapply(seq_along(Rows), function(x) {
  A <- prop.table(table(out[, 1], out[, Rows[x]]), 2)
  A[is.nan(A)] <- 0
  A
})

res <- lapply(split(as.matrix(df), 1:nrow(df)), factor, levels=unique(unlist(df)))
lapply(res, function(row) sweep(sapply(levels(row), '==', row), 1, table(row)[row], FUN='/'))