R/summary.dea_fuzzy.R
In rbensua/deaR: Conventional and Fuzzy Data Envelopment Analysis
Defines functions
summary.dea_fuzzy
Documented in
summary.dea_fuzzy
#' @title Summary Fuzzy DEA models.
#'
#' @description Summary of the results obtained by a fuzzy DEA model.
#'
#' @param object An object of class \code{"dea_fuzzy"} obtained with a fuzzy DEA
#' model function (\code{modelfuzzy_guotanaka}, \code{modelfuzzy_kaoliu},
#' \code{modelfuzzy_possibilistic}).
#' @param ... Extra options.
#' @param exportExcel Logical value. If TRUE (FALSE by default) the results are
#' also exported to an Excel file.
#' @param filename Character string. Absolute file name (including path) of the exported Excel file.
#' If NULL, then the file name will be "ResultsDEA" + timestamp.xlsx.
#' @param returnList Logical value. If TRUE then the results are given as a list of data frames.
#' If FALSE (default) all the data frames are merged into a single data frame.
#'
#' @return If the model is that from Guo and Tanaka (\code{modelfuzzy_guotanaka}), it returns a data.frame
#' with columns: DMU, alpha cuts and efficiencies.
#' For the possibilistic model (\code{modelfuzzy_possibilistic}) it returns a data.frame with columns:
#' DMU, alpha-cuts, efficiencies and the corresponding lambda values
#' For the Kao-Liu model (\code{modelfuzzy_kaoliu}), the result may depend on the crisp sub-model used.
#' It will contain a data.frame with the efficiencies (if any), the slacks and superslacks (if any),
#' the lambda values and the targets.
#'
#' If \code{exportExcel} is TRUE, then an Excel file will be created containing as many
#' sheets as necessary depending on the variables returned.
#'
#' @author
#' \strong{Vicente Coll-Serrano} (\email{vicente.coll@@uv.es}).
#' \emph{Quantitative Methods for Measuring Culture (MC2). Applied Economics.}
#'
#' \strong{Vicente Bolós} (\email{vicente.bolos@@uv.es}).
#' \emph{Department of Business Mathematics}
#'
#' \strong{Rafael Benítez} (\email{rafael.suarez@@uv.es}).
#' \emph{Department of Business Mathematics}
#'
#' University of Valencia (Spain)
#'
#' @examples
#' data("Leon2003")
#' data_example <- make_deadata_fuzzy(Leon2003,
#' inputs.mL = 2,
#' inputs.dL = 3,
#' outputs.mL = 4,
#' outputs.dL = 5)
#' result <- modelfuzzy_possibilistic(data_example,
#' h = seq(0, 1, by = 0.1),
#' orientation = "io",
#' rts = "vrs")
#' summary(result)
#'
#' @references
#' Leon, T.; Liern, V. Ruiz, J.; Sirvent, I. (2003). "A Possibilistic Programming
#' Approach to the Assessment of Efficiency with DEA Models", Fuzzy Sets and Systems,
#' 139, 407–419. \doi{10.1016/S0165-0114(02)00608-5}
#'
#' @method summary dea_fuzzy
#'
#' @import writexl tidyr
#'
#' @export
summary.dea_fuzzy <- function(object,
...,
exportExcel = FALSE,
filename = NULL,
returnList = FALSE) {
if (!is.dea_fuzzy(object)) {
stop("Input should be of class dea_fuzzy!")
}
modelname <- object$modelname
# For CRAN - check pass
DMU <- NULL
# Guo-Tanaka -----------------------
if (modelname == "fuzzy_guotanaka") {
eff <- efficiencies(object)
if (!returnList) {
effmat <-
do.call(rbind, lapply(seq(dim(eff)[3]), function(x)
eff[, , x]))
effdf <- cbind(data.frame(
DMU = dimnames(effmat)[[1]],
hlevel = rep(object$h, each = dim(eff)[1])
),
data.frame(effmat, row.names = NULL))
if (exportExcel) {
if (is.null(filename)) {
filename <- paste("ResultsDEA", Sys.time(), ".xlsx", sep = "")
filename <- gsub(" ", "_", filename)
filename <- gsub(":", ".", filename)
}
write_xlsx(effdf, path = filename)
}
return(effdf)
} else {
efflist <- lapply(seq(dim(eff)[3]), function(x)
eff[, , x])
names(efflist) <- paste("h =", dimnames(eff)[[3]])
if (exportExcel) {
if (is.null(filename)) {
filename <- paste("ResultsDEA", Sys.time(), ".xlsx", sep = "")
filename <- gsub(" ", "_", filename)
filename <- gsub(":", ".", filename)
}
write_xlsx(efflist, path = filename)
}
return(efflist)
}
# Possibilistic --------------------
} else if (modelname == "fuzzy_possibilistic_basic") {
# Efficiencies
eff <- efficiencies(object)
eff <- cbind(data.frame(DMU = dimnames(eff)[[1]]),
data.frame(eff, row.names = NULL))
eff %>% gather(key = "hlevel", value = "efficiency", -DMU) -> eff
eff$hlevel <- rep(object$h, each = length(object$data$dmunames))
eff <- eff[,c(2,1,3)]
# Lambdas
lamb <- lambdas(object)
lamblist <- lapply(seq(dim(lamb)[3]), function(x)
lamb[, , x])
lambmat <- do.call(rbind, lamblist)
if (!returnList) {
df <- cbind(eff, data.frame(lambmat, row.names = NULL))
if (exportExcel) {
if (is.null(filename)) {
filename <- paste("ResultsDEA", Sys.time(), ".xlsx", sep = "")
filename <- gsub(" ", "_", filename)
filename <- gsub(":", ".", filename)
}
write_xlsx(df, path = filename)
}
return(df)
} else {
lambdas = data.frame(hlevel = eff$hlevel, DMU =eff$DMU, data.frame(lambmat, row.names = NULL))
reslist <- list(efficiencies = eff, lambdas = lambdas)
if (exportExcel) {
if (is.null(filename)) {
filename <- paste("ResultsDEA", Sys.time(), ".xlsx", sep = "")
filename <- gsub(" ", "_", filename)
filename <- gsub(":", ".", filename)
}
write_xlsx(reslist, path = filename)
}
return(reslist)
}
# Kao - Liu ---------------------
} else {
modelkl <- strsplit(object$modelname, "_")[[1]][3]
# Efficiencies ----------
if (!modelkl %in% c("addsupereff")) {
eff <- efficiencies(object)
# Radial models ----------------
if (!modelkl %in% c("nonradial", "deaps")) {
eff.Worst <- data.frame(eff$Worst, stringsAsFactors = FALSE)
eff.Worst <-
data.frame(cbind(data.frame(DMU = rownames(eff.Worst)),
eff.Worst),
row.names = NULL)
eff.Worst %>% gather(key = "alphacut",
value = "efficiency.Worst", -DMU) -> eff.Worst
eff.Worst$alphacut <- rep(object$alpha,
each = length(object$data$dmunames))
eff.Best <- data.frame(eff$Best, stringsAsFactors = FALSE)
eff.Best <-
data.frame(cbind(data.frame(DMU = rownames(eff.Best)), eff.Best), row.names = NULL)
eff.Best %>% gather(key = "alphacut", value = "efficiency.Best", -DMU) -> eff.Best
eff.Best$alphacut <-
rep(object$alpha, each = length(object$data$dmunames))
eff.df <- merge(eff.Worst, eff.Best, by = c("DMU", "alphacut"))
} else {
# Non - radial models-----------------
neff <- length(object$alphacut[[1]]$DMU$Worst[[1]]$efficiency)
if(neff > 1){
effmat.Worst <-
do.call(rbind, lapply(seq(dim(eff$Worst)[3]), function(x)
eff$Worst[, , x]))
effdf.Worst <-
cbind(
data.frame(
DMU = dimnames(effmat.Worst)[[1]],
alphacut = rep(object$alpha, each = dim(eff$Worst)[1])
),
data.frame(effmat.Worst, row.names = NULL)
)
colnames(effdf.Worst)[3:(ncol(effdf.Worst))] <-
paste("eff", colnames(effdf.Worst)[3:(ncol(effdf.Worst))], "Worst", sep = ".")
effmat.Best <-
do.call(rbind, lapply(seq(dim(eff$Best)[3]), function(x)
eff$Best[, , x]))
effdf.Best <-
cbind(
data.frame(
DMU = dimnames(effmat.Best)[[1]],
alphacut = rep(object$alpha, each = dim(eff$Best)[1])
),
data.frame(effmat.Best, row.names = NULL)
)
colnames(effdf.Best)[3:(ncol(effdf.Best))] <-
paste("eff", colnames(effdf.Best)[3:(ncol(effdf.Best))], "Best", sep = ".")
eff.df <-
merge(effdf.Worst, effdf.Best, by = c("alphacut", "DMU"))
# Re-arranging columns so they are sorted in col1.Worst col1.Best, col2.Worst col2.Best, ....
srtidx <- (3:ncol(eff.df))
srtidx <- t(matrix(srtidx, ncol = 2))
dim(srtidx) <- c(1, length(srtidx))
eff.df <- eff.df[, c(2, 1, srtidx)]
} else {
eff.Worst <- data.frame(eff$Worst, stringsAsFactors = FALSE)
eff.Worst <-
data.frame(cbind(data.frame(DMU = rownames(eff.Worst)),
eff.Worst),
row.names = NULL)
eff.Worst %>% gather(key = "alphacut",
value = "efficiency.Worst", -DMU) -> eff.Worst
eff.Worst$alphacut <- rep(object$alpha,
each = length(object$data$dmunames))
eff.Best <- data.frame(eff$Best, stringsAsFactors = FALSE)
eff.Best <-
data.frame(cbind(data.frame(DMU = rownames(eff.Best)), eff.Best), row.names = NULL)
eff.Best %>% gather(key = "alphacut", value = "efficiency.Best", -DMU) -> eff.Best
eff.Best$alphacut <-
rep(object$alpha, each = length(object$data$dmunames))
eff.df <- merge(eff.Worst, eff.Best, by = c("DMU", "alphacut"))
}
}
} else {
eff.df <- NULL
}
# Slacks -------------------------
s <- slacks(object)
s[sapply(s, is.null)] <-
NULL # Remove NULL fields from slacks list
dmunames <- object$data$dmunames
# Case 1: both input and output slacks are present -----------------
if (!modelkl %in% c("nonradial", "deaps")) {
s.i.Worst <- do.call(rbind, lapply(seq(dim(s$slack_input.W)[3]),
function(x)
matrix(
s$slack_input.W[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(s$slack_input.W)[[2]])
)))
s.i.Worst <-
cbind(
data.frame(
DMU = object$data$dmunames,
#dimnames(s.i.Worst)[[1]],
alphacut = rep(object$alpha, each = dim(s$slack_input.W)[1])
),
data.frame(s.i.Worst, row.names = NULL)
)
colnames(s.i.Worst)[3:(ncol(s.i.Worst))] <- paste("slack",
colnames(s.i.Worst)[3:(ncol(s.i.Worst))],
"Worst", sep = ".")
s.o.Worst <-
do.call(rbind, lapply(seq(dim(s$slack_output.W)[3]),
function(x)
matrix(
s$slack_output.W[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(s$slack_output.W)[[2]])
)))
s.o.Worst <-
cbind(
data.frame(
DMU = object$data$dmunames,
#dimnames(s.o.Worst)[[1]],
alphacut = rep(object$alpha, each = dim(s$slack_output.W)[1])
),
data.frame(s.o.Worst, row.names = NULL)
)
colnames(s.o.Worst)[3:(ncol(s.o.Worst))] <- paste("slack",
colnames(s.o.Worst)[3:(ncol(s.o.Worst))],
"Worst", sep = ".")
s.i.Best <- do.call(rbind, lapply(seq(dim(s$slack_input.B)[3]),
function(x)
matrix(
s$slack_input.B[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(s$slack_input.B)[[2]])
)))
s.i.Best <- cbind(
data.frame(
DMU = dimnames(s.i.Best)[[1]],
alphacut = rep(object$alpha, each = dim(s$slack_input.B)[1])
),
data.frame(s.i.Best, row.names = NULL)
)
colnames(s.i.Best)[3:(ncol(s.i.Best))] <- paste("slack",
colnames(s.i.Best)[3:(ncol(s.i.Best))],
"Best", sep = ".")
s.o.Best <-
do.call(rbind, lapply(seq(dim(s$slack_output.B)[3]),
function(x)
matrix(
s$slack_output.B[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(s$slack_output.B)[[2]])
)))
s.o.Best <-
cbind(
data.frame(
DMU = object$data$dmunames,
#dimnames(s.o.Best)[[1]],
alphacut = rep(object$alpha, each = dim(s$slack_output.B)[1])
),
data.frame(s.o.Best, row.names = NULL)
)
colnames(s.o.Best)[3:(ncol(s.o.Best))] <- paste("slack",
colnames(s.o.Best)[3:(ncol(s.o.Best))],
"Best", sep = ".")
s.i.df <- merge(s.i.Worst, s.i.Best, by = c("alphacut", "DMU"))
# Re-arranging columns so they are sorted in col1.Worst col1.Best, col2.Worst col2.Best, ....
srtidx <- (3:ncol(s.i.df))
srtidx <- t(matrix(srtidx, ncol = 2))
dim(srtidx) <- c(1, length(srtidx))
s.i.df <- s.i.df[, c(2, 1, srtidx)]
s.o.df <- merge(s.o.Worst, s.o.Best, by = c("alphacut", "DMU"))
# Re-arranging columns so they are sorted in col1.Worst col1.Best, col2.Worst col2.Best, ....
srtidx <- (3:ncol(s.o.df))
srtidx <- t(matrix(srtidx, ncol = 2))
dim(srtidx) <- c(1, length(srtidx))
s.o.df <- s.o.df[, c(2, 1, srtidx)]
s.df <- cbind(s.i.df, s.o.df[, 3:ncol(s.o.df)])
} else {
# Case 2: only either input or output slacks are present (but not both) --------------
if (object$orientation == "io") {
s.o.Worst <- do.call(rbind, lapply(seq(dim(s$slack_output.W)[3]),
function(x)
matrix(
s$slack_output.W[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(s$slack_output.W)[[2]])
)))
s.o.Worst <-
cbind(
data.frame(
DMU = object$data$dmunames,
#dimnames(s.o.Worst)[[1]],
alphacut = rep(object$alpha, each = dim(s$slack_output.W)[1])
),
data.frame(s.o.Worst, row.names = NULL)
)
colnames(s.o.Worst)[3:(ncol(s.o.Worst))] <- paste("slack",
colnames(s.o.Worst)[3:(ncol(s.o.Worst))],
"Worst", sep = ".")
s.o.Best <-
do.call(rbind, lapply(seq(dim(s$slack_output.B)[3]),
function(x)
matrix(
s$slack_output.B[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(s$slack_output.B)[[2]])
)))
s.o.Best <-
cbind(
data.frame(
DMU = object$data$dmunames,
#dimnames(s.o.Best)[[1]],
alphacut = rep(object$alpha, each = dim(s$slack_output.B)[1])
),
data.frame(s.o.Best, row.names = NULL)
)
colnames(s.o.Best)[3:(ncol(s.o.Best))] <- paste("slack",
colnames(s.o.Best)[3:(ncol(s.o.Best))],
"Best", sep = ".")
s.o.df <-
merge(s.o.Worst, s.o.Best, by = c("alphacut", "DMU"))
# Re-arranging columns so they are sorted in col1.Worst col1.Best, col2.Worst col2.Best, ....
srtidx <- (3:ncol(s.o.df))
srtidx <- t(matrix(srtidx, ncol = 2))
dim(srtidx) <- c(1, length(srtidx))
s.df <- s.o.df[, c(2, 1, srtidx)]
} else {
s.i.Worst <-
do.call(rbind, lapply(seq(dim(s$slack_input.W)[3]),
function(x)
matrix(
s$slack_input.W[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(s$slack_input.W)[[2]])
)))
s.i.Worst <-
cbind(
data.frame(
DMU = object$data$dmunames,
#dimnames(s.i.Worst)[[1]],
alphacut = rep(object$alpha, each = dim(s$slack_input.W)[1])
),
data.frame(s.i.Worst, row.names = NULL)
)
colnames(s.i.Worst)[3:(ncol(s.i.Worst))] <- paste("slack",
colnames(s.i.Worst)[3:(ncol(s.i.Worst))],
"Worst", sep = ".")
s.i.Best <-
do.call(rbind, lapply(seq(dim(s$slack_input.B)[3]),
function(x)
matrix(
s$slack_input.B[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(s$slack_input.B)[[2]])
)))
s.i.Best <- cbind(
data.frame(
DMU = dimnames(s.i.Best)[[1]],
alphacut = rep(object$alpha, each = dim(s$slack_input.B)[1])
),
data.frame(s.i.Best, row.names = NULL)
)
colnames(s.i.Best)[3:(ncol(s.i.Best))] <- paste("slack",
colnames(s.i.Best)[3:(ncol(s.i.Best))],
"Best", sep = ".")
s.i.df <-
merge(s.i.Worst, s.i.Best, by = c("alphacut", "DMU"))
# Re-arranging columns so they are sorted in col1.Worst col1.Best, col2.Worst col2.Best, ....
srtidx <- (3:ncol(s.i.df))
srtidx <- t(matrix(srtidx, ncol = 2))
dim(srtidx) <- c(1, length(srtidx))
s.df <- s.i.df[, c(2, 1, srtidx)]
}
}
# Case 3: extra option for supers! Superslacks present -------------
if (modelkl %in% c("addsupereff", "sbmsupereff")) {
supers.i.Worst <-
do.call(rbind, lapply(seq(dim(s$superslack_input.W)[3]),
function(x)
matrix(
s$superslack_input.W[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(s$superslack_input.W)[[2]])
)))
supers.i.Worst <-
cbind(
data.frame(
DMU = object$data$dmunames,
#dimnames(supers.i.Worst)[[1]],
alphacut = rep(object$alpha, each = dim(s$superslack_input.W)[1])
),
data.frame(supers.i.Worst, row.names = NULL)
)
colnames(supers.i.Worst)[3:(ncol(supers.i.Worst))] <-
paste("superslack",
colnames(supers.i.Worst)[3:(ncol(supers.i.Worst))],
"Worst", sep = ".")
supers.o.Worst <-
do.call(rbind, lapply(seq(dim(s$superslack_output.W)[3]),
function(x)
matrix(
s$superslack_output.W[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(s$superslack_output.W)[[2]])
)))
supers.o.Worst <-
cbind(
data.frame(
DMU = object$data$dmunames,
#dimnames(supers.o.Worst)[[1]],
alphacut = rep(object$alpha, each = dim(s$superslack_output.W)[1])
),
data.frame(supers.o.Worst, row.names = NULL)
)
colnames(supers.o.Worst)[3:(ncol(supers.o.Worst))] <-
paste("superslack",
colnames(supers.o.Worst)[3:(ncol(supers.o.Worst))],
"Worst", sep = ".")
supers.i.Best <-
do.call(rbind, lapply(seq(dim(s$superslack_input.B)[3]),
function(x)
matrix(
s$superslack_input.B[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(s$superslack_input.B)[[2]])
)))
supers.i.Best <-
cbind(
data.frame(
DMU = dimnames(supers.i.Best)[[1]],
alphacut = rep(object$alpha, each = dim(s$superslack_input.B)[1])
),
data.frame(supers.i.Best, row.names = NULL)
)
colnames(supers.i.Best)[3:(ncol(supers.i.Best))] <-
paste("superslack",
colnames(supers.i.Best)[3:(ncol(supers.i.Best))],
"Best", sep = ".")
supers.o.Best <-
do.call(rbind, lapply(seq(dim(s$superslack_output.B)[3]),
function(x)
matrix(
s$superslack_output.B[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(s$superslack_output.B)[[2]])
)))
supers.o.Best <-
cbind(
data.frame(
DMU = object$data$dmunames,
#dimnames(supers.o.Best)[[1]],
alphacut = rep(object$alpha, each = dim(s$superslack_output.B)[1])
),
data.frame(supers.o.Best, row.names = NULL)
)
colnames(supers.o.Best)[3:(ncol(supers.o.Best))] <-
paste("superslack",
colnames(supers.o.Best)[3:(ncol(supers.o.Best))],
"Best", sep = ".")
supers.i.df <-
merge(supers.i.Worst, supers.i.Best, by = c("alphacut", "DMU"))
# Re-arranging columns so they are sorted in col1.Worst col1.Best, col2.Worst col2.Best, ....
srtidx <- (3:ncol(supers.i.df))
srtidx <- t(matrix(srtidx, ncol = 2))
dim(srtidx) <- c(1, length(srtidx))
supers.i.df <- supers.i.df[, c(2, 1, srtidx)]
supers.o.df <-
merge(supers.o.Worst, supers.o.Best, by = c("alphacut", "DMU"))
# Re-arranging columns so they are sorted in col1.Worst col1.Best, col2.Worst col2.Best, ....
srtidx <- (3:ncol(supers.o.df))
srtidx <- t(matrix(srtidx, ncol = 2))
dim(srtidx) <- c(1, length(srtidx))
supers.o.df <- supers.o.df[, c(2, 1, srtidx)]
supers.df <-
cbind(supers.i.df, supers.o.df[, 3:ncol(supers.o.df)])
} else {
supers.df <- NULL
}
# Lambdas ------------------
lmb <- lambdas(object)
lmbmat.Worst <-
do.call(rbind, lapply(seq(dim(lmb$Worst)[3]), function(x)
lmb$Worst[, , x]))
lmbdf.Worst <-
cbind(
data.frame(
DMU = dimnames(lmbmat.Worst)[[1]],
alphacut = rep(object$alpha, each = dim(lmb$Worst)[1])
),
data.frame(lmbmat.Worst, row.names = NULL)
)
colnames(lmbdf.Worst)[3:(ncol(lmbdf.Worst))] <-
paste("lambda", colnames(lmbdf.Worst)[3:(ncol(lmbdf.Worst))], "Worst", sep = ".")
lmbmat.Best <-
do.call(rbind, lapply(seq(dim(lmb$Best)[3]), function(x)
lmb$Best[, , x]))
lmbdf.Best <-
cbind(
data.frame(
DMU = dimnames(lmbmat.Best)[[1]],
alphacut = rep(object$alpha, each = dim(lmb$Best)[1])
),
data.frame(lmbmat.Best, row.names = NULL)
)
colnames(lmbdf.Best)[3:(ncol(lmbdf.Best))] <-
paste("lambda", colnames(lmbdf.Best)[3:(ncol(lmbdf.Best))], "Best", sep = ".")
lmb.df <-
merge(lmbdf.Worst, lmbdf.Best, by = c("alphacut", "DMU"))
# Re-arranging columns so they are sorted in col1.Worst col1.Best, col2.Worst col2.Best, ....
srtidx <- (3:ncol(lmb.df))
srtidx <- t(matrix(srtidx, ncol = 2))
dim(srtidx) <- c(1, length(srtidx))
lmb.df <- lmb.df[, c(2, 1, srtidx)]
# Targets ---------------------
tar <- targets(object)
tar.i.Worst <-
do.call(rbind, lapply(seq(dim(tar$target_input.W)[3]),
function(x)
matrix(
tar$target_input.W[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(tar$target_input.W)[[2]])
)))
tar.i.Worst <-
cbind(
data.frame(
DMU = object$data$dmunames,
#dimnames(tar.i.Worst)[[1]],
alphacut = rep(object$alpha, each = dim(tar$target_input.W)[1])
),
data.frame(tar.i.Worst, row.names = NULL)
)
colnames(tar.i.Worst)[3:(ncol(tar.i.Worst))] <- paste("target",
colnames(tar.i.Worst)[3:(ncol(tar.i.Worst))],
"Worst", sep = ".")
tar.o.Worst <-
do.call(rbind, lapply(seq(dim(tar$target_output.W)[3]),
function(x)
matrix(
tar$target_output.W[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(tar$target_output.W)[[2]])
)))
tar.o.Worst <-
cbind(
data.frame(
DMU = object$data$dmunames,
#dimnames(tar.o.Worst)[[1]],
alphacut = rep(object$alpha, each = dim(tar$target_output.W)[1])
),
data.frame(tar.o.Worst, row.names = NULL)
)
colnames(tar.o.Worst)[3:(ncol(tar.o.Worst))] <- paste("target",
colnames(tar.o.Worst)[3:(ncol(tar.o.Worst))],
"Worst", sep = ".")
tar.i.Best <-
do.call(rbind, lapply(seq(dim(tar$target_input.B)[3]),
function(x)
matrix(
tar$target_input.B[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(tar$target_input.B)[[2]])
)))
tar.i.Best <-
cbind(
data.frame(
DMU = dimnames(tar.i.Best)[[1]],
alphacut = rep(object$alpha, each = dim(tar$target_input.B)[1])
),
data.frame(tar.i.Best, row.names = NULL)
)
colnames(tar.i.Best)[3:(ncol(tar.i.Best))] <- paste("target",
colnames(tar.i.Best)[3:(ncol(tar.i.Best))],
"Best", sep = ".")
tar.o.Best <-
do.call(rbind, lapply(seq(dim(tar$target_output.B)[3]),
function(x)
matrix(
tar$target_output.B[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(tar$target_output.B)[[2]])
)))
tar.o.Best <-
cbind(
data.frame(
DMU = object$data$dmunames,
#dimnames(tar.o.Best)[[1]],
alphacut = rep(object$alpha, each = dim(tar$target_output.B)[1])
),
data.frame(tar.o.Best, row.names = NULL)
)
colnames(tar.o.Best)[3:(ncol(tar.o.Best))] <- paste("target",
colnames(tar.o.Best)[3:(ncol(tar.o.Best))],
"Best", sep = ".")
tar.i.df <-
merge(tar.i.Worst, tar.i.Best, by = c("alphacut", "DMU"))
# Re-arranging columns so they are sorted in col1.Worst col1.Best, col2.Worst col2.Best, ....
srtidx <- (3:ncol(tar.i.df))
srtidx <- t(matrix(srtidx, ncol = 2))
dim(srtidx) <- c(1, length(srtidx))
tar.i.df <- tar.i.df[, c(2, 1, srtidx)]
tar.o.df <-
merge(tar.o.Worst, tar.o.Best, by = c("alphacut", "DMU"))
# Re-arranging columns so they are sorted in col1.Worst col1.Best, col2.Worst col2.Best, ....
srtidx <- (3:ncol(tar.o.df))
srtidx <- t(matrix(srtidx, ncol = 2))
dim(srtidx) <- c(1, length(srtidx))
tar.o.df <- tar.o.df[, c(2, 1, srtidx)]
tar.df <- cbind(tar.i.df, tar.o.df[, 3:ncol(tar.o.df)])
if (!modelkl %in% c("additive", "addsupereff")) {
df <-
cbind(eff.df, s.df[, 3:ncol(s.df)], lmb.df[, 3:ncol(lmb.df)], tar.df[, 3:ncol(tar.df)])
} else {
df <-
cbind(s.df[, 3:ncol(s.df)], lmb.df[, 3:ncol(lmb.df)], tar.df[, 3:ncol(tar.df)])
}
if (modelkl %in% c("addsupereff", "sbmsupereff")) {
df <- cbind(df, supers.df[3:ncol(supers.df)])
}
if (exportExcel) {
df.list <- list(
efficiencies = eff.df,
slacks = s.df,
superslacks = supers.df,
lambdas = lmb.df,
targets = tar.df
)
df.list[sapply(df.list, is.null)] <- NULL
if (is.null(filename)) {
filename <- paste("ResultsDEA", Sys.time(), ".xlsx", sep = "")
filename <- gsub(" ", "_", filename)
filename <- gsub(":", ".", filename)
}
write_xlsx(df.list, path = filename)
}
if (!returnList) {
return(df)
} else {
df.list <- list(
efficiencies = eff.df,
slacks = s.df,
superslacks = supers.df,
lambdas = lmb.df,
targets = tar.df
)
return(df.list)
}
}
}
rbensua/deaR documentation built on April 5, 2025, 9:09 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions summary.dea_fuzzy
Documented in summary.dea_fuzzy
#' @title Summary Fuzzy DEA models.
#'
#' @description Summary of the results obtained by a fuzzy DEA model.
#'
#' @param object An object of class \code{"dea_fuzzy"} obtained with a fuzzy DEA
#' model function (\code{modelfuzzy_guotanaka}, \code{modelfuzzy_kaoliu},
#' \code{modelfuzzy_possibilistic}).
#' @param ... Extra options.
#' @param exportExcel Logical value. If TRUE (FALSE by default) the results are
#' also exported to an Excel file.
#' @param filename Character string. Absolute file name (including path) of the exported Excel file.
#' If NULL, then the file name will be "ResultsDEA" + timestamp.xlsx.
#' @param returnList Logical value. If TRUE then the results are given as a list of data frames.
#' If FALSE (default) all the data frames are merged into a single data frame.
#'
#' @return If the model is that from Guo and Tanaka (\code{modelfuzzy_guotanaka}), it returns a data.frame
#' with columns: DMU, alpha cuts and efficiencies.
#' For the possibilistic model (\code{modelfuzzy_possibilistic}) it returns a data.frame with columns:
#' DMU, alpha-cuts, efficiencies and the corresponding lambda values
#' For the Kao-Liu model (\code{modelfuzzy_kaoliu}), the result may depend on the crisp sub-model used.
#' It will contain a data.frame with the efficiencies (if any), the slacks and superslacks (if any),
#' the lambda values and the targets.
#'
#' If \code{exportExcel} is TRUE, then an Excel file will be created containing as many
#' sheets as necessary depending on the variables returned.
#'
#' @author
#' \strong{Vicente Coll-Serrano} (\email{vicente.coll@@uv.es}).
#' \emph{Quantitative Methods for Measuring Culture (MC2). Applied Economics.}
#'
#' \strong{Vicente Bolós} (\email{vicente.bolos@@uv.es}).
#' \emph{Department of Business Mathematics}
#'
#' \strong{Rafael Benítez} (\email{rafael.suarez@@uv.es}).
#' \emph{Department of Business Mathematics}
#'
#' University of Valencia (Spain)
#'
#' @examples
#' data("Leon2003")
#' data_example <- make_deadata_fuzzy(Leon2003,
#' inputs.mL = 2,
#' inputs.dL = 3,
#' outputs.mL = 4,
#' outputs.dL = 5)
#' result <- modelfuzzy_possibilistic(data_example,
#' h = seq(0, 1, by = 0.1),
#' orientation = "io",
#' rts = "vrs")
#' summary(result)
#'
#' @references
#' Leon, T.; Liern, V. Ruiz, J.; Sirvent, I. (2003). "A Possibilistic Programming
#' Approach to the Assessment of Efficiency with DEA Models", Fuzzy Sets and Systems,
#' 139, 407–419. \doi{10.1016/S0165-0114(02)00608-5}
#'
#' @method summary dea_fuzzy
#'
#' @import writexl tidyr
#'
#' @export
summary.dea_fuzzy <- function(object,
...,
exportExcel = FALSE,
filename = NULL,
returnList = FALSE) {
if (!is.dea_fuzzy(object)) {
stop("Input should be of class dea_fuzzy!")
}
modelname <- object$modelname
# For CRAN - check pass
DMU <- NULL
# Guo-Tanaka -----------------------
if (modelname == "fuzzy_guotanaka") {
eff <- efficiencies(object)
if (!returnList) {
effmat <-
do.call(rbind, lapply(seq(dim(eff)[3]), function(x)
eff[, , x]))
effdf <- cbind(data.frame(
DMU = dimnames(effmat)[[1]],
hlevel = rep(object$h, each = dim(eff)[1])
),
data.frame(effmat, row.names = NULL))
if (exportExcel) {
if (is.null(filename)) {
filename <- paste("ResultsDEA", Sys.time(), ".xlsx", sep = "")
filename <- gsub(" ", "_", filename)
filename <- gsub(":", ".", filename)
}
write_xlsx(effdf, path = filename)
}
return(effdf)
} else {
efflist <- lapply(seq(dim(eff)[3]), function(x)
eff[, , x])
names(efflist) <- paste("h =", dimnames(eff)[[3]])
if (exportExcel) {
if (is.null(filename)) {
filename <- paste("ResultsDEA", Sys.time(), ".xlsx", sep = "")
filename <- gsub(" ", "_", filename)
filename <- gsub(":", ".", filename)
}
write_xlsx(efflist, path = filename)
}
return(efflist)
}
# Possibilistic --------------------
} else if (modelname == "fuzzy_possibilistic_basic") {
# Efficiencies
eff <- efficiencies(object)
eff <- cbind(data.frame(DMU = dimnames(eff)[[1]]),
data.frame(eff, row.names = NULL))
eff %>% gather(key = "hlevel", value = "efficiency", -DMU) -> eff
eff$hlevel <- rep(object$h, each = length(object$data$dmunames))
eff <- eff[,c(2,1,3)]
# Lambdas
lamb <- lambdas(object)
lamblist <- lapply(seq(dim(lamb)[3]), function(x)
lamb[, , x])
lambmat <- do.call(rbind, lamblist)
if (!returnList) {
df <- cbind(eff, data.frame(lambmat, row.names = NULL))
if (exportExcel) {
if (is.null(filename)) {
filename <- paste("ResultsDEA", Sys.time(), ".xlsx", sep = "")
filename <- gsub(" ", "_", filename)
filename <- gsub(":", ".", filename)
}
write_xlsx(df, path = filename)
}
return(df)
} else {
lambdas = data.frame(hlevel = eff$hlevel, DMU =eff$DMU, data.frame(lambmat, row.names = NULL))
reslist <- list(efficiencies = eff, lambdas = lambdas)
if (exportExcel) {
if (is.null(filename)) {
filename <- paste("ResultsDEA", Sys.time(), ".xlsx", sep = "")
filename <- gsub(" ", "_", filename)
filename <- gsub(":", ".", filename)
}
write_xlsx(reslist, path = filename)
}
return(reslist)
}
# Kao - Liu ---------------------
} else {
modelkl <- strsplit(object$modelname, "_")[[1]][3]
# Efficiencies ----------
if (!modelkl %in% c("addsupereff")) {
eff <- efficiencies(object)
# Radial models ----------------
if (!modelkl %in% c("nonradial", "deaps")) {
eff.Worst <- data.frame(eff$Worst, stringsAsFactors = FALSE)
eff.Worst <-
data.frame(cbind(data.frame(DMU = rownames(eff.Worst)),
eff.Worst),
row.names = NULL)
eff.Worst %>% gather(key = "alphacut",
value = "efficiency.Worst", -DMU) -> eff.Worst
eff.Worst$alphacut <- rep(object$alpha,
each = length(object$data$dmunames))
eff.Best <- data.frame(eff$Best, stringsAsFactors = FALSE)
eff.Best <-
data.frame(cbind(data.frame(DMU = rownames(eff.Best)), eff.Best), row.names = NULL)
eff.Best %>% gather(key = "alphacut", value = "efficiency.Best", -DMU) -> eff.Best
eff.Best$alphacut <-
rep(object$alpha, each = length(object$data$dmunames))
eff.df <- merge(eff.Worst, eff.Best, by = c("DMU", "alphacut"))
} else {
# Non - radial models-----------------
neff <- length(object$alphacut[[1]]$DMU$Worst[[1]]$efficiency)
if(neff > 1){
effmat.Worst <-
do.call(rbind, lapply(seq(dim(eff$Worst)[3]), function(x)
eff$Worst[, , x]))
effdf.Worst <-
cbind(
data.frame(
DMU = dimnames(effmat.Worst)[[1]],
alphacut = rep(object$alpha, each = dim(eff$Worst)[1])
),
data.frame(effmat.Worst, row.names = NULL)
)
colnames(effdf.Worst)[3:(ncol(effdf.Worst))] <-
paste("eff", colnames(effdf.Worst)[3:(ncol(effdf.Worst))], "Worst", sep = ".")
effmat.Best <-
do.call(rbind, lapply(seq(dim(eff$Best)[3]), function(x)
eff$Best[, , x]))
effdf.Best <-
cbind(
data.frame(
DMU = dimnames(effmat.Best)[[1]],
alphacut = rep(object$alpha, each = dim(eff$Best)[1])
),
data.frame(effmat.Best, row.names = NULL)
)
colnames(effdf.Best)[3:(ncol(effdf.Best))] <-
paste("eff", colnames(effdf.Best)[3:(ncol(effdf.Best))], "Best", sep = ".")
eff.df <-
merge(effdf.Worst, effdf.Best, by = c("alphacut", "DMU"))
# Re-arranging columns so they are sorted in col1.Worst col1.Best, col2.Worst col2.Best, ....
srtidx <- (3:ncol(eff.df))
srtidx <- t(matrix(srtidx, ncol = 2))
dim(srtidx) <- c(1, length(srtidx))
eff.df <- eff.df[, c(2, 1, srtidx)]
} else {
eff.Worst <- data.frame(eff$Worst, stringsAsFactors = FALSE)
eff.Worst <-
data.frame(cbind(data.frame(DMU = rownames(eff.Worst)),
eff.Worst),
row.names = NULL)
eff.Worst %>% gather(key = "alphacut",
value = "efficiency.Worst", -DMU) -> eff.Worst
eff.Worst$alphacut <- rep(object$alpha,
each = length(object$data$dmunames))
eff.Best <- data.frame(eff$Best, stringsAsFactors = FALSE)
eff.Best <-
data.frame(cbind(data.frame(DMU = rownames(eff.Best)), eff.Best), row.names = NULL)
eff.Best %>% gather(key = "alphacut", value = "efficiency.Best", -DMU) -> eff.Best
eff.Best$alphacut <-
rep(object$alpha, each = length(object$data$dmunames))
eff.df <- merge(eff.Worst, eff.Best, by = c("DMU", "alphacut"))
}
}
} else {
eff.df <- NULL
}
# Slacks -------------------------
s <- slacks(object)
s[sapply(s, is.null)] <-
NULL # Remove NULL fields from slacks list
dmunames <- object$data$dmunames
# Case 1: both input and output slacks are present -----------------
if (!modelkl %in% c("nonradial", "deaps")) {
s.i.Worst <- do.call(rbind, lapply(seq(dim(s$slack_input.W)[3]),
function(x)
matrix(
s$slack_input.W[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(s$slack_input.W)[[2]])
)))
s.i.Worst <-
cbind(
data.frame(
DMU = object$data$dmunames,
#dimnames(s.i.Worst)[[1]],
alphacut = rep(object$alpha, each = dim(s$slack_input.W)[1])
),
data.frame(s.i.Worst, row.names = NULL)
)
colnames(s.i.Worst)[3:(ncol(s.i.Worst))] <- paste("slack",
colnames(s.i.Worst)[3:(ncol(s.i.Worst))],
"Worst", sep = ".")
s.o.Worst <-
do.call(rbind, lapply(seq(dim(s$slack_output.W)[3]),
function(x)
matrix(
s$slack_output.W[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(s$slack_output.W)[[2]])
)))
s.o.Worst <-
cbind(
data.frame(
DMU = object$data$dmunames,
#dimnames(s.o.Worst)[[1]],
alphacut = rep(object$alpha, each = dim(s$slack_output.W)[1])
),
data.frame(s.o.Worst, row.names = NULL)
)
colnames(s.o.Worst)[3:(ncol(s.o.Worst))] <- paste("slack",
colnames(s.o.Worst)[3:(ncol(s.o.Worst))],
"Worst", sep = ".")
s.i.Best <- do.call(rbind, lapply(seq(dim(s$slack_input.B)[3]),
function(x)
matrix(
s$slack_input.B[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(s$slack_input.B)[[2]])
)))
s.i.Best <- cbind(
data.frame(
DMU = dimnames(s.i.Best)[[1]],
alphacut = rep(object$alpha, each = dim(s$slack_input.B)[1])
),
data.frame(s.i.Best, row.names = NULL)
)
colnames(s.i.Best)[3:(ncol(s.i.Best))] <- paste("slack",
colnames(s.i.Best)[3:(ncol(s.i.Best))],
"Best", sep = ".")
s.o.Best <-
do.call(rbind, lapply(seq(dim(s$slack_output.B)[3]),
function(x)
matrix(
s$slack_output.B[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(s$slack_output.B)[[2]])
)))
s.o.Best <-
cbind(
data.frame(
DMU = object$data$dmunames,
#dimnames(s.o.Best)[[1]],
alphacut = rep(object$alpha, each = dim(s$slack_output.B)[1])
),
data.frame(s.o.Best, row.names = NULL)
)
colnames(s.o.Best)[3:(ncol(s.o.Best))] <- paste("slack",
colnames(s.o.Best)[3:(ncol(s.o.Best))],
"Best", sep = ".")
s.i.df <- merge(s.i.Worst, s.i.Best, by = c("alphacut", "DMU"))
# Re-arranging columns so they are sorted in col1.Worst col1.Best, col2.Worst col2.Best, ....
srtidx <- (3:ncol(s.i.df))
srtidx <- t(matrix(srtidx, ncol = 2))
dim(srtidx) <- c(1, length(srtidx))
s.i.df <- s.i.df[, c(2, 1, srtidx)]
s.o.df <- merge(s.o.Worst, s.o.Best, by = c("alphacut", "DMU"))
# Re-arranging columns so they are sorted in col1.Worst col1.Best, col2.Worst col2.Best, ....
srtidx <- (3:ncol(s.o.df))
srtidx <- t(matrix(srtidx, ncol = 2))
dim(srtidx) <- c(1, length(srtidx))
s.o.df <- s.o.df[, c(2, 1, srtidx)]
s.df <- cbind(s.i.df, s.o.df[, 3:ncol(s.o.df)])
} else {
# Case 2: only either input or output slacks are present (but not both) --------------
if (object$orientation == "io") {
s.o.Worst <- do.call(rbind, lapply(seq(dim(s$slack_output.W)[3]),
function(x)
matrix(
s$slack_output.W[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(s$slack_output.W)[[2]])
)))
s.o.Worst <-
cbind(
data.frame(
DMU = object$data$dmunames,
#dimnames(s.o.Worst)[[1]],
alphacut = rep(object$alpha, each = dim(s$slack_output.W)[1])
),
data.frame(s.o.Worst, row.names = NULL)
)
colnames(s.o.Worst)[3:(ncol(s.o.Worst))] <- paste("slack",
colnames(s.o.Worst)[3:(ncol(s.o.Worst))],
"Worst", sep = ".")
s.o.Best <-
do.call(rbind, lapply(seq(dim(s$slack_output.B)[3]),
function(x)
matrix(
s$slack_output.B[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(s$slack_output.B)[[2]])
)))
s.o.Best <-
cbind(
data.frame(
DMU = object$data$dmunames,
#dimnames(s.o.Best)[[1]],
alphacut = rep(object$alpha, each = dim(s$slack_output.B)[1])
),
data.frame(s.o.Best, row.names = NULL)
)
colnames(s.o.Best)[3:(ncol(s.o.Best))] <- paste("slack",
colnames(s.o.Best)[3:(ncol(s.o.Best))],
"Best", sep = ".")
s.o.df <-
merge(s.o.Worst, s.o.Best, by = c("alphacut", "DMU"))
# Re-arranging columns so they are sorted in col1.Worst col1.Best, col2.Worst col2.Best, ....
srtidx <- (3:ncol(s.o.df))
srtidx <- t(matrix(srtidx, ncol = 2))
dim(srtidx) <- c(1, length(srtidx))
s.df <- s.o.df[, c(2, 1, srtidx)]
} else {
s.i.Worst <-
do.call(rbind, lapply(seq(dim(s$slack_input.W)[3]),
function(x)
matrix(
s$slack_input.W[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(s$slack_input.W)[[2]])
)))
s.i.Worst <-
cbind(
data.frame(
DMU = object$data$dmunames,
#dimnames(s.i.Worst)[[1]],
alphacut = rep(object$alpha, each = dim(s$slack_input.W)[1])
),
data.frame(s.i.Worst, row.names = NULL)
)
colnames(s.i.Worst)[3:(ncol(s.i.Worst))] <- paste("slack",
colnames(s.i.Worst)[3:(ncol(s.i.Worst))],
"Worst", sep = ".")
s.i.Best <-
do.call(rbind, lapply(seq(dim(s$slack_input.B)[3]),
function(x)
matrix(
s$slack_input.B[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(s$slack_input.B)[[2]])
)))
s.i.Best <- cbind(
data.frame(
DMU = dimnames(s.i.Best)[[1]],
alphacut = rep(object$alpha, each = dim(s$slack_input.B)[1])
),
data.frame(s.i.Best, row.names = NULL)
)
colnames(s.i.Best)[3:(ncol(s.i.Best))] <- paste("slack",
colnames(s.i.Best)[3:(ncol(s.i.Best))],
"Best", sep = ".")
s.i.df <-
merge(s.i.Worst, s.i.Best, by = c("alphacut", "DMU"))
# Re-arranging columns so they are sorted in col1.Worst col1.Best, col2.Worst col2.Best, ....
srtidx <- (3:ncol(s.i.df))
srtidx <- t(matrix(srtidx, ncol = 2))
dim(srtidx) <- c(1, length(srtidx))
s.df <- s.i.df[, c(2, 1, srtidx)]
}
}
# Case 3: extra option for supers! Superslacks present -------------
if (modelkl %in% c("addsupereff", "sbmsupereff")) {
supers.i.Worst <-
do.call(rbind, lapply(seq(dim(s$superslack_input.W)[3]),
function(x)
matrix(
s$superslack_input.W[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(s$superslack_input.W)[[2]])
)))
supers.i.Worst <-
cbind(
data.frame(
DMU = object$data$dmunames,
#dimnames(supers.i.Worst)[[1]],
alphacut = rep(object$alpha, each = dim(s$superslack_input.W)[1])
),
data.frame(supers.i.Worst, row.names = NULL)
)
colnames(supers.i.Worst)[3:(ncol(supers.i.Worst))] <-
paste("superslack",
colnames(supers.i.Worst)[3:(ncol(supers.i.Worst))],
"Worst", sep = ".")
supers.o.Worst <-
do.call(rbind, lapply(seq(dim(s$superslack_output.W)[3]),
function(x)
matrix(
s$superslack_output.W[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(s$superslack_output.W)[[2]])
)))
supers.o.Worst <-
cbind(
data.frame(
DMU = object$data$dmunames,
#dimnames(supers.o.Worst)[[1]],
alphacut = rep(object$alpha, each = dim(s$superslack_output.W)[1])
),
data.frame(supers.o.Worst, row.names = NULL)
)
colnames(supers.o.Worst)[3:(ncol(supers.o.Worst))] <-
paste("superslack",
colnames(supers.o.Worst)[3:(ncol(supers.o.Worst))],
"Worst", sep = ".")
supers.i.Best <-
do.call(rbind, lapply(seq(dim(s$superslack_input.B)[3]),
function(x)
matrix(
s$superslack_input.B[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(s$superslack_input.B)[[2]])
)))
supers.i.Best <-
cbind(
data.frame(
DMU = dimnames(supers.i.Best)[[1]],
alphacut = rep(object$alpha, each = dim(s$superslack_input.B)[1])
),
data.frame(supers.i.Best, row.names = NULL)
)
colnames(supers.i.Best)[3:(ncol(supers.i.Best))] <-
paste("superslack",
colnames(supers.i.Best)[3:(ncol(supers.i.Best))],
"Best", sep = ".")
supers.o.Best <-
do.call(rbind, lapply(seq(dim(s$superslack_output.B)[3]),
function(x)
matrix(
s$superslack_output.B[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(s$superslack_output.B)[[2]])
)))
supers.o.Best <-
cbind(
data.frame(
DMU = object$data$dmunames,
#dimnames(supers.o.Best)[[1]],
alphacut = rep(object$alpha, each = dim(s$superslack_output.B)[1])
),
data.frame(supers.o.Best, row.names = NULL)
)
colnames(supers.o.Best)[3:(ncol(supers.o.Best))] <-
paste("superslack",
colnames(supers.o.Best)[3:(ncol(supers.o.Best))],
"Best", sep = ".")
supers.i.df <-
merge(supers.i.Worst, supers.i.Best, by = c("alphacut", "DMU"))
# Re-arranging columns so they are sorted in col1.Worst col1.Best, col2.Worst col2.Best, ....
srtidx <- (3:ncol(supers.i.df))
srtidx <- t(matrix(srtidx, ncol = 2))
dim(srtidx) <- c(1, length(srtidx))
supers.i.df <- supers.i.df[, c(2, 1, srtidx)]
supers.o.df <-
merge(supers.o.Worst, supers.o.Best, by = c("alphacut", "DMU"))
# Re-arranging columns so they are sorted in col1.Worst col1.Best, col2.Worst col2.Best, ....
srtidx <- (3:ncol(supers.o.df))
srtidx <- t(matrix(srtidx, ncol = 2))
dim(srtidx) <- c(1, length(srtidx))
supers.o.df <- supers.o.df[, c(2, 1, srtidx)]
supers.df <-
cbind(supers.i.df, supers.o.df[, 3:ncol(supers.o.df)])
} else {
supers.df <- NULL
}
# Lambdas ------------------
lmb <- lambdas(object)
lmbmat.Worst <-
do.call(rbind, lapply(seq(dim(lmb$Worst)[3]), function(x)
lmb$Worst[, , x]))
lmbdf.Worst <-
cbind(
data.frame(
DMU = dimnames(lmbmat.Worst)[[1]],
alphacut = rep(object$alpha, each = dim(lmb$Worst)[1])
),
data.frame(lmbmat.Worst, row.names = NULL)
)
colnames(lmbdf.Worst)[3:(ncol(lmbdf.Worst))] <-
paste("lambda", colnames(lmbdf.Worst)[3:(ncol(lmbdf.Worst))], "Worst", sep = ".")
lmbmat.Best <-
do.call(rbind, lapply(seq(dim(lmb$Best)[3]), function(x)
lmb$Best[, , x]))
lmbdf.Best <-
cbind(
data.frame(
DMU = dimnames(lmbmat.Best)[[1]],
alphacut = rep(object$alpha, each = dim(lmb$Best)[1])
),
data.frame(lmbmat.Best, row.names = NULL)
)
colnames(lmbdf.Best)[3:(ncol(lmbdf.Best))] <-
paste("lambda", colnames(lmbdf.Best)[3:(ncol(lmbdf.Best))], "Best", sep = ".")
lmb.df <-
merge(lmbdf.Worst, lmbdf.Best, by = c("alphacut", "DMU"))
# Re-arranging columns so they are sorted in col1.Worst col1.Best, col2.Worst col2.Best, ....
srtidx <- (3:ncol(lmb.df))
srtidx <- t(matrix(srtidx, ncol = 2))
dim(srtidx) <- c(1, length(srtidx))
lmb.df <- lmb.df[, c(2, 1, srtidx)]
# Targets ---------------------
tar <- targets(object)
tar.i.Worst <-
do.call(rbind, lapply(seq(dim(tar$target_input.W)[3]),
function(x)
matrix(
tar$target_input.W[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(tar$target_input.W)[[2]])
)))
tar.i.Worst <-
cbind(
data.frame(
DMU = object$data$dmunames,
#dimnames(tar.i.Worst)[[1]],
alphacut = rep(object$alpha, each = dim(tar$target_input.W)[1])
),
data.frame(tar.i.Worst, row.names = NULL)
)
colnames(tar.i.Worst)[3:(ncol(tar.i.Worst))] <- paste("target",
colnames(tar.i.Worst)[3:(ncol(tar.i.Worst))],
"Worst", sep = ".")
tar.o.Worst <-
do.call(rbind, lapply(seq(dim(tar$target_output.W)[3]),
function(x)
matrix(
tar$target_output.W[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(tar$target_output.W)[[2]])
)))
tar.o.Worst <-
cbind(
data.frame(
DMU = object$data$dmunames,
#dimnames(tar.o.Worst)[[1]],
alphacut = rep(object$alpha, each = dim(tar$target_output.W)[1])
),
data.frame(tar.o.Worst, row.names = NULL)
)
colnames(tar.o.Worst)[3:(ncol(tar.o.Worst))] <- paste("target",
colnames(tar.o.Worst)[3:(ncol(tar.o.Worst))],
"Worst", sep = ".")
tar.i.Best <-
do.call(rbind, lapply(seq(dim(tar$target_input.B)[3]),
function(x)
matrix(
tar$target_input.B[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(tar$target_input.B)[[2]])
)))
tar.i.Best <-
cbind(
data.frame(
DMU = dimnames(tar.i.Best)[[1]],
alphacut = rep(object$alpha, each = dim(tar$target_input.B)[1])
),
data.frame(tar.i.Best, row.names = NULL)
)
colnames(tar.i.Best)[3:(ncol(tar.i.Best))] <- paste("target",
colnames(tar.i.Best)[3:(ncol(tar.i.Best))],
"Best", sep = ".")
tar.o.Best <-
do.call(rbind, lapply(seq(dim(tar$target_output.B)[3]),
function(x)
matrix(
tar$target_output.B[, , x],
nrow = length(dmunames),
dimnames = list(dmunames, dimnames(tar$target_output.B)[[2]])
)))
tar.o.Best <-
cbind(
data.frame(
DMU = object$data$dmunames,
#dimnames(tar.o.Best)[[1]],
alphacut = rep(object$alpha, each = dim(tar$target_output.B)[1])
),
data.frame(tar.o.Best, row.names = NULL)
)
colnames(tar.o.Best)[3:(ncol(tar.o.Best))] <- paste("target",
colnames(tar.o.Best)[3:(ncol(tar.o.Best))],
"Best", sep = ".")
tar.i.df <-
merge(tar.i.Worst, tar.i.Best, by = c("alphacut", "DMU"))
# Re-arranging columns so they are sorted in col1.Worst col1.Best, col2.Worst col2.Best, ....
srtidx <- (3:ncol(tar.i.df))
srtidx <- t(matrix(srtidx, ncol = 2))
dim(srtidx) <- c(1, length(srtidx))
tar.i.df <- tar.i.df[, c(2, 1, srtidx)]
tar.o.df <-
merge(tar.o.Worst, tar.o.Best, by = c("alphacut", "DMU"))
# Re-arranging columns so they are sorted in col1.Worst col1.Best, col2.Worst col2.Best, ....
srtidx <- (3:ncol(tar.o.df))
srtidx <- t(matrix(srtidx, ncol = 2))
dim(srtidx) <- c(1, length(srtidx))
tar.o.df <- tar.o.df[, c(2, 1, srtidx)]
tar.df <- cbind(tar.i.df, tar.o.df[, 3:ncol(tar.o.df)])
if (!modelkl %in% c("additive", "addsupereff")) {
df <-
cbind(eff.df, s.df[, 3:ncol(s.df)], lmb.df[, 3:ncol(lmb.df)], tar.df[, 3:ncol(tar.df)])
} else {
df <-
cbind(s.df[, 3:ncol(s.df)], lmb.df[, 3:ncol(lmb.df)], tar.df[, 3:ncol(tar.df)])
}
if (modelkl %in% c("addsupereff", "sbmsupereff")) {
df <- cbind(df, supers.df[3:ncol(supers.df)])
}
if (exportExcel) {
df.list <- list(
efficiencies = eff.df,
slacks = s.df,
superslacks = supers.df,
lambdas = lmb.df,
targets = tar.df
)
df.list[sapply(df.list, is.null)] <- NULL
if (is.null(filename)) {
filename <- paste("ResultsDEA", Sys.time(), ".xlsx", sep = "")
filename <- gsub(" ", "_", filename)
filename <- gsub(":", ".", filename)
}
write_xlsx(df.list, path = filename)
}
if (!returnList) {
return(df)
} else {
df.list <- list(
efficiencies = eff.df,
slacks = s.df,
superslacks = supers.df,
lambdas = lmb.df,
targets = tar.df
)
return(df.list)
}
}
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.