从矩阵乘法绘制矢量场 r

Question

我正在尝试打印基于矩阵乘法的矢量场。 问题是将打印值以进行矩阵乘法的 function 只能取一个数字。 当将一系列数字放入all.p function 时，output 不能用于矩阵乘法。 有没有办法改变all.p使得有多个输入时，矩阵乘法仍然有效，并且可以计算矢量场？ 代码在向量场 function 处失败，因为此vectorfield将值置于 0 到 1 的范围内，但all.p不能接受多个输入。

geno.fit = matrix(c(0.791,1.000,0.834,
                    0.670,1.006,0.901,
                    0.657,0.657,1.067), 
                  nrow = 3, 
                  ncol = 3,
                  byrow = T)

all.p <- function(p) {
  if (length(p)>1) {
    stop("More numbers in input than expected")
  }
  P = p^2
  PQ = 2*p*(1-p)
  Q = (1-p)^2  
  return(list=c(P=P,PQ=PQ,Q=Q))
}



library(pracma)
f <- function(x, y) all.p(x) %*% geno.fit %*% all.p(y)
xx <- c(0, 1); yy <- c(0, 1)

vectorfield(fun = f, xlim = xx, ylim = yy, scale = 0.1)

for (xs in seq(0, 1, by = 0.25)) {
  sol <- rk4(f, 0, 1, xs, 100)
  lines(sol$x, sol$y, col="darkgreen")
}
grid()

我还尝试使用 for 循环。

f <- function(x, y, n = 16) {
  space3 = matrix(NA,nrow = n,ncol = n)
  for (i in 1:(length(x))) {
    for (j in 1:(length(y))) {
      # Calculate mean fitness 
      space3[i,j] = all.p(x[i]) %*% geno.fit %*% all.p(y[j])
    }
  }
  return(space3)
  }
xx <- c(0, 1); yy <- c(0, 1)
f(seq(0,1,length.out = 16), seq(0,1,length.out = 16))
vectorfield(fun = f, xlim = xx, ylim = yy, scale = 0.1)

下面是使梯度上升的代码（没有向量）。

library(fields) # for image.plot 
res = 0.01
seq.x = seq(0,1,by = res)
space = outer(seq.x,seq.x,"*") 

pace2 = space
for (i in 1:length(seq.x)) {
  for (j in 1:length(seq.x)) {
    space[i,j] = all.p(1-seq.x[i]) %*% geno.fit %*% all.p(1-seq.x[j])
  }
}
round(t(space),3)
new.space = t(space)
image.plot(new.space)
by.text = 8
for (i in seq(1,length(seq.x),by = by.text)) {
  for (j in seq(1,length(seq.x),by = by.text)) {
    text(seq.x[i],seq.x[j],
         labels = round(new.space[i,j],4),
         cex = new.space[i,j]/2, 
         col = "black")
  }
}
contour(new.space,ylim=c(1,0),add = T, nlevels = 50)

我能够使矢量场 function 工作，但它没有显示我对之前梯度上升矢量场的期望：

两者如何调和？ （即，在梯度上升图像上绘制向量，这将显示最陡上升向量的正确方向）

Answer 1

这是我的解决方案：

library(fields) # for image.plot 
library(plotly)
library(raster)

# Genotype fitness matrix -------------------------------------------------
geno.fit = matrix(c(0.791,1.000,0.834,
                    0.670,1.006,0.901,
                    0.657,0.657,1.067), 
                  nrow = 3, 
                  ncol = 3,
                  byrow = T)
# Resolution 
res = 0.01
# Sequence of X 
seq.x = seq(0,1,by = res)
# Make a matrix 
space = outer(seq.x,seq.x,"*") 

# Function to calculate the AVERAGE fitness for a given frequency of an allele to get the expected frequency of genotypes in a population
all.p <- function(p) { # Takes frequency of an allele in the population 
  if (length(p)>1) { # Has to be only 1 number 
    stop("More numbers in input than expected")
  }
  P = p^2 # Gets the AA 
  PQ = 2*p*(1-p) # gets the Aa
  Q = (1-p)^2 # Gets the aa 
  return(list=c(P=P, # Return the values 
                PQ=PQ,
                Q=Q)) 
}
# Examples 
all.p(0)
all.p(1)
# Plot the matrix of all combinations of genotype frequencies
image.plot(space,
           ylim=c(1.05,-0.05), 
           ylab= "Percentage of Chromosome EF of TD form",
           xlab= "Percentage of Chromosome CD of BL form")
# Backup the data 
space2 = space
# calculate the average fitness for EVERY combination of frequency of 2 genotypes 
for (i in 1:length(seq.x)) {
  for (j in 1:length(seq.x)) {
    # Calculate mean fitness 
    space[i,j] = all.p(1-seq.x[i]) %*% geno.fit %*% all.p(1-seq.x[j])
  }
}
# Show the result 
round(t(space),3)

# Transform the space
new.space = t(space)
image.plot(new.space, 
           # ylim=c( 1.01,-0.01), 
           ylab= "Percentage of Chromosome EF of TD (Tidbinbilla) form",
           xlab= "Percentage of Chromosome CD of BL (Blundell) form")
# Add the numbers to get a better sense of the average fitness values at each point 
by.text = 8
for (i in seq(1,length(seq.x),by = by.text)) {
  for (j in seq(1,length(seq.x),by = by.text)) {
    text(seq.x[i],seq.x[j],
         labels = round(new.space[i,j],4),
         cex = new.space[i,j]/2, 
         col = "black") # col = "gray70"
  }
}
# Add contour lines 
contour(new.space,ylim=c(1,0),add = T, nlevels = 50)

# Plotly 3D graph  --------------------------------------------------------
# To get the 3D plane in an INTERACTIVE graph 
xyz=cbind(expand.grid(seq.x,
                      seq.x),
          as.vector(new.space))

plot_ly(x = xyz[,1],y = xyz[,2],z = xyz[,3],
        color = xyz[,3])


# Vector field on the Adaptive landscape ----------------------------------
library(tidyverse)
library(ggquiver)
raster2quiver <- function(rast, aggregate = 50, colours = terrain.colors(6), contour.breaks = 200)
{
  names(rast) <- "z"
  quiv <- aggregate(rast, aggregate)
  terr <- terrain(quiv, opt = c('slope', 'aspect'))
  quiv$u <- -terr$slope[] * sin(terr$aspect[])
  quiv$v <- -terr$slope[] * cos(terr$aspect[])
  quiv_df <- as.data.frame(quiv, xy = TRUE)
  rast_df <- as.data.frame(rast, xy = TRUE)
  
  print(ggplot(mapping = aes(x = x, y = y, fill = z)) + 
          geom_raster(data = rast_df, na.rm = TRUE) + 
          geom_contour(data = rast_df, 
                       aes(z=z, color=..level..),
                       breaks = seq(0,3, length.out = contour.breaks), 
                       size = 1.4)+
          scale_color_gradient(low="blue", high="red")+
          geom_quiver(data = quiv_df, aes(u = u, v = v), vecsize = 1.5) +
          scale_fill_gradientn(colours = colours, na.value = "transparent") +
          theme_bw())
  
  return(quiv_df)
}

r <-raster(
  space,
  xmn=range(seq.x)[1], xmx=range(seq.x)[2],
  ymn=range(seq.x)[1], ymx=range(seq.x)[2],
  crs=CRS("+proj=utm +zone=11 +datum=NAD83")
)

# Draw the adaptive landscape
raster2quiver(rast = r, aggregate = 2, colours = tim.colors(100)) 

不完全是我想要的，但它确实是我想要的！