Question

我需要确定由离散数据点表示的一系列曲面下方的音量。在我的数据中，每个样本作为单独的数据帧存储在数据帧列表中。以下是一些（小）示例数据：

df1 <- data.frame(x=c(2,2,2,3,3,3,4,4,4,5,5,5,6,6,6),
                  y=c(1,2,3,1,2,3,1,2,3,1,2,3,1,2,3),
                  z=c(0,2,0,4,6,7,3,2,1,2,7,8,9,4,2))

df2 <- data.frame(x=c(2,2,2,3,3,3,4,4,4,5,5,5,6,6,6),
                  y=c(1,2,3,1,2,3,1,2,3,1,2,3,1,2,3),
                  z=c(1,1,2,3,5,6,2,1,3,3,8,9,8,3,1))

DF <- list(df1,df2)

类似问题的答案可能是其他语言（matlab，python），或者答案中没有可用的脚本来解决问题（as here）。我可以想出两种可接受的方法来估计每个表面下的音量：1）写出一个离散化版本的simpson规则作为R中的函数，应用于数据帧列表（DF）; 2）计算x，y和z之间的任意关系，并使用多元数值积分来找到表面下的体积（在pracma包中使用simpson2d / quad2d或者在cubature中使用adaptIntegrate）。

关于第一种方法，复合simpson规则（我想使用）的公式是here，但由于其复杂性，我在写一个有效的双重求和方面没有成功功能。在该表达式中，I（lambda（em）lambda（ex））在每个x，y网格点的上述数据集中等于z，并且Delta（em）和Delta（ex）表示x和y点之间的间隔。

第二种方法基本上将方法found here扩展到多变量样条拟合，然后将预测的z值作为积分函数传递。以下是我迄今为止尝试过的方法：

require(pracma)

df1.loess <- loess(z ~ x + y, data=DF[[1]])
mod.fun <- function(x,y) predict(df1.loess, newdata=x,y)

simpson2d(mod.fun, x=c(2,6), y=c(1,3))

但这不会产生有用的结果。

实际上，我有一个包含单个样本的近100个数据帧的列表，所以我真的需要能够将解决方案表达为一系列lapply函数，这些函数可以在列表中的所有数据帧中自动执行这些计算。一个例子看起来像这样：

require(akima)
DF.splines <- lapply(DF, function(x,y,z) interp(x = "x", y = "y", z = "z",
                                                linear=F, nx=4, ny=2))

不幸的是，这会导致缺失值和Infs的异常。我对如何成功实施其中一种策略或使用不同（更简单的？）方法的建议非常开放。 kriging函数（如DiceKriging包中的km）是否可以产生更好的拟合，可以传递给数值积分？

Answer 1

您可以通过 pracma 包中的函数barylag2d中实现的“重心拉格朗日”方法来近似表面。然后，为了避免任何矢量化问题，明确应用高斯求积法则。

library(pracma)

df1 <- data.frame(x=c(2,2,2,3,3,3,4,4,4,5,5,5,6,6,6),
                  y=c(1,2,3,1,2,3,1,2,3,1,2,3,1,2,3),
                  z=c(0,2,0,4,6,7,3,2,1,2,7,8,9,4,2))

# Define the nodes in x- and y-direction
xn <- df1$x[c(1,4,7,10,13)]
yn <- df1$y[1:3]

# Define the matrix representing the function
m1 <- matrix(df1$z, nrow=5, byrow=TRUE)
f <- function(x, y) 
        c(pracma::barylag2d(m1, xn, yn, x, y))

# 32 nodes in integration intervals
n <- 32
xa <- 2; xb <- 6; ya <- 1; yb <- 3

# Apply quadrature rules explicitely
cx <- gaussLegendre(n, xa, xb)
x <- cx$x; wx <- cx$w
cy <- gaussLegendre(n, ya, yb)
y <- cy$x; wy <- cy$w

# Sum weights * values over all nodes
I <- 0
for (i in 1:n) {
  for (j in 1:n) {
    I <- I + wx[i] * wy[j] * f(x[i], y[j])
  }
}
I  # 40.37037

根据数据，40的积分值似乎是合理的。 <{1}}或simpson2d无法在此设置中使用。

您可以尝试quad2d是否可以使用如此定义的函数adaptIntegrate。

Answer 2

我假设体积表面网格是通过直线连接点来定义的。然后你可以通过

找到该表面下方的体积

将(x,y)网格三角形细分为区域为T_i的三角形A_i
为每个三角形z找到相应的Z_i值T_i
通过V_i计算截断棱柱（由T_i和Z_i定义）的体积V_i=A_i*sum(Z_i)/3（请参阅https://en.wikipedia.org/wiki/Prism_(geometry)和https://math.stackexchange.com/questions/2371139/volume-of-truncated-prism）
总结所有截断的棱镜卷V_i

但请注意，音量确实取决于您的曲面细分以及曲面细分不是唯一的。但是你的问题没有完全定义，因为它没有描述如何在点之间进行插值。因此，任何计算量的方法都必须做出额外的假设。

回到我的解决方案方法，可以通过geometry包实现第1点和第2点。这里有一些代码

library(geometry)

getVolume=function(df) {
  #find triangular tesselation of (x,y) grid
  res=delaunayn(as.matrix(df[,-3]),full=TRUE,options="Qz")
  #calulates sum of truncated prism volumes
  sum(mapply(function(triPoints,A) A/3*sum(df[triPoints,"z"]),
             split.data.frame(res$tri,seq_along(res$areas)),
             res$areas))
}

sapply(DF,getVolume)
#[1] 32.50000 30.33333

由于很难检查结果是否一致，这里有一个简单的例子，我们知道正确的答案。这是一个边长为2的立方体，我们沿x轴切出一个楔形。切口区域是总体积的1/4。

cutOutCube=expand.grid(c(0,1,2),c(0,1,2))
colnames(cutOutCube)=c("x","y")
cutOutCube$z=ifelse(cutOutCube$x==1,1,2)

sapply(list(cutOutCube),getVolume)
#[1] 6

自2^3*(1-1/4)=6以来这是正确的。

可以通过计算体积w.r.t的“补码”来执行另一种健全性检查。到一个简单的长方体，其中所有z值都设置为最大z值（在您的情况下max(z)=9两种情况下）。对于您的两种情况，简单的长方体体积为72。不要让我们定义补充曲面并总结音量和补充音量

df1c=df1
df1c$z=max(df1c$z)-df1c$z
df2c=df2
df2c$z=max(df2c$z)-df2c$z
DFc=list(df1c,df2c)

sapply(DFc,getVolume)+sapply(DF,getVolume)
#[1] 72 72

因此，在两种情况下，音量和补充音量都会给出正确的长方体音量。

如何计算离散数据定义的曲面下的体积？

2 个答案: