Skip to content

R
Radiant
Commit 5653482b authored by wuzekai's avatar wuzekai
Browse files
Options

Initial commit

parent d3861e30
Show whitespace changes
Inline Side-by-side
Showing with 0 additions and 998 deletions
radiant.quickgen/.Rproj.user/F437B50E/pcs/files-pane.pper deleted 100644 → 0
View file @ d3861e30
{
"sortOrder": [
{
"columnIndex": 2,
"ascending": true
}
],
"path": "D:/R"
}
\ No newline at end of file
radiant.quickgen/.Rproj.user/F437B50E/pcs/source-pane.pper deleted 100644 → 0
View file @ d3861e30
{
"activeTab": 2
}
\ No newline at end of file
radiant.quickgen/.Rproj.user/F437B50E/pcs/windowlayoutstate.pper deleted 100644 → 0
View file @ d3861e30
{
"left": {
"splitterpos": 312,
"topwindowstate": "NORMAL",
"panelheight": 826,
"windowheight": 864
},
"right": {
"splitterpos": 518,
"topwindowstate": "NORMAL",
"panelheight": 826,
"windowheight": 864
}
}
\ No newline at end of file
radiant.quickgen/.Rproj.user/F437B50E/pcs/workbench-pane.pper deleted 100644 → 0
View file @ d3861e30
{
"TabSet1": 0,
"TabSet2": 0,
"TabZoom": {}
}
\ No newline at end of file
radiant.quickgen/.Rproj.user/F437B50E/saved_source_markers deleted 100644 → 0
View file @ d3861e30
{"active_set":"","sets":[]}
\ No newline at end of file
radiant.quickgen/.Rproj.user/F437B50E/sources/per/t/37A6706B deleted 100644 → 0
View file @ d3861e30
{
"id": "37A6706B",
"path": "D:/R/radiant.quickgen/R/quickgen_basic.R",
"project_path": "R/quickgen_basic.R",
"type": "r_source",
"hash": "2601472834",
"contents": "",
"dirty": false,
"created": 1756092822912.0,
"source_on_save": false,
"relative_order": 2,
"properties": {
"source_window_id": "",
"Source": "Source",
"cursorPosition": "18,40",
"scrollLine": "0"
},
"folds": "",
"lastKnownWriteTime": 1756087288,
"encoding": "UTF-8",
"collab_server": "",
"source_window": "",
"last_content_update": 1756087288,
"read_only": false,
"read_only_alternatives": []
}
\ No newline at end of file
radiant.quickgen/.Rproj.user/F437B50E/sources/per/t/37A6706B-contents deleted 100644 → 0
View file @ d3861e30
explore <- function(dataset, vars = "", byvar = "", fun = c("mean", "sd"),
top = "fun", tabfilt = "", tabsort = "", tabslice = "",
nr = Inf, data_filter = "", arr = "", rows = NULL,
envir = parent.frame()) {
tvars <- vars
if (!is.empty(byvar)) tvars <- unique(c(tvars, byvar))
df_name <- if (is_string(dataset)) dataset else deparse(substitute(dataset))
dataset <- get_data(dataset, tvars, filt = data_filter, arr = arr, rows = rows, na.rm = FALSE, envir = envir)
rm(tvars)
## in case : was used
vars <- base::setdiff(colnames(dataset), byvar)
## converting data as needed for summarization
dc <- get_class(dataset)
fixer <- function(x, fun = as_integer) {
if (is.character(x) || is.Date(x)) {
x <- rep(NA, length(x))
} else if (is.factor(x)) {
x_num <- sshhr(as.integer(as.character(x)))
if (length(na.omit(x_num)) == 0) {
x <- fun(x)
} else {
x <- x_num
}
}
x
}
fixer_first <- function(x) {
x <- fixer(x, function(x) as_integer(x == levels(x)[1]))
}
mean <- function(x, na.rm = TRUE) sshhr(base::mean(fixer_first(x), na.rm = na.rm))
sum <- function(x, na.rm = TRUE) sshhr(base::sum(fixer_first(x), na.rm = na.rm))
var <- function(x, na.rm = TRUE) sshhr(stats::var(fixer_first(x), na.rm = na.rm))
sd <- function(x, na.rm = TRUE) sshhr(stats::sd(fixer_first(x), na.rm = na.rm))
se <- function(x, na.rm = TRUE) sshhr(radiant.data::se(fixer_first(x), na.rm = na.rm))
me <- function(x, na.rm = TRUE) sshhr(radiant.data::me(fixer_first(x), na.rm = na.rm))
cv <- function(x, na.rm = TRUE) sshhr(radiant.data::cv(fixer_first(x), na.rm = na.rm))
prop <- function(x, na.rm = TRUE) sshhr(radiant.data::prop(fixer_first(x), na.rm = na.rm))
varprop <- function(x, na.rm = TRUE) sshhr(radiant.data::varprop(fixer_first(x), na.rm = na.rm))
sdprop <- function(x, na.rm = TRUE) sshhr(radiant.data::sdprop(fixer_first(x), na.rm = na.rm))
seprop <- function(x, na.rm = TRUE) sshhr(radiant.data::seprop(fixer_first(x), na.rm = na.rm))
meprop <- function(x, na.rm = TRUE) sshhr(radiant.data::meprop(fixer_first(x), na.rm = na.rm))
varpop <- function(x, na.rm = TRUE) sshhr(radiant.data::varpop(fixer_first(x), na.rm = na.rm))
sdpop <- function(x, na.rm = TRUE) sshhr(radiant.data::sdpop(fixer_first(x), na.rm = na.rm))
median <- function(x, na.rm = TRUE) sshhr(stats::median(fixer(x), na.rm = na.rm))
min <- function(x, na.rm = TRUE) sshhr(base::min(fixer(x), na.rm = na.rm))
max <- function(x, na.rm = TRUE) sshhr(base::max(fixer(x), na.rm = na.rm))
p01 <- function(x, na.rm = TRUE) sshhr(radiant.data::p01(fixer(x), na.rm = na.rm))
p025 <- function(x, na.rm = TRUE) sshhr(radiant.data::p025(fixer(x), na.rm = na.rm))
p05 <- function(x, na.rm = TRUE) sshhr(radiant.data::p05(fixer(x), na.rm = na.rm))
p10 <- function(x, na.rm = TRUE) sshhr(radiant.data::p10(fixer(x), na.rm = na.rm))
p25 <- function(x, na.rm = TRUE) sshhr(radiant.data::p25(fixer(x), na.rm = na.rm))
p75 <- function(x, na.rm = TRUE) sshhr(radiant.data::p75(fixer(x), na.rm = na.rm))
p90 <- function(x, na.rm = TRUE) sshhr(radiant.data::p90(fixer(x), na.rm = na.rm))
p95 <- function(x, na.rm = TRUE) sshhr(radiant.data::p95(fixer(x), na.rm = na.rm))
p975 <- function(x, na.rm = TRUE) sshhr(radiant.data::p975(fixer(x), na.rm = na.rm))
p99 <- function(x, na.rm = TRUE) sshhr(radiant.data::p99(fixer(x), na.rm = na.rm))
skew <- function(x, na.rm = TRUE) sshhr(radiant.data::skew(fixer(x), na.rm = na.rm))
kurtosi <- function(x, na.rm = TRUE) sshhr(radiant.data::kurtosi(fixer(x), na.rm = na.rm))
isLogNum <- "logical" == dc & names(dc) %in% base::setdiff(vars, byvar)
if (sum(isLogNum) > 0) {
dataset[, isLogNum] <- select(dataset, which(isLogNum)) %>%
mutate_all(as.integer)
dc[isLogNum] <- "integer"
}
if (is.empty(byvar)) {
byvar <- c()
tab <- summarise_all(dataset, fun, na.rm = TRUE)
} else {
## convert categorical variables to factors if needed
## needed to deal with empty/missing values
dataset[, byvar] <- select_at(dataset, .vars = byvar) %>%
mutate_all(~ empty_level(.))
tab <- dataset %>%
group_by_at(.vars = byvar) %>%
summarise_all(fun, na.rm = TRUE)
}
## adjust column names
if (length(vars) == 1 || length(fun) == 1) {
rng <- (length(byvar) + 1):ncol(tab)
colnames(tab)[rng] <- paste0(vars, "_", fun)
rm(rng)
}
## setup regular expression to split variable/function column appropriately
rex <- paste0("(.*?)_", glue('({glue_collapse(fun, "$|")}$)'))
## useful answer and comments: http://stackoverflow.com/a/27880388/1974918
tab <- gather(tab, "variable", "value", !!-(seq_along(byvar))) %>%
extract(variable, into = c("variable", "fun"), regex = rex) %>%
mutate(fun = factor(fun, levels = !!fun), variable = factor(variable, levels = vars)) %>%
# mutate(variable = paste0(variable, " {", dc[variable], "}")) %>%
spread("fun", "value")
## flip the table if needed
if (top != "fun") {
tab <- list(tab = tab, byvar = byvar, fun = fun) %>%
flip(top)
}
nrow_tab <- nrow(tab)
## filtering the table if desired from Report > Rmd
if (!is.empty(tabfilt)) {
tab <- filter_data(tab, tabfilt)
}
## sorting the table if desired from Report > Rmd
if (!identical(tabsort, "")) {
tabsort <- gsub(",", ";", tabsort)
tab <- tab %>% arrange(!!!rlang::parse_exprs(tabsort))
}
## ensure factors ordered as in the (sorted) table
if (!is.empty(byvar) && top != "byvar") {
for (i in byvar) tab[[i]] <- tab[[i]] %>% (function(x) factor(x, levels = unique(x)))
rm(i)
}
## frequencies converted to doubles during gather/spread above
check_int <- function(x) {
if (is.double(x) && length(na.omit(x)) > 0) {
x_int <- sshhr(as.integer(round(x, .Machine$double.rounding)))
if (isTRUE(all.equal(x, x_int, check.attributes = FALSE))) x_int else x
} else {
x
}
}
tab <- ungroup(tab) %>% mutate_all(check_int)
## slicing the table if desired
if (!is.empty(tabslice)) {
tab <- tab %>%
slice_data(tabslice) %>%
droplevels()
}
## convert to data.frame to maintain attributes
tab <- as.data.frame(tab, stringsAsFactors = FALSE)
attr(tab, "radiant_nrow") <- nrow_tab
if (!isTRUE(is.infinite(nr))) {
ind <- if (nr > nrow(tab)) 1:nrow(tab) else 1:nr
tab <- tab[ind, , drop = FALSE]
rm(ind)
}
list(
tab = tab,
df_name = df_name,
vars = vars,
byvar = byvar,
fun = fun,
top = top,
tabfilt = tabfilt,
tabsort = tabsort,
tabslice = tabslice,
nr = nr,
data_filter = data_filter,
arr = arr,
rows = rows
) %>% add_class("explore")
}
summary.explore <- function(object, dec = 3, ...) {
cat("Explore\n")
cat("Data :", object$df_name, "\n")
if (!is.empty(object$data_filter)) {
cat("Filter :", gsub("\\n", "", object$data_filter), "\n")
}
if (!is.empty(object$arr)) {
cat("Arrange :", gsub("\\n", "", object$arr), "\n")
}
if (!is.empty(object$rows)) {
cat("Slice :", gsub("\\n", "", object$rows), "\n")
}
if (!is.empty(object$tabfilt)) {
cat("Table filter:", object$tabfilt, "\n")
}
if (!is.empty(object$tabsort[1])) {
cat("Table sorted:", paste0(object$tabsort, collapse = ", "), "\n")
}
if (!is.empty(object$tabslice)) {
cat("Table slice :", object$tabslice, "\n")
}
nr <- attr(object$tab, "radiant_nrow")
if (!isTRUE(is.infinite(nr)) && !isTRUE(is.infinite(object$nr)) && object$nr < nr) {
cat(paste0("Rows shown : ", object$nr, " (out of ", nr, ")\n"))
}
if (!is.empty(object$byvar[1])) {
cat("Grouped by :", object$byvar, "\n")
}
cat("Functions :", paste0(object$fun, collapse = ", "), "\n")
cat("Top :", c("fun" = "Function", "var" = "Variables", "byvar" = "Group by")[object$top], "\n")
cat("\n")
format_df(object$tab, dec = dec, mark = ",") %>%
print(row.names = FALSE)
invisible()
}
store.explore <- function(dataset, object, name, ...) {
if (missing(name)) {
object$tab
} else {
stop(
paste0(
"This function is deprecated. Use the code below instead:\n\n",
name, " <- ", deparse(substitute(object)), "$tab\nregister(\"",
name, ")"
),
call. = FALSE
)
}
}
flip <- function(expl, top = "fun") {
cvars <- expl$byvar %>%
(function(x) if (is.empty(x[1])) character(0) else x)
if (top[1] == "var") {
expl$tab %<>% gather(".function", "value", !!-(1:(length(cvars) + 1))) %>%
spread("variable", "value")
expl$tab[[".function"]] %<>% factor(., levels = expl$fun)
} else if (top[1] == "byvar" && length(cvars) > 0) {
expl$tab %<>% gather(".function", "value", !!-(1:(length(cvars) + 1))) %>%
spread(!!cvars[1], "value")
expl$tab[[".function"]] %<>% factor(., levels = expl$fun)
## ensure we don't have invalid column names
colnames(expl$tab) <- fix_names(colnames(expl$tab))
}
expl$tab
}
dtab.explore <- function(object, dec = 3, searchCols = NULL,
order = NULL, pageLength = NULL,
caption = NULL, ...) {
style <- if (exists("bslib_current_version") && "4" %in% bslib_current_version()) "bootstrap4" else "bootstrap"
tab <- object$tab
cn_all <- colnames(tab)
cn_num <- cn_all[sapply(tab, is.numeric)]
cn_cat <- cn_all[-which(cn_all %in% cn_num)]
isInt <- sapply(tab, is.integer)
isDbl <- sapply(tab, is_double)
dec <- ifelse(is.empty(dec) || dec < 0, 3, round(dec, 0))
top <- c("fun" = "Function", "var" = "Variables", "byvar" = paste0("Group by: ", object$byvar[1]))[object$top]
sketch <- shiny::withTags(
table(
thead(
tr(
th(" ", colspan = length(cn_cat)),
lapply(top, th, colspan = length(cn_num), class = "text-center")
),
tr(lapply(cn_all, th))
)
)
)
if (!is.empty(caption)) {
## from https://github.com/rstudio/DT/issues/630#issuecomment-461191378
caption <- shiny::tags$caption(style = "caption-side: bottom; text-align: left; font-size:100%;", caption)
}
## for display options see https://datatables.net/reference/option/dom
dom <- if (nrow(tab) < 11) "t" else "ltip"
fbox <- if (nrow(tab) > 5e6) "none" else list(position = "top")
dt_tab <- DT::datatable(
tab,
container = sketch,
caption = caption,
selection = "none",
rownames = FALSE,
filter = fbox,
## must use fillContainer = FALSE to address
## see https://github.com/rstudio/DT/issues/367
## https://github.com/rstudio/DT/issues/379
fillContainer = FALSE,
style = style,
options = list(
dom = dom,
stateSave = TRUE, ## store state
searchCols = searchCols,
order = order,
columnDefs = list(list(orderSequence = c("desc", "asc"), targets = "_all")),
autoWidth = TRUE,
processing = FALSE,
pageLength = {
if (is.null(pageLength)) 10 else pageLength
},
lengthMenu = list(c(5, 10, 25, 50, -1), c("5", "10", "25", "50", "All"))
),
## https://github.com/rstudio/DT/issues/146#issuecomment-534319155
callback = DT::JS('$(window).on("unload", function() { table.state.clear(); })')
) %>%
DT::formatStyle(., cn_cat, color = "white", backgroundColor = "grey")
## rounding as needed
if (sum(isDbl) > 0) {
dt_tab <- DT::formatRound(dt_tab, names(isDbl)[isDbl], dec)
}
if (sum(isInt) > 0) {
dt_tab <- DT::formatRound(dt_tab, names(isInt)[isInt], 0)
}
## see https://github.com/yihui/knitr/issues/1198
dt_tab$dependencies <- c(
list(rmarkdown::html_dependency_bootstrap("bootstrap")),
dt_tab$dependencies
)
dt_tab
}
###########################################
## turn functions below into functional ...
###########################################
n_obs <- function(x, ...) length(x)
n_missing <- function(x, ...) sum(is.na(x))
p01 <- function(x, na.rm = TRUE) quantile(x, .01, na.rm = na.rm)
p025 <- function(x, na.rm = TRUE) quantile(x, .025, na.rm = na.rm)
p05 <- function(x, na.rm = TRUE) quantile(x, .05, na.rm = na.rm)
p10 <- function(x, na.rm = TRUE) quantile(x, .1, na.rm = na.rm)
p25 <- function(x, na.rm = TRUE) quantile(x, .25, na.rm = na.rm)
p75 <- function(x, na.rm = TRUE) quantile(x, .75, na.rm = na.rm)
p90 <- function(x, na.rm = TRUE) quantile(x, .90, na.rm = na.rm)
p95 <- function(x, na.rm = TRUE) quantile(x, .95, na.rm = na.rm)
p975 <- function(x, na.rm = TRUE) quantile(x, .975, na.rm = na.rm)
p99 <- function(x, na.rm = TRUE) quantile(x, .99, na.rm = na.rm)
cv <- function(x, na.rm = TRUE) {
m <- mean(x, na.rm = na.rm)
if (m == 0) {
message("Mean should be greater than 0")
NA
} else {
sd(x, na.rm = na.rm) / m
}
}
se <- function(x, na.rm = TRUE) {
if (na.rm) x <- na.omit(x)
sd(x) / sqrt(length(x))
}
me <- function(x, conf_lev = 0.95, na.rm = TRUE) {
if (na.rm) x <- na.omit(x)
se(x) * qt(conf_lev / 2 + .5, length(x) - 1, lower.tail = TRUE)
}
prop <- function(x, na.rm = TRUE) {
if (na.rm) x <- na.omit(x)
if (is.numeric(x)) {
mean(x == max(x, 1)) ## gives proportion of max value in x
} else if (is.factor(x)) {
mean(x == levels(x)[1]) ## gives proportion of first level in x
} else if (is.logical(x)) {
mean(x)
} else {
NA
}
}
varprop <- function(x, na.rm = TRUE) {
p <- prop(x, na.rm = na.rm)
p * (1 - p)
}
sdprop <- function(x, na.rm = TRUE) sqrt(varprop(x, na.rm = na.rm))
seprop <- function(x, na.rm = TRUE) {
if (na.rm) x <- na.omit(x)
sqrt(varprop(x, na.rm = FALSE) / length(x))
}
meprop <- function(x, conf_lev = 0.95, na.rm = TRUE) {
if (na.rm) x <- na.omit(x)
seprop(x) * qnorm(conf_lev / 2 + .5, lower.tail = TRUE)
}
varpop <- function(x, na.rm = TRUE) {
if (na.rm) x <- na.omit(x)
n <- length(x)
var(x) * ((n - 1) / n)
}
sdpop <- function(x, na.rm = TRUE) sqrt(varpop(x, na.rm = na.rm))
ln <- function(x, na.rm = TRUE) {
if (na.rm) log(na.omit(x)) else log(x)
}
does_vary <- function(x, na.rm = TRUE) {
## based on http://stackoverflow.com/questions/4752275/test-for-equality-among-all-elements-of-a-single-vector
if (length(x) == 1L) {
FALSE
} else {
if (is.factor(x) || is.character(x)) {
length(unique(x)) > 1
} else {
abs(max(x, na.rm = na.rm) - min(x, na.rm = na.rm)) > .Machine$double.eps^0.5
}
}
}
empty_level <- function(x) {
if (!is.factor(x)) x <- as.factor(x)
levs <- levels(x)
if ("" %in% levs) {
levs[levs == ""] <- "NA"
x <- factor(x, levels = levs)
x[is.na(x)] <- "NA"
} else if (any(is.na(x))) {
x <- factor(x, levels = unique(c(levs, "NA")))
x[is.na(x)] <- "NA"
}
x
}
modal <- function(x, na.rm = TRUE) {
if (na.rm) x <- na.omit(x)
unv <- unique(x)
unv[which.max(tabulate(match(x, unv)))]
}
radiant.quickgen/.Rproj.user/F437B50E/sources/per/t/7DCB57AF deleted 100644 → 0
View file @ d3861e30
{
"id": "7DCB57AF",
"path": "D:/R/radiant-master/inst/app/global.R",
"project_path": null,
"type": "r_source",
"hash": "1707112965",
"contents": "",
"dirty": false,
"created": 1756093055069.0,
"source_on_save": false,
"relative_order": 3,
"properties": {
"source_window_id": "",
"Source": "Source",
"cursorPosition": "13,70",
"scrollLine": "0"
},
"folds": "",
"lastKnownWriteTime": 1755759383,
"encoding": "UTF-8",
"collab_server": "",
"source_window": "",
"last_content_update": 1755759383,
"read_only": false,
"read_only_alternatives": []
}
\ No newline at end of file
radiant.quickgen/.Rproj.user/F437B50E/sources/per/t/7DCB57AF-contents deleted 100644 → 0
View file @ d3861e30
library(shiny.i18n)
i18n <- Translator$new(translation_csvs_path = "../translations")
i18n$set_translation_language("zh")
## sourcing from radiant.data
options(radiant.path.data = system.file(package = "radiant.data"))
source(file.path(getOption("radiant.path.data"), "app/global.R"), encoding = getOption("radiant.encoding", default = "UTF-8"), local = TRUE)
if (getOption("radiant.development", default = TRUE)) {
ifelse(grepl("radiant", getwd()) && file.exists("../../inst"), "..", system.file(package = "radiant")) %>%
options(radiant.path = .)
}
options(radiant.path.design = system.file(package = "radiant.design"))
options(radiant.path.basics = system.file(package = "radiant.basics"))
options(radiant.path.model = system.file(package = "radiant.model"))
options(radiant.path.multivariate = system.file(package = "radiant.multivariate"))
# 添加quickgen模块路径
options(radiant.path.quickgen = "D:/R/radiant.quickgen/inst")
# sourcing from radiant base, note that path is set in base/global.R
#source(file.path(getOption("radiant.path.data"), "app/global.R"), encoding = getOption("radiant.encoding", default = "UTF-8"), local = TRUE)
## setting path for figures in help files
addResourcePath("figures_design", file.path(getOption("radiant.path.design"), "app/tools/help/figures/"))
addResourcePath("figures_basics", file.path(getOption("radiant.path.basics"), "app/tools/help/figures/"))
addResourcePath("figures_model", file.path(getOption("radiant.path.model"), "app/tools/help/figures/"))
addResourcePath("figures_multivariate", file.path(getOption("radiant.path.multivariate"), "app/tools/help/figures/"))
# 添加quickgen模块的figures路径
addResourcePath("figures_quickgen", file.path(getOption("radiant.path.quickgen"), "app/tools/help/figures/"))
## setting path for www resources
addResourcePath("www_design", file.path(getOption("radiant.path.design"), "app/www/"))
addResourcePath("www_basics", file.path(getOption("radiant.path.basics"), "app/www/"))
addResourcePath("www_model", file.path(getOption("radiant.path.model"), "app/www/"))
addResourcePath("www_multivariate", file.path(getOption("radiant.path.multivariate"), "app/www/"))
# 添加quickgen模块的www路径
addResourcePath("www_quickgen", file.path(getOption("radiant.path.quickgen"), "app/www/"))
## loading url information
source(file.path(getOption("radiant.path.design"), "app/init.R"), encoding = getOption("radiant.encoding"), local = TRUE)
source(file.path(getOption("radiant.path.basics"), "app/init.R"), encoding = getOption("radiant.encoding"), local = TRUE)
source(file.path(getOption("radiant.path.model"), "app/init.R"), encoding = getOption("radiant.encoding"), local = TRUE)
source(file.path(getOption("radiant.path.multivariate"), "app/init.R"), encoding = getOption("radiant.encoding"), local = TRUE)
# 添加quickgen模块的init.R
source(file.path(getOption("radiant.path.quickgen"), "app/init.R"), encoding = getOption("radiant.encoding"), local = TRUE)
options(radiant.url.patterns = make_url_patterns())
if (!"package:radiant" %in% search() &&
isTRUE(getOption("radiant.development")) &&
getOption("radiant.path") == "..") {
options(radiant.from.package = FALSE)
} else {
options(radiant.from.package = TRUE)
}
## to use an alternative set of .rda files with data.frames as the default adapt and
## un-comment the line below
## note that "data/" here points to inst/app/data in the radiant directory but can
## be any (full) path on a server
# options(radiant.init.data = list.files(path = "data/", full.names = TRUE))
radiant.quickgen/.Rproj.user/F437B50E/sources/per/t/AC1E4C1F deleted 100644 → 0
View file @ d3861e30
{
"id": "AC1E4C1F",
"path": "D:/R/radiant.quickgen/inst/app/tools/analysis/quickgen_basic_ui.R",
"project_path": "inst/app/tools/analysis/quickgen_basic_ui.R",
"type": "r_source",
"hash": "953623402",
"contents": "",
"dirty": false,
"created": 1756092786308.0,
"source_on_save": false,
"relative_order": 1,
"properties": {
"source_window_id": "",
"Source": "Source",
"cursorPosition": "15,2",
"scrollLine": "0"
},
"folds": "",
"lastKnownWriteTime": 1756090465,
"encoding": "UTF-8",
"collab_server": "",
"source_window": "",
"last_content_update": 1756090465,
"read_only": false,
"read_only_alternatives": []
}
\ No newline at end of file
radiant.quickgen/.Rproj.user/F437B50E/sources/per/t/AC1E4C1F-contents deleted 100644 → 0
View file @ d3861e30
## quickgen_basic 的形参列表
default_funs <- c("n_obs", "mean", "sd", "min", "max")
qgb_args <- as.list(formals(explore))
## 收集用户输入的 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)
})
## 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))
selectInput(
"qgb_vars",
label = i18n$t("Numeric variable(s):"), choices = vars,
selected = state_multiple("qgb_vars", vars, isolate(input$qgb_vars)), multiple = TRUE,
size = min(8, length(vars)), selectize = FALSE
)
})
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
)
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("Create table"), 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("Create table"), relabel = i18n$t("Update table"))
output$ui_quickgen_basic <- renderUI({
tagList(
wellPanel(
uiOutput("ui_qgb_run")
),
wellPanel(
uiOutput("ui_qgb_vars"),
uiOutput("ui_qgb_byvar"),
uiOutput("ui_qgb_fun"),
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")
# ),
numericInput("qgb_dec", label = i18n$t("Decimals:"), value = state_init("qgb_dec", 3), min = 0)
),
wellPanel(
tags$table(
tags$td(uiOutput("ui_qgb_name")),
tags$td(actionButton("qgb_store", i18n$t("Store"), icon = icon("plus", verify_fa = FALSE)), class = "top")
)
),
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"
)
)
})
.explore <- 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$explore <- DT::renderDataTable({
input$qgb_run
withProgress(message = i18n$t("Generating explore table"), value = 1, {
isolate({
qgb <- .explore()
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(.explore(), silent = TRUE)
if (inherits(dat, "try-error") || is.null(dat)) {
write.csv(tibble::tibble("Data" = "[Empty]"), path, row.names = FALSE)
} else {
rows <- input$qgb_rows_all
dat$tab %>%
(function(x) if (is.null(rows)) x else x[rows, , drop = FALSE]) %>%
#(function(x) if (is.empty(input$qgb_tab_slice)) x else slice_data(x, input$qgb_tab_slice)) %>%
write.csv(path, row.names = FALSE)
}
}
download_handler(
id = "dl_qgb_tab",
fun = dl_qgb_tab,
fn = function() paste0(input$dataset, "_qgb"),
type = "csv"
)
observeEvent(input$qgb_store, {
req(input$qgb_name)
dat <- .explore()
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
dat$tab <- dat$tab %>%
(function(x) if (is.null(rows)) x else x[rows, , drop = FALSE]) %>%
#(function(x) if (is.empty(input$qgb_tab_slice)) x else slice_data(x, input$qgb_tab_slice))
r_data[[dataset]] <- dat$tab
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("explore")
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
)
}
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()
})
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("explore")
)
)
)
})
\ No newline at end of file
radiant.quickgen/.Rproj.user/F437B50E/sources/prop/279BFA89 deleted 100644 → 0
View file @ d3861e30
{
"source_window_id": "",
"Source": "Source",
"cursorPosition": "15,2",
"scrollLine": "0"
}
\ No newline at end of file
radiant.quickgen/.Rproj.user/F437B50E/sources/prop/60F6F2DC deleted 100644 → 0
View file @ d3861e30
{
"source_window_id": "",
"Source": "Source",
"cursorPosition": "18,40",
"scrollLine": "0"
}
\ No newline at end of file
radiant.quickgen/.Rproj.user/F437B50E/sources/prop/B388924E deleted 100644 → 0
View file @ d3861e30
{
"source_window_id": "",
"Source": "Source",
"cursorPosition": "13,70",
"scrollLine": "0"
}
\ No newline at end of file
radiant.quickgen/.Rproj.user/F437B50E/sources/prop/INDEX deleted 100644 → 0
View file @ d3861e30
D%3A%2FR%2Fradiant-master%2Finst%2Fapp%2Fglobal.R="B388924E"
D%3A%2FR%2Fradiant.quickgen%2FR%2Fquickgen_basic.R="60F6F2DC"
D%3A%2FR%2Fradiant.quickgen%2Finst%2Fapp%2Ftools%2Fanalysis%2Fquickgen_basic_ui.R="279BFA89"
radiant.quickgen/.Rproj.user/shared/notebooks/paths deleted 100644 → 0
View file @ d3861e30
D:/R/radiant.quickgen/R/quickgen_basic.R="741A1A01"
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment