亲测有效的mem 流行病预测，时间序列预测，r语言做移动流行区间法,MEM流行病阈值设置指南

zhangfeng11332025-11-03 15:15

亲测有效代码 ，自己调试的代码

bash 复制代码 
# 移动流行区间法参数寻优

# 约登指数 
# J=0.6171875+0.979166666666667−1=0.596354166666667
# 约登指数（通常用 J表示）的计算公式基于模型的两个基本性能指标：灵敏度（Sensitivity）和特异度（Specificity）。其定义为两者之和减去1
# ：
# J=灵敏度+特异度−1
# 其中：
# 灵敏度（真阳性率）=  
#   TP+FN
# TP
# 
# ，衡量模型正确找出阳性样本的能力
# 。
# 特异度（真阴性率）=  
#   TN+FP
# TN
# 
# ，衡量模型正确找出阴性样本的能力
# 。
# 公式中的 TP（真阳性）、FN（假阴性）、TN（真阴性）、FP（假阳性）的含义如下表所示
# ：


rm(list=ls())

# install.packages("mem")  # 仅第一次安装

library(mem)




library(readxl)

# 读取第一个文件
excel_file_1 <- read_excel('年份.xlsx')
# 
# # 读取第二个文件
# excel_file_2 <- read_excel('手足口病按周发病-data-去掉20年.xlsx')
# 
# # 查看第一个文件的基本信息
# print('年份.xlsx基本信息：')
# summary(excel_file_1)
# 
# # 查看第一个文件的行数和列数
# rows_1 <- nrow(excel_file_1)
# columns_1 <- ncol(excel_file_1)
# 
# if (rows_1 < 100 && columns_1 < 20) {
#   # 短表数据（行数少于100且列数少于20）查看全量数据信息
#   print('年份.xlsx全部内容信息：')
#   print(excel_file_1, na.print = 'nan')
# } else {
#   # 长表数据查看数据前几行信息
#   print('年份.xlsx前几行内容信息：')
#   print(head(excel_file_1), na.print = 'nan')
# }
# 
# # 查看第二个文件的基本信息
# print('手足口病按周发病-data-去掉20年.xlsx基本信息：')
# summary(excel_file_2)
# 
# # 查看第二个文件的行数和列数
# rows_2 <- nrow(excel_file_2)
# columns_2 <- ncol(excel_file_2)
# 
# if (rows_2 < 100 && columns_2 < 20) {
#   # 短表数据（行数少于100且列数少于20）查看全量数据信息
#   print('手足口病按周发病-data-去掉20年.xlsx全部内容信息：')
#   print(excel_file_2, na.print = 'nan')
# } else {
#   # 长表数据查看数据前几行信息
#   print('手足口病按周发病-data-去掉20年.xlsx前几行内容信息：')
#   print(head(excel_file_2), na.print = 'nan')
# }



# 使用基础R函数
data <- read.csv("手足口病按周发病-data-去掉20年.csv", fileEncoding = "UTF-8") # 根据文件实际编码调整，可能是"GBK"


print(head(data), na.print = 'nan')




# # 使用字符串函数直接拆分
# data$year <- substr(data$date, 1, 4) # 提取前4位作为年
# data$week <- as.numeric(substr(data$date, 5, 6)) # 提取第5、6位作为周，转换为数值

# 或者使用tidyr包的separate函数[6](@ref)
# install.packages("tidyr")
library(tidyr)
data <- separate(data, col = date, into = c("year", "week"), sep = c(4), remove = FALSE)
# remove = FALSE 表示保留原始的date列

#转换成数子 ，否则 1-9的数值会是 null
data$week <- as.integer(data$week)
data$year <- as.integer(data$year)


print(head(data), na.print = 'nan')

sapply(data, class)


# # 获取所有列名
# all_columns <- names(data)
# # 定义新的列顺序，例如：年、周、原始日期列、其他列...
# new_column_order <- c("year", "week", all_columns[!all_columns %in% c("year", "week")])
# # 重排列顺序
# data <- data[, new_column_order]
# # 移动流行区间法参数寻优

# 约登指数 
# J=0.6171875+0.979166666666667−1=0.596354166666667
# 约登指数（通常用 J表示）的计算公式基于模型的两个基本性能指标：灵敏度（Sensitivity）和特异度（Specificity）。其定义为两者之和减去1
# ：
# J=灵敏度+特异度−1
# 其中：
# 灵敏度（真阳性率）=  
#   TP+FN
# TP
# 
# ，衡量模型正确找出阳性样本的能力
# 。
# 特异度（真阴性率）=  
#   TN+FP
# TN
# 
# ，衡量模型正确找出阴性样本的能力
# 。
# 公式中的 TP（真阳性）、FN（假阴性）、TN（真阴性）、FP（假阳性）的含义如下表所示
# ：


rm(list=ls())

# install.packages("mem")  # 仅第一次安装

library(mem)




library(readxl)

# 读取第一个文件
excel_file_1 <- read_excel('年份.xlsx')
# 
# # 读取第二个文件
# excel_file_2 <- read_excel('手足口病按周发病-data-去掉20年.xlsx')
# 
# # 查看第一个文件的基本信息
# print('年份.xlsx基本信息：')
# summary(excel_file_1)
# 
# # 查看第一个文件的行数和列数
# rows_1 <- nrow(excel_file_1)
# columns_1 <- ncol(excel_file_1)
# 
# if (rows_1 < 100 && columns_1 < 20) {
#   # 短表数据（行数少于100且列数少于20）查看全量数据信息
#   print('年份.xlsx全部内容信息：')
#   print(excel_file_1, na.print = 'nan')
# } else {
#   # 长表数据查看数据前几行信息
#   print('年份.xlsx前几行内容信息：')
#   print(head(excel_file_1), na.print = 'nan')
# }
# 
# # 查看第二个文件的基本信息
# print('手足口病按周发病-data-去掉20年.xlsx基本信息：')
# summary(excel_file_2)
# 
# # 查看第二个文件的行数和列数
# rows_2 <- nrow(excel_file_2)
# columns_2 <- ncol(excel_file_2)
# 
# if (rows_2 < 100 && columns_2 < 20) {
#   # 短表数据（行数少于100且列数少于20）查看全量数据信息
#   print('手足口病按周发病-data-去掉20年.xlsx全部内容信息：')
#   print(excel_file_2, na.print = 'nan')
# } else {
#   # 长表数据查看数据前几行信息
#   print('手足口病按周发病-data-去掉20年.xlsx前几行内容信息：')
#   print(head(excel_file_2), na.print = 'nan')
# }



# 使用基础R函数
data <- read.csv("手足口病按周发病-data-去掉20年.csv", fileEncoding = "UTF-8") # 根据文件实际编码调整，可能是"GBK"


print(head(data), na.print = 'nan')




# # 使用字符串函数直接拆分
# data$year <- substr(data$date, 1, 4) # 提取前4位作为年
# data$week <- as.numeric(substr(data$date, 5, 6)) # 提取第5、6位作为周，转换为数值

# 或者使用tidyr包的separate函数[6](@ref)
# install.packages("tidyr")
library(tidyr)
data <- separate(data, col = date, into = c("year", "week"), sep = c(4), remove = FALSE)
# remove = FALSE 表示保留原始的date列

#转换成数子 ，否则 1-9的数值会是 null
data$week <- as.integer(data$week)
data$year <- as.integer(data$year)


print(head(data), na.print = 'nan')

sapply(data, class)


# # 获取所有列名
# all_columns <- names(data)
# # 定义新的列顺序，例如：年、周、原始日期列、其他列...
# new_column_order <- c("year", "week", all_columns[!all_columns %in% c("year", "week")])
# # 重排列顺序
# data <- data[, new_column_order]
# 
# # 查看处理后的数据前几行
# head(data)


class(data)
str(data)
# summary(data)
sapply(data, class)


# 准备数据：假设数据格式为data.frame，包含year, week, rate三列
# 使用2014-2019年的数据进行参数寻优
data_2014_2019 <- subset(data, year %in% 2014:2019)


colnames(data_2014_2019)
# ?transformdata
# 转换数据格式为mem包要求的格式


