R 实现熵权法计算权重

按照信息论基本原理的解释，信息是系统有序程度的一个度量，熵是系统无序程度的一个度量；根据信息熵的定义，对于某项指标，可以用熵值来判断某个指标的离散程度，其信息熵值越小，指标的离散程度越大，该指标对综合评价的影响（即权重）就越大，如果某项指标的值全部相等，则该指标在综合评价中不起作用。因此，可利用信息熵这个工具，计算出各个指标的权重，为多指标综合评价提供依据。

熵权法

物理学上指热能除以温度所得的商，标志热量转化为功的程度。
◎ 科学技术上泛指某些物质系统状态的一种量（liàng）度，某些物质系统状态可能出现的程度。亦被社会科学用以借喻人类社会某些状态的程度。
◎ 在信息论中，熵表示的是不确定性的量度。

熵权法是一种客观赋权方法。它十分复杂，计算步骤如下：
a．构建各评价指标的判断矩阵：
b．将判断矩阵进行归一化处理, 得到归一化判断矩阵：
c．根据熵的定义，根据评价指标计算评价指标的信息熵。
d．计算系统的权重值。

详细原理可以参考知乎链接：如何用熵权法计算权重？

示例数据

演示数据量不大，读者可以直接复制为csv文件。

# dept,x1,x2,x3,x4,x5,x6,x7,x8,x9
# A,100,90,100,84,90,100,100,100,100
# B,100,100,78.6,100,90,100,100,100,100
# C,75,100,85.7,100,90,100,100,100,100
# D,100,100,78.6,100,90,100,94.4,100,100
# E,100,90,100,100,100,90,100,100,80
# F,100,100,100,100,90,100,100,85.7,100
# G,100,100,78.6,100,90,100,55.6,100,100
# H,87.5,100,85.7,100,100,100,100,100,100
# I,100,100,92.9,100,80,100,100,100,100
# J,100,90,100,100,100,100,100,100,100
# K,100,100,92.9,100,90,100,100,100,100

# 需要加载包
library(tibble)
library(dplyr)

函数准备

这里先定义需要的函数，方便后面在dplyr中使用。

## 归一化,也可以使用内置函数scale
min_max_norm <- function(x) {
  (x - min(x)) / (max(x) - min(x))
}

## 计算P值
p_value <- function(x){
  x / sum(x)
}

## 计算熵值
entropy <- function(x){
  n <- length(x)
  (-1 / log2(n)) * (sum( x * ifelse(log2(x)==-Inf, 0, log2(x)) ))
  
}

## 计算权重
weight <- function(x){
  (1-x) / (length(x)-sum(x))
}

## 计算得分
fscore <- function(x, y){
  sum(x*y)
}

R 实现熵权法

## 加载数据
dt <- read.csv("data-dp.csv")
tb.dt <- as_tibble(dt)

# A tibble: 11 x 10
#    dept     x1    x2    x3    x4    x5    x6    x7    x8    x9
#    <chr> <dbl> <int> <dbl> <int> <int> <int> <dbl> <dbl> <int>
#  1 A     100      90 100      84    90   100 100   100     100
#  2 B     100     100  78.6   100    90   100 100   100     100
#  3 C      75     100  85.7   100    90   100 100   100     100
#  4 D     100     100  78.6   100    90   100  94.4 100     100
#  5 E     100      90 100     100   100    90 100   100      80
#  6 F     100     100 100     100    90   100 100    85.7   100
#  7 G     100     100  78.6   100    90   100  55.6 100     100
#  8 H      87.5   100  85.7   100   100   100 100   100     100
#  9 I     100     100  92.9   100    80   100 100   100     100
# 10 J     100      90 100     100   100   100 100   100     100
# 11 K     100     100  92.9   100    90   100 100   100     100

## 计算信息熵

#   mutate_all 不建议使用了
# tb.dt <- tb.dt %>% select(2:10) %>% 
#  mutate_all(.funs = min_max_norm) %>% 
#  mutate_all(.funs = p_value) %>%
#  summarise_all(.funs = entropy) 

tb.dt <- tb.dt %>% mutate(across(c(2:10), min_max_norm)) %>%
      mutate(across(c(2:10), p_value)) %>%
      summarise(across(c(2:10), entropy))  
tb.dt

# A tibble: 1 x 9
#      x1    x2    x3    x4    x5    x6    x7    x8    x9
#   <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
# 1 0.954 0.867 0.836 0.960 0.936 0.960 0.960 0.960 0.960

## 计算权重
w_dat <- tb.dt %>% weight
w_dat

#           x1        x2        x3         x4        x5         x6         x7         x8         x9
# 1 0.07578559 0.2191587 0.2713738 0.06559212 0.1051977 0.06559212 0.06611572 0.06559212 0.06559212

## 计算得分
dt %>% group_by(1:n()) %>% 
  mutate(score = fscore(c_across(2:10), w_dat)) %>% 
  arrange(-score) %>%
  ungroup() %>%
  select("dept", "score")

# A tibble: 11 x 2
#    dept  score
#    <chr> <dbl>
#  1 F      98.0
#  2 J      97.8
#  3 K      97.0
#  4 I      96.0
#  5 E      95.8
#  6 A      95.7
#  7 H      95.2
#  8 C      93.2
#  9 B      93.1
# 10 D      92.8
# 11 G      90.2