svm_plots <- c( "none", "decision_boundary", "margin", "vip" ) names(svm_plots) <- c( i18n$t("None"), i18n$t("Decision Boundary (2 vars)"), i18n$t("Support Vectors & Margin(2 vars)"), i18n$t("Variable importance") ) ## SVM函数参数列表 svm_args <- as.list(formals(svm)) ## 用户选择的输入参数 svm_inputs <- reactive({ svm_args$data_filter <- if (input$show_filter) input$data_filter else "" svm_args$arr <- if (input$show_filter) input$data_arrange else "" svm_args$rows <- if (input$show_filter) input$data_rows else "" svm_args$dataset <- input$dataset for (i in r_drop(names(svm_args))) { svm_args[[i]] <- input[[paste0("svm_", i)]] } svm_args }) ## 预测参数(保留命令模式,未改动) svm_pred_args <- as.list(if (exists("predict.svm")) { formals(predict.svm) } else { formals(radiant.model:::predict.svm) }) svm_pred_inputs <- reactive({ for (i in names(svm_pred_args)) { svm_pred_args[[i]] <- input[[paste0("svm_", i)]] } svm_pred_args$dec <- input$svm_dec %||% 3 svm_pred_args$pred_cmd <- svm_pred_args$pred_data <- "" if (input$svm_predict == "cmd") { svm_pred_args$pred_cmd <- gsub("\\s{2,}", " ", input$svm_pred_cmd) %>% gsub(";\\s+", ";", .) %>% gsub("\"", "\'", .) } else if (input$svm_predict == "data") { svm_pred_args$pred_data <- input$svm_pred_data } else if (input$svm_predict == "datacmd") { svm_pred_args$pred_cmd <- gsub("\\s{2,}", " ", input$svm_pred_cmd) %>% gsub(";\\s+", ";", .) %>% gsub("\"", "\'", .) svm_pred_args$pred_data <- input$svm_pred_data } return(svm_pred_args) }) ## 绘图参数(砍掉vip、pdp、svm_margin) svm_plot_args <- as.list(if (exists("plot.svm")) { formals(plot.svm) } else { formals(radiant.model:::plot.svm) }) svm_plot_inputs <- reactive({ for (i in names(svm_plot_args)) { svm_plot_args[[i]] <- input[[paste0("svm_", i)]] } svm_plot_args }) ## 响应变量UI output$ui_svm_rvar <- renderUI({ req(input$svm_type) withProgress(message = i18n$t("Acquiring variable information"), value = 1, { if (input$svm_type == "classification") { vars <- two_level_vars() # 仅二分类 } else { isNum <- .get_class() %in% c("integer", "numeric", "ts") vars <- varnames()[isNum] } }) init <- if (input$svm_type == "classification") { if (is.empty(input$logit_rvar)) isolate(input$svm_rvar) else input$logit_rvar } else { if (is.empty(input$reg_rvar)) isolate(input$svm_rvar) else input$reg_rvar } selectInput( inputId = "svm_rvar", label = i18n$t("Response variable:"), choices = vars, selected = state_single("svm_rvar", vars, init), multiple = FALSE ) }) ## 分类水平UI output$ui_svm_lev <- renderUI({ req(input$svm_type == "classification") req(available(input$svm_rvar)) levs <- .get_data()[[input$svm_rvar]] %>% as_factor() %>% levels() init <- if (is.empty(input$logit_lev)) isolate(input$svm_lev) else input$logit_lev selectInput( inputId = "svm_lev", label = i18n$t("Choose level:"), choices = levs, selected = state_init("svm_lev", init) ) }) ## 解释变量UI output$ui_svm_evar <- renderUI({ if (not_available(input$svm_rvar)) return() vars <- varnames() if (length(vars) > 0) vars <- vars[-which(vars == input$svm_rvar)] init <- if (input$svm_type == "classification") { if (is.empty(input$logit_evar)) isolate(input$svm_evar) else input$logit_evar } else { if (is.empty(input$reg_evar)) isolate(input$svm_evar) else input$reg_evar } selectInput( inputId = "svm_evar", label = i18n$t("Explanatory variables:"), choices = vars, selected = state_multiple("svm_evar", vars, init), multiple = TRUE, size = min(10, length(vars)), selectize = FALSE ) }) ## 权重变量UI output$ui_svm_wts <- renderUI({ isNum <- .get_class() %in% c("integer", "numeric", "ts") vars <- varnames()[isNum] if (length(vars) > 0 && any(vars %in% input$svm_evar)) { vars <- base::setdiff(vars, input$svm_evar) names(vars) <- varnames() %>% {.[match(vars, .)]} %>% names() } vars <- c("None", vars) selectInput( inputId = "svm_wts", label = i18n$t("Weights:"), choices = vars, selected = state_single("svm_wts", vars), multiple = FALSE ) }) ## 存储预测值UI(残差存储已删除) output$ui_svm_store_pred_name <- renderUI({ init <- state_init("svm_store_pred_name", "pred_svm") %>% sub("\\d{1,}$", "", .) %>% paste0(., ifelse(is.empty(input$svm_kernel), "", input$svm_kernel)) textInput( "svm_store_pred_name", i18n$t("Store predictions:"), init ) }) ## 数据集/模型类型切换时重置预测与绘图 observeEvent(input$dataset, { updateSelectInput(session = session, inputId = "svm_predict", selected = "none") updateSelectInput(session = session, inputId = "svm_plots", selected = "none") }) observeEvent(input$svm_type, { updateSelectInput(session = session, inputId = "svm_predict", selected = "none") updateSelectInput(session = session, inputId = "svm_plots", selected = "none") }) ## 绘图选项UI(已删vip、pdp、svm_margin) output$ui_svm_plots <- renderUI({ req(input$svm_type) avail_plots <- svm_plots if (input$svm_type != "classification") { avail_plots <- avail_plots[!names(avail_plots) %in% i18n$t("Decision Boundary (2 vars)")] } selectInput( "svm_plots", i18n$t("Plots:"), choices = avail_plots, selected = state_single("svm_plots", avail_plots) ) }) ## 数据点数量UI(仅dashboard用,保留) output$ui_svm_nrobs <- renderUI({ nrobs <- nrow(.get_data()) choices <- c("1,000" = 1000, "5,000" = 5000, "10,000" = 10000, "All" = -1) %>% .[. < nrobs] selectInput( "svm_nrobs", i18n$t("Number of data points plotted:"), choices = choices, selected = state_single("svm_nrobs", choices, 1000) ) }) ## 主UI面板(已删残差存储入口) output$ui_svm <- renderUI({ req(input$dataset) tagList( conditionalPanel( condition = "input.tabs_svm == 'Summary'", wellPanel( actionButton("svm_run", i18n$t("Estimate model"), width = "100%", icon = icon("play", verify_fa = FALSE), class = "btn-success") ) ), wellPanel( conditionalPanel( condition = "input.tabs_svm == 'Summary'", radioButtons( "svm_type", label = NULL, choices = c("classification", "regression") %>% { names(.) <- c(i18n$t("Classification"), i18n$t("Regression")); . }, inline = TRUE ), uiOutput("ui_svm_rvar"), uiOutput("ui_svm_lev"), uiOutput("ui_svm_evar"), uiOutput("ui_svm_wts"), # SVM特有参数 fluidRow( column(width = 6, selectInput( "svm_kernel", label = i18n$t("Kernel:"), choices = c("linear", "radial", "poly", "sigmoid"), selected = state_init("svm_kernel", "radial"), width = "100%" ) ), column(width = 6, numericInput( "svm_cost", label = i18n$t("Cost (C):"), min = 0.1, max = 100, step = 0.1, value = state_init("svm_cost", 1), width = "100%" ) ) ), fluidRow( column(width = 6, conditionalPanel( condition = "input.svm_kernel != 'linear'", numericInput( "svm_gamma", label = i18n$t("Gamma:"), min = 0.1, max = 20, step = 0.1, value = state_init("svm_gamma", 1), width = "100%" ) ) ), column(width = 6, numericInput( "svm_seed", label = i18n$t("Seed:"), value = state_init("svm_seed", 1234), width = "100%" ) ) ) ), # 预测面板(残差存储已删除) conditionalPanel( condition = "input.tabs_svm == 'Predict'", selectInput( "svm_predict", label = i18n$t("Prediction input type:"), choices = reg_predict, selected = state_single("svm_predict", reg_predict, "none") ), conditionalPanel( "input.svm_predict != 'none'", numericInput( "svm_dec", label = i18n$t("Decimal places:"), min = 1, max = 10, value = state_init("svm_dec", 3), width = "200px" ) ), conditionalPanel( "input.svm_predict == 'data' | input.svm_predict == 'datacmd'", selectizeInput( inputId = "svm_pred_data", label = i18n$t("Prediction data:"), choices = c("None" = "", r_info[["datasetlist"]]), selected = state_single("svm_pred_data", c("None" = "", r_info[["datasetlist"]])), multiple = FALSE ) ), conditionalPanel( "input.svm_predict == 'cmd' | input.svm_predict == 'datacmd'", returnTextAreaInput( "svm_pred_cmd", i18n$t("Prediction command:"), value = state_init("svm_pred_cmd", ""), rows = 3, placeholder = i18n$t("Type a formula to set values for model variables (e.g., carat = 1; cut = 'Ideal') and press return") ) ), conditionalPanel( "input.svm_predict == 'data' | input.svm_predict == 'datacmd'", tags$table( tags$td(uiOutput("ui_svm_store_pred_name")), tags$td(actionButton("svm_store_pred", i18n$t("Store"), icon = icon("plus", verify_fa = FALSE)), class = "top") ) ) ), # 绘图面板(已删vip、pdp、svm_margin) conditionalPanel( condition = "input.tabs_svm == 'Plot'", uiOutput("ui_svm_plots"), conditionalPanel( condition = "input.svm_plots == 'pred_plot'", uiOutput("ui_svm_incl"), uiOutput("ui_svm_incl_int") ), conditionalPanel( condition = "input.svm_plots == 'dashboard'", uiOutput("ui_svm_nrobs") ) ) ), # 帮助和报告面板 help_and_report( modal_title = i18n$t("Support Vector Machine (SVM)"), fun_name = "svm", help_file = inclMD(file.path(getOption("radiant.path.model"), "app/tools/help/svm.md")) ) ) }) ## 绘图尺寸计算(已删vip、pdp、svm_margin) svm_plot <- reactive({ if (svm_available() != "available") return() if (is.empty(input$svm_plots, "none")) return() res <- .svm() if (is.character(res)) return() plot_width <- 650 if ("decision_boundary" %in% input$svm_plots) { plot_height <- 500 } else if (input$svm_plots == "pred_plot") { nr_vars <- length(input$svm_incl) + length(input$svm_incl_int) plot_height <- max(250, ceiling(nr_vars / 2) * 250) } else { plot_height <- max(500, length(res$evar) * 30) } list(plot_width = plot_width, plot_height = plot_height) }) svm_plot_width <- function() svm_plot()$plot_width %||% 650 svm_plot_height <- function() svm_plot()$plot_height %||% 500 ## 主输出面板(已删残差存储) output$svm <- renderUI({ register_print_output("summary_svm", ".summary_svm") register_print_output("predict_svm", ".predict_print_svm") register_plot_output( "plot_svm", ".plot_svm", height_fun = "svm_plot_height", width_fun = "svm_plot_width" ) svm_output_panels <- tabsetPanel( id = "tabs_svm", tabPanel(i18n$t("Summary"), value = "Summary", verbatimTextOutput("summary_svm")), tabPanel(i18n$t("Predict"), value = "Predict", download_link("dl_svm_pred"), br(), verbatimTextOutput("predict_svm")), tabPanel(i18n$t("Plot"), value = "Plot", download_link("dlp_svm"), plotOutput("plot_svm", width = "100%", height = "100%")) ) stat_tab_panel( menu = i18n$t("Model > Estimate"), tool = i18n$t("Support Vector Machine (SVM)"), tool_ui = "ui_svm", output_panels = svm_output_panels ) }) ## 模型可用性检查 svm_available <- reactive({ req(input$svm_type) if (not_available(input$svm_rvar)) { if (input$svm_type == "classification") { i18n$t("This analysis requires a response variable with two levels and one\nor more explanatory variables. If these variables are not available\nplease select another dataset.\n\n") %>% suggest_data("titanic") } else { i18n$t("This analysis requires a response variable of type integer\nor numeric and one or more explanatory variables.\nIf these variables are not available please select another dataset.\n\n") %>% suggest_data("diamonds") } } else if (not_available(input$svm_evar)) { i18n$t("Please select one or more explanatory variables.") %>% suggest_data(ifelse(input$svm_type == "classification", "titanic", "diamonds")) } else { "available" } }) ## 核心函数壳子 .svm <- eventReactive(input$svm_run, { svi <- svm_inputs() svi$envir <- r_data withProgress(message = i18n$t("Estimating SVM model"), value = 1, do.call(svm, svi)) }) ## 辅助输出函数壳子 .summary_svm <- reactive({ if (not_pressed(input$svm_run)) return(i18n$t("** Press the Estimate button to estimate the SVM model **")) if (svm_available() != "available") return(svm_available()) summary(.svm()) }) .predict_svm <- reactive({ if (not_pressed(input$svm_run)) return(i18n$t("** Press 'Estimate model' first to train the SVM **")) if (svm_available() != "available") return(svm_available()) if (is.empty(input$svm_predict, "none")) return(i18n$t("** Select prediction type **")) if (input$svm_predict %in% c("data", "datacmd") &&(is.null(input$svm_pred_data) || is.empty(input$svm_pred_data))) { return(i18n$t("** Select a dataset for prediction (under 'Prediction data') **")) } if (input$svm_predict %in% c("cmd", "datacmd") && is.empty(input$svm_pred_cmd)) return(i18n$t("** Enter commands (e.g., 'carat = 1; cut = 'Ideal'') **")) withProgress(message = i18n$t("Generating SVM predictions (scaling applied)"), value = 1, { pred_args <- svm_pred_inputs() pred_args$object <- .svm() pred_args$envir <- r_data if (input$svm_predict %in% c("data", "datacmd")) { pred_args$pred_data <- r_data[[input$svm_pred_data]] if (is.null(pred_args$pred_data)) return(sprintf(i18n$t("** Dataset '%s' not found **"), input$svm_pred_data)) } do.call(predict, pred_args) }) }) .predict_print_svm <- reactive({ .predict_svm() %>% { if (is.character(.)) cat(., "\n") else print(.) } }) .plot_svm <- reactive({ if (not_pressed(input$svm_run)) return(i18n$t("** Press the Estimate button to estimate the SVM model **")) if (svm_available() != "available") return(svm_available()) if (is.empty(input$svm_plots, "none")) return(i18n$t("Please select an SVM plot from the drop-down menu")) pinp <- svm_plot_inputs() pinp$shiny <- TRUE withProgress(message = i18n$t("Generating SVM plots"), value = 1, do.call(plot, c(list(x = .svm()), pinp))) }) ## 存储预测值(残差存储已删除) observeEvent(input$svm_store_pred, { req( pressed(input$svm_run), !is.empty(input$svm_pred_data), !is.empty(input$svm_store_pred_name), inherits(.predict_svm(), "svm.predict") ) pred_result <- .predict_svm() target_data <- r_data[[input$svm_pred_data]] base_col_name <- fix_names(input$svm_store_pred_name) meta <- attr(pred_result, "svm_meta") pred_cols <- if (meta$model_type == "classification") { colnames(pred_result)[grepl("^Predicted_Class|^Prob_", colnames(pred_result))] } else { "Predicted_Value" } new_col_names <- if (length(pred_cols) == 1) base_col_name else { suffix <- gsub("^Predicted_|^Prob_", "", pred_cols) paste0(base_col_name, "_", suffix) } colnames(pred_result)[match(pred_cols, colnames(pred_result))] <- new_col_names merged_data <- merge( target_data, pred_result[, c(meta$evar, new_col_names), drop = FALSE], by = meta$evar, all.x = TRUE ) r_data[[input$svm_pred_data]] <- merged_data showNotification( sprintf(i18n$t("SVM predictions stored as: %s (in '%s')"), paste(new_col_names, collapse = ", "), input$svm_pred_data), type = "message" ) updateTextInput(session, "svm_store_pred_name", value = base_col_name) }) ## 下载处理 dl_svm_pred <- function(path) { if (pressed(input$svm_run)) { write.csv(.predict_svm(), file = path, row.names = FALSE) } else { cat(i18n$t("No output available. Press the Estimate button to generate SVM results"), file = path) } } download_handler( id = "dl_svm_pred", fun = dl_svm_pred, fn = function() paste0(input$dataset, "_svm_pred"), type = "csv", caption = i18n$t("Save SVM predictions") ) download_handler( id = "dlp_svm", fun = download_handler_plot, fn = function() paste0(input$dataset, "_svm"), type = "png", caption = i18n$t("Save SVM plot"), plot = .plot_svm, width = svm_plot_width, height = svm_plot_height ) ## 报告生成(空壳,保留接口) svm_report <- function() invisible() observeEvent(input$svm_report, { r_info[["latest_screenshot"]] <- NULL svm_report() }) observeEvent(input$svm_screenshot, { r_info[["latest_screenshot"]] <- NULL radiant_screenshot_modal("modal_svm_screenshot") }) observeEvent(input$modal_svm_screenshot, { svm_report() removeModal() })