# 5. 转换为mem包要求的格式（关键：修正列名拼写）
# 列名改为正确的"disease_count_hundred_thousand"（d-i-s-e-a-s-e）
formatted_data <- transformdata(
  data_2014_2019, 
  i.name = "disease_count_hundred_thousand",  # 修正拼写错误
  i.max.na.per = 35
)



# 定义δ参数范围
delta_values <- seq(1.9, 3.1, 0.1)

# 存储结果的矩阵
results_matrix <- matrix(nrow = length(delta_values), ncol = 6)
colnames(results_matrix) <- c(
  "delta", 
  "sensitivity",
  "specificity",
  "youden_index",
  "PPV", 
  "NPV")

results_matrix


class(formatted_data)
str(formatted_data)
View(formatted_data)



# 
# $optimum
# pos.likehood neg.likehood aditive multiplicative mixed percent matthews youden
# 1          2.9          2.9     2.9            2.9   2.9     2.9      2.9    2.9
# 
# $rankings
# pos.likehood neg.likehood aditive multiplicative mixed percent matthews youden
# 1            1            1       2              1     3       1        1      1
# 
# $roc.data
# value weeks non.missing.weeks true.positives false.positives true.negatives
# 1   2.9   416               416             48               8            324
# false.negatives sensitivity specificity positive.predictive.value
# 1              36   0.5714286   0.9759036                 0.8571429
# negative.predictive.value positive.likehood.ratio negative.likehood.ratio
# 1                       0.9                23.71429               0.4391534
# percent.agreement matthews.correlation.coefficient youdens.index
# 1         0.8942308                        0.6437458     0.5473322
# 
# $param.param.values
# [1] 2.9
# 
# $call
# roc.analysis(i.data = formatted_data$data, i.param.values = c(delta), 
#              i.detection.values = c(delta))





# 
# class(formatted_data)
# 修正后的循环：增加错误捕获+正确提取路径
# 必须是6年以上的数据
for (i in seq_along(delta_values)) {
  delta <- delta_values[i]
  print(paste("开始处理delta =", delta))
  
  # 1. 尝试运行roc.analysis，捕获错误
  tryCatch({
    # 关键：i.param.values和i.detection.values必须是向量，且参数名需完整
    roc_results <- roc.analysis(
      i.data = formatted_data$data,  # 明确指定data参数（避免位置参数错误）
      i.param.values = c(delta),  # 转为向量格式（mem包要求）
      i.detection.values = c(delta)
    )
    # print(roc_results)
    # str(roc_results)
    # 2. 从正确路径提取指标（roc_results$roc.data）
    names(roc_results)
    if ("roc.data" %in% names(roc_results)) {  # 确认roc.data子列表存在
      results_matrix[i, "delta"] <- delta
      results_matrix[i, "sensitivity"] <- roc_results$roc.data$sensitivity  # 无需[1]，本身是单值
      results_matrix[i, "specificity"] <- roc_results$roc.data$specificity
      results_matrix[i, "youden_index"] <- roc_results$roc.data$youdens.index
      results_matrix[i, "PPV"] <- roc_results$roc.data$positive.predictive.value  # 阳性预测值
      results_matrix[i, "NPV"] <- roc_results$roc.data$negative.predictive.value  # 阴性预测值
      print(paste("delta =", delta, "处理完成，指标已存储"))
    } else {
      print(paste("delta =", delta, "错误：roc_results中无roc.data子列表"))
    }
    
  }, error = function(e) {  # 捕获运行错误，避免循环中断
    #print(roc_results)
    print(paste("delta =", delta, "运行错误：", e$message))
  })
}


# 输出结果表格
print("移动流行区间法参数寻优结果：")
print(results_matrix)

# 找到最优参数
best_idx <- which.max(results_matrix[, "youden_index"])
best_delta <- results_matrix[best_idx, "delta"]
print(paste("最优δ值为：", best_delta))
print(paste("对应的约登指数为：", results_matrix[best_idx, "youden_index"]))
print(paste("灵敏度为：", results_matrix[best_idx, "sensitivity"]))
print(paste("特异度为：", results_matrix[best_idx, "specificity"]))

