限制R中二次擬合的導數

Question

我需要對一些數據擬合二次模型，以基於3個變量（var.a，var.b，var.c）預測值（var.d）。 數據量受到限制，因此創建合理的擬合是不可行的。 但是，可以做出一些合理的假設，這些假設至少允許一個合理的擬合：

• 增加變種a->增加變種d
• 增加var.b->減少var.d
• 增加var.c->減少var.d

從數學上講，我可以說：變量a的偏導數（在變量a的定義范圍內）必須為正。 其他兩個變量均為負數。

問題是：如何將其實現到R的lm函數中。我想到的唯一事情是每次計算偏導數時都要進行“手動”擬合函數系數優化，並且排除所有解，其中他們不符合我的要求...

任何更智能的解決方案將不勝感激。

在下面，您將找到一個示例代碼，該示例代碼向您顯示了一些數據和非限制性lm擬合：

  # Get example data
df<-structure(list(var.a = c(21.2, 21.2, 21.2, 15.3, 12.4, 9.4, 
15.3, 5, 5, 12.4, 15.3, 5, 9.4, 12.4, 9.4), var.b = c(22.6, 23.8, 24.8,
25.1, 26.3, 27.5, 27.4, 36.8, 29.1, 29.1, 29.6, 33.1, 30.8, 31.7, 
33.8), var.c = c(1.65, 2.03, 2.74, 2.84, 3.4, 3.86, 4, 4.12, 
4.48, 4.88, 5.23, 5.41, 5.8, 6.42, 6.84), var.d = c(1.177, 1.196, 
1.234, 1.196, 1.179, 1.186, 1.209, 0.784, 1.116, 1.197, 1.212, 0.94, 1.149, 1.187, 1.109)),
.Names = c("var.a", "var.b", "var.c","var.d"), row.names = c(NA, -15L), class = "data.frame")

# Plot original data
library(plot3D)
par(mfrow = c(1, 1))
with(quakes, scatter3D(#x = long, y = lat, z = -depth, colvar = mag,
    x = df$var.a, y = df$var.b, z = df$var.c, colvar = df$var.d,
    type="h",
    pch = 16, cex = 1.5, 
    xlab = "df$var.a", ylab = "df$var.b",zlab = "df$var.c", clab = c("var.d"),
    xlim=c(5,21.2),ylim=c(22.6,36.8),zlim=c(0,10),
    ticktype = "detailed",
    theta = 25, d = 10,
    colkey = list(length = 0.5, width = 0.5, cex.clab = 0.75))
)

# Create a quadratic fit
# fit.df <- lm(df$var.d ~ poly(cbind(df$var.a, df$var.b, df$var.c),2, raw=T), data=df)
# This works fine, but "predict" further down the line does not like NA coefficients (different issue), that's why I translated the poly fit results to a standard lm...
fit.df <- lm(var.d ~ I(var.a^2)+I(var.a) + 
                    I(var.b^2) + I(var.b) +
                    I(var.a*var.b)+
                    I(var.a*var.c)+
                    I(var.b*var.c)+
                    I(var.c)+I(var.c^2), data=df)


# Check the model
summary(fit.df)

# Create grid for testing of partial derivatives
var.a.test<-c(5,9.4,12.4,15.3,21.2)
var.b.test<-rev(c(36.8,33.8,31.7,29.6,24.8))
var.c.test<-seq(1,10,1)
df.test<-expand.grid(var.a.test,var.b.test,var.c.test)
names(df.test)<-c("var.a","var.b","var.c")

# Predict the new var.d with the model
df.test$var.d.fit<-predict(fit.df, newdata=df.test)

# Plot the results over the grid
with(quakes, scatter3D(x = df.test$var.a, y = df.test$var.b, z = df.test$var.c, colvar = df.test$var.d,
    type="h",
    pch = 16, cex = 1.5, 
    xlab = "df.test$var.a", ylab = "df.test$var.b",zlab = "df.test$var.c", clab = "var.d",
    xlim=c(5,21.2),ylim=c(22.6,36.8),zlim=c(0,10),
    ticktype = "detailed",
    theta = 25, d = 10,
    colkey = list(length = 0.5, width = 0.5, cex.clab = 0.75))
)

# Result is not consistent with my restrictions
# No surprise, because I did not implement them yet

Answer 1

我的想法是使用二次編程而不是“ lm”。

library(quadprog)

M <- matrix( c( rep(1,nrow(df)),
                df$var.a * df$var.a,
                df$var.b * df$var.b,
                df$var.c * df$var.c,
                df$var.a,
                df$var.b,
                df$var.c,
                df$var.a * df$var.b,
                df$var.b * df$var.c,
                df$var.c * df$var.a ),
             nrow(df),
             10        )

