Nothing
R/Electre3_AlphaBetaThresholds.R
In OutrankingTools: Functions for Solving Multiple-criteria Decision-making Problems
Defines functions
Electre3_AlphaBetaThresholds
Documented in
Electre3_AlphaBetaThresholds
Electre3_AlphaBetaThresholds <-
function(performanceMatrix,alternatives,criteria,minmaxcriteria,criteriaWeights,alpha_q,beta_q,alpha_p,beta_p,alpha_v,beta_v,mode_def){
cat("\014")
####################################################################################################################################################
# #
# Copyright Michel Prombo, 2014 #
# Module : electre III #
# Version 1.0 #
# #
# Contributors: #
# Michel Prombo <michel.prombo@statec.etat.lu> #
# Kevin Prombo-Rosamont <kevinrosamont@ymail.com> #
# #
# This software, ELECTRE III , is a package for the R OR software which allows to use MCDA algorithms and methods. #
# #
# This software is governed by the terms and conditions of the Free and open-source licenses. You can #
# use, modify and/ or redistribute the software under the terms of ....... #
# #
# #
# As a counterpart to the access to the source code and rights to copy,modify and redistribute granted by the license, users are provided only #
# with a limited warranty and the software's author, the holder of the economic rights, and the successive licensors have only limited liability. #
# #
# In this respect, the user's attention is drawn to the risks associated with loading, using, modifying and/or developing or reproducing the #
# software by the user in light of its specific status of free software, that may mean that it is complicated to manipulate, and that also #
# therefore means that it is reserved for developers and experienced professionals having in-depth computer knowledge. Users are therefore #
# encouraged to load and test the software's suitability as regards their requirements in conditions enabling the security of their systems and/or #
# data to be ensured and, more generally, to use and operate it in the # same conditions as regards security. #
# #
# The fact that you are presently reading this means that you have had knowledge of the terms and conditions of the Free and open-source licenses #
# and that you accept its terms. #
# #
####################################################################################################################################################
## ******************************************************* checking the input data **************************************************************#
# data is filtered, check for some data consistency
# if there are less than 2 criteria or 2 alternatives, there is no MCDA problem
if (is.null(dim(performanceMatrix)))
stop("less than 2 criteria or 2 alternatives")
## check the input data
if (!((is.matrix(performanceMatrix) || (is.data.frame(performanceMatrix)))))
stop("wrong performanceMatrix, should be a matrix or a data frame")
if (!(is.vector(alternatives)))
stop("alternatives should be a vector")
if (!is.character(alternatives))
stop("alternatives should be a character vector")
if(!(nrow(performanceMatrix)==length(alternatives)))
stop("length of alternatives should be checked")
if (!(is.vector(criteria)))
stop("criteria should be a vector")
if (!is.character(criteria))
stop("criteria should be a character vector")
if(!(ncol(performanceMatrix)==length(criteria)))
stop("length of criteria should be checked")
if (!(is.vector(minmaxcriteria)))
stop("minmaxcriteria should be a vector")
minmaxcriteria=tolower(minmaxcriteria)
if(!(ncol(performanceMatrix)==length(minmaxcriteria)))
stop("length of minmaxcriteria should be checked")
n=length(minmaxcriteria)
for (i in 1:n){
if(!((minmaxcriteria[i]=='min') ||(minmaxcriteria[i]=='max'))){
stop(" Vector minmaxcriteria must contain 'max' or 'min' ")
}
}
if (!(is.vector(criteriaWeights)))
stop("criteriaWeights should be a vector")
if (!is.numeric(criteriaWeights))
stop("criteriaWeights should be a numeric vector")
if(!(ncol(performanceMatrix)==length(criteriaWeights)))
stop("length of criteriaWeights should be checked")
if (!(is.vector(alpha_q)))
stop("alpha_q should be a vector")
if (!(is.vector(beta_q)))
stop("beta_q should be a vector")
if(!(ncol(performanceMatrix)==length(alpha_q)))
stop("length of alpha_q should be checked")
if(!(ncol(performanceMatrix)==length(beta_q)))
stop("length of beta_q should be checked")
if (!(is.vector(alpha_p)))
stop("alpha_p should be a vector")
if (!(is.vector(beta_p)))
stop("beta_p should be a vector")
if(!(ncol(performanceMatrix)==length(alpha_p)))
stop("length of alpha_p should be checked")
if(!(ncol(performanceMatrix)==length(beta_p)))
stop("length of beta_p should be checked")
if (!(is.vector(alpha_v)))
stop("alpha_v should be a vector")
if (!(is.vector(beta_v)))
stop("beta_v should be a vector")
if(!(ncol(performanceMatrix)==length(alpha_v)))
stop("length of alpha_v should be checked")
if(!(ncol(performanceMatrix)==length(beta_v)))
stop("length of beta_v should be checked")
if (!(is.vector(mode_def)))
stop("mode_def should be a vector")
mode_def=toupper(mode_def)
if(!(ncol(performanceMatrix)==length(mode_def)))
stop("length of mode_def should be checked")
n=length(mode_def)
for (i in 1:n){
if(!((mode_def[i]!="I") ||(mode_def[i]!="D"))){
stop(" Vector mode_def must contain 'I' or 'D'")
}
}
## ************************************* End of checking the validity of the "inputs" ******************************************************####
# ********************************************** Function related to the ascending distillation step ************************************** #
etape_asc <- function(newmat,to_rank,c_bar,alpha,beta) {
newmat_e=newmat
newmat_0=newmat
to_rank_e=to_rank
to_rank_0=to_rank
ind_min_lq=to_rank_e
lambda_1=1
etap=1
beta=0.30
alpha=0.15
lambda_10=0
c_bar_e=list()
len_ind_min_lq=length(ind_min_lq)
stop=0
while ((len_ind_min_lq > 1) && (lambda_1 >0) ){
cat(paste("Etape ",etap,sep=""),"\n")
to_rank_e=rownames(newmat_e)
to_rank_e=setdiff(to_rank_0,names(ind_min_lq))
fomn=rownames(newmat_e)
m=nrow(newmat_e)
newmat_i=newmat_e
diag(newmat_i)=0
vec_mat_cred =as.vector(newmat_i)
v_m_c=rev(sort(vec_mat_cred)) # vector related to the credibility matrix sorted in descending order
if (etap==1){
lambda_0=max(v_m_c)
} else{
lambda_0=lambda_10
}
lambda=lambda_0-(0.30-0.15*lambda_0)
v_m_c=v_m_c[v_m_c<lambda]
if (length(v_m_c)==0){
lambda_1=0
}else{
lambda_1= max(v_m_c)
}
# **************************************** Construction of the outranking matrix relation. ****************************************** #
mat_rel_cred <- matrix (rep(0, m*m), m, m)
for (i in 1:m){
for (j in 1:m){
if ((newmat_e[i,j] > lambda_1) && ( newmat_e[i,j] > (newmat_e[j,i] +(0.30-0.15*newmat_e[i,j]) ) ) ){
mat_rel_cred[i,j]=1
} else {
mat_rel_cred[i,j]=0
}
}
}
colnames(mat_rel_cred)=fomn
rownames(mat_rel_cred)=fomn
# ************************************ calcul lambda_puissance lambda_faiblesse lambda_qualification ************************************ #
lambda_p=c(rep(0,m)) # lamda power
lambda_f =c(rep(0,m)) # lambda weakness
lambda_q=c(rep(0,m)) # lambda qualification = difference (lambda_p - lambda_q)
lambda_p=apply(mat_rel_cred,1,sum) # calculation of the "lambda-power"
lambda_f=apply(mat_rel_cred,2,sum) # calculation of the "lambda-weakness"
lambda_q=lambda_p-lambda_f # calculation of the "lambda-qualification"
# Research of the minimal value of the qualification vector.
v_min_lq=min(lambda_q)
# calculating the vector corresponding to the minimum values action (there can be many)
ind_min_lq=which(lambda_q==v_min_lq)
name_ind_min_lq=names(ind_min_lq)
len_ind_min_lq=length(ind_min_lq)
if (len_ind_min_lq==1){
c_bar_e=name_ind_min_lq
} else {
c_bar_e=name_ind_min_lq
newmat_e=newmat_e[match(name_ind_min_lq, rownames(newmat_e)),match(name_ind_min_lq, colnames(newmat_e))]
}
cat("----------------------------------------------------","\n")
cat("Etap's ranking.","\n")
cat("----------------------------------------------------","\n")
print(c_bar_e)
cat("----------------------------------------------------","\n")
lambda_10=lambda_1
len_ind_min_lq==length(c_bar_e)
etap=etap+1
}
c_bar=c_bar_e
new_mat=newmat_0[-match(c_bar_e, rownames(newmat_0)),match(c_bar_e, colnames(newmat_0))]
to_rank=rownames(newmat)
return(list("newmat"=newmat,"to_rank"=to_rank,"c_bar"=c_bar))
}
# ***************************************** End of the Function related to the ascending distillation step ******************************************** #
# ********************************************** Function related to the descending distillation step ******************************************** #
etape_dsc <- function(newmat,to_rank,c_bar,alpha,beta) {
newmat_e=newmat
newmat_0=newmat
to_rank_e=to_rank
to_rank_0=to_rank
ind_max_lq=to_rank_e
lambda_1=1
etap=1
beta=0.30
alpha=0.15
lambda_10=0
c_bar_e=list()
len_ind_max_lq=length(ind_max_lq)
stop=0
while ((len_ind_max_lq > 1) && (lambda_1 >0) ){
cat(paste("Etape ",etap,sep=""),"\n")
to_rank_e=rownames(newmat_e)
to_rank_e=setdiff(to_rank_0,names(ind_max_lq))
fomn=rownames(newmat_e)
m=nrow(newmat_e)
newmat_i=newmat_e
diag(newmat_i)=0
vec_mat_cred =as.vector(newmat_i)
v_m_c=rev(sort(vec_mat_cred)) # vector related to the credibility matrix sorted in descending order
if (etap==1){
lambda_0=max(v_m_c)
} else{
lambda_0=lambda_10
}
lambda=lambda_0-(0.30-0.15*lambda_0)
v_m_c=v_m_c[v_m_c<lambda]
if (length(v_m_c)==0){
lambda_1=0
}else{
lambda_1= max(v_m_c) # lambda_1= max(v_m_c)
}
# cat("-------------------------------------------------------------------------------------------------------------------------------------","\n")
# ******************************************* Construction of the outranking matrix relation. ********************************************** #
mat_rel_cred <- matrix (rep(0, m*m), m, m)
for (i in 1:m){
for (j in 1:m){
if ((newmat_e[i,j] > lambda_1) && ( newmat_e[i,j] > (newmat_e[j,i] +(0.30-0.15*newmat_e[i,j]) ) ) ){
mat_rel_cred[i,j]=1
} else {
mat_rel_cred[i,j]=0
}
}
}
colnames(mat_rel_cred)=fomn
rownames(mat_rel_cred)=fomn
# ************************************ calcul lambda_puissance lambda_faiblesse lambda_qualification ************************************ #
lambda_p=c(rep(0,m)) # lamda power
lambda_f =c(rep(0,m)) # lambda weakness
lambda_q=c(rep(0,m)) # lambda qualification = difference (lambda_p - lambda_q)
lambda_p=apply(mat_rel_cred,1,sum) # calculation of the "lambda-power"
lambda_f=apply(mat_rel_cred,2,sum) # calculation of the "lambda-weakness"
lambda_q=lambda_p-lambda_f # calculation of the "lambda-qualification"
v_max_lq=max(lambda_q)
# calculating the vector corresponding to the maximum values action (there can be many)
ind_max_lq=which(lambda_q==v_max_lq)
name_ind_max_lq=names(ind_max_lq)
len_ind_max_lq=length(ind_max_lq)
if (len_ind_max_lq==1){
c_bar_e=name_ind_max_lq
} else {
c_bar_e=name_ind_max_lq
newmat_e=newmat_e[match(name_ind_max_lq, rownames(newmat_e)),match(name_ind_max_lq, colnames(newmat_e))]
}
cat("----------------------------------------------------","\n")
cat("Etap's ranking.","\n")
cat("----------------------------------------------------","\n")
print(c_bar_e)
cat("----------------------------------------------------","\n")
lambda_10=lambda_1
len_ind_max_lq==length(c_bar_e)
etap=etap+1
}
c_bar=c_bar_e
new_mat=newmat_0[-match(c_bar_e, rownames(newmat_0)),match(c_bar_e, colnames(newmat_0))]
to_rank=rownames(newmat)
return(list("newmat"=newmat,"to_rank"=to_rank,"c_bar"=c_bar))
}
# ***************************************** End of the Function related to the distillation step ******************************************** #
compte <- function(symbole, seq) {
seqbinaire <- rep(0, length(seq))
seqbinaire[seq == symbole] <- 1
nb <- sum(seqbinaire)
return(nb)
}
# ********************************************************* Variables initialization ********************************************************* #
mc1=0
mc2=0
md1=0
md2=0
mmv <- minmaxcriteria
p_1=alpha_p
p_2=beta_p
q_1=alpha_q
q_2=beta_q
v_1=alpha_v
v_2=beta_v
m_def=mode_def
pm=performanceMatrix
cr <- criteria
al=alternatives
vp=criteriaWeights
n=nrow(pm)
mc <- matrix (rep(0, n*n), n, n)
asc_ranking <- data.frame(Action=character(1),Rank=integer(1), stringsAsFactors = FALSE)
dsc_ranking <- data.frame(Action=character(1),Rank=integer(1), stringsAsFactors = FALSE)
ranking=list()
mc=diag(1,n)
md=diag(0,n)
print(m_def)
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
print(mmv)
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
print(p_1)
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
print(p_2)
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
print(q_1)
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
print(q_2)
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
print(v_1)
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
print(v_2)
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
# ****************************************** Check the validity of the thresholds coefficient ******************************************* #
for(j in 1:ncol(pm)){
if ((m_def[j]=="D") && (mmv[j]=="max")) {
if ( p_1[j] < (-1) ) {
stop(" alpha_p is less than -1 " )
}
if (q_1[j] < (-1)) {
stop(" alpha_q is less than -1 " )
}
if (!(is.na(v_1[j]))){
if (v_1[j] < (-1)){
stop(" retourne NA" )
}
}
}
if ((m_def[j]=="I") && (mmv[j]=="min") ) {
if (p_1[j] < -1 ) {
stop(" alpha_p is less than -1 " )
}
if (q_1[j] < -1) {
stop(" Please check the limits or bounds of the thresholds" )
}
if (!(is.na(v_1[j]))){
if (v_1[j] < (-1)){
cat("v_1 is less than (-1)","\n")
stop(" Please check the limits or bounds of the thresholds" )
}
}
}
if ( (m_def[j]=="D") && (mmv[j]=="min") ) {
if (p_1[j] > 1 ) {
# stop(" Please check the limits or bounds of the thresholds" )
}
if (q_1[j] > 1){
# stop(" Please check the limits or bounds of the thresholds" )
}
if (!(is.na(v_1[j]))){
# stop(" Please check the limits or bounds of the thresholds" )
}
if (is.na((v_1[j] < -1))){
# stop(" Please check the limits or bounds of the thresholds" )
}
}
if ( (m_def[j]=="I") && (mmv[j]=="max") ) {
if (p_1[j] > 1){
# stop(" Please check the limits or bounds of the thresholds" )
}
if (q_1[j] > 1){
# stop(" Please check the limits or bounds of the thresholds" )
}
if (!(is.na(v_1[j]))){
# stop(" Please check the limits or bounds of the thresholds" )
}
if (is.na((v_1[j] < -1))){
# stop(" Please check the limits or bounds of the thresholds" )
}
}
}
# ************************************************ Transforming Inverse mode to Direct mode ********************************************* #
if (!(is.na(match("I", m_def)))) {
for(j in 1:ncol(pm)){
if (m_def[j]=="I"){
alpha_p=p_1[j]
alpha_q=q_1[j]
alpha_v=v_1[j]
if (mmv[j]=="min"){
p_1[j]=p_1[j]/(1+alpha_p)
p_2[j]=p_2[j]/(1+alpha_p)
q_1[j]=q_1[j]/(1+alpha_q)
q_2[j]=q_2[j]/(1+alpha_q)
v_1[j]=v_1[j]/(1+alpha_v)
v_2[j]=v_2[j]/(1+alpha_v)
} else {
if (mmv[j]=="max"){
p_1[j]=p_1[j]/(1-alpha_p)
p_2[j]=p_2[j]/(1-alpha_p)
q_1[j]=q_1[j]/(1-alpha_q)
q_2[j]=q_2[j]/(1-alpha_q)
v_1[j]=v_1[j]/(1-alpha_v)
v_2[j]=v_2[j]/(1-alpha_v)
}
}
}
}
}
# ********************************************** End of converting Inverse mode to Direct mode ***************************************** #
# ********************************************************** Calculation of the concordance matrix ***************************************** #
mc1=0
mc2=0
for (i in 1:nrow(pm)){
k=i+1
while (k<=n){
# Columns' iterations
for (j in 1:ncol(pm)){
# calculation of the partial concordance index (i,k) related to the criteria j
# ***** CASE 1
if ((mmv[j]=="max") && (m_def[j]=="D") ) {
c_ik =( (p_1[j]*pm[i,j]+p_2[j])+ pm[i,j]-pm[k,j])/((p_1[j]*pm[i,j]+p_2[j])- (q_1[j]*pm[i,j]+q_2[j]))
c_ki =( (p_1[j]*pm[k,j]+p_2[j])+ pm[k,j]-pm[i,j])/((p_1[j]*pm[k,j]+p_2[j])- (q_1[j]*pm[k,j]+q_2[j]))
}
# ***** CASE 2
if ((mmv[j]=="min") && (m_def[j]=="D") ) {
c_ik =( (p_1[j]*pm[i,j]+p_2[j])- (pm[i,j]- pm[k,j]))/((p_1[j]*pm[i,j]+p_2[j])- (q_1[j]*pm[i,j]+q_2[j]))
c_ki =( (p_1[j]*pm[k,j]+p_2[j])- (pm[k,j]- pm[i,j]))/((p_1[j]*pm[k,j]+p_2[j])- (q_1[j]*pm[k,j]+q_2[j]))
}
# ***** CASE 3 <=> CASE 1
if ((mmv[j]=="max") && (m_def[j]=="I") ) {
c_ik =( (p_1[j]*pm[i,j]+p_2[j])+ pm[i,j]-pm[k,j])/((p_1[j]*pm[i,j]+p_2[j])- (q_1[j]*pm[i,j]+q_2[j]))
c_ki =( (p_1[j]*pm[k,j]+p_2[j])+ pm[k,j]-pm[i,j])/((p_1[j]*pm[k,j]+p_2[j])- (q_1[j]*pm[k,j]+q_2[j]))
}
# ***** CASE 4 <=> CASE 2
if ((mmv[j]=="min") && (m_def[j]=="I") ){
c_ik =( (p_1[j]*pm[i,j]+p_2[j])- (pm[i,j]- pm[k,j]))/((p_1[j]*pm[i,j]+p_2[j])- (q_1[j]*pm[i,j]+q_2[j]))
c_ki =( (p_1[j]*pm[k,j]+p_2[j])- (pm[k,j]- pm[i,j]))/((p_1[j]*pm[k,j]+p_2[j])- (q_1[j]*pm[k,j]+q_2[j]))
}
if(c_ik <=0){
c10=0
} else if (c_ik >=1) {
c10=1
} else {
c10=c_ik
}
if(c_ki<=0){
c20=0
} else if (c_ki >=1) {
c20=1
} else {
c20=c_ki
}
mc1=round(mc1+c10*vp[j], digits=4)
mc2=round(mc2+c20*vp[j], digits=4)
}
mc[i,k]=round(mc1/sum(vp) , digits=4)
mc[k,i]=round(mc2/sum(vp) , digits=4)
mc1=0
mc2=0
k=k+1
}
}
# ************************************************* End of the calculation of the concordance matrix *************************************** #
# ********************************* row names of the table (dv) related to the discordance values ****************************************** #
col_d=matrix(c(rep(0,n*n)),nrow=n)
for (i in 1:n){
for (j in 1:n){
col_d[i,j]=paste(i,"R",j,sep="")
}
}
# don't forget to transpose due to the R process to convert matrix into vector
name_d=as.vector(t(col_d))
# *********************************************** Calculation of the discordance table ************************************** #
# v_1[is.na(v_1)] <- 0
# v_2[is.na(v_2)] <- 0
n=nrow(pm)
m=ncol(pm)
dv <- matrix (rep(0, n*n*m), n*n, m)
l=1
for (i in 1:nrow(pm)){
k=1
while (k<=n){
# Columns' iterations
for (j in 1:ncol(pm)){
# calculation of the discordance index (i,k) related to the criteria j
if( (!(is.na(v_1[j]))) &&!(is.na(v_2[j]))){
# ***** CAS 1
if ((mmv[j]=="max") && (m_def[j]=="D") ){
d_ik =( pm[k,j]-pm[i,j]-(p_1[j]*pm[i,j]+p_2[j]))/((v_1[j]*pm[i,j]+v_2[j])-(p_1[j]*pm[i,j]+p_2[j]))
}
# ***** CAS 2
if ((mmv[j]=="min") && (m_def[j]=="D") ){
d_ik =( (pm[i,j]- (p_1[j]*pm[i,j]+p_2[j])- pm[k,j]))/((v_1[j]*pm[i,j]+v_2[j])-(p_1[j]*pm[i,j]+p_2[j]))
}
# ***** CAS 3
if ((mmv[j]=="max") && (m_def[j]=="I") ){
d_ik =( pm[k,j]-pm[i,j]-(p_1[j]*pm[i,j]+p_2[j]))/((v_1[j]*pm[i,j]+v_2[j])-(p_1[j]*pm[i,j]+p_2[j]))
}
# ***** CAS 4
if ((mmv[j]=="min") && (m_def[j]=="I") ){
d_ik =( (pm[i,j]- (p_1[j]*pm[i,j]+p_2[j])- pm[k,j]))/((v_1[j]*pm[i,j]+v_2[j])-(p_1[j]*pm[i,j]+p_2[j]))
}
#d1 =(pm[k,j] - pm[i,j] - p[j])/(v[j]-p[j])
} else {
d_ik=0
}
if(d_ik <=0){
d10=0
} else if (d_ik >=1) {
d10=1
} else {
d10=d_ik
}
# ******************************************************************************************************************************************* #
dv[l,j]=round(d10,digits=4)
}
l=l+1
k=k+1
}
}
# ************************************************* End of the calculation of the discordance table ************************************* #
# ****************************************** Calculation of the Fuzzy Outranking credibility Matrix *********************************** #
v_mc=as.vector(t(mc))
# print(v_mc)
v_cred=c(rep(0,n*n))
v_cum=1
m=ncol(pm)
for (i in 1:(n*n)){
if (max(dv[i,])==1){
v_cred[i]=0
} else if (max(dv[i,])<v_mc[i]){
v_cred[i]=v_mc[i]
} else if (max(dv[i,]) > v_mc[i]){
v_cum=1
for (j in 1:m) {
# calcul de l'indicateur de crédibilité pour les dv[i,j] supérieurs ŕ l'indicateur de concordance globale
if (dv[i,j] > v_mc[i]) {
v_cum=v_cum*( (1-dv[i,j])/(1-v_mc[i]))
}
}
v_cum=v_mc[i]*v_cum
v_cred[i]=round(v_cum, digits=4)
}
}
# *************************************** End of the calculation of the credibility matrix ************************************* #
dv=round(dv,digits=4)
mat_cred=round(matrix(v_cred,ncol=n,nrow=n),digits=4)
mat_cred=t(mat_cred)
rownames(pm)=al
colnames(pm)=cr
rownames(mc)=al
colnames(mc)=al
rownames(mat_cred)=al
colnames(mat_cred)=al
rownames(dv)=name_d
colnames(dv)=cr
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
cat("Performance Matrix","\n")
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
print(pm)
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
cat("Concordance Matrix","\n")
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
print(mc )
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
cat("Criteria Discordance Table ","\n")
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
print(dv)
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
cat("Credibility Matrix","\n")
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
print(mat_cred)
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
# ******************************************************* Ascending distillation *************************************************** #
cat("--------------------------------------------------------- Ascending distillation ----------------------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
cat("-----------------------------------------------Beginning of the Ascending distillation ------------------------------------------","\n")
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
# ******************************************************************************************************************************************* #
to_rank_0=al # vector of the alternatives to be ranked
len=length(to_rank_0) # number of the alternatives to be ranked
c_bar=list() # list of the ranked alternatives
# ******************************************************************************************************************************************* #
beta=0.30
alpha=0.15
compt_d=1
to_rank =to_rank_0
newmat=mat_cred
newmat_0=mat_cred
len_to_rank=length(al)
len_to_rank_0=length(al)
r=0
while ( len_to_rank_0 != 1 && nrow(newmat)>1){
cat(paste("Distillation_",compt_d,sep=""),"\n")
z=etape_asc(newmat,to_rank,c_bar,alpha,beta)
c_bar= union(c_bar,z$c_bar)
newmat=newmat_0[-match(c_bar, rownames(newmat_0)),-match(c_bar, colnames(newmat_0))]
to_rank =z$to_rank
len_to_rank_0=len_to_rank - length(c_bar)
# cat("---------------------- we print the rankings before moving to d+1 ------------------","\n")
ranking=union(ranking,c_bar)
# print(ranking)
cat("----------------------------------------------------------------------------------------","\n")
zc_bar=z$c_bar
c=length(zc_bar)
j=1
for (i in (r+1):(r+c)){
asc_ranking[i,1]=zc_bar[j]
asc_ranking[i,2]=compt_d
j=j+1
}
r=nrow(asc_ranking)
to_rank_0=setdiff(to_rank_0,c_bar)
if (len_to_rank_0==1) {
asc_ranking[nrow(asc_ranking)+1,1]=to_rank_0
asc_ranking[nrow(asc_ranking),2]=compt_d+1
}
if (len_to_rank_0==0) {
len_to_rank_0=1
}
compt_d=compt_d+1
}
b_e=max(asc_ranking[,2])+min(asc_ranking[,2])
for (i in 1:length(al)){
asc_ranking[i,2]=b_e-asc_ranking[i,2]
}
asc_ranking=asc_ranking[order(-(asc_ranking[,2])),]
print(asc_ranking)
cat("------------------------------------------------------------------------------------------------------------","\n")
cat("---------------------------------- End of the Ascending distillation -----------------------------------","\n")
cat("------------------------------------------------------------------------------------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
asc=asc_ranking
cat("-----------------------------------------------------------------------------------------------------------","\n")
cat("-------------------------Beginning of the Descending distillation ------------------------------------","\n")
cat("-----------------------------------------------------------------------------------------------------------","\n")
# ******************************************************************************************************************************************** #
to_rank_0=al # vector of the alternatives to be ranked
len=length(to_rank_0) # number of the alternatives to be ranked
c_bar=list() # list of the ranked alternatives
# ********************************************************************************************************************************************* #
beta=0.30
alpha=0.15
compt_d=1
to_rank =to_rank_0
newmat=mat_cred
newmat_0=mat_cred
len_to_rank=length(al)
len_to_rank_0=length(al)
r=0
while (len_to_rank_0 != 1){ #(len_to_rank_0 == 1)
cat(paste("Distillation_",compt_d,sep=""),"\n")
z=etape_dsc(newmat,to_rank,c_bar,alpha,beta)
c_bar= union(c_bar,z$c_bar)
newmat=newmat_0[-match(c_bar, rownames(newmat_0)),-match(c_bar, colnames(newmat_0))]
to_rank =z$to_rank
len_to_rank_0=len_to_rank - length(c_bar)
# cat("---------------------- we print the rankings before moving to ŕ d+1 ------------------","\n")
ranking=union(ranking,c_bar)
# print(ranking)
cat("-------------------------------------------------------------------------------------------","\n")
zc_bar=z$c_bar
c=length(zc_bar)
j=1
for (i in (r+1):(r+c)){
dsc_ranking[i,1]=zc_bar[j]
dsc_ranking[i,2]=compt_d
j=j+1
}
r=nrow(dsc_ranking)
to_rank_0=setdiff(to_rank_0,c_bar)
cat("-----------------------------------------------------------------------------------------","\n")
if (len_to_rank_0==1) {
dsc_ranking[nrow(dsc_ranking)+1,1]=to_rank_0
dsc_ranking[nrow(dsc_ranking),2]=compt_d+1
}
if (len_to_rank_0==0) {
len_to_rank_0=1
}
# print(dsc_ranking)
compt_d=compt_d+1
}
dsc=dsc_ranking[ order(dsc_ranking[,2], dsc_ranking[,1]), ]
# cat("--------------------------------------------------------------------------------------------------------","\n")
cat("-------------------------------- End of the Descending distillation ---------------------------------","\n")
# cat("--------------------------------------------------------------------------------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat("-------------------------------- Ascending distillation ranking ---------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
print(asc_ranking)
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat("-------------------------------- Descending distillation ranking ---------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
print(dsc_ranking)
cat(" ","\n")
cat(" ","\n")
n=nrow(pm)
matranking <- matrix (rep(0, n*n), n, n)
mrank <- matrix (rep(0, n*n), n, n)
d_matrank=c(rep("I",times=n))
diag(matranking)=d_matrank
al=dsc[,1]
rownames(matranking)=al
colnames(matranking)=al
rownames(mrank)=al
colnames(mrank)=al
final_ranking <- data.frame(alternative=al,sum_outrank=c(rep(0,times=length(al))),ranking=c(rep(0,times=length(al))),stringsAsFactors = FALSE)
# print(final_ranking)
# ******************************************************************************************************************************************************* #
for (i in 1:n){
for (j in 1:n){
if ((dsc[which(dsc$Action==al[i]),2] < dsc[which(dsc$Action==al[j]),2]) && (asc[which(asc$Action==al[i]),2] <= asc[which(asc$Action==al[j]),2])){
matranking[al[i],al[j]]="P"
mrank[al[i],al[j]]=1
} else if ((dsc[which(dsc$Action==al[i]),2] <= dsc[which(dsc$Action==al[j]),2]) && (asc[which(asc$Action==al[i]),2] < asc[which(asc$Action==al[j]),2])){
matranking[al[i],al[j]]="P"
mrank[al[i],al[j]]=1
} else if ((dsc[which(dsc$Action==al[i]),2] > dsc[which(dsc$Action==al[j]),2]) && (asc[which(asc$Action==al[i]),2] >= asc[which(asc$Action==al[j]),2])){
matranking[al[i],al[j]]="NP"
} else if ((dsc[which(dsc$Action==al[i]),2] >= dsc[which(dsc$Action==al[j]),2]) && (asc[which(asc$Action==al[i]),2] > asc[which(asc$Action==al[j]),2])){
matranking[al[i],al[j]]="NP"
} else if ((dsc[which(dsc$Action==al[i]),2] == dsc[which(dsc$Action==al[j]),2]) && (asc[which(asc$Action==al[i]),2] == asc[which(asc$Action==al[j]),2])){
matranking[al[i],al[j]]="I"
} else if ((dsc[which(dsc$Action==al[i]),2] < dsc[which(dsc$Action==al[j]),2]) && (asc[which(asc$Action==al[i]),2] > asc[which(asc$Action==al[j]),2])){
matranking[al[i],al[j]]="R"
mrank[al[i],al[j]]=1
} else if ((dsc[which(dsc$Action==al[i]),2] > dsc[which(dsc$Action==al[j]),2]) && (asc[which(asc$Action==al[i]),2] < asc[which(asc$Action==al[j]),2])){
matranking[al[i],al[j]]="R"
mrank[al[i],al[j]]=1
}
}
}
# ***************************************************************************************************************************************************** #
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat("----------------------------------- Final Ranking Matrix -----------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
print(matranking)
cat(" ","\n")
cat(" ","\n")
cat(" --------------------------- End of Final Ranking Matrix ----------------------------------","\n")
for (i in 1:n){
seq=matranking[final_ranking[i,1],]
final_ranking[i,2]=compte("P",seq)
}
final_ranking=final_ranking[ order(-final_ranking[,2], final_ranking[,1]), ]
j=1
for (i in 1:n-1){
if (matranking[final_ranking[i,1],final_ranking[i+1,1]]== "P" && i==1){
final_ranking[i,3]=j
final_ranking[i+1,3]=j+1
j=j+1
}
if (matranking[final_ranking[i,1],final_ranking[i+1,1]]== "I" && i==1){
final_ranking[i,3]=i
final_ranking[i+1,3]=i
j=j+1
}
else if (i>1){
if ( (matranking[final_ranking[i,1],final_ranking[i+1,1]]== "P") && (final_ranking[i,2]>1)){
final_ranking[i,3]=j
final_ranking[i+1,3]=j+1
j=j+1
} else if ( (matranking[final_ranking[i,1],final_ranking[i+1,1]]== "P") && (final_ranking[i+1,2]==0)){
final_ranking[i,3]=j
final_ranking[i+1,3]=j+1
j=j+1
} else if ( (matranking[final_ranking[i,1],final_ranking[i+1,1]]== "R") && (final_ranking[i+1,2]==0)){
final_ranking[i,3]=j
final_ranking[i+1,3]=final_ranking[i,3]+1
}else if ( (matranking[final_ranking[i,1],final_ranking[i+1,1]]== "I") && (final_ranking[i+1,2]==0)){
final_ranking[i+1,3]=final_ranking[i,3]
} else if (matranking[final_ranking[i,1],final_ranking[i+1,1]]== "I" && (final_ranking[i+1,2]!=0)){
final_ranking[i+1,3]=final_ranking[i,3]
} else if (matranking[final_ranking[i,1],final_ranking[i+1,1]]== "R" && (final_ranking[i+1,2]!=0)){
final_ranking[i+1,3]=final_ranking[i,3]
}
}
}
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
print(final_ranking[,-2])
names_matrank_adj=final_ranking[,1]
matrank_adj <- matrix (rep(0, n*n), n, n)
rownames(matrank_adj)=names_matrank_adj
colnames(matrank_adj)=names_matrank_adj
for (i in 1:n){
for (j in 1:n){
if( (final_ranking[j,3]-final_ranking[i,3]==1) && (matranking[final_ranking[i,1],final_ranking[j,1]]== "P")){
matrank_adj[i,j]=1
}
if( (final_ranking[j,3]-final_ranking[i,3]==1) && (matranking[final_ranking[i,1],final_ranking[j,1]]== "I")){
matrank_adj[i,j]=1
}
if( (final_ranking[j,3]-final_ranking[i,3]==1) && (matranking[final_ranking[i,1],final_ranking[j,1]]== "R")){
matrank_adj[i,j]=1
}
}
}
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat("------------------------------------------ adjacent Ranking Matrix -------------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
print(matrank_adj)
cat(" ","\n")
cat(" ","\n")
cat("-------------------------------------------------------------------------------------------------------------","\n")
# print(mrank)
g1<-graph.adjacency(matrank_adj);
g2=plot(g1)
final_ranking=final_ranking[,-2]
# prepare the output
sink("result.txt")
cat("------------------------------------------------------------------------------ Performance table --------------------------------------------------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
print(pm)
cat(" ","\n")
cat(" ","\n")
cat("----------------------------------------------------------------------------- Concordance matrix -------------------------------------------------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
print(mc)
cat(" ","\n")
cat(" ","\n")
cat("----------------------------------------------------------------------------- Discordance table --------------------------------------------------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
print(dv)
cat(" ","\n")
cat(" ","\n")
cat("----------------------------------------------------------------------------- Credibility matrix -----------------------------------------------------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
print(mat_cred)
cat(" ","\n")
cat(" ","\n")
cat("----------------------------------------------------------------------------- Ascending ranking ----------------------------------------------------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
print(asc_ranking)
cat(" ","\n")
cat(" ","\n")
cat("----------------------------------------------------------------------------- Descending ranking ---------------------------------------------------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
print(dsc_ranking)
cat(" ","\n")
cat(" ","\n")
cat("----------------------------------------------------------------------------- Final ranking ---------------------------------------------------------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
print(final_ranking)
cat(" ","\n")
cat(" ","\n")
cat("-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------","\n")
sink()
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat("----------------------------------------------------------------------------------------------------------------","\n")
cat("End of the calculation","\n")
cat("----------------------------------------------------------------------------------------------------------------","\n")
# prepare the output
out <- list("Performance Matrix"=pm,"Concordance Matrix"=mc,"Criteria Discordance Table" =dv,"Credibility Matrix"=mat_cred,"Ascending distillation ranking"=asc_ranking,"Descending distillation ranking"=dsc_ranking,"Final Ranking Matrix"=final_ranking)
return(out)
}
Try the OutrankingTools package in your browser
Any scripts or data that you put into this service are public.
OutrankingTools documentation built on May 2, 2019, 1:06 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 Electre3_AlphaBetaThresholds
Documented in Electre3_AlphaBetaThresholds
Electre3_AlphaBetaThresholds <-
function(performanceMatrix,alternatives,criteria,minmaxcriteria,criteriaWeights,alpha_q,beta_q,alpha_p,beta_p,alpha_v,beta_v,mode_def){
cat("\014")
####################################################################################################################################################
# #
# Copyright Michel Prombo, 2014 #
# Module : electre III #
# Version 1.0 #
# #
# Contributors: #
# Michel Prombo <michel.prombo@statec.etat.lu> #
# Kevin Prombo-Rosamont <kevinrosamont@ymail.com> #
# #
# This software, ELECTRE III , is a package for the R OR software which allows to use MCDA algorithms and methods. #
# #
# This software is governed by the terms and conditions of the Free and open-source licenses. You can #
# use, modify and/ or redistribute the software under the terms of ....... #
# #
# #
# As a counterpart to the access to the source code and rights to copy,modify and redistribute granted by the license, users are provided only #
# with a limited warranty and the software's author, the holder of the economic rights, and the successive licensors have only limited liability. #
# #
# In this respect, the user's attention is drawn to the risks associated with loading, using, modifying and/or developing or reproducing the #
# software by the user in light of its specific status of free software, that may mean that it is complicated to manipulate, and that also #
# therefore means that it is reserved for developers and experienced professionals having in-depth computer knowledge. Users are therefore #
# encouraged to load and test the software's suitability as regards their requirements in conditions enabling the security of their systems and/or #
# data to be ensured and, more generally, to use and operate it in the # same conditions as regards security. #
# #
# The fact that you are presently reading this means that you have had knowledge of the terms and conditions of the Free and open-source licenses #
# and that you accept its terms. #
# #
####################################################################################################################################################
## ******************************************************* checking the input data **************************************************************#
# data is filtered, check for some data consistency
# if there are less than 2 criteria or 2 alternatives, there is no MCDA problem
if (is.null(dim(performanceMatrix)))
stop("less than 2 criteria or 2 alternatives")
## check the input data
if (!((is.matrix(performanceMatrix) || (is.data.frame(performanceMatrix)))))
stop("wrong performanceMatrix, should be a matrix or a data frame")
if (!(is.vector(alternatives)))
stop("alternatives should be a vector")
if (!is.character(alternatives))
stop("alternatives should be a character vector")
if(!(nrow(performanceMatrix)==length(alternatives)))
stop("length of alternatives should be checked")
if (!(is.vector(criteria)))
stop("criteria should be a vector")
if (!is.character(criteria))
stop("criteria should be a character vector")
if(!(ncol(performanceMatrix)==length(criteria)))
stop("length of criteria should be checked")
if (!(is.vector(minmaxcriteria)))
stop("minmaxcriteria should be a vector")
minmaxcriteria=tolower(minmaxcriteria)
if(!(ncol(performanceMatrix)==length(minmaxcriteria)))
stop("length of minmaxcriteria should be checked")
n=length(minmaxcriteria)
for (i in 1:n){
if(!((minmaxcriteria[i]=='min') ||(minmaxcriteria[i]=='max'))){
stop(" Vector minmaxcriteria must contain 'max' or 'min' ")
}
}
if (!(is.vector(criteriaWeights)))
stop("criteriaWeights should be a vector")
if (!is.numeric(criteriaWeights))
stop("criteriaWeights should be a numeric vector")
if(!(ncol(performanceMatrix)==length(criteriaWeights)))
stop("length of criteriaWeights should be checked")
if (!(is.vector(alpha_q)))
stop("alpha_q should be a vector")
if (!(is.vector(beta_q)))
stop("beta_q should be a vector")
if(!(ncol(performanceMatrix)==length(alpha_q)))
stop("length of alpha_q should be checked")
if(!(ncol(performanceMatrix)==length(beta_q)))
stop("length of beta_q should be checked")
if (!(is.vector(alpha_p)))
stop("alpha_p should be a vector")
if (!(is.vector(beta_p)))
stop("beta_p should be a vector")
if(!(ncol(performanceMatrix)==length(alpha_p)))
stop("length of alpha_p should be checked")
if(!(ncol(performanceMatrix)==length(beta_p)))
stop("length of beta_p should be checked")
if (!(is.vector(alpha_v)))
stop("alpha_v should be a vector")
if (!(is.vector(beta_v)))
stop("beta_v should be a vector")
if(!(ncol(performanceMatrix)==length(alpha_v)))
stop("length of alpha_v should be checked")
if(!(ncol(performanceMatrix)==length(beta_v)))
stop("length of beta_v should be checked")
if (!(is.vector(mode_def)))
stop("mode_def should be a vector")
mode_def=toupper(mode_def)
if(!(ncol(performanceMatrix)==length(mode_def)))
stop("length of mode_def should be checked")
n=length(mode_def)
for (i in 1:n){
if(!((mode_def[i]!="I") ||(mode_def[i]!="D"))){
stop(" Vector mode_def must contain 'I' or 'D'")
}
}
## ************************************* End of checking the validity of the "inputs" ******************************************************####
# ********************************************** Function related to the ascending distillation step ************************************** #
etape_asc <- function(newmat,to_rank,c_bar,alpha,beta) {
newmat_e=newmat
newmat_0=newmat
to_rank_e=to_rank
to_rank_0=to_rank
ind_min_lq=to_rank_e
lambda_1=1
etap=1
beta=0.30
alpha=0.15
lambda_10=0
c_bar_e=list()
len_ind_min_lq=length(ind_min_lq)
stop=0
while ((len_ind_min_lq > 1) && (lambda_1 >0) ){
cat(paste("Etape ",etap,sep=""),"\n")
to_rank_e=rownames(newmat_e)
to_rank_e=setdiff(to_rank_0,names(ind_min_lq))
fomn=rownames(newmat_e)
m=nrow(newmat_e)
newmat_i=newmat_e
diag(newmat_i)=0
vec_mat_cred =as.vector(newmat_i)
v_m_c=rev(sort(vec_mat_cred)) # vector related to the credibility matrix sorted in descending order
if (etap==1){
lambda_0=max(v_m_c)
} else{
lambda_0=lambda_10
}
lambda=lambda_0-(0.30-0.15*lambda_0)
v_m_c=v_m_c[v_m_c<lambda]
if (length(v_m_c)==0){
lambda_1=0
}else{
lambda_1= max(v_m_c)
}
# **************************************** Construction of the outranking matrix relation. ****************************************** #
mat_rel_cred <- matrix (rep(0, m*m), m, m)
for (i in 1:m){
for (j in 1:m){
if ((newmat_e[i,j] > lambda_1) && ( newmat_e[i,j] > (newmat_e[j,i] +(0.30-0.15*newmat_e[i,j]) ) ) ){
mat_rel_cred[i,j]=1
} else {
mat_rel_cred[i,j]=0
}
}
}
colnames(mat_rel_cred)=fomn
rownames(mat_rel_cred)=fomn
# ************************************ calcul lambda_puissance lambda_faiblesse lambda_qualification ************************************ #
lambda_p=c(rep(0,m)) # lamda power
lambda_f =c(rep(0,m)) # lambda weakness
lambda_q=c(rep(0,m)) # lambda qualification = difference (lambda_p - lambda_q)
lambda_p=apply(mat_rel_cred,1,sum) # calculation of the "lambda-power"
lambda_f=apply(mat_rel_cred,2,sum) # calculation of the "lambda-weakness"
lambda_q=lambda_p-lambda_f # calculation of the "lambda-qualification"
# Research of the minimal value of the qualification vector.
v_min_lq=min(lambda_q)
# calculating the vector corresponding to the minimum values action (there can be many)
ind_min_lq=which(lambda_q==v_min_lq)
name_ind_min_lq=names(ind_min_lq)
len_ind_min_lq=length(ind_min_lq)
if (len_ind_min_lq==1){
c_bar_e=name_ind_min_lq
} else {
c_bar_e=name_ind_min_lq
newmat_e=newmat_e[match(name_ind_min_lq, rownames(newmat_e)),match(name_ind_min_lq, colnames(newmat_e))]
}
cat("----------------------------------------------------","\n")
cat("Etap's ranking.","\n")
cat("----------------------------------------------------","\n")
print(c_bar_e)
cat("----------------------------------------------------","\n")
lambda_10=lambda_1
len_ind_min_lq==length(c_bar_e)
etap=etap+1
}
c_bar=c_bar_e
new_mat=newmat_0[-match(c_bar_e, rownames(newmat_0)),match(c_bar_e, colnames(newmat_0))]
to_rank=rownames(newmat)
return(list("newmat"=newmat,"to_rank"=to_rank,"c_bar"=c_bar))
}
# ***************************************** End of the Function related to the ascending distillation step ******************************************** #
# ********************************************** Function related to the descending distillation step ******************************************** #
etape_dsc <- function(newmat,to_rank,c_bar,alpha,beta) {
newmat_e=newmat
newmat_0=newmat
to_rank_e=to_rank
to_rank_0=to_rank
ind_max_lq=to_rank_e
lambda_1=1
etap=1
beta=0.30
alpha=0.15
lambda_10=0
c_bar_e=list()
len_ind_max_lq=length(ind_max_lq)
stop=0
while ((len_ind_max_lq > 1) && (lambda_1 >0) ){
cat(paste("Etape ",etap,sep=""),"\n")
to_rank_e=rownames(newmat_e)
to_rank_e=setdiff(to_rank_0,names(ind_max_lq))
fomn=rownames(newmat_e)
m=nrow(newmat_e)
newmat_i=newmat_e
diag(newmat_i)=0
vec_mat_cred =as.vector(newmat_i)
v_m_c=rev(sort(vec_mat_cred)) # vector related to the credibility matrix sorted in descending order
if (etap==1){
lambda_0=max(v_m_c)
} else{
lambda_0=lambda_10
}
lambda=lambda_0-(0.30-0.15*lambda_0)
v_m_c=v_m_c[v_m_c<lambda]
if (length(v_m_c)==0){
lambda_1=0
}else{
lambda_1= max(v_m_c) # lambda_1= max(v_m_c)
}
# cat("-------------------------------------------------------------------------------------------------------------------------------------","\n")
# ******************************************* Construction of the outranking matrix relation. ********************************************** #
mat_rel_cred <- matrix (rep(0, m*m), m, m)
for (i in 1:m){
for (j in 1:m){
if ((newmat_e[i,j] > lambda_1) && ( newmat_e[i,j] > (newmat_e[j,i] +(0.30-0.15*newmat_e[i,j]) ) ) ){
mat_rel_cred[i,j]=1
} else {
mat_rel_cred[i,j]=0
}
}
}
colnames(mat_rel_cred)=fomn
rownames(mat_rel_cred)=fomn
# ************************************ calcul lambda_puissance lambda_faiblesse lambda_qualification ************************************ #
lambda_p=c(rep(0,m)) # lamda power
lambda_f =c(rep(0,m)) # lambda weakness
lambda_q=c(rep(0,m)) # lambda qualification = difference (lambda_p - lambda_q)
lambda_p=apply(mat_rel_cred,1,sum) # calculation of the "lambda-power"
lambda_f=apply(mat_rel_cred,2,sum) # calculation of the "lambda-weakness"
lambda_q=lambda_p-lambda_f # calculation of the "lambda-qualification"
v_max_lq=max(lambda_q)
# calculating the vector corresponding to the maximum values action (there can be many)
ind_max_lq=which(lambda_q==v_max_lq)
name_ind_max_lq=names(ind_max_lq)
len_ind_max_lq=length(ind_max_lq)
if (len_ind_max_lq==1){
c_bar_e=name_ind_max_lq
} else {
c_bar_e=name_ind_max_lq
newmat_e=newmat_e[match(name_ind_max_lq, rownames(newmat_e)),match(name_ind_max_lq, colnames(newmat_e))]
}
cat("----------------------------------------------------","\n")
cat("Etap's ranking.","\n")
cat("----------------------------------------------------","\n")
print(c_bar_e)
cat("----------------------------------------------------","\n")
lambda_10=lambda_1
len_ind_max_lq==length(c_bar_e)
etap=etap+1
}
c_bar=c_bar_e
new_mat=newmat_0[-match(c_bar_e, rownames(newmat_0)),match(c_bar_e, colnames(newmat_0))]
to_rank=rownames(newmat)
return(list("newmat"=newmat,"to_rank"=to_rank,"c_bar"=c_bar))
}
# ***************************************** End of the Function related to the distillation step ******************************************** #
compte <- function(symbole, seq) {
seqbinaire <- rep(0, length(seq))
seqbinaire[seq == symbole] <- 1
nb <- sum(seqbinaire)
return(nb)
}
# ********************************************************* Variables initialization ********************************************************* #
mc1=0
mc2=0
md1=0
md2=0
mmv <- minmaxcriteria
p_1=alpha_p
p_2=beta_p
q_1=alpha_q
q_2=beta_q
v_1=alpha_v
v_2=beta_v
m_def=mode_def
pm=performanceMatrix
cr <- criteria
al=alternatives
vp=criteriaWeights
n=nrow(pm)
mc <- matrix (rep(0, n*n), n, n)
asc_ranking <- data.frame(Action=character(1),Rank=integer(1), stringsAsFactors = FALSE)
dsc_ranking <- data.frame(Action=character(1),Rank=integer(1), stringsAsFactors = FALSE)
ranking=list()
mc=diag(1,n)
md=diag(0,n)
print(m_def)
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
print(mmv)
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
print(p_1)
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
print(p_2)
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
print(q_1)
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
print(q_2)
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
print(v_1)
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
print(v_2)
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
# ****************************************** Check the validity of the thresholds coefficient ******************************************* #
for(j in 1:ncol(pm)){
if ((m_def[j]=="D") && (mmv[j]=="max")) {
if ( p_1[j] < (-1) ) {
stop(" alpha_p is less than -1 " )
}
if (q_1[j] < (-1)) {
stop(" alpha_q is less than -1 " )
}
if (!(is.na(v_1[j]))){
if (v_1[j] < (-1)){
stop(" retourne NA" )
}
}
}
if ((m_def[j]=="I") && (mmv[j]=="min") ) {
if (p_1[j] < -1 ) {
stop(" alpha_p is less than -1 " )
}
if (q_1[j] < -1) {
stop(" Please check the limits or bounds of the thresholds" )
}
if (!(is.na(v_1[j]))){
if (v_1[j] < (-1)){
cat("v_1 is less than (-1)","\n")
stop(" Please check the limits or bounds of the thresholds" )
}
}
}
if ( (m_def[j]=="D") && (mmv[j]=="min") ) {
if (p_1[j] > 1 ) {
# stop(" Please check the limits or bounds of the thresholds" )
}
if (q_1[j] > 1){
# stop(" Please check the limits or bounds of the thresholds" )
}
if (!(is.na(v_1[j]))){
# stop(" Please check the limits or bounds of the thresholds" )
}
if (is.na((v_1[j] < -1))){
# stop(" Please check the limits or bounds of the thresholds" )
}
}
if ( (m_def[j]=="I") && (mmv[j]=="max") ) {
if (p_1[j] > 1){
# stop(" Please check the limits or bounds of the thresholds" )
}
if (q_1[j] > 1){
# stop(" Please check the limits or bounds of the thresholds" )
}
if (!(is.na(v_1[j]))){
# stop(" Please check the limits or bounds of the thresholds" )
}
if (is.na((v_1[j] < -1))){
# stop(" Please check the limits or bounds of the thresholds" )
}
}
}
# ************************************************ Transforming Inverse mode to Direct mode ********************************************* #
if (!(is.na(match("I", m_def)))) {
for(j in 1:ncol(pm)){
if (m_def[j]=="I"){
alpha_p=p_1[j]
alpha_q=q_1[j]
alpha_v=v_1[j]
if (mmv[j]=="min"){
p_1[j]=p_1[j]/(1+alpha_p)
p_2[j]=p_2[j]/(1+alpha_p)
q_1[j]=q_1[j]/(1+alpha_q)
q_2[j]=q_2[j]/(1+alpha_q)
v_1[j]=v_1[j]/(1+alpha_v)
v_2[j]=v_2[j]/(1+alpha_v)
} else {
if (mmv[j]=="max"){
p_1[j]=p_1[j]/(1-alpha_p)
p_2[j]=p_2[j]/(1-alpha_p)
q_1[j]=q_1[j]/(1-alpha_q)
q_2[j]=q_2[j]/(1-alpha_q)
v_1[j]=v_1[j]/(1-alpha_v)
v_2[j]=v_2[j]/(1-alpha_v)
}
}
}
}
}
# ********************************************** End of converting Inverse mode to Direct mode ***************************************** #
# ********************************************************** Calculation of the concordance matrix ***************************************** #
mc1=0
mc2=0
for (i in 1:nrow(pm)){
k=i+1
while (k<=n){
# Columns' iterations
for (j in 1:ncol(pm)){
# calculation of the partial concordance index (i,k) related to the criteria j
# ***** CASE 1
if ((mmv[j]=="max") && (m_def[j]=="D") ) {
c_ik =( (p_1[j]*pm[i,j]+p_2[j])+ pm[i,j]-pm[k,j])/((p_1[j]*pm[i,j]+p_2[j])- (q_1[j]*pm[i,j]+q_2[j]))
c_ki =( (p_1[j]*pm[k,j]+p_2[j])+ pm[k,j]-pm[i,j])/((p_1[j]*pm[k,j]+p_2[j])- (q_1[j]*pm[k,j]+q_2[j]))
}
# ***** CASE 2
if ((mmv[j]=="min") && (m_def[j]=="D") ) {
c_ik =( (p_1[j]*pm[i,j]+p_2[j])- (pm[i,j]- pm[k,j]))/((p_1[j]*pm[i,j]+p_2[j])- (q_1[j]*pm[i,j]+q_2[j]))
c_ki =( (p_1[j]*pm[k,j]+p_2[j])- (pm[k,j]- pm[i,j]))/((p_1[j]*pm[k,j]+p_2[j])- (q_1[j]*pm[k,j]+q_2[j]))
}
# ***** CASE 3 <=> CASE 1
if ((mmv[j]=="max") && (m_def[j]=="I") ) {
c_ik =( (p_1[j]*pm[i,j]+p_2[j])+ pm[i,j]-pm[k,j])/((p_1[j]*pm[i,j]+p_2[j])- (q_1[j]*pm[i,j]+q_2[j]))
c_ki =( (p_1[j]*pm[k,j]+p_2[j])+ pm[k,j]-pm[i,j])/((p_1[j]*pm[k,j]+p_2[j])- (q_1[j]*pm[k,j]+q_2[j]))
}
# ***** CASE 4 <=> CASE 2
if ((mmv[j]=="min") && (m_def[j]=="I") ){
c_ik =( (p_1[j]*pm[i,j]+p_2[j])- (pm[i,j]- pm[k,j]))/((p_1[j]*pm[i,j]+p_2[j])- (q_1[j]*pm[i,j]+q_2[j]))
c_ki =( (p_1[j]*pm[k,j]+p_2[j])- (pm[k,j]- pm[i,j]))/((p_1[j]*pm[k,j]+p_2[j])- (q_1[j]*pm[k,j]+q_2[j]))
}
if(c_ik <=0){
c10=0
} else if (c_ik >=1) {
c10=1
} else {
c10=c_ik
}
if(c_ki<=0){
c20=0
} else if (c_ki >=1) {
c20=1
} else {
c20=c_ki
}
mc1=round(mc1+c10*vp[j], digits=4)
mc2=round(mc2+c20*vp[j], digits=4)
}
mc[i,k]=round(mc1/sum(vp) , digits=4)
mc[k,i]=round(mc2/sum(vp) , digits=4)
mc1=0
mc2=0
k=k+1
}
}
# ************************************************* End of the calculation of the concordance matrix *************************************** #
# ********************************* row names of the table (dv) related to the discordance values ****************************************** #
col_d=matrix(c(rep(0,n*n)),nrow=n)
for (i in 1:n){
for (j in 1:n){
col_d[i,j]=paste(i,"R",j,sep="")
}
}
# don't forget to transpose due to the R process to convert matrix into vector
name_d=as.vector(t(col_d))
# *********************************************** Calculation of the discordance table ************************************** #
# v_1[is.na(v_1)] <- 0
# v_2[is.na(v_2)] <- 0
n=nrow(pm)
m=ncol(pm)
dv <- matrix (rep(0, n*n*m), n*n, m)
l=1
for (i in 1:nrow(pm)){
k=1
while (k<=n){
# Columns' iterations
for (j in 1:ncol(pm)){
# calculation of the discordance index (i,k) related to the criteria j
if( (!(is.na(v_1[j]))) &&!(is.na(v_2[j]))){
# ***** CAS 1
if ((mmv[j]=="max") && (m_def[j]=="D") ){
d_ik =( pm[k,j]-pm[i,j]-(p_1[j]*pm[i,j]+p_2[j]))/((v_1[j]*pm[i,j]+v_2[j])-(p_1[j]*pm[i,j]+p_2[j]))
}
# ***** CAS 2
if ((mmv[j]=="min") && (m_def[j]=="D") ){
d_ik =( (pm[i,j]- (p_1[j]*pm[i,j]+p_2[j])- pm[k,j]))/((v_1[j]*pm[i,j]+v_2[j])-(p_1[j]*pm[i,j]+p_2[j]))
}
# ***** CAS 3
if ((mmv[j]=="max") && (m_def[j]=="I") ){
d_ik =( pm[k,j]-pm[i,j]-(p_1[j]*pm[i,j]+p_2[j]))/((v_1[j]*pm[i,j]+v_2[j])-(p_1[j]*pm[i,j]+p_2[j]))
}
# ***** CAS 4
if ((mmv[j]=="min") && (m_def[j]=="I") ){
d_ik =( (pm[i,j]- (p_1[j]*pm[i,j]+p_2[j])- pm[k,j]))/((v_1[j]*pm[i,j]+v_2[j])-(p_1[j]*pm[i,j]+p_2[j]))
}
#d1 =(pm[k,j] - pm[i,j] - p[j])/(v[j]-p[j])
} else {
d_ik=0
}
if(d_ik <=0){
d10=0
} else if (d_ik >=1) {
d10=1
} else {
d10=d_ik
}
# ******************************************************************************************************************************************* #
dv[l,j]=round(d10,digits=4)
}
l=l+1
k=k+1
}
}
# ************************************************* End of the calculation of the discordance table ************************************* #
# ****************************************** Calculation of the Fuzzy Outranking credibility Matrix *********************************** #
v_mc=as.vector(t(mc))
# print(v_mc)
v_cred=c(rep(0,n*n))
v_cum=1
m=ncol(pm)
for (i in 1:(n*n)){
if (max(dv[i,])==1){
v_cred[i]=0
} else if (max(dv[i,])<v_mc[i]){
v_cred[i]=v_mc[i]
} else if (max(dv[i,]) > v_mc[i]){
v_cum=1
for (j in 1:m) {
# calcul de l'indicateur de crédibilité pour les dv[i,j] supérieurs ŕ l'indicateur de concordance globale
if (dv[i,j] > v_mc[i]) {
v_cum=v_cum*( (1-dv[i,j])/(1-v_mc[i]))
}
}
v_cum=v_mc[i]*v_cum
v_cred[i]=round(v_cum, digits=4)
}
}
# *************************************** End of the calculation of the credibility matrix ************************************* #
dv=round(dv,digits=4)
mat_cred=round(matrix(v_cred,ncol=n,nrow=n),digits=4)
mat_cred=t(mat_cred)
rownames(pm)=al
colnames(pm)=cr
rownames(mc)=al
colnames(mc)=al
rownames(mat_cred)=al
colnames(mat_cred)=al
rownames(dv)=name_d
colnames(dv)=cr
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
cat("Performance Matrix","\n")
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
print(pm)
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
cat("Concordance Matrix","\n")
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
print(mc )
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
cat("Criteria Discordance Table ","\n")
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
print(dv)
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
cat("Credibility Matrix","\n")
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
print(mat_cred)
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
# ******************************************************* Ascending distillation *************************************************** #
cat("--------------------------------------------------------- Ascending distillation ----------------------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
cat("-----------------------------------------------Beginning of the Ascending distillation ------------------------------------------","\n")
cat("--------------------------------------------------------------------------------------------------------------------------------------","\n")
# ******************************************************************************************************************************************* #
to_rank_0=al # vector of the alternatives to be ranked
len=length(to_rank_0) # number of the alternatives to be ranked
c_bar=list() # list of the ranked alternatives
# ******************************************************************************************************************************************* #
beta=0.30
alpha=0.15
compt_d=1
to_rank =to_rank_0
newmat=mat_cred
newmat_0=mat_cred
len_to_rank=length(al)
len_to_rank_0=length(al)
r=0
while ( len_to_rank_0 != 1 && nrow(newmat)>1){
cat(paste("Distillation_",compt_d,sep=""),"\n")
z=etape_asc(newmat,to_rank,c_bar,alpha,beta)
c_bar= union(c_bar,z$c_bar)
newmat=newmat_0[-match(c_bar, rownames(newmat_0)),-match(c_bar, colnames(newmat_0))]
to_rank =z$to_rank
len_to_rank_0=len_to_rank - length(c_bar)
# cat("---------------------- we print the rankings before moving to d+1 ------------------","\n")
ranking=union(ranking,c_bar)
# print(ranking)
cat("----------------------------------------------------------------------------------------","\n")
zc_bar=z$c_bar
c=length(zc_bar)
j=1
for (i in (r+1):(r+c)){
asc_ranking[i,1]=zc_bar[j]
asc_ranking[i,2]=compt_d
j=j+1
}
r=nrow(asc_ranking)
to_rank_0=setdiff(to_rank_0,c_bar)
if (len_to_rank_0==1) {
asc_ranking[nrow(asc_ranking)+1,1]=to_rank_0
asc_ranking[nrow(asc_ranking),2]=compt_d+1
}
if (len_to_rank_0==0) {
len_to_rank_0=1
}
compt_d=compt_d+1
}
b_e=max(asc_ranking[,2])+min(asc_ranking[,2])
for (i in 1:length(al)){
asc_ranking[i,2]=b_e-asc_ranking[i,2]
}
asc_ranking=asc_ranking[order(-(asc_ranking[,2])),]
print(asc_ranking)
cat("------------------------------------------------------------------------------------------------------------","\n")
cat("---------------------------------- End of the Ascending distillation -----------------------------------","\n")
cat("------------------------------------------------------------------------------------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
asc=asc_ranking
cat("-----------------------------------------------------------------------------------------------------------","\n")
cat("-------------------------Beginning of the Descending distillation ------------------------------------","\n")
cat("-----------------------------------------------------------------------------------------------------------","\n")
# ******************************************************************************************************************************************** #
to_rank_0=al # vector of the alternatives to be ranked
len=length(to_rank_0) # number of the alternatives to be ranked
c_bar=list() # list of the ranked alternatives
# ********************************************************************************************************************************************* #
beta=0.30
alpha=0.15
compt_d=1
to_rank =to_rank_0
newmat=mat_cred
newmat_0=mat_cred
len_to_rank=length(al)
len_to_rank_0=length(al)
r=0
while (len_to_rank_0 != 1){ #(len_to_rank_0 == 1)
cat(paste("Distillation_",compt_d,sep=""),"\n")
z=etape_dsc(newmat,to_rank,c_bar,alpha,beta)
c_bar= union(c_bar,z$c_bar)
newmat=newmat_0[-match(c_bar, rownames(newmat_0)),-match(c_bar, colnames(newmat_0))]
to_rank =z$to_rank
len_to_rank_0=len_to_rank - length(c_bar)
# cat("---------------------- we print the rankings before moving to ŕ d+1 ------------------","\n")
ranking=union(ranking,c_bar)
# print(ranking)
cat("-------------------------------------------------------------------------------------------","\n")
zc_bar=z$c_bar
c=length(zc_bar)
j=1
for (i in (r+1):(r+c)){
dsc_ranking[i,1]=zc_bar[j]
dsc_ranking[i,2]=compt_d
j=j+1
}
r=nrow(dsc_ranking)
to_rank_0=setdiff(to_rank_0,c_bar)
cat("-----------------------------------------------------------------------------------------","\n")
if (len_to_rank_0==1) {
dsc_ranking[nrow(dsc_ranking)+1,1]=to_rank_0
dsc_ranking[nrow(dsc_ranking),2]=compt_d+1
}
if (len_to_rank_0==0) {
len_to_rank_0=1
}
# print(dsc_ranking)
compt_d=compt_d+1
}
dsc=dsc_ranking[ order(dsc_ranking[,2], dsc_ranking[,1]), ]
# cat("--------------------------------------------------------------------------------------------------------","\n")
cat("-------------------------------- End of the Descending distillation ---------------------------------","\n")
# cat("--------------------------------------------------------------------------------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat("-------------------------------- Ascending distillation ranking ---------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
print(asc_ranking)
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat("-------------------------------- Descending distillation ranking ---------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
print(dsc_ranking)
cat(" ","\n")
cat(" ","\n")
n=nrow(pm)
matranking <- matrix (rep(0, n*n), n, n)
mrank <- matrix (rep(0, n*n), n, n)
d_matrank=c(rep("I",times=n))
diag(matranking)=d_matrank
al=dsc[,1]
rownames(matranking)=al
colnames(matranking)=al
rownames(mrank)=al
colnames(mrank)=al
final_ranking <- data.frame(alternative=al,sum_outrank=c(rep(0,times=length(al))),ranking=c(rep(0,times=length(al))),stringsAsFactors = FALSE)
# print(final_ranking)
# ******************************************************************************************************************************************************* #
for (i in 1:n){
for (j in 1:n){
if ((dsc[which(dsc$Action==al[i]),2] < dsc[which(dsc$Action==al[j]),2]) && (asc[which(asc$Action==al[i]),2] <= asc[which(asc$Action==al[j]),2])){
matranking[al[i],al[j]]="P"
mrank[al[i],al[j]]=1
} else if ((dsc[which(dsc$Action==al[i]),2] <= dsc[which(dsc$Action==al[j]),2]) && (asc[which(asc$Action==al[i]),2] < asc[which(asc$Action==al[j]),2])){
matranking[al[i],al[j]]="P"
mrank[al[i],al[j]]=1
} else if ((dsc[which(dsc$Action==al[i]),2] > dsc[which(dsc$Action==al[j]),2]) && (asc[which(asc$Action==al[i]),2] >= asc[which(asc$Action==al[j]),2])){
matranking[al[i],al[j]]="NP"
} else if ((dsc[which(dsc$Action==al[i]),2] >= dsc[which(dsc$Action==al[j]),2]) && (asc[which(asc$Action==al[i]),2] > asc[which(asc$Action==al[j]),2])){
matranking[al[i],al[j]]="NP"
} else if ((dsc[which(dsc$Action==al[i]),2] == dsc[which(dsc$Action==al[j]),2]) && (asc[which(asc$Action==al[i]),2] == asc[which(asc$Action==al[j]),2])){
matranking[al[i],al[j]]="I"
} else if ((dsc[which(dsc$Action==al[i]),2] < dsc[which(dsc$Action==al[j]),2]) && (asc[which(asc$Action==al[i]),2] > asc[which(asc$Action==al[j]),2])){
matranking[al[i],al[j]]="R"
mrank[al[i],al[j]]=1
} else if ((dsc[which(dsc$Action==al[i]),2] > dsc[which(dsc$Action==al[j]),2]) && (asc[which(asc$Action==al[i]),2] < asc[which(asc$Action==al[j]),2])){
matranking[al[i],al[j]]="R"
mrank[al[i],al[j]]=1
}
}
}
# ***************************************************************************************************************************************************** #
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat("----------------------------------- Final Ranking Matrix -----------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
print(matranking)
cat(" ","\n")
cat(" ","\n")
cat(" --------------------------- End of Final Ranking Matrix ----------------------------------","\n")
for (i in 1:n){
seq=matranking[final_ranking[i,1],]
final_ranking[i,2]=compte("P",seq)
}
final_ranking=final_ranking[ order(-final_ranking[,2], final_ranking[,1]), ]
j=1
for (i in 1:n-1){
if (matranking[final_ranking[i,1],final_ranking[i+1,1]]== "P" && i==1){
final_ranking[i,3]=j
final_ranking[i+1,3]=j+1
j=j+1
}
if (matranking[final_ranking[i,1],final_ranking[i+1,1]]== "I" && i==1){
final_ranking[i,3]=i
final_ranking[i+1,3]=i
j=j+1
}
else if (i>1){
if ( (matranking[final_ranking[i,1],final_ranking[i+1,1]]== "P") && (final_ranking[i,2]>1)){
final_ranking[i,3]=j
final_ranking[i+1,3]=j+1
j=j+1
} else if ( (matranking[final_ranking[i,1],final_ranking[i+1,1]]== "P") && (final_ranking[i+1,2]==0)){
final_ranking[i,3]=j
final_ranking[i+1,3]=j+1
j=j+1
} else if ( (matranking[final_ranking[i,1],final_ranking[i+1,1]]== "R") && (final_ranking[i+1,2]==0)){
final_ranking[i,3]=j
final_ranking[i+1,3]=final_ranking[i,3]+1
}else if ( (matranking[final_ranking[i,1],final_ranking[i+1,1]]== "I") && (final_ranking[i+1,2]==0)){
final_ranking[i+1,3]=final_ranking[i,3]
} else if (matranking[final_ranking[i,1],final_ranking[i+1,1]]== "I" && (final_ranking[i+1,2]!=0)){
final_ranking[i+1,3]=final_ranking[i,3]
} else if (matranking[final_ranking[i,1],final_ranking[i+1,1]]== "R" && (final_ranking[i+1,2]!=0)){
final_ranking[i+1,3]=final_ranking[i,3]
}
}
}
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
print(final_ranking[,-2])
names_matrank_adj=final_ranking[,1]
matrank_adj <- matrix (rep(0, n*n), n, n)
rownames(matrank_adj)=names_matrank_adj
colnames(matrank_adj)=names_matrank_adj
for (i in 1:n){
for (j in 1:n){
if( (final_ranking[j,3]-final_ranking[i,3]==1) && (matranking[final_ranking[i,1],final_ranking[j,1]]== "P")){
matrank_adj[i,j]=1
}
if( (final_ranking[j,3]-final_ranking[i,3]==1) && (matranking[final_ranking[i,1],final_ranking[j,1]]== "I")){
matrank_adj[i,j]=1
}
if( (final_ranking[j,3]-final_ranking[i,3]==1) && (matranking[final_ranking[i,1],final_ranking[j,1]]== "R")){
matrank_adj[i,j]=1
}
}
}
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat("------------------------------------------ adjacent Ranking Matrix -------------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
print(matrank_adj)
cat(" ","\n")
cat(" ","\n")
cat("-------------------------------------------------------------------------------------------------------------","\n")
# print(mrank)
g1<-graph.adjacency(matrank_adj);
g2=plot(g1)
final_ranking=final_ranking[,-2]
# prepare the output
sink("result.txt")
cat("------------------------------------------------------------------------------ Performance table --------------------------------------------------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
print(pm)
cat(" ","\n")
cat(" ","\n")
cat("----------------------------------------------------------------------------- Concordance matrix -------------------------------------------------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
print(mc)
cat(" ","\n")
cat(" ","\n")
cat("----------------------------------------------------------------------------- Discordance table --------------------------------------------------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
print(dv)
cat(" ","\n")
cat(" ","\n")
cat("----------------------------------------------------------------------------- Credibility matrix -----------------------------------------------------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
print(mat_cred)
cat(" ","\n")
cat(" ","\n")
cat("----------------------------------------------------------------------------- Ascending ranking ----------------------------------------------------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
print(asc_ranking)
cat(" ","\n")
cat(" ","\n")
cat("----------------------------------------------------------------------------- Descending ranking ---------------------------------------------------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
print(dsc_ranking)
cat(" ","\n")
cat(" ","\n")
cat("----------------------------------------------------------------------------- Final ranking ---------------------------------------------------------------------------------","\n")
cat(" ","\n")
cat(" ","\n")
print(final_ranking)
cat(" ","\n")
cat(" ","\n")
cat("-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------","\n")
sink()
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat(" ","\n")
cat("----------------------------------------------------------------------------------------------------------------","\n")
cat("End of the calculation","\n")
cat("----------------------------------------------------------------------------------------------------------------","\n")
# prepare the output
out <- list("Performance Matrix"=pm,"Concordance Matrix"=mc,"Criteria Discordance Table" =dv,"Credibility Matrix"=mat_cred,"Ascending distillation ranking"=asc_ranking,"Descending distillation ranking"=dsc_ranking,"Final Ranking Matrix"=final_ranking)
return(out)
}
Try the OutrankingTools package in your browser
Any scripts or data that you put into this service are public.
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.