# 
# > # 找到最优参数
#   > best_idx <- which.max(results_matrix[, "youden_index"])
# > best_delta <- results_matrix[best_idx, "delta"]
# > print(paste("最优δ值为：", best_delta))
# [1] "最优δ值为： 2"
# > print(paste("对应的约登指数为：", results_matrix[best_idx, "youden_index"]))
# [1] "对应的约登指数为： 0.596354166666667"
# > print(paste("灵敏度为：", results_matrix[best_idx, "sensitivity"]))
# [1] "灵敏度为： 0.6171875"
# > print(paste("特异度为：", results_matrix[best_idx, "specificity"]))
# [1] "特异度为： 0.979166666666667"
# # 查看处理后的数据前几行
# head(data)


class(data)
str(data)
# summary(data)
sapply(data, class)


# 准备数据：假设数据格式为data.frame，包含year, week, rate三列
# 使用2014-2019年的数据进行参数寻优
data_2014_2019 <- subset(data, year %in% 2014:2019)


colnames(data_2014_2019)
# ?transformdata
# 转换数据格式为mem包要求的格式


# 5. 转换为mem包要求的格式（关键：修正列名拼写）
# 列名改为正确的"disease_count_hundred_thousand"（d-i-s-e-a-s-e）
formatted_data <- transformdata(
  data_2014_2019, 
  i.name = "disease_count_hundred_thousand",  # 修正拼写错误
  i.max.na.per = 35
)



# 定义δ参数范围
delta_values <- seq(1.9, 3.1, 0.1)

# 存储结果的矩阵
results_matrix <- matrix(nrow = length(delta_values), ncol = 6)
colnames(results_matrix) <- c(
  "delta", 
  "sensitivity",
  "specificity",
  "youden_index",
  "PPV", 
  "NPV")

results_matrix


class(formatted_data)
str(formatted_data)
View(formatted_data)



# 
# $optimum
# pos.likehood neg.likehood aditive multiplicative mixed percent matthews youden
# 1          2.9          2.9     2.9            2.9   2.9     2.9      2.9    2.9
# 
# $rankings
# pos.likehood neg.likehood aditive multiplicative mixed percent matthews youden
# 1            1            1       2              1     3       1        1      1
# 
# $roc.data
# value weeks non.missing.weeks true.positives false.positives true.negatives
# 1   2.9   416               416             48               8            324
# false.negatives sensitivity specificity positive.predictive.value
# 1              36   0.5714286   0.9759036                 0.8571429
# negative.predictive.value positive.likehood.ratio negative.likehood.ratio
# 1                       0.9                23.71429               0.4391534
# percent.agreement matthews.correlation.coefficient youdens.index
# 1         0.8942308                        0.6437458     0.5473322
# 
# $param.param.values
# [1] 2.9
# 
# $call
# roc.analysis(i.data = formatted_data$data, i.param.values = c(delta), 
#              i.detection.values = c(delta))





# 
# class(formatted_data)
# 修正后的循环：增加错误捕获+正确提取路径
# 必须是6年以上的数据
for (i in seq_along(delta_values)) {
  delta <- delta_values[i]
  print(paste("开始处理delta =", delta))
  
  # 1. 尝试运行roc.analysis，捕获错误
  tryCatch({
    # 关键：i.param.values和i.detection.values必须是向量，且参数名需完整
    roc_results <- roc.analysis(
      i.data = formatted_data$data,  # 明确指定data参数（避免位置参数错误）
      i.param.values = c(delta),  # 转为向量格式（mem包要求）
      i.detection.values = c(delta)
    )
    # print(roc_results)
    # str(roc_results)
    # 2. 从正确路径提取指标（roc_results$roc.data）
    names(roc_results)
    if ("roc.data" %in% names(roc_results)) {  # 确认roc.data子列表存在
      results_matrix[i, "delta"] <- delta
      results_matrix[i, "sensitivity"] <- roc_results$roc.data$sensitivity  # 无需[1]，本身是单值
      results_matrix[i, "specificity"] <- roc_results$roc.data$specificity
      results_matrix[i, "youden_index"] <- roc_results$roc.data$youdens.index
      results_matrix[i, "PPV"] <- roc_results$roc.data$positive.predictive.value  # 阳性预测值
      results_matrix[i, "NPV"] <- roc_results$roc.data$negative.predictive.value  # 阴性预测值
      print(paste("delta =", delta, "处理完成，指标已存储"))
    } else {
      print(paste("delta =", delta, "错误：roc_results中无roc.data子列表"))
    }
    
  }, error = function(e) {  # 捕获运行错误，避免循环中断
    #print(roc_results)
    print(paste("delta =", delta, "运行错误：", e$message))
  })
}


