Dear UseRs,
I wrote following function in order to solve Data Envelopment Analysis.
Reason for posting is that the function is slow when nrow(dat) is large.
I wonder if other functions could substitute the for() loop in the
code, such as mapply().
Can anybody help to rewrite the dea() function as efficiently as
possible?
The code is as follows:
------------------------------------------------------------------------
-------------------
dea <- function(dta, noutput = 1, rts = 1) {
#rts = 1: CRS
#rts = 2: VRS
# lpSolve library call
require(lpSolve)
# set number of outputs
s <- noutput
# set number of inputs
m <- dim(dta)[2] - s
# set number of observations
n <- dim(dta)[1]
# make output matrix
Y <- as.matrix(dta[,1:s])
# make input matrix
X <- as.matrix(dta[,-(1:s)])
# allocate result matrix
result <- matrix(0, nrow=n, ncol=1)
# define column names of result as ``eff''
colnames(result) <- "eff"
# If RTS is CRS
if(rts==1){
# make part of lhs constraint matrix
cond1 <- rbind(t(Y), -t(X))
# make inequality matrix
f.dir <- rep(">=", s+m)
# make objective matrix
f.obj <- c(1, rep(0,n))
# solve LP for all DMUs by using for syntax
for(i in 1:n){
# make part of lhs constraint matrix
cond2 <- matrix(c(rep(0, s), X[i,]), byrow=T)
# make final constraint matrix
f.con <- cbind(cond2, cond1)
# make rhs constraint
f.rhs <- c(Y[i,], rep(0, m))
# solve LP problem
result[i,'eff'] <- lp("min", f.obj, f.con, f.dir, f.rhs)
$solution[1]
}
}
# if RTS is VRS
if(rts == 2) {
cond1 <- rbind(t(Y), -t(X), matrix(rep(1, n), ncol=n))
# make inequality/equality matrix
f.dir <- c(rep(">=", s+m), "=")
f.obj <- c(1, rep(0, n))
for(i in 1:n){
# note that 0 is added in the part of lhs constraint matrix
cond2 <- matrix(c(rep(0, s), X[i,], 0), byrow=T)
f.con <- cbind(cond2, cond1)
# note that 1 is added in the rhs constraint matrix
f.rhs <- c(Y[i,], rep(0, m), 1)
result[i,'eff'] <- lp("min", f.obj, f.con, f.dir, f.rhs)
$solution[1]
}
}
return(result)
}
------------------------------------------------------------------------
--------------------
Thank you in advance.
______________________________________________
R-help@r-project.org mailing list
https://stat.ethz.ch/mailman/listinfo/r-help
PLEASE do read the posting guide http://www.R-project.org/posting-guide.html
and provide commented, minimal, self-contained, reproducible code.