A <- rbind(  matrix( c( 2*df$var.a,
                       rep(1,nrow(df)),
                       df$var.b,
                       df$var.c  ),
                     nrow(df), 4      ),
            -matrix( c( 2*df$var.b,
                        rep(1,nrow(df)),
                        df$var.a,
                        df$var.c  ),
                     nrow(df), 4      ),
            -matrix( c( 2*df$var.c,
                        rep(1,nrow(df)),
                        df$var.b,
                        df$var.a  ),
                     nrow(df), 4      )  )

Aind <- rbind( t(matrix(rep(c(4,2,5,8,10),nrow(df)),5,nrow(df))),
               t(matrix(rep(c(4,3,6,8, 9),nrow(df)),5,nrow(df))),
               t(matrix(rep(c(4,4,7,9,10),nrow(df)),5,nrow(df)))  )

bvec <- rep(0,3*nrow(df))

qp <- solve.QP.compact( Dmat = t(M)%*%M,
                        dvec = t(M) %*% df$var.d,
                        Amat = t(A),
                        Aind = t(Aind),
                        bvec = bvec,
                        meq=0,
                        factorized=FALSE)

d_approx <- function(abc,x)
{
  x[1] + x[2]*abc[1]^2 + x[3]*abc[2]^2 + x[4]*abc[3]^2 + x[5]*abc[1] + x[6]*abc[2] + x[7]*abc[3] + x[8]*abc[1]*abc[2] + x[9]*abc[2]*abc[3] + x[10]*abc[3]*abc[1]
}

如果“ x”是我們正在尋找的系數向量，則“ d”的近似值可以寫為

d_approx = x [1] + x [2] * a ^ 2 + x [3] * b ^ 2 + x [4] * c ^ 2 + x [5] * a + x [6] * b + x [ 7] * c + x [8] * ab + x [9] * bc + x [10] * ca。

令M為具有列1,a^2,b^2,c^2,a,b,c,a*b,b*c,c*a的矩陣。 那么M %*% d是上面的“ d”的近似值，所以

t(x) %*% t(M) %*% M %*% x - 2*t(d) %*% M %*% x + t(d)%*%d

是誤差平方和。 來自“ quadprog”包的函數“ solve.QP.compact”可以計算向量“ x”，該向量在附加線性約束下以A %*% x >= 0的形式最小化該平方誤差和。 d_approx關於“ a”的偏導數在“ x”中是線性的： 2*x[2]*a + x[5] + x[8]*b + x[10]*c 。 因此，這種偏導數為正的說法是可行的約束，對於其他偏導數也是如此。

“ solve.QP.compact”計算約束解以及無約束解。 后者同意“ lp”的結果：

> qp
$solution
 [1]  2.169440e+00  1.364438e-04 -2.515349e-17 -7.111370e-18 -4.630430e-02
 [6] -3.800905e-02  8.417128e-16  1.792880e-03 -2.071742e-17 -1.688799e-17

$value
[1] -9.797515

$unconstrained.solution
 [1]  8.9121756902  0.0009357732  0.0072692251 -0.0037239683 -0.2392086131
 [6] -0.5145628191  0.6099481094  0.0099390059 -0.0123152238 -0.0133647655

$iterations
[1] 8 0

$Lagrangian
 [1] 0.87345970 0.00000000 0.00000000 0.00000000 0.00000000 0.00000000
 [7] 0.00000000 0.00000000 0.00000000 0.00000000 0.00000000 0.00000000
[13] 0.00000000 0.00000000 0.00000000 0.51565123 0.00000000 0.26065656
[19] 0.00000000 0.00000000 0.00000000 0.00000000 0.00000000 0.00000000
[25] 0.00000000 0.00000000 0.00000000 0.00000000 0.00000000 0.00000000
[31] 0.30858510 0.00000000 0.00000000 0.00000000 0.00000000 0.00000000
[37] 0.00000000 0.18092816 0.01762177 0.00000000 0.00000000 0.00000000
[43] 0.00000000 0.00000000 0.34055654

$iact
[1] 39 45 16 38 31  1 18

> 

讓我們看看是否違反了約束：

> d_test_approx <- d_approx(df.test[,1:3],qp$solution)

> n1 <- which(diff(df.test[,1])>0 & diff(df.test[,2])==0 & diff(df.test[,3])==0)

> which( d_test_approx[n1+1,] - d_test_approx[n1,] < 0 )
integer(0)

> n2 <- which(diff(df.test[,1])==0 & diff(df.test[,2])>0 & diff(df.test[,3])==0)

> which( d_test_approx[n2+1,] - d_test_approx[n2,] > 0 )
integer(0)

> n3 <- which(diff(df.test[,1])==0 & diff(df.test[,2])==0 & diff(df.test[,3])>0)

> which( d_test_approx[n3+1,] - d_test_approx[n3,] > 0 )
integer(0)
> 

我幾乎可以確定我的公式充滿了錯誤的計算，但是使用二次編程的想法也許值得嘗試。