# 输出结果表格
print("移动流行区间法参数寻优结果：")
print(results_matrix)

# 找到最优参数
best_idx <- which.max(results_matrix[, "youden_index"])
best_delta <- results_matrix[best_idx, "delta"]
print(paste("最优δ值为：", best_delta))
print(paste("对应的约登指数为：", results_matrix[best_idx, "youden_index"]))
print(paste("灵敏度为：", results_matrix[best_idx, "sensitivity"]))
print(paste("特异度为：", results_matrix[best_idx, "specificity"]))

# 
# > # 找到最优参数
#   > best_idx <- which.max(results_matrix[, "youden_index"])
# > best_delta <- results_matrix[best_idx, "delta"]
# > print(paste("最优δ值为：", best_delta))
# [1] "最优δ值为： 2"
# > print(paste("对应的约登指数为：", results_matrix[best_idx, "youden_index"]))
# [1] "对应的约登指数为： 0.596354166666667"
# > print(paste("灵敏度为：", results_matrix[best_idx, "sensitivity"]))
# [1] "灵敏度为： 0.6171875"
# > print(paste("特异度为：", results_matrix[best_idx, "specificity"]))
# [1] "特异度为： 0.979166666666667"

MEM流行病阈值设置指南

基于您的代码和搜索结果，我为您详细解释如何在移动流行区间法（MEM）中设置流行病的阈值。您的代码已经完成了δ参数寻优（最优δ=2），接下来需要基于这个最优参数来计算具体的流行阈值。

📊 MEM阈值设置原理

MEM阈值设置包括三类关键阈值：

阈值类型 计算原理 流行病学意义

流行开始阈值 流行前期最高30个发病值的算术平均数单侧95%置信区间上限 超过此值标志流行期开始

流行结束阈值 流行后期最高30个发病值的算术平均数单侧95%置信区间上限 低于此值标志流行期结束

强度分级阈值 流行期最高30个发病值的几何均数单侧50%/90%/97.5%置信区间上限 区分中、高、极高流行强度

💻 阈值设置代码实现

在您现有代码的基础上，添加以下内容：

使用最优δ值拟合MEM模型（在您现有代码后添加）

best_delta <- 2 # 从您的寻优结果中获得

方法1：使用memmodel函数直接计算阈值

mem_model <- memmodel(

i.data = formatted_data$data,

i.delta = best_delta

)

查看模型完整输出

print(mem_model)

提取关键阈值

start_threshold <- mem_modelKaTeX parse error: Expected 'EOF', got '#' at position 25: ...thresholds[1] #̲ 流行开始阈值 end_thr...epidemic.thresholds[2] # 流行结束阈值

intensity_thresholds <- mem_model$intensity.thresholds # 强度分级阈值

输出结果

print(paste("流行开始阈值:", round(start_threshold, 2)))

print(paste("流行结束阈值:", round(end_threshold, 2)))

print("强度分级阈值:")

print(paste("中等强度阈值:", round(intensity_thresholds[1], 2)))

print(paste("高强度阈值:", round(intensity_thresholds[2], 2)))

print(paste("极高强度阈值:", round(intensity_thresholds[3], 2)))

🎯 针对手足口病的优化建议

根据广东省手足口病研究，针对双峰流行特征的特殊处理：

建议：分季节独立建模（显著提升准确性）

1. 定义季节范围（根据广东地区特征）

summer_season <- subset(data_2014_2019, week >= 6 & week <= 46) # 夏季流行季（第6-46周）

