Question

我正在尝试优化一些样条算法，以执行样条回归领域中的向后选择。基本上，算法是：

采用k个具有n个分量的结向量。

消除第i个分量i=1,...,n。

使用结向量k[-i]，i=1,...,n估计样条回归。

选择一个残差平方和（RSS）较小的模型，然后估算该模型的BIC。

让k=k[-which.min(RSS)]。

再次启动算法，直到n=1。

我的代码是

library(splines)
prune<-function(K,y0,x,deg=3){
  KNOTS<-matrix(nrow = (length(K)),ncol=(length(K)-1))
  y<-y0
  BIC<-vector(length =(length(K)-1) )

  for(j in 1:(length(K)-1)){
    RSS<-vector(1:(length(K)))
    {for(i in 1:(length(K)))
      RSS[i]<-sum((y-lm(y~bs(x,knots = K[-i],Boundary.knots = c(min(x),max(x)),degree = deg,intercept = T)-1)$fitted.values)^2)
    }
    K<-K[-which.min(RSS)]
    for (k in 1:(length(K)))
      KNOTS[k,j]<-K[k]

    BIC[j]<-BIC(lm(y~bs(x,knots = K,Boundary.knots = c(min(x),max(x)),degree = deg,intercept = T)-1))
  }

  KSTAR<-as.vector(KNOTS[, which.min(BIC)])
  I<-which.min(BIC)
  KSTAR<-na.omit(KSTAR)  
  return(list(KSTAR,KNOTS,I))
}

其中K是结向量，y0是因变量，x是自变量，deg是B样条曲线的度。问题是，当我有很多观察结果时，比如说5000或10000，计算输出将花费太多。

我的R编程技能非常基础，可能为了提高速度可以用另一种方式编写东西。

能给我一些建议吗？

我一直在阅读有关加速R代码的博客，但老实说，我不知道如何应用预分配，向量化等方法。

例如，可以以

开头

x=(0:4000)/4000  
y=sin(4*x)+2*exp(-30*(4*x)^2)+rnorm(4000,0,0.1)
K=seq(0,4000,by=100)

我不是要你做我的工作，只是在寻求一些建议关于算法的结构。预先感谢！

Answer 1

代码中花费的大部分时间是通过重复的lm调用来完成的。如果您尝试以下操作，则可以看到此信息：

N <- 4000
x=(0:N)/N
y=sin(4*x)+2*exp(-30*(4*x)^2)+rnorm(N+1,0,0.1)
K=seq(0,N,by=100)
library(profvis)
profvis(prune1(K,x,y))

如果您分解了函数调用，

lm(y~bs(x,knots = K[-i],Boundary.knots = c(min(x),max(x)),degree = deg,intercept = T)-1)

为：

x1 <- bs(x,knots = K,degree = 3,intercept = T)
  lmod <- lm(y~x1-1)

bs，x1的输出仅在前几列中具有值。其余全为零。另外，由于您实际上并不需要lm提供的额外细节，因此可以进一步将其简化为基本要素。完成后，您的功能将更快：

library(rbenchmark)
library(MASS)
benchmark(a={
  x1 <- bs(x,knots = K,degree = 3,intercept = T)
  lmod <- lm(y~x1-1)
  RSS<-sum(lmod$residuals**2)
},
b={
  x1 <- bs(x,knots = K,degree = 3,intercept = T)
  x2 <- x1[,which(colSums(abs(x1))>0)]   # Removing zero columns
  x21 <- ginv(x2)            # Simplified lm. If you don't want to risk it,
  y1 <- x2 %*%(x21  %*% y)   # you can try: lmod <- lm(y~x2-1)
  RSS <- sum((y-y1)^2)       #              RSS<-sum(lmod$residuals**2)
},replications = 9)          
#   test replications elapsed relative user.self sys.self user.child sys.child
# 1    a            9   0.187    5.054     0.171    0.016          0         0
# 2    b            9   0.037    1.000     0.036    0.000          0         0
all.equal(lmod$residuals,as.numeric(y-y1),check.attributes = F)
# [1] TRUE

对于更大尺寸的数据，它甚至应该更快。您的最终功能将类似于：

prune1<-function(K,y0,x,deg=3){
  KNOTS<-matrix(nrow = (length(K)),ncol=(length(K)-1))
  y<-y0
  BIC<-numeric(length =(length(K)-1) )
  kmin <- 0
  for(j in 1:(length(K)-1)){
    min_rss=Inf
    for(i in 1:(length(K))){
      x1 <- bs(x,knots = K,degree = 3,intercept = T)
      x2 <- x1[,which(colSums(abs(x1))>0)]
      x21 <- ginv(x2)
      y1 <- x2 %*%(x21  %*% y)
      RSS <- sum((y-y1)^2)
      if(RSS<min_rss){
        min_rss <- RSS
        kmin <- i
      }
    }
    K<-K[-kmin]
    KNOTS[1:length(K),j]<-K
    x1 <- bs(x,knots = K,degree = deg,intercept = T)
    x2 <- x1[,which(colSums(abs(x1))>0)]
    lmod <- lm(y~x2-1)
    BIC[j]<-BIC(lmod)
  }

  KSTAR<-as.vector(KNOTS[, which.min(BIC)])
  I<-which.min(BIC)
  KSTAR<-na.omit(KSTAR)  
  return(list(KSTAR,KNOTS,I))
}

benchmark(a={l <- prune(K,y,x)},
          b={l1 <- prune1(K,y,x)},
          replications = 1)
# test replications elapsed relative user.self sys.self user.child sys.child
# 1    a            1  15.480    3.091    15.483        0          0         0
# 2    b            1   5.008    1.000     5.008        0          0         0

我还试用了10,000个观测值和100节的功能，并获得了3分钟的运行时间

R：寻找优化后向选择算法的建议

1 个答案: