基于熵权法的未确知测度评价模型

理论自己找个论文看看就可以了，直接放代码与数据，数据来源于统计年鉴

这里使用三个表具体如下：

原始数据表

 分级标准表

 分级评价指标表

 其中，分级评价指标表是原始数据表经过归一化处理操作后所得，分级标准表是为了方便描述所建立的特殊分级标准。

正题开始，主要有四步

第一步，熵权法计算权重，实际运用可以使用其它权重计算方法

library(readxl)
library(dplyr)
#重新设置R工作路径
setwd('D:/重要文件/22数学建模校赛/过程/问题三')
#读取指标数据
data <- read_xlsx('数据.xlsx',col_names = T)
#去除无用列
data$年份 <- NULL
#熵权法计算指标权重
#定义正向指标归一化处理函数
svf1 <- function(x){(x-min(x))/(max(x)-min(x))}
#定义逆向指标归一化处理函数
svf2 <- function(x){(max(x)-x)/(max(x)-min(x))}
#归一化处理
sv1 <- apply(data[,c(1,2,3,10,11,12)],2,svf1)
sv2 <- apply(data[,-c(1,2,3,10,11,12)],2,svf2)
a <- sv1[,c(1:3)]
b <- sv2[,c(1:6)]
c <- sv1[,c(4:6)]
d <- sv2[,c(7:13)]
svt <- cbind(a,b,c,d)
e <- t(svt)
colnames(e) <- c('2010','2011','2012','2013','2014','2015',
                 '2016','2017','2018','2019','2020')
write.csv(e,file='分级评价指标.csv')
#计算第j个指标下第i个样本值占该指标的比重
sgf <- function(x){y <- c(sv1)
for(i in 1:length(x))
  y[i] = x[i]/sum(x[])
return(y)}
sg <- apply(svt,2,sgf)
#计算信息熵
lef <- function(x)
{
  y <- c(x)
  for(i in 1:length(x)){
    if(y[i] == 0){
      y[i] = 0
    }else{
      y[i] = x[i] * log(x[i])
    }
  }
  return(y)
}
le <- apply(svt,2,lef)
k <- 1/log(length(le[,1]))
#计算第j项指标的熵值
e <- -k * colSums(le)
#计算信息熵差异
d <- 1-e
#计算各项指标权重
w <- d/sum(d)
write.csv(w,file='各项指标权重.csv')

第二步，计算单指标测度函数矩阵

