################################################################################
# 系统配置参数 - 用户只需修改此部分
################################################################################
# 1. 研究区名称(用于输出文件名)
STUDY_AREA <- "范县"
# 2. 输入文件路径配置
INPUT_FILE <- "C:\\Users\\huangfengying\\Desktop\\耕地FX_code\\11-05-FJZB\\FJZB-2025_11_05.xls"
INPUT_SHEET <- "FJZB"
# 3. 表格输出开关(TRUE=输出,FALSE=不输出)
OUTPUT_SETTINGS <- list(
`表格1_耕地质量总体状况` = TRUE,
`表格2_各乡镇等级状况` = TRUE,
`表格3_立地条件` = TRUE,
`表格4_土壤养分` = TRUE,
`表格5_水资源_排水` = TRUE,
`表格6_土壤容重` = TRUE,
`表格7_土壤质地` = TRUE,
`表格8_地形部位` = TRUE,
`表格9_酸碱度` = TRUE,
`表格10_粮食生产潜力` = TRUE
)
# 4. 输出目录
OUTPUT_DIR <- "C:\\Users\\huangfengying\\Desktop\\耕地代码-范县-NEW\\result"
# 如果目录不存在则自动创建
if (!dir.exists(OUTPUT_DIR)) {
dir.create(OUTPUT_DIR, recursive = TRUE)
}
# 5. 官方核定面积(万亩)
OFFICIAL_AREA <- 51.53
################################################################################
# 加载必需包
################################################################################
library(readxl)
library(dplyr)
library(openxlsx)
library(stringr)
library(tidyr)
################################################################################
# 全局常量与辅助函数
################################################################################
# 1-9等级面积常量(表格1计算结果将覆盖此值)
GRADE_AREAS <- c(0.02, 1.15, 13.91, 17.10, 12.38, 6.97, 0.00, 0.00, 0.00)
names(GRADE_AREAS) <- as.character(1:9)
# 等级中文映射
GRADE_CHINESE <- c("1" = "一等", "2" = "二等", "3" = "三等", "4" = "四等",
"5" = "五等", "6" = "六等", "7" = "七等", "8" = "八等", "9" = "九等")
# 安全转换函数
safe_numeric <- function(x) {
suppressWarnings(as.numeric(x))
}
# 安全平均值计算
safe_mean <- function(x, na_rm = TRUE) {
x <- as.numeric(x)
if (length(x) == 0 || all(is.na(x))) return(0.00)
mean_val <- mean(x, na.rm = na_rm)
if (is.nan(mean_val) || is.infinite(mean_val)) return(0.00)
return(round(mean_val, 2))
}
# Excel样式设置函数
set_common_styles <- function(wb, sheet, n_rows, n_cols) {
center_style <- createStyle(halign = "center", valign = "center")
border_style <- createStyle(border = "TopBottomLeftRight", borderStyle = "thin")
addStyle(wb, sheet, center_style, rows = 1:n_rows, cols = 1:n_cols, gridExpand = TRUE)
addStyle(wb, sheet, border_style, rows = 1:n_rows, cols = 1:n_cols, gridExpand = TRUE)
}
################################################################################
# 表格函数封装
################################################################################
# 表格1:耕地质量总体状况(核心基准表)
generate_table1 <- function(input_file, input_sheet, output_dir, study_area) {
cat("正在生成表格1:耕地质量总体状况...\n")
# 读取数据
raw_df <- read_excel(path = input_file, sheet = input_sheet)
# 验证必需字段
required_cols <- c("质量等", "MJ米")
if (!all(required_cols %in% names(raw_df))) {
stop("表格1错误:缺少必要字段(质量等、MJ米)")
}
# 数据清洗
raw_df$质量等 <- safe_numeric(raw_df$质量等)
raw_df <- raw_df[!is.na(raw_df$质量等) & raw_df$质量等 %in% 1:9, ]
raw_df$MJ米 <- safe_numeric(raw_df$MJ米)
raw_df$MJ米[is.na(raw_df$MJ米)] <- 0
# 计算等级数据
grade_data_raw <- raw_df %>%
group_by(ZLD = 质量等) %>%
summarise(
DJMJ_3W = round(sum(MJ米 * 0.0015 / 10000, na.rm = TRUE), 3),
NDQL_raw = round(mean(LSC, na.rm = TRUE), 2),
DJQL_raw = round(mean(DJC, na.rm = TRUE), 2),
.groups = "drop"
) %>%
right_join(data.frame(ZLD = 1:9), by = "ZLD") %>%
mutate(across(c(DJMJ_3W, NDQL_raw, DJQL_raw), ~ ifelse(is.na(.), 0.00, .))) %>%
arrange(ZLD)
total_area_3W_raw <- round(sum(grade_data_raw$DJMJ_3W), 3)
# 面积平差处理
grade_data_raw$DJMJ_2W_raw <- round(grade_data_raw$DJMJ_3W, 2)
total_area_2W_raw <- round(OFFICIAL_AREA, 2)
Original_area <- sum(grade_data_raw$DJMJ_2W_raw)
area_diff <- total_area_2W_raw - Original_area
if (abs(area_diff) >= 0.01) {
max_area_index <- which.max(grade_data_raw$DJMJ_3W)
grade_data_raw$DJMJ_2W_raw[max_area_index] <- grade_data_raw$DJMJ_2W_raw[max_area_index] + area_diff
}
# 比例平差
grade_data_raw$DJBL_raw <- round((grade_data_raw$DJMJ_3W / total_area_3W_raw) * 100, 2)
ratio_error <- 100 - sum(grade_data_raw$DJBL_raw)
if (abs(ratio_error) >= 0.01) {
max_ratio_index <- which.max(grade_data_raw$DJBL_raw)
grade_data_raw$DJBL_raw[max_ratio_index] <- grade_data_raw$DJBL_raw[max_ratio_index] + ratio_error
}
# 准备最终数据
grade_data <- grade_data_raw %>%
mutate(
DJ = paste0(c("一","二","三","四","五","六","七","八","九"), "等"),
DJMJ = DJMJ_2W_raw,
DJBL = DJBL_raw / 100,
NDQL = NDQL_raw,
DJQL = DJQL_raw
) %>%
select(ZLD, DJ, DJMJ_3W, DJMJ, DJBL, NDQL, DJQL)
# 分级数据
create_grade_group <- function(grade_range, group_name) {
group_data <- grade_data[grade_data$ZLD %in% grade_range, ]
group_area_2W <- round(sum(group_data$DJMJ), 2)
group_ratio_raw <- round(sum(group_data$DJBL) * 100, 2)
group_data$FJ <- ""
group_data$FJ[1] <- group_name
group_data$FJMJ <- NA_real_
group_data$FJMJ[1] <- group_area_2W
group_data$FJBL <- NA_real_
group_data$FJBL[1] <- group_ratio_raw / 100
return(group_data)
}
high_df <- create_grade_group(1:3, "高等级耕地")
mid_df <- create_grade_group(4:6, "中等等级耕地")
low_df <- create_grade_group(7:9, "低等级耕地")
# 合并数据
final_df <- bind_rows(high_df, mid_df, low_df) %>%
select(FJ, FJMJ, FJBL, DJ, DJMJ, DJBL, NDQL, DJQL) %>%
mutate(
NDQL = ifelse(is.na(DJMJ) | DJMJ == 0, 0.00, NDQL),
DJQL = ifelse(is.na(DJMJ) | DJMJ == 0, 0.00, DJQL)
)
# 生产潜力平均值
non_zero_annual <- final_df$NDQL[!is.na(final_df$DJMJ) & final_df$DJMJ > 0]
non_zero_seasonal <- final_df$DJQL[!is.na(final_df$DJMJ) & final_df$DJMJ > 0]
annual_avg <- safe_mean(non_zero_annual)
seasonal_avg <- safe_mean(non_zero_seasonal)
# 总计行
total_row <- data.frame(
FJ = "总计", FJMJ = OFFICIAL_AREA, FJBL = 1.00,
DJ = "", DJMJ = OFFICIAL_AREA, DJBL = 1.00,
NDQL = annual_avg, DJQL = seasonal_avg,
stringsAsFactors = FALSE
)
final_df <- bind_rows(final_df, total_row) %>%
mutate(
FJ = case_when(
FJ == "高等级耕地" ~ "高等级耕地",
FJ == "中等等级耕地" ~ "中等等级耕地",
FJ == "低等级耕地" ~ "低等级耕地",
FJ == "总计" ~ "总计",
TRUE ~ FJ
),
DJ = str_replace(DJ, "等", "等")
)
# 中文列名
colnames(final_df) <- c(
"分级", "分级面积(万亩)", "分级比例",
"等级", "等级面积(万亩)", "等级比例",
"年度粮食生产潜力(kg/亩)", "单季粮食生产潜力(kg/亩)"
)
# Excel输出
wb <- createWorkbook()
addWorksheet(wb, "耕地质量总体状况")
writeData(wb, "耕地质量总体状况", final_df, rowNames = FALSE)
# 合并单元格
merge_cells <- list(c(2, 4), c(5, 7), c(8, 10))
for (rows in merge_cells) {
mergeCells(wb, "耕地质量总体状况", cols = 1, rows = rows[1]:rows[2])
mergeCells(wb, "耕地质量总体状况", cols = 2, rows = rows[1]:rows[2])
mergeCells(wb, "耕地质量总体状况", cols = 3, rows = rows[1]:rows[2])
}
# 样式设置
num_style_2 <- createStyle(numFmt = "0.00")
percent_style <- createStyle(numFmt = "0.00%")
addStyle(wb, "耕地质量总体状况", num_style_2, cols = c(2, 5, 7, 8), rows = 2:(nrow(final_df)+1), gridExpand = TRUE)
addStyle(wb, "耕地质量总体状况", percent_style, cols = c(3, 6), rows = 2:(nrow(final_df)+1), gridExpand = TRUE)
# 保存
output_file <- file.path(output_dir, sprintf("%s_表格1_耕地质量总体状况.xlsx", study_area))
saveWorkbook(wb, output_file, overwrite = TRUE)
cat(sprintf("表格1输出完成:%s\n", output_file))
# 返回关键参数供后续表格使用
return(list(
grade_areas = setNames(round(final_df[final_df$等级 != "总计", "等级面积(万亩)"], 2), 1:9),
high_area = sum(final_df[final_df$分级 == "高等级耕地", "分级面积(万亩)"], na.rm = TRUE),
mid_area = sum(final_df[final_df$分级 == "中等等级耕地", "分级面积(万亩)"], na.rm = TRUE),
low_area = sum(final_df[final_df$分级 == "低等级耕地", "分级面积(万亩)"], na.rm = TRUE)
))
}
# 表格2:各乡镇等级状况
generate_table2 <- function(input_file, input_sheet, output_dir, study_area, grade_params) {
if (!OUTPUT_SETTINGS$表格2_各乡镇等级状况) return(NULL)
cat("正在生成表格2:各乡镇等级状况...\n")
df <- read_excel(input_file, sheet = input_sheet)
if (!all(c("XZQMC", "质量等", "MJ米") %in% names(df))) {
stop("表格2错误:缺少必要字段(XZQMC、质量等、MJ米)")
}
df$grade <- safe_numeric(df$质量等)
df <- df[!is.na(df$grade) & df$grade %in% 1:9, ]
df$area_m2 <- safe_numeric(df$MJ米)
df$area_m2[is.na(df$area_m2)] <- 0
# 基础统计
result <- df %>%
mutate(grade_level = ifelse(grade <= 3, "high", ifelse(grade <= 6, "mid", "low"))) %>%
group_by(township = XZQMC, grade_level) %>%
summarise(area = sum(area_m2), .groups = 'drop') %>%
pivot_wider(names_from = grade_level, values_from = area, values_fill = 0) %>%
mutate(
high = round(high * 0.0015 / 10000, 2),
mid = round(mid * 0.0015 / 10000, 2),
low = round(low * 0.0015 / 10000, 2),
total = round(high + mid + low, 2)
) %>%
select(township, high, mid, low, total)
# 面积平差
targets <- list(high = grade_params$high_area, mid = grade_params$mid_area, low = grade_params$low_area)
for (level in c("high", "mid", "low")) {
current <- sum(result[[level]])
diff <- round(targets[[level]] - current, 2)
if (abs(diff) >= 0.01) {
max_idx <- which.max(result[[level]])
result[[level]][max_idx] <- round(result[[level]][max_idx] + diff, 2)
result$total[max_idx] <- round(result$high[max_idx] + result$mid[max_idx] + result$low[max_idx], 2)
}
}
# 强制修正总面积
current_total <- round(sum(result$total), 2)
total_diff <- round(OFFICIAL_AREA - current_total, 2)
if (abs(total_diff) >= 0.01) {
grade_totals <- c(high = sum(result$high), mid = sum(result$mid), low = sum(result$low))
max_level <- names(which.max(grade_totals))
max_idx <- which.max(result[[max_level]])
result[[max_level]][max_idx] <- round(result[[max_level]][max_idx] + total_diff, 2)
result$total[max_idx] <- round(result$high[max_idx] + result$mid[max_idx] + result$low[max_idx], 2)
}
# 最终验证
for (level in c("high", "mid", "low")) {
final_current <- sum(result[[level]])
final_diff <- round(targets[[level]] - final_current, 2)
if (abs(final_diff) >= 0.01) {
max_idx <- which.max(result[[level]])
result[[level]][max_idx] <- round(result[[level]][max_idx] + final_diff, 2)
result$total[max_idx] <- round(result$high[max_idx] + result$mid[max_idx] + result$low[max_idx], 2)
}
}
# 计算百分比并平差
result <- result %>%
mutate(
high_ratio = ifelse(total > 0, round(high / total * 100, 2), 0),
mid_ratio = ifelse(total > 0, round(mid / total * 100, 2), 0),
low_ratio = ifelse(total > 0, round(low / total * 100, 2), 0)
)
for (i in 1:nrow(result)) {
if (result$total[i] > 0) {
total_percent <- round(result$high_ratio[i] + result$mid_ratio[i] + result$low_ratio[i], 2)
diff <- 100 - total_percent
if (abs(diff) > 0.001) {
percents <- c(result$high_ratio[i], result$mid_ratio[i], result$low_ratio[i])
max_index <- which.max(percents)
if (max_index == 1) result$high_ratio[i] <- round(result$high_ratio[i] + diff, 2)
else if (max_index == 2) result$mid_ratio[i] <- round(result$mid_ratio[i] + diff, 2)
else result$low_ratio[i] <- round(result$low_ratio[i] + diff, 2)
}
}
}
# 最终结果格式化
final_result <- result %>%
mutate(
high = round(high, 2), mid = round(mid, 2), low = round(low, 2),
high_ratio = round(high_ratio, 2), mid_ratio = round(mid_ratio, 2), low_ratio = round(low_ratio, 2)
) %>%
select(township, high, high_ratio, mid, mid_ratio, low, low_ratio, total) %>%
arrange(desc(total))
# 添加总计行
total_row <- final_result %>%
summarise(
township = "总计", high = round(sum(high), 2), mid = round(sum(mid), 2),
low = round(sum(low), 2), total = round(sum(total), 2),
high_ratio = ifelse(sum(total) > 0, round(sum(high) / sum(total) * 100, 2), 0),
mid_ratio = ifelse(sum(total) > 0, round(sum(mid) / sum(total) * 100, 2), 0),
low_ratio = ifelse(sum(total) > 0, round(sum(low) / sum(total) * 100, 2), 0)
)
final_result <- bind_rows(final_result, total_row) %>%
rename(
镇街 = township, 高等级面积 = high, 高等级占比 = high_ratio,
中等级面积 = mid, 中等级占比 = mid_ratio, 低等级面积 = low,
低等级占比 = low_ratio, 合计面积 = total
)
cat("表格2计算完成\n")
return(list(df = final_result, name = "各乡镇等级状况"))
}
# 表格3-9:分级统计通用生成器
generate_grading_table <- function(input_file, input_sheet, output_dir, study_area,
table_name, indicator_config) {
cat(sprintf("正在生成%s:%s...\n", table_name, indicator_config$chinese_label))
data <- read_excel(path = input_file, sheet = input_sheet)
# 确保ZLD字段存在
if (!"ZLD" %in% names(data)) {
stop(sprintf("%s错误:数据中缺少ZLD字段", table_name))
}
# 计算面积(万亩)字段
if (!"MJWM" %in% names(data)) {
if (!"MJ米" %in% names(data)) {
stop(sprintf("%s错误:数据中缺少MJ米字段", table_name))
}
data$MJWM <- safe_numeric(data$MJ米) * 0.0015 / 10000
}
# 动态检测有效等级
valid_grades <- data %>%
filter(!is.na(MJWM), MJWM > 0) %>%
pull(ZLD) %>%
unique() %>%
sort() %>%
as.character()
# 创建结果框架
result <- data.frame(
DJ = rep(GRADE_CHINESE[valid_grades], each = 2),
SX = rep(c("面积/万亩", "占比/%"), length(valid_grades)),
stringsAsFactors = FALSE
)
# 确保所有分级列存在
for (level in indicator_config$standard_levels) {
result[[level]] <- 0.0
}
# 核心统计逻辑
for (grade in valid_grades) {
target_area <- GRADE_AREAS[grade]
grade_num <- as.numeric(grade)
grade_data <- data %>% filter(ZLD == grade_num, !is.na(MJWM), MJWM > 0)
row_area <- which(result$DJ == GRADE_CHINESE[grade] & result$SX == "面积/万亩")
row_pct <- which(result$DJ == GRADE_CHINESE[grade] & result$SX == "占比/%")
if (length(row_area) == 0) next
# 计算各分级原始面积
if (nrow(grade_data) > 0) {
for (level in indicator_config$standard_levels) {
if (!indicator_config$data_col %in% names(grade_data)) {
# 动态生成分级字段(如果不存在)
original_col <- indicator_config$raw_col
if (original_col %in% names(grade_data)) {
# 使用原始字段作为分级
grade_data[[indicator_config$data_col]] <- grade_data[[original_col]]
} else {
# 创建默认分级
grade_data[[indicator_config$data_col]] <- indicator_config$standard_levels[1]
}
}
area_val <- grade_data %>%
filter(.data[[indicator_config$data_col]] == level) %>%
pull(MJWM) %>%
sum(na.rm = TRUE)
result[row_area, level] <- round(area_val, 2)
}
} else {
# 无数据时分配全部面积到第一个分级
if (target_area > 0) {
result[row_area, indicator_config$standard_levels[1]] <- round(target_area, 2)
}
}
# 面积平差
level_cols <- indicator_config$standard_levels
total_original <- sum(result[row_area, level_cols], na.rm = TRUE)
if (abs(total_original - target_area) >= 0.001) {
diff <- target_area - total_original
# 找到最大值索引
values <- result[row_area, level_cols]
max_idx <- which.max(values)
if (length(max_idx) > 0) {
result[row_area, level_cols[max_idx]] <- round(result[row_area, level_cols[max_idx]] + diff, 2)
}
}
# 占比计算与平差
if (target_area > 0) {
pct_values <- (result[row_area, level_cols] / target_area) * 100
result[row_pct, level_cols] <- round(pct_values, 2)
# 占比平差
pct_sum <- sum(result[row_pct, level_cols], na.rm = TRUE)
if (abs(pct_sum - 100) >= 0.01) {
pct_diff <- 100 - pct_sum
# 找到最大占比的索引
pct_vals <- result[row_pct, level_cols]
max_pct_idx <- which.max(pct_vals)
if (length(max_pct_idx) > 0) {
result[row_pct, level_cols[max_pct_idx]] <- round(result[row_pct, level_cols[max_pct_idx]] + pct_diff, 2)
}
}
} else {
result[row_pct, level_cols] <- 0.00
}
}
# 合并等级单元格
if (nrow(result) >= 2) {
for (i in seq(1, nrow(result) - 1, by = 2)) {
if (i + 1 <= nrow(result)) {
result[i + 1, "DJ"] <- ""
}
}
}
# 总计行计算
total_area_row <- data.frame(DJ = "总计", SX = "面积/万亩", stringsAsFactors = FALSE)
total_pct_row <- data.frame(DJ = "", SX = "占比/%", stringsAsFactors = FALSE)
for (level in indicator_config$standard_levels) {
total_area <- sum(result[result$SX == "面积/万亩", level], na.rm = TRUE)
total_area_row[[level]] <- round(total_area, 2)
total_pct_row[[level]] <- round((total_area / OFFICIAL_AREA) * 100, 2)
}
# 总计行面积平差
current_total <- sum(total_area_row[indicator_config$standard_levels], na.rm = TRUE)
if (abs(current_total - OFFICIAL_AREA) >= 0.001) {
diff <- OFFICIAL_AREA - current_total
max_level <- indicator_config$standard_levels[which.max(total_area_row[indicator_config$standard_levels])]
total_area_row[[max_level]] <- round(total_area_row[[max_level]] + diff, 2)
}
# 总计行占比平差
pct_total <- sum(total_pct_row[indicator_config$standard_levels], na.rm = TRUE)
if (abs(pct_total - 100) >= 0.01) {
pct_diff <- 100 - pct_total
max_pct_level <- indicator_config$standard_levels[which.max(total_pct_row[indicator_config$standard_levels])]
total_pct_row[[max_pct_level]] <- round(total_pct_row[[max_pct_level]] + pct_diff, 2)
}
# 合并结果
result <- rbind(result, total_area_row, total_pct_row)
colnames(result) <- c("等级", "属性", indicator_config$standard_levels)
cat(sprintf("%s计算完成\n", indicator_config$sheet_name))
return(list(
df = result,
name = indicator_config$sheet_name,
indicator = indicator_config$chinese_label,
levels = indicator_config$standard_levels,
grading_field = indicator_config$data_col,
grading_info = indicator_config$grading_info
))
}
# 表格10:粮食生产潜力
generate_table10 <- function(input_file, input_sheet, output_dir, study_area) {
if (!OUTPUT_SETTINGS$表格10_粮食生产潜力) return(NULL)
cat("正在生成表格10:粮食生产潜力...\n")
# 读取主数据
data <- read_excel(path = input_file, sheet = input_sheet)
# 读取调查样点数据
survey_file <- "C:\\Users\\huangfengying\\Desktop\\【结果数据】范县_调查样点平均年产量-2026-1-3-1555-hfy.xlsx"
survey_data <- NULL
if (file.exists(survey_file)) {
survey_data <- read_excel(survey_file)
if ("调查样产量等级" %in% names(survey_data)) {
survey_data <- survey_data %>%
filter(!is.na(`调查样产量等级`), `调查样产量等级` != "") %>%
mutate(ZLD = suppressWarnings(as.numeric(`调查样产量等级`))) %>%
filter(!is.na(ZLD)) %>%
select(ZLD, `调查样点平均年产量(kg/亩)`)
}
}
# 合并数据
if (!is.null(survey_data)) {
data <- data %>%
left_join(survey_data, by = "ZLD")
}
# 计算
valid_grades <- 1:9
result <- tibble(DJ = GRADE_CHINESE[as.character(valid_grades)])
indicators <- list(
list(col = "评价得", name = "综合指数平均值"),
list(col = "粮食产", name = "耕地粮食生产潜力"),
list(col = "调查样点平均年产量(kg/亩)", name = "调查样点平均年产量(kg/亩)")
)
for (ind in indicators) {
result[[ind$name]] <- 0.00
for (i in seq_along(valid_grades)) {
grade <- valid_grades[i]
if (ind$col %in% names(data)) {
if (ind$col == "调查样点平均年产量(kg/亩)") {
col_val <- data %>%
filter(ZLD == grade) %>%
pull(!!sym(ind$col)) %>%
safe_mean()
} else {
grade_data <- data %>%
filter(ZLD == grade, !is.na(MJWM), MJWM > 0)
col_val <- if (nrow(grade_data) > 0) {
grade_data %>%
pull(!!sym(ind$col)) %>%
safe_mean()
} else { 0.00 }
}
result[i, ind$name] <- col_val
}
}
}
colnames(result) <- c("等级", sapply(indicators, `[[`, "name"))
cat("表格10计算完成\n")
return(list(df = result, name = "粮食生产潜力"))
}
################################################################################
# 主执行逻辑
################################################################################
# 存储所有表格结果
all_results <- list()
grading_info_list <- list()
# 执行表格1(基准表)
if (OUTPUT_SETTINGS$表格1_耕地质量总体状况) {
tryCatch({
grade_params <- generate_table1(INPUT_FILE, INPUT_SHEET, OUTPUT_DIR, STUDY_AREA)
# 更新全局GRADE_AREAS
GRADE_AREAS <<- grade_params$grade_areas
# 读取表格1的结果用于后续表格
table1_file <- file.path(OUTPUT_DIR, sprintf("%s_表格1_耕地质量总体状况.xlsx", STUDY_AREA))
if (file.exists(table1_file)) {
table1_data <- read_excel(table1_file, sheet = "耕地质量总体状况")
# 提取1-9等级面积
grade_rows <- table1_data[table1_data$等级 != "总计" & table1_data$属性 == "面积/万亩", ]
if (nrow(grade_rows) >= 9) {
GRADE_AREAS <<- setNames(
round(grade_rows[1:9, "等级面积(万亩)"], 2),
as.character(1:9)
)
}
}
all_results[[length(all_results) + 1]] <- list(
df = grade_params$df,
name = "耕地质量总体状况"
)
}, error = function(e) {
cat(sprintf("表格1执行失败:%s\n", e$message))
cat("后续依赖表格1的表格将无法正确计算!\n")
})
}
# 执行表格2
if (OUTPUT_SETTINGS$表格2_各乡镇等级状况) {
tryCatch({
result <- generate_table2(INPUT_FILE, INPUT_SHEET, OUTPUT_DIR, STUDY_AREA, grade_params)
if (!is.null(result)) {
all_results[[length(all_results) + 1]] <- result
}
}, error = function(e) {
cat(sprintf("表格2执行失败:%s\n", e$message))
})
}
# 表格3-9配置定义
grading_configs <- list(
list(
chinese_label = "耕层厚度", sheet_name = "耕层厚度统计", data_col = "GCHDFJ", raw_col = "耕层厚",
standard_levels = c("Ⅰ(厚)", "Ⅱ(较厚)", "Ⅲ(中)", "Ⅳ(较薄)", "Ⅴ(薄)"),
is_numeric = TRUE, unit = "cm"
),
list(
chinese_label = "有效土层厚度", sheet_name = "有效土层厚度统计", data_col = "YXTFJ", raw_col = "有效土",
standard_levels = c("Ⅰ级(>100)", "Ⅱ级(90,100]", "Ⅲ级(80,90]", "Ⅳ级(70,80]", "Ⅴ级(<=70)"),
is_numeric = TRUE, unit = "cm"
),
list(
chinese_label = "有机质", sheet_name = "有机质统计", data_col = "YJZFJ", raw_col = "有机质",
standard_levels = c("Ⅰ(高)", "Ⅱ(较高)", "Ⅲ(中)", "Ⅳ(较低)", "Ⅴ(低)"),
is_numeric = TRUE, unit = "g/kg"
),
list(
chinese_label = "有效磷", sheet_name = "有效磷统计", data_col = "YXLFJ", raw_col = "有效磷",
standard_levels = c("Ⅰ(丰富)", "Ⅱ(较丰富)", "Ⅲ(中等)", "Ⅳ(缺乏)", "Ⅴ(极缺)"),
is_numeric = TRUE, unit = "mg/kg"
),
list(
chinese_label = "速效钾", sheet_name = "速效钾统计", data_col = "SXJFJ", raw_col = "速效钾",
standard_levels = c("Ⅰ(丰富)", "Ⅱ(较丰富)", "Ⅲ(中等)", "Ⅳ(缺乏)", "Ⅴ(极缺)"),
is_numeric = TRUE, unit = "mg/kg"
),
list(
chinese_label = "水资源", sheet_name = "水资源统计", data_col = "SZYFJ", raw_col = "水资源",
standard_levels = c("充分满足", "满足", "基本满足", "不满足"),
is_numeric = FALSE, unit = ""
),
list(
chinese_label = "排水", sheet_name = "排水统计", data_col = "PSFJ", raw_col = "排水",
standard_levels = c("充分满足", "满足", "基本满足", "不满足"),
is_numeric = FALSE, unit = ""
),
list(
chinese_label = "土壤容重", sheet_name = "土壤容重统计", data_col = "TRRZFJ", raw_col = "土容重",
standard_levels = c("Ⅰ(不适宜)", "Ⅱ(较适宜)", "Ⅲ(适宜)", "Ⅳ(较适宜)", "Ⅴ(不适宜)"),
is_numeric = TRUE, unit = "g/cm³"
),
list(
chinese_label = "土壤质地", sheet_name = "土壤质地统计", data_col = "ZDFJ", raw_col = "质地",
standard_levels = c("Ⅰ(不适宜)", "Ⅱ(适宜)", "Ⅲ(较适宜)", "Ⅳ(较不适宜)", "Ⅴ(不适宜)"),
is_numeric = FALSE, unit = ""
),
list(
chinese_label = "地形部位", sheet_name = "地形部位统计", data_col = "DXBFJ", raw_col = "地形部位",
standard_levels = c("平原低阶", "平原中阶", "平原高阶", "丘陵下部", "丘陵中部", "丘陵上部"),
is_numeric = FALSE, unit = ""
),
list(
chinese_label = "酸碱度", sheet_name = "酸碱度统计", data_col = "PHFJ", raw_col = "pH",
standard_levels = c("Ⅰ(强酸性)", "Ⅱ(中等酸性)", "Ⅲ(弱酸性)", "Ⅳ(中性)", "Ⅴ(弱碱性)", "Ⅵ(中等碱性)", "Ⅶ(强碱性)"),
is_numeric = TRUE, unit = ""
)
)
# 表格名称映射
table_names <- c(
"表格3_立地条件" = 1:2,
"表格4_土壤养分" = 3:5,
"表格5_水资源_排水" = 6:7,
"表格6_土壤容重" = 8,
"表格7_土壤质地" = 9,
"表格8_地形部位" = 10,
"表格9_酸碱度" = 11
)
# 执行表格3-9
for (table_key in names(table_names)) {
if (!OUTPUT_SETTINGS[[table_key]]) next
idx_range <- table_names[[table_key]]
for (idx in idx_range) {
config <- grading_configs[[idx]]
# 检查是否需要生成分级字段
data <- read_excel(INPUT_FILE, sheet = INPUT_SHEET)
if (!config$data_col %in% names(data)) {
cat(sprintf("正在计算%s分级字段...\n", config$chinese_label))
# 数值型指标分级逻辑
if (config$chinese_label == "耕层厚度") {
data$GCHDFJ <- sapply(data[[config$raw_col]], function(x) {
x <- safe_numeric(x)
if (is.na(x)) return(NA)
if (x > 25) return("Ⅰ(厚)")
if (x > 20) return("Ⅱ(较厚)")
if (x > 15) return("Ⅲ(中)")
if (x > 10) return("Ⅳ(较薄)")
return("Ⅴ(薄)")
})
} else if (config$chinese_label == "有效土层厚度") {
data$YXTFJ <- sapply(data[[config$raw_col]], function(x) {
x <- safe_numeric(x)
if (is.na(x)) return(NA)
if (x > 100) return("Ⅰ级(>100)")
if (x > 90) return("Ⅱ级(90,100]")
if (x > 80) return("Ⅲ级(80,90]")
if (x > 70) return("Ⅳ级(70,80]")
return("Ⅴ级(<=70)")
})
} else if (config$chinese_label == "有机质") {
data$YJZFJ <- sapply(data[[config$raw_col]], function(x) {
x <- safe_numeric(x)
if (is.na(x)) return(NA)
if (x > 40) return("Ⅰ(高)")
if (x > 30) return("Ⅱ(较高)")
if (x > 20) return("Ⅲ(中)")
if (x > 10) return("Ⅳ(较低)")
return("Ⅴ(低)")
})
} else if (config$chinese_label == "有效磷") {
data$YXLFJ <- sapply(data[[config$raw_col]], function(x) {
x <- safe_numeric(x)
if (is.na(x)) return(NA)
if (x > 40) return("Ⅰ(丰富)")
if (x > 20) return("Ⅱ(较丰富)")
if (x > 10) return("Ⅲ(中等)")
if (x > 5) return("Ⅳ(缺乏)")
return("Ⅴ(极缺)")
})
} else if (config$chinese_label == "速效钾") {
data$SXJFJ <- sapply(data[[config$raw_col]], function(x) {
x <- safe_numeric(x)
if (is.na(x)) return(NA)
if (x > 200) return("Ⅰ(丰富)")
if (x > 150) return("Ⅱ(较丰富)")
if (x > 100) return("Ⅲ(中等)")
if (x > 50) return("Ⅳ(缺乏)")
return("Ⅴ(极缺)")
})
} else if (config$chinese_label == "土壤容重") {
data$TRRZFJ <- sapply(data[[config$raw_col]], function(x) {
x <- safe_numeric(x)
if (is.na(x)) return(NA)
if (x <= 0.90) return("Ⅰ(不适宜)")
if (x <= 1.10) return("Ⅱ(较适宜)")
if (x <= 1.35) return("Ⅲ(适宜)")
if (x <= 1.55) return("Ⅳ(较适宜)")
return("Ⅴ(不适宜)")
})
} else if (config$chinese_label == "酸碱度") {
data$PHFJ <- sapply(data[[config$raw_col]], function(x) {
x <- safe_numeric(x)
if (is.na(x)) return(NA)
if (x <= 4.5) return("Ⅰ(强酸性)")
if (x <= 5.5) return("Ⅱ(中等酸性)")
if (x <= 6.5) return("Ⅲ(弱酸性)")
if (x <= 7.5) return("Ⅳ(中性)")
if (x <= 8.5) return("Ⅴ(弱碱性)")
if (x <= 9.0) return("Ⅵ(中等碱性)")
return("Ⅶ(强碱性)")
})
} else if (config$chinese_label %in% c("水资源", "排水", "土壤质地", "地形部位")) {
# 非数值型:直接使用原始字段作为分级
if (config$raw_col %in% names(data)) {
data[[config$data_col]] <- data[[config$raw_col]]
} else {
data[[config$data_col]] <- config$standard_levels[1]
}
}
}
# 保存临时文件(包含分级字段)
temp_file <- file.path(OUTPUT_DIR, "temp_grading_data.xlsx")
write_xlsx(data, temp_file)
tryCatch({
result <- generate_grading_table(temp_file, INPUT_SHEET, OUTPUT_DIR, STUDY_AREA,
table_key, config)
if (!is.null(result)) {
all_results[[length(all_results) + 1]] <- result
# 收集分级信息
for (level in result$levels) {
if (sum(result$df[result$df$属性 == "面积/万亩", level], na.rm = TRUE) > 0) {
grading_info_list[[length(grading_info_list) + 1]] <- list(
指标 = result$indicator,
分级结果 = level,
分级字段 = result$grading_field,
分级标准 = config$grading_standards[[level]] %||% "未知标准"
)
}
}
}
}, error = function(e) {
cat(sprintf("%s执行失败:%s\n", table_key, e$message))
})
# 删除临时文件
unlink(temp_file)
}
}
# 执行表格10
if (OUTPUT_SETTINGS$表格10_粮食生产潜力) {
tryCatch({
result <- generate_table10(INPUT_FILE, INPUT_SHEET, OUTPUT_DIR, STUDY_AREA)
if (!is.null(result)) {
all_results[[length(all_results) + 1]] <- result
}
}, error = function(e) {
cat(sprintf("表格10执行失败:%s\n", e$message))
})
}
################################################################################
# 统一Excel输出
################################################################################
if (length(all_results) > 0) {
cat("\n正在生成综合Excel文件...\n")
# 主输出文件
main_output <- file.path(OUTPUT_DIR, sprintf("%s_耕地质量统计报告.xlsx", STUDY_AREA))
wb <- createWorkbook()
# 写入所有表格
for (res in all_results) {
if (!is.null(res$df)) {
addWorksheet(wb, res$name)
writeData(wb, res$name, res$df, rowNames = FALSE)
# 设置样式
set_common_styles(wb, res$name, nrow(res$df) + 1, ncol(res$df))
# 特殊格式处理
if (res$name == "耕地质量总体状况") {
percent_style <- createStyle(numFmt = "0.00%")
addStyle(wb, res$name, percent_style, cols = c(3, 6), rows = 2:(nrow(res$df)+1), gridExpand = TRUE)
}
# 合并单元格处理
if (grepl("统计$", res$name)) {
# 合并前两行前两列
mergeCells(wb, res$name, cols = 1, rows = 1:2)
mergeCells(wb, res$name, cols = 2, rows = 1:2)
# 合并指标名称
if (ncol(res$df) > 2) {
mergeCells(wb, res$name, cols = 3:ncol(res$df), rows = 1)
}
# 合并等级单元格
grade_rows <- which(res$df$属性 == "面积/万亩" & res$df$等级 != "总计")
for (row_idx in grade_rows) {
excel_row_start <- row_idx + 2
excel_row_end <- excel_row_start + 1
mergeCells(wb, res$name, cols = 1, rows = excel_row_start:excel_row_end)
}
# 合并总计行
total_rows <- which(res$df$等级 == "总计")
if (length(total_rows) > 0) {
total_area_row <- total_rows[1]
total_pct_row <- total_area_row + 1
mergeCells(wb, res$name, cols = 1, rows = c(total_area_row + 2, total_pct_row + 2))
}
}
}
}
# 添加分级指标汇总表
if (length(grading_info_list) > 0) {
grading_df <- do.call(rbind, lapply(grading_info_list, function(x) {
data.frame(
指标 = x$指标,
分级结果 = x$分级结果,
分级字段 = x$分级字段,
分级标准 = x$分级标准,
stringsAsFactors = FALSE
)
}))
# 去重
grading_df <- grading_df[!duplicated(paste0(grading_df$指标, "_", grading_df$分级结果)), ]
addWorksheet(wb, "分级指标汇总")
writeData(wb, "分级指标汇总", grading_df, rowNames = FALSE)
set_common_styles(wb, "分级指标汇总", nrow(grading_df) + 1, ncol(grading_df))
# 设置列宽
setColWidths(wb, "分级指标汇总", cols = 1:ncol(grading_df), widths = c(20, 25, 15, 30))
}
# 保存主文件
saveWorkbook(wb, main_output, overwrite = TRUE)
cat(sprintf("\n✓ 综合报告已生成:%s\n", main_output))
# 输出统计摘要
cat("\n========== 统计摘要 ==========\n")
cat(sprintf("研究区:%s\n", STUDY_AREA))
cat(sprintf("官方面积:%.2f 万亩\n", OFFICIAL_AREA))
cat(sprintf("输出表格数:%d 个\n", length(all_results)))
cat(sprintf("包含分级指标:%d 项\n", length(grading_info_list)))
cat("============================\n")
} else {
cat("警告:没有成功生成任何表格!\n")
}
cat("\n程序执行完成。\n")
【合并所有表格——代码设计】
1、【参数配置】
(1)请输入研究区名”范县“,最终在输出的.xl表格命名使用
(2)
直接在表格后面输入:"TRUE”或者“FALSE”,输入“TRUE”则输出该表格;
输入“FALSE”则不输出该表格:
表格1_耕地质量总体状况 TRUE
表格2_各乡镇等级状况 TRUE
表格3_立地条件 TRUE
表格4_土壤养分 TRUE
表格5_水资源_排水 TRUE
表格6_土壤容重 TRUE
表格7_土壤质地 TRUE
表格8_地形部位 TRUE
表格9_酸碱度 TRUE
表格10_粮食生产潜力 TRUE
2、【分别单独分表格装1-10对应的10个大函数】
将1-10表格单独分装成:
不同表格对应的代码,直接在参数配置部分,用户直接调用需要输出的表格即可
3、【输出.XL表格函数】
(1)将“表格1”统计到的结果:“1-9等级面积、高中低等级面积、官方面积=高中低等级总面积”定死,并准确精准传递到后面表格需要这些的参数中的表格中
【其他表格1-9等级面积、高中低等级面积、官方面积=等级面积总计,这些数据都是必须依靠表格1的统计数据的结果传入其他需要固定参数的表格中】
(2)1到10表格分别输出到同一个.xl表格的不同的sheet中,并命名与原来表格名称一致
(3)所有输出表格保持原来表格输出的默认输出的单元格大小、样式
(4)1到10表格的添加”指标分级“字段的信息,最终是统一输出到同一个.XL表格中,并命名“XX县_分级指标“
请你准确严谨规范有逻辑健壮精准高效全自动化灵活严格科学按照要求修改代码,
修改后的R语言代码必须是自动化、健壮、灵活、准确、严格、科学的,可以用于读取不同的数据,固定的参数会根据读取的数据不同而不同,最终的代码只需要一键运行即可完成用户指定需要输出的表格,不能改变代码思路、添加或者删减代码
最新发布