使用 apply 函数清理代码

Question

如何使用 sapply 函数清理此代码？

Orig <- .45 
Adjusted <- matrix(1:130, nrow =13)

Original <- rbind(Orig,
                  Orig1 <- pmin(Orig*(1+Adjusted[1,]),100),
                  Orig2 <- pmin(Orig1*(1+Adjusted[2,]),100),
                  Orig3 <- pmin(Orig2*(1+Adjusted[3,]),100),
                  Orig4 <- pmin(Orig3*(1+Adjusted[4,]),100),
                  Orig5 <- pmin(Orig4*(1+Adjusted[5,]),100),
                  Orig6 <- pmin(Orig5*(1+Adjusted[6,]),100),
                  Orig7 <- pmin(Orig6*(1+Adjusted[7,]),100),
                  Orig8 <- pmin(Orig7*(1+Adjusted[8,]),100),
                  Orig9 <- pmin(Orig8*(1+Adjusted[9,]),100),
                  Orig10 <- pmin(Orig9*(1+Adjusted[10,]),100),
                  Orig11 <- pmin(Orig10*(1+Adjusted[11,]),100),
                  Orig12 <- pmin(Orig11*(1+Adjusted[12,]),100)
)

Answer 1

使用 lapply，而不是 sapply，同时创建自定义环境：

O_envir<-new.env()
O_envir$Orig<-.45
func<-function(n){
    O_envir$Orig<-pmin(O_envir$Orig*(1+Adjusted[n,]),100)
    return(O_envir$Orig)
}
rbind(O_envir$Orig,
      do.call(rbind,lapply(1:12,func)))

Answer 2

据我所知，不需要sapply。尝试这样的事情。

adj1 <- 1 + rbind(0, Adjusted)
adjprod <- apply(adj1, 2, cumprod)

result <- Orig * adjprod
result[result > 100] <- 100
result

Answer 3

这是一个 Rcpp 实现：

library('Rcpp');
cppFunction('
    NumericMatrix makeOriginal(double orig, int NR, int NC ) {
        NumericMatrix m(NR,NC);
        for (size_t c = 0; c < NC; ++c)
            m[c*NR] = orig;
        for (size_t r = 1; r < NR; ++r) for (size_t c = 0; c < NC; ++c) {
            size_t i = r+c*NR;
            m[i] = std::min<double>(m[i-1]*(i+1),100);
        }
        return m;
    }
');
makeOriginal(0.45,13L,10L);
##         [,1]   [,2]   [,3]   [,4]   [,5]   [,6]   [,7]   [,8]   [,9]  [,10]
##  [1,]   0.45   0.45   0.45   0.45   0.45   0.45   0.45   0.45   0.45   0.45
##  [2,]   0.90   6.75  12.60  18.45  24.30  30.15  36.00  41.85  47.70  53.55
##  [3,]   2.70 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00
##  [4,]  10.80 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00
##  [5,]  54.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00
##  [6,] 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00
##  [7,] 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00
##  [8,] 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00
##  [9,] 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00
## [10,] 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00
## [11,] 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00
## [12,] 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00
## [13,] 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00 100.00

编辑： 另一种方法，但相似：

cppFunction('
    NumericMatrix makeOriginal(double orig, int NR, int NC ) {
        NumericMatrix m(NR,NC);
        size_t len = NR*NC;
        for (size_t i = 0; i < len; ++i)
            m[i] = i%NR == 0 ? orig : std::min<double>(m[i-1]*(1+i),100);
        return m;
    }
');

使用 apply 函数清理代码

Clean code with sapply function

r

matrix

rbind