#计算单指标测度函数矩阵
setwd('D:/重要文件/22数学建模校赛/过程/问题三')
#读入数据
data1 <- read_excel('分级标准.xlsx')
data2 <- read_excel('分级评价指标.xlsx')
#数据处理
data1[,c(1:3)] <- NULL
data2[,c(1,2)] <- NULL
x1 <- data2[,1]
x2 <- data2[,2]
x3 <- data2[,3]
x4 <- data2[,4]
x5 <- data2[,5]
x6 <- data2[,6]
x7 <- data2[,7]
x8 <- data2[,8]
x9 <- data2[,9]
x10 <- data2[,10]
x11 <- data2[,11]
#转置
x1 <- t(x1)
x2 <- t(x2)
x3 <- t(x3)
x4 <- t(x4)
x5 <- t(x5)
x6 <- t(x6)
x7 <- t(x7)
x8 <- t(x8)
x9 <- t(x9)
x10 <- t(x10)
x11 <- t(x11)
#定义单指标测度函数矩阵
#if条件随评分标准变动，多个指标不同标准需要建立多个函数判断
fv <- function(x)
{
  f <- matrix(rep(0,95),19,5)
  for(i in 1:length(x)){
    if(x[,i]==0){
      f[i,] <- c(0,0,0,0,1)
    }else if(x[,i]==0.2){
      f[i,] <- c(0,0,0,0,1)
    }else if(x[,i]==0.4){
      f[i,] <- c(0,0,0,1,0)
    }else if(x[,i]==0.6){
      f[i,] <- c(0,0,1,0,0)
    }else if(x[,i]==0.8){
      f[i,] <- c(0,1,0,0,0)
    }else if(x[,i]==1){
      f[i,] <- c(1,0,0,0,0)
    }else if(0<x[,i] & x[,i]<0.2){
      f[i,] <- c(0,0,0,0,1)
    }else if(0.2<x[,i] & x[,i]<0.4){
      f[i,] <- c(0,0,0,(x[,i]-0.2)/0.2,(0.4-x[,i])/0.2)
    }else if(0.4<x[,i] & x[,i]<0.6){
      f[i,] <- c(0,0,(x[,i]-0.4)/0.2,(0.6-x[,i])/0.2,0)
    }else if(0.6<x[,i] & x[,i]<0.8){
      f[i,] <- c(0,(x[,i]-0.6)/0.2,(0.8-x[,i])/0.2,0,0)
    }else if(0.8<x[,i] & x[,i]<1){
      f[i,] <- c(1,0,0,0,0)
    }else{
    }}
  return(f)
}
#得到各个样本年份的单指标测度函数矩阵
g1 <- fv(x1)
g2 <- fv(x2)
g3 <- fv(x3)
g4 <- fv(x4)
g5 <- fv(x5)
g6 <- fv(x6)
g7 <- fv(x7)
g8 <- fv(x8)
g9 <- fv(x9)
g10 <- fv(x10)
g11 <- fv(x11)
#将各个样本年份的单指标测度函数矩阵输出为csv文件
setwd('D:/重要文件/22数学建模校赛/过程/问题三/测度矩阵')
write.csv(g1,file='2010.csv')
write.csv(g2,file='2011.csv')
write.csv(g3,file='2012.csv')
write.csv(g4,file='2013.csv')
write.csv(g5,file='2014.csv')
write.csv(g6,file='2015.csv')
write.csv(g7,file='2016.csv')
write.csv(g8,file='2017.csv')
write.csv(g9,file='2018.csv')
write.csv(g10,file='2019.csv')
write.csv(g11,file='2020.csv')

第三步，计算多指标综合测度矩阵，其中计算各个年份矩阵的各个元素值的代码，可自行编写循坏进行代替，这里有点冗余了

#计算多指标测度矩阵与各个样本得分
w <- read.csv('各项指标权重.csv')
setwd('D:/重要文件/22数学建模校赛/过程/问题三/测度矩阵')
#读入数据与处理
m1 <- read.csv('2010.csv')
m2 <- read.csv('2011.csv')
m3 <- read.csv('2012.csv')
m4 <- read.csv('2013.csv')
m5 <- read.csv('2014.csv')
m6 <- read.csv('2015.csv')
m7 <- read.csv('2016.csv')
m8 <- read.csv('2017.csv')
m9 <- read.csv('2018.csv')
m10 <- read.csv('2019.csv')
m11 <- read.csv('2020.csv')
m1[,1] <- NULL
m2[,1] <- NULL
m3[,1] <- NULL
m4[,1] <- NULL
m5[,1] <- NULL
m6[,1] <- NULL
m7[,1] <- NULL
m8[,1] <- NULL
m9[,1] <- NULL
m10[,1] <- NULL
m11[,1] <- NULL
w[,1] <- NULL
#生成空矩阵
n <- matrix(rep(0,55),11,5)
#计算2010年各元素值
n[1,1] <- w[1,]* m1[1,1] + w[2,]* m1[2,1]+w[3,]* m1[3,1]+w[4,]* m1[4,1]+w[5,]* m1[5,1]+w[6,]* m1[6,1]+
  w[7,]* m1[7,1]+w[8,]* m1[8,1]+w[9,]* m1[9,1]+w[10,]* m1[10,1]+w[11,]* m1[11,1]+w[12,]* m1[12,1]+w[13