make_desc_text <- function(df) { if (is.null(df) || nrow(df) == 0) return(i18n$t("No data available")) num_cols <- sapply(df, is.numeric) if (sum(num_cols) == 0) return("No numerical variable available") df_num <- df[, num_cols, drop = FALSE] buf <- c(i18n$t("### Current data overview")) buf <- c(buf, sprintf("- **Sample size**:%d records", nrow(df))) ## 连续变量 for (v in names(df_num)) { x <- df_num[[v]] x <- x[!is.na(x)] if (length(x) == 0) next buf <- c(buf, sprintf( "- **%s**: mean %.2f ± %.2f; median %.2f; range [%.2f, %.2f]; missing %.1f%%", v, mean(x), sd(x), median(x), min(x), max(x), 100 * (1 - length(x) / nrow(df)) )) } ## 分类变量 cat_cols <- sapply(df, function(z) is.factor(z) || is.character(z)) for (v in names(df)[cat_cols]) { tbl <- table(df[[v]], useNA = "ifany") lev_txt <- paste(sprintf("%s (%d, %.1f%%)", names(tbl), tbl, 100 * tbl / sum(tbl)), collapse = "、") buf <- c(buf, sprintf("- **%s**:%s", v, lev_txt)) } paste(buf, collapse = "\n") } ## quickgen_basic 的形参列表 default_funs <- c("n_obs", "mean", "sd", "min", "max") qib_type <- c( "分布图(dist)" = "dist", "密度图(density)" = "density", "散点图(scatter)" = "scatter", "曲面图(surface)" = "surface", "折线图(line)" = "line", "条形图(bar)" = "bar", "箱线图(box)" = "box" ) qib_check <- c( "直线(line)" = "line", "局部加权回归(loess)" = "loess", "抖动(jitter)" = "jitter", "插值(interpolate)" = "interpolate" ) qib_axes <- c( "翻转坐标轴(flip)" = "flip", "X轴对数变换(log_x)" = "log_x", "Y轴对数变换(log_y)" = "log_y", "Y轴缩放(scale_y)" = "scale_y", "密度(density)" = "density", "排序(sort)" = "sort" ) qib_theme <- c( "灰色主题(gray)" = "theme_gray", "黑白主题(bw)" = "theme_bw", "明亮主题(light)" = "theme_light", "暗黑主题(dark)" = "theme_dark", "极简主题(minimal)" = "theme_minimal", "经典主题(classic)" = "theme_classic" ) os_type <- Sys.info()["sysname"] if (os_type == "Windows") { fnt <- names(windowsFonts()) names(fnt) <- tools::toTitleCase(fnt) qib_base_family <- c("Theme default" = "", fnt) } else { qib_base_family <- c( "Theme default" = "", "Helvetica" = "Helvetica", "Serif" = "serif", "Sans" = "sans", "Mono" = "mono", "Courier" = "Courier", "Times" = "Times" ) } qib_labs <- c(i18n$t("title"), i18n$t("subtitle"), i18n$t("caption"), i18n$t("x"), i18n$t("y")) qib_add_labs <- function() { lab_list <- list() for (l in qib_labs) { inp <- input[[paste0("qib_labs_", l)]] if (!is.empty(inp)) lab_list[[l]] <- inp } lab_list } qgb_args <- as.list(formals(explore)) qib_args <- as.list(formals(visualize)) ## 收集用户输入的 reactive 列表 qgb_inputs <- reactive({ qgb_args$data_filter <- if (input$show_filter) input$data_filter else "" qgb_args$arr <- if (input$show_filter) input$data_arrange else "" qgb_args$rows <- if (input$show_filter) input$data_rows else "" qgb_args$dataset <- input$dataset for (i in r_drop(names(qgb_args))) { qgb_args[[i]] <- input[[paste0("qgb_", i)]] } qgb_args }) qgb_sum_args <- as.list(if (exists("summary.explore")) { formals(summary.explore) } else { formals(radiant.data:::summary.explore) }) qib_inputs <- reactive({ qib_args$data_filter <- if (isTRUE(input$show_filter)) input$data_filter else "" qib_args$arr <- if (isTRUE(input$show_filter)) input$data_arrange else "" qib_args$rows <- if (isTRUE(input$show_filter)) input$data_rows else "" qib_args$dataset <- input$dataset qib_args$shiny <- input$shiny qib_args$labs <- qib_add_labs() for (i in r_drop(names(qib_args), drop = c(i18n$t("dataset"), i18n$t("data_filter"), i18n$t("arr"), i18n$t("rows"), i18n$t("labs")))) { qib_args[[i]] <- input[[paste0("qib_", i)]] } qib_args }) ## list of function inputs selected by user qgb_sum_inputs <- reactive({ ## loop needed because reactive values don't allow single bracket indexing for (i in names(qgb_sum_args)) { qgb_sum_args[[i]] <- input[[paste0("qgb_", i)]] } qgb_sum_args }) ## UI-elements output$ui_qgb_vars <- renderUI({ vars <- varnames() req(available(vars)) selectizeInput( "qgb_vars", label = i18n$t("Numeric variable(s):"), choices = vars, selected = state_multiple("qgb_vars", vars, isolate(input$qgb_vars)), multiple = TRUE, options = list( placeholder = i18n$t("Select numeric variables"), plugins = list("remove_button", "drag_drop") ) ) }) output$ui_qgb_byvar <- renderUI({ withProgress(message = i18n$t("Acquiring variable information"), value = 1, { vars <- groupable_vars() }) req(available(vars)) if (any(vars %in% input$qgb_vars)) { vars <- base::setdiff(vars, input$qgb_vars) names(vars) <- varnames() %>% (function(x) x[match(vars, x)]) %>% names() } isolate({ ## if nothing is selected expl_byvar is also null if ("qgb_byvar" %in% names(input) && is.null(input$qgb_byvar)) { r_state$qgb_byvar <<- NULL } else { if (available(r_state$qgb_byvar) && all(r_state$qgb_byvar %in% vars)) { vars <- unique(c(r_state$qgb_byvar, vars)) names(vars) <- varnames() %>% (function(x) x[match(vars, x)]) %>% names() } } }) selectizeInput( "qgb_byvar", label = i18n$t("Group by:"), choices = vars, selected = state_multiple("qgb_byvar", vars, isolate(input$qgb_byvar)), multiple = TRUE, options = list( placeholder = i18n$t("Select group-by variable"), plugins = list("remove_button", "drag_drop") ) ) }) output$ui_qgb_fun <- renderUI({ r_funs <- getOption("radiant.functions") selected <- isolate( if (is.empty(input$qgb_fun)) default_funs else input$qgb_fun ) tagList( div( style = "margin-top: 5px; display: flex; gap: 3px; flex-wrap: wrap;", actionButton("qgb_select_all", i18n$t("Select All"), class = "btn-xs btn-primary", icon = icon("check-square")), actionButton("qgb_deselect_all", i18n$t("Deselect All"), class = "btn-xs btn-primary", icon = icon("square")), actionButton("qgb_invert_selection", i18n$t("Invert"), class = "btn-xs btn-primary", icon = icon("undo")) ), checkboxGroupInput( inputId = "qgb_fun", label = i18n$t("Apply function(s):"), choices = r_funs, selected = selected ) ) }) output$ui_qgb_top <- renderUI({ if (is.empty(input$qgb_vars)) { return() } top_var <- setNames( c("fun", "var", "byvar"), c(i18n$t("Function"), i18n$t("Variables"), i18n$t("Group by")) ) if (is.empty(input$qgb_byvar)) top_var <- top_var[1:2] selectizeInput( "qgb_top", label = i18n$t("Column header:"), choices = top_var, selected = state_single("qgb_top", top_var, isolate(input$qgb_top)), multiple = FALSE ) }) output$ui_qgb_name <- renderUI({ req(input$dataset) textInput("qgb_name", i18n$t("Store as:"), "", placeholder = i18n$t("Provide a table name")) }) output$ui_qgb_run <- renderUI({ ## updates when dataset changes req(input$dataset) actionButton("qgb_run", i18n$t("OneClick table generation"), width = "100%", icon = icon("play", verify_fa = FALSE), class = "btn-success") }) ## add a spinning refresh icon if the table needs to be (re)calculated run_refresh(qgb_args, "qgb", init = "vars", label = i18n$t("OneClick table generation"), relabel = i18n$t("Update table")) ####################################### # Visualize data ####################################### output$ui_qib_type <- renderUI({ selectInput( inputId = "qib_type", label = i18n$t("Plot-type:"), choices = qib_type, selected = state_single("qib_type", qib_type), multiple = FALSE ) }) output$ui_qib_nrobs <- renderUI({ req(input$qib_type == "scatter") nrobs <- nrow(.get_data()) choices <- c("1,000" = 1000, "5,000" = 5000, "10,000" = 10000, "All" = -1) %>% .[. < nrobs] selectInput( "qib_nrobs", i18n$t("Number of data points plotted:"), choices = choices, selected = state_single("qib_nrobs", choices, 1000) ) }) ## Y - variable output$ui_qib_yvar <- renderUI({ req(input$qib_type) vars <- varying_vars() req(available(vars)) vars <- vars["date" != .get_class()[vars]] if (input$qib_type %in% c("line", "bar", "scatter", "surface", "box")) { vars <- vars["character" != .get_class()[vars]] } if (input$qib_type %in% c("box", "scatter")) { vars <- vars["factor" != .get_class()[vars]] } selectizeInput( inputId = "qib_yvar", label = i18n$t("Y-variable:"), choices = vars, selected = state_multiple("qib_yvar", vars, isolate(input$qib_yvar)), multiple = TRUE, options = list( placeholder = i18n$t("Select Y variable(s)"), plugins = list("remove_button", "drag_drop") ) ) }) ## X - variable output$ui_qib_xvar <- renderUI({ req(input$qib_type) vars <- varying_vars() req(available(vars)) if (input$qib_type == "dist") vars <- vars["date" != .get_class()[vars]] if (input$qib_type == "density") vars <- vars["factor" != .get_class()[vars]] if (input$qib_type %in% c("box", "bar")) vars <- groupable_vars_nonum() selectizeInput( inputId = "qib_xvar", label = i18n$t("X-variable:"), choices = vars, selected = state_multiple("qib_xvar", vars, isolate(input$qib_xvar)), multiple = TRUE, options = list( placeholder = i18n$t("Select X variable(s)"), plugins = list("remove_button", "drag_drop") ) ) }) output$ui_qib_comby <- renderUI({ checkboxInput( "qib_comby", i18n$t("Combine Y-variables in one plot"), state_init("qib_comby", FALSE) ) }) output$ui_qib_combx <- renderUI({ checkboxInput( "qib_combx", i18n$t("Combine X-variables in one plot"), state_init("qib_combx", FALSE) ) }) observeEvent(length(input$qib_xvar) < 2, { updateCheckboxInput(session, "qib_combx", value = FALSE) }) observeEvent(length(input$qib_yvar) < 2, { updateCheckboxInput(session, "qib_comby", value = FALSE) }) observeEvent(input$qib_type, { if (input$qib_type %in% c("dist", "density")) { updateCheckboxInput(session, "qib_comby", value = FALSE) } else { updateCheckboxInput(session, "qib_combx", value = FALSE) } }) observeEvent(input$qib_check, { if (!"loess" %in% input$qib_check && input$qib_smooth != 1) { updateSliderInput(session, "qib_smooth", value = 1) } }) # output$ui_qib_facet_row <- renderUI({ # vars <- c("None" = ".", groupable_vars_nonum()) # selectizeInput( # "qib_facet_row", i18n$t("Facet row:"), vars, # selected = state_single("qib_facet_row", vars, init = "."), # multiple = FALSE # ) # }) # output$ui_qib_facet_col <- renderUI({ # vars <- c("None" = ".", groupable_vars_nonum()) # selectizeInput( # "qib_facet_col", i18n$t("Facet column:"), vars, # selected = state_single("qib_facet_col", vars, init = "."), # multiple = FALSE # ) # }) # output$ui_qib_color <- renderUI({ # req(input$qib_type) # if (input$qib_type == "line") { # vars <- c("None" = "none", groupable_vars()) # } else { # vars <- c("None" = "none", varnames()) # } # # if (isTRUE(input$qib_comby) && length(input$qib_yvar) > 1) vars <- c("None" = "none") # selectizeInput( # "qib_color", i18n$t("Color:"), vars, # multiple = FALSE, # selected = state_single("qib_color", vars, init = "none") # ) # }) # output$ui_qib_fill <- renderUI({ # vars <- c("None" = "none", groupable_vars()) # if (isTRUE(input$qib_combx) && length(input$qib_xvar) > 1) vars <- vars[1] # selectizeInput( # "qib_fill", i18n$t("Fill:"), vars, # multiple = FALSE, # selected = state_single("qib_fill", vars, init = "none") # ) # }) # output$ui_qib_size <- renderUI({ # req(input$qib_type) # isNum <- .get_class() %in% c("integer", "numeric", "ts") # vars <- c("None" = "none", varnames()[isNum]) # if (isTRUE(input$qib_comby) && length(input$qib_yvar) > 1) vars <- c("None" = "none") # selectizeInput( # "qib_size", i18n$t("Size:"), vars, # multiple = FALSE, # selected = state_single("qib_size", vars, init = "none") # ) # }) output$ui_qib_axes <- renderUI({ req(input$qib_type) ind <- 1 if (input$qib_type %in% c("line", "scatter", "surface")) { ind <- 1:3 } else if (input$qib_type == "dist") { ind <- c(1:2, 5) } else if (input$qib_type == "density") { ind <- 1:2 } else if (input$qib_type %in% c("bar", "box")) { ind <- c(1, 3) } if (!is.empty(input$qib_facet_row, ".") || !is.empty(input$qib_facet_col, ".")) ind <- c(ind, 4) if (input$qib_type == "bar") ind <- c(ind, 6) checkboxGroupInput( "qib_axes", NULL, qib_axes[ind], selected = state_group("qib_axes", ""), inline = TRUE ) }) output$ui_qib_check <- renderUI({ req(input$qib_type) if (input$qib_type == "scatter") { ind <- 1:3 } else if (input$qib_type == "box") { ind <- 3 } else if (input$qib_type == "surface") { ind <- 4 } else { ind <- c() } if (!input$qib_type %in% c("scatter", "box")) { r_state$qib_check <<- gsub("jitter", "", r_state$qib_check) } if (input$qib_type != "scatter") { r_state$qib_check <<- gsub("line", "", r_state$qib_check) r_state$qib_check <<- gsub("loess", "", r_state$qib_check) } checkboxGroupInput( "qib_check", NULL, qib_check[ind], selected = state_group("qib_check", ""), inline = TRUE ) }) output$ui_qib_run <- renderUI({ req(input$dataset) actionButton("qib_run", i18n$t("OneClick chart generation"), width = "100%", icon = icon("play", verify_fa = FALSE), class = "btn-success") }) # output$ui_qib_labs <- renderUI({ # ## updates when dataset changes # req(input$dataset) # wellPanel( # textAreaInput("qib_labs_title", NULL, "", placeholder = i18n$t("Title"), rows = 1), # textAreaInput("qib_labs_subtitle", NULL, "", placeholder = i18n$t("Subtitle"), rows = 1), # textAreaInput("qib_labs_caption", NULL, "", placeholder = i18n$t("Caption"), rows = 1), # textAreaInput("qib_labs_y", NULL, "", placeholder = i18n$t("Y-label"), rows = 1), # textAreaInput("qib_labs_x", NULL, "", placeholder = i18n$t("X-label"), rows = 1) # ) # }) output$ui_qib_colors <- renderUI({ tagList( conditionalPanel( condition = "input.qib_type == 'bar' || input.qib_type == 'dist' || input.qib_type == 'box' || input.qib_type == 'density'", selectInput( "qib_fillcol", i18n$t("Fill color:"), choices = colors(), selected = state_single("qib_fillcol", colors(), "blue") ) ), conditionalPanel( condition = "input.qib_type == 'dist' || input.qib_type == 'density' || input.qib_type == 'box' || input.qib_type == 'scatter' || input.qib_type == 'line'", selectInput( "qib_linecol", i18n$t("Line color:"), choices = colors(), selected = state_single("qib_linecol", colors(), "black") ) ), conditionalPanel( condition = "input.qib_type == 'scatter' || input.qib_type == 'line' || input.qib_type == 'box'", selectInput( "qib_pointcol", i18n$t("Point color:"), choices = colors(), selected = state_single("qib_pointcol", colors(), "black") ) ) ) }) run_refresh( qib_args, "qib", init = c("xvar", "yvar"), label = i18n$t("OneClick chart generation"), relabel = i18n$t("Update plot"), inputs = c("labs_title", "labs_subtitle", "labs_caption", "labs_y", "labs_x") ) output$ui_quickgen_basic <- renderUI({ tagList( wellPanel( uiOutput("ui_qgb_run") ), checkboxInput("qgb_details_table", i18n$t("Table"), state_init("qgb_details_table", FALSE)), conditionalPanel( "input.qgb_details_table == true", wellPanel( uiOutput("ui_qgb_vars"), uiOutput("ui_qgb_byvar"), uiOutput("ui_qgb_top"), # returnTextAreaInput("qgb_tab_slice", # label = i18n$t("Table slice (rows):"), # rows = 1, # value = state_init("qgb_tab_slice"), # placeholder = i18n$t("e.g., 1:5 and press return") # ), uiOutput("ui_qgb_fun"), numericInput("qgb_dec", label = i18n$t("Decimals:"), value = state_init("qgb_dec", 3), min = 0), tags$table( tags$td(uiOutput("ui_qgb_name")), tags$td(actionButton("qgb_store", i18n$t("Store"), icon = icon("plus", verify_fa = FALSE)), class = "top") ) ), ), wellPanel( uiOutput("ui_qib_run") ), checkboxInput("qib_details_chart", i18n$t("Chart"), state_init("qib_details_chart", FALSE)), conditionalPanel( "input.qib_details_chart == true", wellPanel( uiOutput("ui_qib_type"), conditionalPanel( "input.qib_type == 'scatter'", uiOutput("ui_qib_nrobs") ), conditionalPanel( condition = "input.qib_type != 'dist' && input.qib_type != 'density'", uiOutput("ui_qib_yvar"), conditionalPanel( "input.qib_yvar != undefined && input.qib_yvar != null && input.qib_yvar.length > 1", uiOutput("ui_qib_comby") ) ), uiOutput("ui_qib_xvar"), conditionalPanel( "input.qib_type == 'dist' || input.qib_type == 'density'", conditionalPanel( "input.qib_xvar != undefined && input.qib_xvar != null && input.qib_xvar.length > 1", uiOutput("ui_qib_combx") ) ), # uiOutput("ui_qib_facet_row"), # uiOutput("ui_qib_facet_col"), # conditionalPanel( # condition = "input.qib_type == 'bar' || # input.qib_type == 'dist' || # input.qib_type == 'density' || # input.qib_type == 'surface'", # uiOutput("ui_qib_fill") # ), # conditionalPanel( # condition = "input.qib_type == 'scatter' || # input.qib_type == 'line' || # input.qib_type == 'box'", # uiOutput("ui_qib_color") # ), # conditionalPanel( # condition = "input.qib_type == 'scatter'", # uiOutput("ui_qib_size") # ), conditionalPanel( condition = "input.qib_type == 'bar' || input.qib_type == 'scatter' || input.qib_type == 'line'", selectInput( "qib_fun", i18n$t("Function:"), choices = getOption("radiant.functions"), selected = state_single("qib_fun", getOption("radiant.functions"), "mean") ) ), # conditionalPanel( # condition = "input.qib_type == 'scatter' || # input.qib_type == 'line' || # input.qib_type == 'surface' || # input.qib_type == 'box'", # uiOutput("ui_qib_check") # ), # uiOutput("ui_qib_axes"), conditionalPanel( condition = "input.qib_type == 'dist'", sliderInput( "qib_bins", label = i18n$t("Number of bins:"), value = state_init("qib_bins", 10), min = 2, max = 50, step = 1 ) ), conditionalPanel( "input.qib_type == 'density' || input.qib_type == 'dist' && (input.qib_axes && input.qib_axes.indexOf('density')) >= 0 || (input.qib_type == 'scatter' && (input.qib_check && input.qib_check.indexOf('loess') >= 0))", sliderInput( "qib_smooth", label = i18n$t("Smooth:"), value = state_init("qib_smooth", 1), min = 0.1, max = 3, step = .1 ) ) ) ), # checkboxInput("qib_details_labels", i18n$t("Labels"), state_init("qib_details_labels", FALSE)), # conditionalPanel( # "input.qib_details_labels == true", # uiOutput("ui_qib_labs") # ), checkboxInput("qib_details_style", i18n$t("Style"), state_init("qib_details_style", FALSE)), conditionalPanel( "input.qib_details_style == true", wellPanel( selectInput( "qib_theme", i18n$t("Plot theme:"), choices = qib_theme, selected = state_single("qib_theme", qib_theme, "theme_gray") ), numericInput( "qib_base_size", i18n$t("Base font size:"), value = state_init("qib_base_size", 11) ), selectInput( "qib_base_family", i18n$t("Font family:"), choices = qib_base_family, selected = state_single("qib_base_family", qib_base_family, "helvetica") ), uiOutput("ui_qib_colors"), sliderInput( "qib_alpha", label = i18n$t("Opacity:"), value = state_init("qib_alpha", .5), min = 0, max = 1, step = .01 ), tags$table( tags$td( numericInput( "qib_plot_height", label = i18n$t("Plot height:"), min = 100, max = 2000, step = 50, value = state_init("qib_plot_height", r_info[["plot_height"]]), width = "117px" ) ), tags$td( numericInput( "qib_plot_width", label = i18n$t("Plot width:"), min = 100, max = 2000, step = 50, value = state_init("qib_plot_width", r_info[["plot_width"]]), width = "117px" ), width = "100%" ) ) ) ), help_and_report( modal_title = i18n$t("Generate descriptive statistics with one click"), fun_name = "quickgen_basic", help_file = inclMD(file.path(getOption("radiant.path.quickgen"), "app/tools/help/quickgen_basic.md")), lic = "by-sa" ) ) }) qib_plot_width <- reactive({ if (is.empty(input$qib_plot_width)) r_info[["plot_width"]] else input$qib_plot_width }) qib_plot_height <- eventReactive( { input$qib_run input$qib_plot_height input$qib_plot_width }, { if (is.empty(input$qib_plot_height)) { r_info[["plot_height"]] } else { lx <- ifelse(not_available(input$qib_xvar) || isTRUE(input$qib_combx), 1, length(input$qib_xvar)) ly <- ifelse(not_available(input$qib_yvar) || input$qib_type %in% c("dist", "density") || isTRUE(input$qib_comby), 1, length(input$qib_yvar)) nr <- lx * ly if (nr > 1) { (input$qib_plot_height / 2) * ceiling(nr / 2) } else { input$qib_plot_height } } } ) .quickgen <- eventReactive(input$qgb_run, { if (not_available(input$qgb_vars) || is.null(input$qgb_top)) { return() } else if (!is.empty(input$qgb_byvar) && not_available(input$qgb_byvar)) { return() } else if (available(input$qgb_byvar) && any(input$qgb_byvar %in% input$qgb_vars)) { return() } qgbi <- qgb_inputs() qgbi$envir <- r_data sshhr(do.call(explore, qgbi)) }) observeEvent(input$qgb_search_columns, { r_state$qgb_search_columns <<- input$qgb_search_columns }) observeEvent(input$qgb_state, { r_state$qgb_state <<- input$qgb_state }) qgb_reset <- function(var, ncol) { if (!identical(r_state[[var]], input[[var]])) { r_state[[var]] <<- input[[var]] r_state$qgb_state <<- list() r_state$qgb_search_columns <<- rep("", ncol) } } output$qgb_tab <- DT::renderDataTable({ input$qgb_run withProgress(message = i18n$t("Generating explore table"), value = 1, { isolate({ qgb <- .quickgen() req(!is.null(qgb)) qgb$shiny <- TRUE ## resetting DT when changes occur nc <- ncol(qgb$tab) qgb_reset("qgb_vars", nc) qgb_reset("qgb_byvar", nc) qgb_reset("qgb_fun", nc) if (!is.null(r_state$qgb_top) && !is.null(input$qgb_top) && !identical(r_state$qgb_top, input$qgb_top)) { r_state$qgb_top <<- input$qgb_top r_state$qgb_state <<- list() r_state$qgb_search_columns <<- rep("", nc) } searchCols <- lapply(r_state$qgb_search_columns, function(x) list(search = x)) order <- r_state$qgb_state$order pageLength <- r_state$qgb_state$length }) caption <- if (is.empty(input$qgb_tab_slice)) NULL else glue("Table slice {input$expl_tab_slice} will be applied on Download, Store, or Report") dtab( qgb, dec = input$qgb_dec, searchCols = searchCols, order = order, pageLength = pageLength, caption = caption ) }) }) dl_qgb_tab <- function(path) { dat <- try(.quickgen(), silent = TRUE) if (inherits(dat, "try-error") || is.null(dat)) { write.csv(tibble::tibble("Data" = "[Empty]"), path, row.names = FALSE) return() } rows <- input$qgb_rows_all tmp <- if (is.null(rows)) dat$tab else dat$tab[rows, , drop = FALSE] if (is.null(tmp) || nrow(tmp) == 0) { write.csv(tibble::tibble("Data" = "[Empty]"), path, row.names = FALSE) } else { write.csv(tmp, path, row.names = FALSE) } } output$qib_chart <- renderPlot( { req(input$qib_type) if (not_available(input$qib_xvar)) { if (!input$qib_type %in% c("box", "line")) { return( plot( x = 1, type = "n", main = " ", axes = FALSE, xlab = "", ylab = "", cex.main = .9 ) ) } } .qib_chart() %>% (function(x) { if (is.empty(x) || is.character(x)) { plot(x = 1, type = "n", main = paste0("\n", x), axes = FALSE, xlab = "", ylab = "", cex.main = .9) } else if (length(x) > 0) { print(x) } }) }, width = qib_plot_width, height = qib_plot_height, res = 96 ) .qib_chart <- eventReactive(input$qib_run, { req(input$qib_type) if (input$qib_type == "scatter") req(input$qib_nrobs) ## need dependency on .. req(input$qib_plot_height && input$qib_plot_width) if (not_available(input$qib_xvar) && !input$qib_type %in% c("box", "line")) { return() } else if (input$qib_type %in% c("scatter", "line", "box", "bar", "surface") && not_available(input$qib_yvar)) { return(i18n$t("No Y-variable provided for a plot that requires one")) } else if (input$qib_type == "box" && !all(input$qib_xvar %in% groupable_vars())) { return() } ## waiting for comby and/or combx to be updated if (input$qib_type %in% c("dist", "density")) { if (isTRUE(input$qib_comby)) { return() } if (length(input$qib_xvar) > 1 && is.null(input$qib_combx)) { return() } } else { if (isTRUE(input$qib_combx)) { return() } if (length(input$qib_yvar) > 1 && is.null(input$qib_comby)) { return() } } #req(!is.null(input$qib_color) || !is.null(input$qib_fill)) qibi <- qib_inputs() qibi$dataset <- input$dataset qibi$shiny <- TRUE qibi$envir <- r_data qibi$color <- "none" qibi$fill <- "none" qibi$facet_row <- "." qibi$facet_col <- "." withProgress(message = i18n$t("Making plot"), value = 1, { do.call(visualize, qibi) }) }) observeEvent(input$qgb_store, { req(input$qgb_name) dat <- .quickgen() if (is.null(dat)) { return() } dataset <- fix_names(input$qgb_name) if (input$qgb_name != dataset) { updateTextInput(session, inputId = "qgb_name", value = dataset) } rows <- input$qgb_rows_all tmp <- if (is.null(rows)) dat$tab else dat$tab[rows, , drop = FALSE] r_data[[dataset]] <- tmp register(dataset) updateSelectInput(session, "dataset", selected = input$dataset) showModal( modalDialog( title = i18n$t("Data Stored"), span( i18n$t("Dataset was successfully added to the datasets dropdown. Add code to Report > Rmd or Report > R to (re)create the results by clicking the report icon on the bottom left of your screen.") ), footer = modalButton(i18n$t("OK")), size = "m", easyClose = TRUE ) ) }) qgb_report <- function() { ## get the state of the dt table ts <- dt_state("qgb_tab") xcmd <- "# summary(result)\ndtab(result" if (!is.empty(input$qgb_dec, 3)) { xcmd <- paste0(xcmd, ", dec = ", input$qgb_dec) } if (!is.empty(r_state$qgb_state$length, 10)) { xcmd <- paste0(xcmd, ", pageLength = ", r_state$qgb_state$length) } xcmd <- paste0(xcmd, ", caption = \"\") %>% render()") if (!is.empty(input$qgb_name)) { dataset <- fix_names(input$qgb_name) if (input$qgb_name != dataset) { updateTextInput(session, inputId = "qgb_name", value = dataset) } xcmd <- paste0(xcmd, "\n", dataset, " <- result$tab\nregister(\"", dataset, "\")") } inp_main <- clean_args(qgb_inputs(), qgb_args) if (ts$tabsort != "") inp_main <- c(inp_main, tabsort = ts$tabsort) if (ts$tabfilt != "") inp_main <- c(inp_main, tabfilt = ts$tabfilt) if (is.empty(inp_main$rows)) { inp_main$rows <- NULL } if (is.empty(input$qgb_tab_slice)) { inp_main <- c(inp_main, nr = Inf) } else { inp_main$tabslice <- input$qgb_tab_slice } inp_out <- list(clean_args(qgb_sum_inputs(), qgb_sum_args[-1])) update_report( inp_main = inp_main, fun_name = "qgb", inp_out = inp_out, outputs = c(), figs = FALSE, xcmd = xcmd ) } qib_report <- function() { ## resetting hidden elements to default values vi <- qib_inputs() if (input$qib_type != "dist") { vi$bins <- qib_args$bins } if (input$qib_type %in% c("dist", "density")) { vi$yvar <- qib_args$yvar } if (!input$qib_type %in% c("density", "scatter", "dist") || !("loess" %in% input$qib_check || "density" %in% input$qib_axes || input$qib_type == "density")) { vi$smooth <- qib_args$smooth } if (!input$qib_type %in% c("scatter", "box") && "jitter" %in% input$qib_check) { vi$check <- base::setdiff(vi$check, "jitter") } if (input$qib_type != "scatter") { vi$size <- "none" vi$nrobs <- NULL } else { vi$nrobs <- as_integer(vi$nrobs) } if (!input$qib_type %in% c("scatter", "line", "box")) { vi$color <- NULL } if (!input$qib_type %in% c("bar", "dist", "density", "surface")) { vi$fill <- NULL } if (!input$qib_type %in% c("bar", "dist", "box", "density")) { vi$fillcol <- "blue" } if (!input$qib_type %in% c("dist", "density", "box", "scatter", "line")) { vi$linecol <- "black" } if (!input$qib_type %in% c("box", "scatter", "line")) { vi$pointcol <- "black" } if (!input$qib_type %in% c("bar", "line", "scatter")) { vi$fun <- "mean" } if (is.empty(input$data_rows)) { vi$rows <- NULL } inp_main <- c(clean_args(vi, qib_args), custom = FALSE) update_report( inp_main = inp_main, fun_name = "qib_chart", outputs = character(0), pre_cmd = "", figs = TRUE, fig.width = qib_plot_width(), fig.height = qib_plot_height() ) } download_handler( id = "dl_qgb_tab", fun = dl_qgb_tab, fn = function() paste0(input$dataset, "_tab"), type = "csv" ) download_handler( id = "dlp_qib_chart", fun = download_handler_plot, fn = function() paste0(input$dataset, "_chart"), type = "png", caption = i18n$t("Save visualize plot"), plot = .qib_chart, width = qib_plot_width, height = qib_plot_height ) observeEvent(input$qgb_report, { r_info[["latest_screenshot"]] <- NULL qgb_report() }) observeEvent(input$qgb_screenshot, { r_info[["latest_screenshot"]] <- NULL radiant_screenshot_modal("modal_qgb_screenshot") }) observeEvent(input$modal_qgb_screenshot, { qgb_report() removeModal() }) observeEvent(input$qib_report, { r_info[["latest_screenshot"]] <- NULL qib_report() }) observeEvent(input$qib_screenshot, { r_info[["latest_screenshot"]] <- NULL radiant_screenshot_modal("modal_qib_screenshot") }) observeEvent(input$modal_qib_screenshot, { qib_report() removeModal() }) # 全选功能 observeEvent(input$qgb_select_all, { r_funs <- getOption("radiant.functions") if (!is.null(r_funs)) { updateCheckboxGroupInput(session, "qgb_fun", selected = r_funs) } }) # 全不选功能 observeEvent(input$qgb_deselect_all, { updateCheckboxGroupInput(session, "qgb_fun", selected = character(0)) }) # 反选功能 observeEvent(input$qgb_invert_selection, { current <- input$qgb_fun %||% character(0) r_funs <- getOption("radiant.functions") if (!is.null(r_funs)) { new_selection <- setdiff(r_funs, current) updateCheckboxGroupInput(session, "qgb_fun", selected = new_selection) } }) output$quickgen_basic <- renderUI({ stat_tab_panel( menu = i18n$t("Oneclick generation > Generate descriptive statistics"), tool = i18n$t("Generate descriptive statistics with one click"), tool_ui = "ui_quickgen_basic", output_panels = tagList( tabPanel( title = i18n$t("Table"), download_link("dl_qgb_tab"),br(), DT::dataTableOutput("qgb_tab"), tags$hr(), htmlOutput("qgb_desc_text", inline = FALSE) ), tabPanel( title = i18n$t("Chart"), download_link("dlp_qib_chart"), br(), plotOutput("qib_chart", width = "100%", height = "auto"), tags$hr(), htmlOutput("qib_desc_text", inline = FALSE) ) ) ) }) ## ---------- 表格的描述文字 ---------- output$qgb_desc_text <- renderUI({ dat <- tryCatch(.quickgen(), error = function(e) NULL) txt <- if (!is.null(dat) && !is.null(dat$tab)) { make_desc_text(dat$tab) } else { " " } HTML(markdown::markdownToHTML(text = txt, fragment.only = TRUE)) }) ## ---------- 图表的描述文字 ---------- output$qib_desc_text <- renderUI({ df <- tryCatch({ qibi <- qib_inputs() qibi$envir <- r_data qibi$dataset <- input$dataset qibi$shiny <- TRUE res <- do.call(visualize, qibi) res$data }, error = function(e) NULL) txt <- if (!is.null(df)) make_desc_text(df) else " " HTML(markdown::markdownToHTML(text = txt, fragment.only = TRUE)) })