winter_season <- subset(data_2014_2019, week >= 47 | week <= 6) # 冬季流行季（第47周-次年6周）

2. 分别转换数据

summer_formatted <- transformdata(summer_season, i.name = "disease_count_hundred_thousand")

winter_formatted <- transformdata(winter_season, i.name = "disease_count_hundred_thousand")

3. 为每个季节寻找最优δ值并计算阈值

（重复您之前的参数寻优流程，但分别对summer_formatted和winter_formatted进行）

📈 阈值应用与验证

设置阈值后，需要在实际监测中应用：

应用阈值进行流行强度判断

current_incidence <- 10.5 # 假设当前发病率为10.5/10万

if (current_incidence <= start_threshold) {

print("基线流行水平")

} else if (current_incidence <= intensity_thresholds[1]) {

print("低流行强度")

} else if (current_incidence <= intensity_thresholds[2]) {

print("中等流行强度")

} else if (current_incidence <= intensity_thresholds[3]) {

print("高流行强度")

} else {

print("极高流行强度")

}

交叉验证模型性能（参考广州研究）

validation_results <- memmodel(

i.data = formatted_dataKaTeX parse error: Expected 'EOF', got '#' at position 47: ... i.method = 2 #̲ 交叉验证方法 ) print...sensitivity))

print(paste("模型特异度:", validation_results$specificity))

⚠️ 注意事项

  1. 数据质量要求：MEM需要至少6个流行季的数据，且缺失值比例应低于35%（您已设置i.max.na.per=35）
  2. 季节划分科学性：手足口病在广东地区通常有春夏和秋冬两个流行高峰，分季建模可提高准确度
  3. 阈值动态调整：随着新数据的积累，应定期重新计算阈值（建议每年更新一次）
  4. 业务衔接：设置的阈值应与《手足口病聚集性和暴发疫情处置工作规范》中的定义相衔接

💡 实用提示

• 您的当前参数寻优结果（δ=2，约登指数=0.596）表明模型特异性很高（0.979），但灵敏度中等（0.617）

• 如果希望提高灵敏度，可以尝试δ=1.9或2.1，虽然约登指数可能略低，但可能获得更好的业务实用价值

• 广州市的研究显示，分季建模后灵敏度特异度均可达0.90以上，值得借鉴

完成阈值设置后，您就可以在实际工作中使用这些阈值进行手足口病的流行强度评估和早期预警了。

相关推荐
小圆5318 小时前
java-learn(9):常见算法，collection框架
java·开发语言·算法
脏脏a8 小时前
【C++ 入门】：引用、内联函数与 C++11 新特性（auto、范围 for、nullptr）全解析
开发语言·c++
毕设源码-林学长8 小时前
计算机毕业设计java和Vue的安全教育科普平台设计与实现 安全知识普及与教育平台 安全教育信息化管理平台
java·开发语言·课程设计
恒者走天下8 小时前
cpp / c++零基础就业学习一站式学习平台
开发语言·c++·学习
Python私教8 小时前
Rust 编程语言基础知识全面介绍
开发语言·后端·rust
向前阿、9 小时前
数据结构从基础到实战——排序
c语言·开发语言·数据结构·程序人生·算法
lsx2024069 小时前
Ruby CGI Cookie 使用指南
开发语言
musenh9 小时前
javascript学习
开发语言·javascript·学习
沐知全栈开发9 小时前
SVG 参考手册
开发语言
热门推荐
01GitHub 镜像站点02UV安装并设置国内源03BongoCat - 跨平台键盘猫动画工具04《大数据技术原理与应用》实验报告三 熟悉HBase常用操作05Linux下V2Ray安装配置指南06NVIDIA显卡驱动、CUDA、cuDNN 和 TensorRT 版本匹配指南07jdk21下载、安装（Windows、Linux、macOS）08GitLab 零基础入门指南：从安装到项目管理全流程09安娜的档案(Anna’s Archive) 镜像网站/国内最新可访问入口（持续更新）10在VSCode配置Java开发环境的保姆级教程（适配各类AI编程IDE）