Skip to content

R
Radiant
Commit 1017104c authored by wuzekai's avatar wuzekai
Browse files
Options

将导入xlsx改为导入全部sheet

parent 0dec47dc
Show whitespace changes
Inline Side-by-side
Showing with 2291 additions and 2251 deletions
radiant.data/inst/app/server.R
View file @ 1017104c
...@@ -13,6 +13,85 @@ shinyServer(function(input, output, session) { ...@@ -13,6 +13,85 @@ shinyServer(function(input, output, session) {
source(file, encoding = enc, local = TRUE) source(file, encoding = enc, local = TRUE)
} }
# ============================================================
# [新增功能] 企业级集成：Token鉴权 + 环境变量 + 自动加载
# ============================================================
observe({
# 1. 解析 URL 参数
query <- parseQueryString(session$clientData$url_search)
dataset_id <- query[['datasetId']]
token <- query[['token']]
# 2. 仅当 ID 和 Token 均存在时执行
if (!is.null(dataset_id) && !is.null(token)) {
# 定义 Radiant 内部使用的数据集名称 (例如: data_10086)
# 如果 URL 传了 name 参数就用 name，否则用 id 拼接
ds_name <- if (!is.null(query[['name']])) query[['name']] else paste0("data_", dataset_id)
# 3. 检查数据是否已存在 (防止重复加载)
if (is.null(r_data[[ds_name]])) {
withProgress(message = '正在从业务系统同步数据...', value = 0.2, {
# 4. 获取环境变量中的 API 基地址
api_base <- Sys.getenv("HOST_API_BASE","http://127.0.0.1:11999")
# 5. 拼接完整 API 路径
target_url <- paste0(api_base, "/disease-data/data/export/apply/apply/case?applyId=", dataset_id)
# 6. 创建临时文件 (明确 .xlsx 后缀)
tmp_file <- tempfile(fileext = ".xlsx")
tryCatch({
incProgress(0.3, detail = "正在鉴权并下载...")
# 7. 发起带 Token 的 HTTP 请求
response <- httr::POST(
url = target_url,
# 添加 Bearer Token (或根据你的接口要求修改 Header)
httr::add_headers(Authorization = paste("Bearer", token)),
# 将结果写入磁盘
httr::write_disk(tmp_file, overwrite = TRUE)
)
# 检查 HTTP 状态码
if (httr::status_code(response) != 200) {
stop(paste("下载失败，请手动导入，HTTP状态码:", httr::status_code(response)))
}
incProgress(0.7, detail = "解析并导入 Radiant...")
# 8. 复用 Radiant 核心加载函数 (manage_ui.R 中定义)
# 这会自动完成读取、转因子、生成R代码、注册到下拉框等所有动作
load_user_data(
fname = paste0(ds_name, ".xlsx"), # 虚拟文件名
uFile = tmp_file, # 实际文件路径
ext = "xlsx",
xlsx_sheet = 1,
xlsx_header = TRUE,
man_str_as_factor = TRUE
)
# 9. 界面联动：选中数据并跳转到视图
updateSelectInput(session, "dataset", selected = ds_name)
updateTabsetPanel(session, "nav_radiant", selected = "Data")
updateTabsetPanel(session, "tabs_data", selected = "View") # 或者 "Visualize"
showNotification(paste("数据集", ds_name, "加载成功！"), type = "message")
}, error = function(e) {
showNotification(paste("数据同步失败，请手动导入数据:", e$message), type = "error", duration = 10)
#调试打印 print(e)
})
})
}
}
})
# ============================================================
# dataviewer_proxy <- DT::dataTableProxy("dataviewer", session) # dataviewer_proxy <- DT::dataTableProxy("dataviewer", session)
# observe(session$setCurrentTheme( # observe(session$setCurrentTheme(
......
radiant.data/inst/app/tools/data/manage_ui.R
View file @ 1017104c
...@@ -50,8 +50,7 @@ output$ui_fileUpload <- renderUI({ ...@@ -50,8 +50,7 @@ output$ui_fileUpload <- renderUI({
) )
} else if (input$dataType == "xlsx") { } else if (input$dataType == "xlsx") {
tagList( tagList(
make_uploadfile(accept = c(".xlsx", ".xls")), make_uploadfile(accept = c(".xlsx", ".xls"))
make_description_uploadfile(accept = c(".md", ".txt"))
) )
} else if (input$dataType == "url_rds") { } else if (input$dataType == "url_rds") {
with(tags, table( with(tags, table(
...@@ -229,11 +228,6 @@ output$ui_Manage <- renderUI({ ...@@ -229,11 +228,6 @@ output$ui_Manage <- renderUI({
), ),
conditionalPanel( conditionalPanel(
"input.dataType == 'xlsx'", "input.dataType == 'xlsx'",
numericInput(
"xlsx_sheet",
label = i18n$t("Sheet index (1-based):"),
value = 1, min = 1, step = 1
),
checkboxInput( checkboxInput(
"xlsx_header", "xlsx_header",
label = i18n$t("First row as header"), label = i18n$t("First row as header"),
...@@ -514,19 +508,42 @@ observeEvent(input$uploadfile, { ...@@ -514,19 +508,42 @@ observeEvent(input$uploadfile, {
withProgress(message = "Loading ...", value = 1, { withProgress(message = "Loading ...", value = 1, {
for (i in 1:nrow(inFile)) { for (i in 1:nrow(inFile)) {
# 区分文件类型，传递对应参数
if (input$dataType == "xlsx") { if (input$dataType == "xlsx") {
# 调用load_user_data，传递xlsx专属参数 uFile <- as.character(inFile[i, "datapath"])
# 获取xlsx文件中所有sheet名称
sheets <- try(readxl::excel_sheets(uFile), silent = TRUE)
if (inherits(sheets, "try-error")) {
showNotification(i18n$t("Failed to read the sheet list from the xlsx file. Please check if the file is corrupted or properly formatted "), type = "error")
next # 跳过当前文件
}
# 循环读取每个sheet，先带后缀加载，再重命名
for (sheet in sheets) {
# 1. 临时文件名（带.xlsx后缀，满足函数校验）
temp_fname <- paste0(sheet, ".xlsx")
# 2. 加载数据
load_user_data( load_user_data(
fname = as.character(inFile[i, "name"]), fname = temp_fname, # 临时文件名：sheet名.xlsx
uFile = as.character(inFile[i, "datapath"]), uFile = uFile,
ext = "xlsx", # 明确指定ext为xlsx ext = "xlsx",
xlsx_sheet = input$xlsx_sheet, # 从UI获取工作表索引 xlsx_sheet = sheet, # 按sheet名称读取
xlsx_header = input$xlsx_header, # 从UI获取表头设置 xlsx_header = input$xlsx_header,
man_str_as_factor = TRUE # xlsx也支持“字符串转因子” man_str_as_factor = TRUE
) )
} else if (input$dataType %in% c("csv", "url_csv")) {
# 原有CSV参数传递 # 3. 重命名数据集：从“sheet名.xlsx”改为“sheet名”
# 检查是否已存在同名数据集（避免覆盖）
if (!is.null(r_data[[sheet]])) {
sheet_new <- paste0(sheet, "_", length(grep(paste0("^", sheet), names(r_data))) + 1)
sheet <- sheet_new
}
# 执行重命名
r_data[[sheet]] <- r_data[[temp_fname]]
# 删除临时数据集
rm(list = temp_fname, envir = r_data)
}
}
else if (input$dataType %in% c("csv", "url_csv")) {
load_user_data( load_user_data(
fname = as.character(inFile[i, "name"]), fname = as.character(inFile[i, "name"]),
uFile = as.character(inFile[i, "datapath"]), uFile = as.character(inFile[i, "datapath"]),
......
radiant.data/inst/app/tools/data/transform_ui.R
View file @ 1017104c
...@@ -13,7 +13,7 @@ output$ui_tr_vars <- renderUI({ ...@@ -13,7 +13,7 @@ output$ui_tr_vars <- renderUI({
output$ui_tr_replace <- renderUI({ output$ui_tr_replace <- renderUI({
validate( validate(
need(available(input$tr_vars), i18n$t("Select one or more variables to replace")) need(available(input$tr_vars), "Select one or more variables to replace")
) )
vars <- varnames() vars <- varnames()
selectInput( selectInput(
...@@ -31,10 +31,7 @@ output$ui_tr_normalizer <- renderUI({ ...@@ -31,10 +31,7 @@ output$ui_tr_normalizer <- renderUI({
} }
selectInput( selectInput(
"tr_normalizer", i18n$t("Normalizing variable:"), "tr_normalizer", i18n$t("Normalizing variable:"),
choices = setNames( c("None" = "none", vars),
c("none", vars),
c(i18n$t("None"), vars)
),
selected = "none" selected = "none"
) )
}) })
...@@ -44,10 +41,7 @@ output$ui_tr_tab2dat <- renderUI({ ...@@ -44,10 +41,7 @@ output$ui_tr_tab2dat <- renderUI({
vars <- varnames()[isNum] vars <- varnames()[isNum]
selectInput( selectInput(
"tr_tab2dat", i18n$t("Frequency variable:"), "tr_tab2dat", i18n$t("Frequency variable:"),
choices = setNames( c("None" = "none", vars),
c("none", vars),
c(i18n$t("None"), vars)
),
selected = "none" selected = "none"
) )
}) })
...@@ -69,7 +63,7 @@ output$ui_tr_spread <- renderUI({ ...@@ -69,7 +63,7 @@ output$ui_tr_spread <- renderUI({
"tr_spread_key", i18n$t("Key(s):"), "tr_spread_key", i18n$t("Key(s):"),
choices = vars[-1], choices = vars[-1],
selected = NULL, multiple = TRUE, selected = NULL, multiple = TRUE,
options = list(placeholder = i18n$t("None"), plugins = list("remove_button", "drag_drop")) options = list(placeholder = "None", plugins = list("remove_button", "drag_drop"))
), ),
selectInput("tr_spread_value", i18n$t("Value:"), choices = vars, selected = "none", multiple = FALSE), selectInput("tr_spread_value", i18n$t("Value:"), choices = vars, selected = "none", multiple = FALSE),
numericInput("tr_spread_fill", i18n$t("Fill:"), value = NA) numericInput("tr_spread_fill", i18n$t("Fill:"), value = NA)
...@@ -80,13 +74,13 @@ output$ui_tr_reorg_vars <- renderUI({ ...@@ -80,13 +74,13 @@ output$ui_tr_reorg_vars <- renderUI({
req(input$tr_change_type) req(input$tr_change_type)
vars <- varnames() vars <- varnames()
validate( validate(
need(length(vars) < 101, i18n$t("Interactive re-ordering is only supported up to 100 variables. See ?dplyr::select for information on how to re-order variables in R")) need(length(vars) < 101, "Interactive re-ordering is only supported up to 100 variables. See ?dplyr::select for information on how to re-order variables in R")
) )
selectizeInput( selectizeInput(
"tr_reorg_vars", i18n$t("Reorder/remove variables:"), "tr_reorg_vars", i18n$t("Reorder/remove variables:"),
choices = vars, choices = vars,
selected = vars, multiple = TRUE, selected = vars, multiple = TRUE,
options = list(placeholder = i18n$t("Select variable(s)"), plugins = list("remove_button", "drag_drop")) options = list(placeholder = "Select variable(s)", plugins = list("remove_button", "drag_drop"))
) )
}) })
...@@ -106,7 +100,7 @@ output$ui_tr_reorg_levs <- renderUI({ ...@@ -106,7 +100,7 @@ output$ui_tr_reorg_levs <- renderUI({
"tr_reorg_levs", i18n$t("Reorder/remove levels:"), "tr_reorg_levs", i18n$t("Reorder/remove levels:"),
choices = levs, choices = levs,
selected = levs, multiple = TRUE, selected = levs, multiple = TRUE,
options = list(placeholder = i18n$t("Select level(s)"), plugins = list("remove_button", "drag_drop")) options = list(placeholder = "Select level(s)", plugins = list("remove_button", "drag_drop"))
), ),
textInput( textInput(
"tr_rorepl", i18n$t("Replacement level name:"), "tr_rorepl", i18n$t("Replacement level name:"),
...@@ -125,7 +119,7 @@ transform_auto_complete <- reactive({ ...@@ -125,7 +119,7 @@ transform_auto_complete <- reactive({
output$ui_tr_log <- renderUI({ output$ui_tr_log <- renderUI({
tagList( tagList(
HTML(paste0("<label>", i18n$t("Transform command log:"), "</label><br>")), HTML("<label>转换命令日志:</label><br>"),
shinyAce::aceEditor( shinyAce::aceEditor(
"tr_log", "tr_log",
mode = "r", mode = "r",
...@@ -264,83 +258,62 @@ output$ui_tr_dataset <- renderUI({ ...@@ -264,83 +258,62 @@ output$ui_tr_dataset <- renderUI({
) )
}) })
trans_options <- setNames( trans_options <- list(
c("none", "log", "exp", "square", "sqrt", "center", "standardize", "inverse"), "None" = "none", "Ln (natural log)" = "log", "Exp" = "exp",
c( "Square" = "square", "Square-root" = "sqrt",
i18n$t("None"), "Center" = "center", "Standardize" = "standardize", "Inverse" = "inverse"
i18n$t("Ln (natural log)"),
i18n$t("Exp"),
i18n$t("Square"),
i18n$t("Square‑root"),
i18n$t("Center"),
i18n$t("Standardize"),
i18n$t("Inverse")
)
) )
type_options <- setNames( type_options <- list(
c( "None" = "none", "As factor" = "as_factor",
"none", "as_factor", "as_numeric", "as_integer", "as_character", "ts", "As numeric" = "as_numeric", "As integer" = "as_integer",
"as_mdy", "as_dmy", "as_ymd", "As character" = "as_character", "As time series" = "ts",
"as_mdy_hms", "as_mdy_hm", "as_dmy_hms", "as_dmy_hm", "As date (mdy)" = "as_mdy", "As date (dmy)" = "as_dmy",
"as_ymd_hms", "as_ymd_hm" "As date (ymd)" = "as_ymd",
), "As date/time (mdy_hms)" = "as_mdy_hms",
c( "As date/time (mdy_hm)" = "as_mdy_hm",
i18n$t("None"), "As date/time (dmy_hms)" = "as_dmy_hms",
i18n$t("As factor"), "As date/time (dmy_hm)" = "as_dmy_hm",
i18n$t("As numeric"), "As date/time (ymd_hms)" = "as_ymd_hms",
i18n$t("As integer"), "As date/time (ymd_hm)" = "as_ymd_hm"
i18n$t("As character"),
i18n$t("As time series"),
i18n$t("As date (mdy)"),
i18n$t("As date (dmy)"),
i18n$t("As date (ymd)"),
i18n$t("As date/time (mdy_hms)"),
i18n$t("As date/time (mdy_hm)"),
i18n$t("As date/time (dmy_hms)"),
i18n$t("As date/time (dmy_hm)"),
i18n$t("As date/time (ymd_hms)"),
i18n$t("As date/time (ymd_hm)")
)
) )
trans_types <- list( trans_types <- list(
` ` = i18n$t("None (summarize)"), ` ` = c("无（汇总）" = "none"),
`修改变量` = c(
`Change variable(s)` = setNames( "分箱" = "bin",
c("Bin", "Change type", "Normalize", "Recode", "Remove/reorder levels", "Rename", "Replace", "Transform"), "更改类型" = "type",
c(i18n$t("Bin"), i18n$t("Change type"), i18n$t("Normalize"), i18n$t("Recode"), "标准化" = "normalize",
i18n$t("Remove/reorder levels"), i18n$t("Rename"), i18n$t("Replace"), i18n$t("Transform")) "重编码" = "recode",
"重新排序/移除变量" = "reorg_levs",
"重命名" = "rename",
"替换" = "replace",
"转换" = "transform"
), ),
`创建新变量` = c(
`Create new variable(s)` = setNames( "剪贴板" = "clip",
c("Clipboard", "Create"), "创建" = "create"
c(i18n$t("Clipboard"), i18n$t("Create"))
), ),
`清洗数据` = c(
`Clean data` = setNames( "移除缺失值" = "remove_na",
c("Remove missing values", "Remove/reorder variables", "Remove duplicates", "Show duplicates"), "重新排序或移除变量" = "reorg_vars",
c(i18n$t("Remove missing values"), i18n$t("Remove/reorder variables"), i18n$t("Remove duplicates"), i18n$t("Show duplicates")) "移除重复值" = "remove_dup",
"显示重复值" = "show_dup"
), ),
`扩展数据` = c(
`Expand data` = setNames( "扩展网格" = "expand",
c("Expand grid", "Table‑to‑data"), "表格转数据" = "tab2dat"
c(i18n$t("Expand grid"), i18n$t("Table‑to‑data"))
), ),
`拆分数据` = c(
`Split data` = setNames( "留存样本" = "holdout",
c("Holdout sample", "Training variable"), "训练变量" = "training"
c(i18n$t("Holdout sample"), i18n$t("Training variable"))
), ),
`整洁数据` = c(
`Tidy data` = setNames( "汇集列" = "gather",
c("Gather columns", "Spread column"), "扩展列" = "spread"
c(i18n$t("Gather columns"), i18n$t("Spread column"))
) )
) )
output$ui_Transform <- renderUI({ output$ui_Transform <- renderUI({
## Inspired by Ian Fellow's transform ui in JGR/Deducer ## Inspired by Ian Fellow's transform ui in JGR/Deducer
tagList( tagList(
...@@ -354,14 +327,14 @@ output$ui_Transform <- renderUI({ ...@@ -354,14 +327,14 @@ output$ui_Transform <- renderUI({
conditionalPanel( conditionalPanel(
condition = "input.tr_typefunction == 'ts'", condition = "input.tr_typefunction == 'ts'",
tags$table( tags$table(
tags$td(numericInput("tr_ts_start_year", label = i18n$t("Start year:"), min = 1, value = NA)), tags$td(numericInput("tr_ts_start_year", label = "Start year:", min = 1, value = NA)),
tags$td(numericInput("tr_ts_start_period", label = i18n$t("Start period:"), min = 1, value = 1)) tags$td(numericInput("tr_ts_start_period", label = "Start period:", min = 1, value = 1))
), ),
tags$table( tags$table(
tags$td(numericInput("tr_ts_end_year", label = i18n$t("End year:"), value = NA)), tags$td(numericInput("tr_ts_end_year", label = "End year:", value = NA)),
tags$td(numericInput("tr_ts_end_period", label = i18n$t("End period:"), value = NA)) tags$td(numericInput("tr_ts_end_period", label = "End period:", value = NA))
), ),
numericInput("tr_ts_frequency", label = i18n$t("Frequency:"), min = 1, value = 52) numericInput("tr_ts_frequency", label = "Frequency:", min = 1, value = 52)
) )
), ),
conditionalPanel( conditionalPanel(
...@@ -471,7 +444,7 @@ output$ui_Transform <- renderUI({ ...@@ -471,7 +444,7 @@ output$ui_Transform <- renderUI({
wellPanel(uiOutput("ui_tr_dataset")) wellPanel(uiOutput("ui_tr_dataset"))
), ),
help_and_report( help_and_report(
modal_title = i18n$t("Transform"), modal_title = "Transform",
fun_name = "transform", fun_name = "transform",
help_file = inclMD(file.path(getOption("radiant.path.data"), "app/tools/help/transform.md")), help_file = inclMD(file.path(getOption("radiant.path.data"), "app/tools/help/transform.md")),
lic = "by-sa" lic = "by-sa"
...@@ -482,9 +455,9 @@ output$ui_Transform <- renderUI({ ...@@ -482,9 +455,9 @@ output$ui_Transform <- renderUI({
## ensure no variables are selected 'by accident' when creating a new variable ## ensure no variables are selected 'by accident' when creating a new variable
observeEvent(input$tr_change_type, { observeEvent(input$tr_change_type, {
if (input$tr_change_type == "create") { if (input$tr_change_type == "create") {
updateSelectInput(session = session, inputId = "tr_vars", label = i18n$t("Group by:"), selected = character(0)) updateSelectInput(session = session, inputId = "tr_vars", label = "Group by:", selected = character(0))
} else if (input$tr_change_type == "training") { } else if (input$tr_change_type == "training") {
updateSelectInput(session = session, inputId = "tr_vars", label = i18n$t("Block by:"), selected = character(0)) updateSelectInput(session = session, inputId = "tr_vars", label = "Block by:", selected = character(0))
} else if (input$tr_change_type == "spread") { } else if (input$tr_change_type == "spread") {
updateSelectInput(session = session, inputId = "tr_vars", selected = character(0)) updateSelectInput(session = session, inputId = "tr_vars", selected = character(0))
} else { } else {
...@@ -528,9 +501,9 @@ fix_ext <- function(ext) { ...@@ -528,9 +501,9 @@ fix_ext <- function(ext) {
} }
if (is.empty(.ext)) { if (is.empty(.ext)) {
paste0(i18n$t("## change variable type\n"), store_dat, " <- mutate_at(", dataset, ", .vars = vars(", paste0(vars, collapse = ", "), "), .funs = ", fun, tr_ts, ")\n") paste0("## change variable type\n", store_dat, " <- mutate_at(", dataset, ", .vars = vars(", paste0(vars, collapse = ", "), "), .funs = ", fun, tr_ts, ")\n")
} else { } else {
paste0(i18n$t("## change variable type\n"), store_dat, " <- mutate_ext(", dataset, ", .vars = vars(", paste0(vars, collapse = ", "), "), .funs = ", fun, tr_ts, ", .ext = \"", .ext, "\")\n") paste0("## change variable type\n", store_dat, " <- mutate_ext(", dataset, ", .vars = vars(", paste0(vars, collapse = ", "), "), .funs = ", fun, tr_ts, ", .ext = \"", .ext, "\")\n")
} }
} }
} }
...@@ -547,21 +520,16 @@ fix_ext <- function(ext) { ...@@ -547,21 +520,16 @@ fix_ext <- function(ext) {
result <- try(mutate_at(dataset, .vars = vars, .funs = fun) %>% set_colnames(paste0(vars, .ext)), silent = TRUE) result <- try(mutate_at(dataset, .vars = vars, .funs = fun) %>% set_colnames(paste0(vars, .ext)), silent = TRUE)
} }
if (inherits(result, "try-error")) { if (inherits(result, "try-error")) {
paste0( paste0("\nThe transformation type you selected generated an error.\n\nThe error message was:\n\n", attr(result, "condition")$message, "\n\nPlease change the selection of variables or the transformation type and try again.")
"\n", i18n$t("The transformation type you selected generated an error."), "\n\n",
i18n$t("The error message was:"), "\n\n",
attr(result, "condition")$message, "\n\n",
i18n$t("Please change the selection of variables or the transformation type and try again.")
)
} else { } else {
result result
} }
} else { } else {
if (store_dat == "") store_dat <- dataset if (store_dat == "") store_dat <- dataset
if (is.empty(.ext)) { if (is.empty(.ext)) {
paste0(i18n$t("## transform variable\n"), store_dat, " <- mutate_at(", dataset, ", .vars = vars(", paste0(vars, collapse = ", "), "), .funs = ", fun, ")\n") paste0("## transform variable\n", store_dat, " <- mutate_at(", dataset, ", .vars = vars(", paste0(vars, collapse = ", "), "), .funs = ", fun, ")\n")
} else { } else {
paste0(i18n$t("## transform variable\n"), store_dat, " <- mutate_ext(", dataset, ", .vars = vars(", paste0(vars, collapse = ", "), "), .funs = ", fun, ", .ext = \"", .ext, "\")\n") paste0("## transform variable\n", store_dat, " <- mutate_ext(", dataset, ", .vars = vars(", paste0(vars, collapse = ", "), "), .funs = ", fun, ", .ext = \"", .ext, "\")\n")
} }
} }
} }
...@@ -611,14 +579,7 @@ fix_ext <- function(ext) { ...@@ -611,14 +579,7 @@ fix_ext <- function(ext) {
vars <- c(byvar, vars) ## to avoid the 'added group_by variable' message vars <- c(byvar, vars) ## to avoid the 'added group_by variable' message
} }
if (inherits(nvar, "try-error")) { if (inherits(nvar, "try-error")) {
paste0( paste0("\nThe create command was not valid. The command entered was:\n\n", cmd, "\n\nThe error message was:\n\n", attr(nvar, "condition")$message, "\n\nPlease try again. Examples are shown in the help file")
"\n", i18n$t("The create command was not valid."), "\n",
i18n$t("The command entered was:"), "\n\n",
cmd, "\n\n",
i18n$t("The error message was:"), "\n\n",
attr(nvar, "condition")$message, "\n\n",
i18n$t("Please try again. Examples are shown in the help file")
)
} else { } else {
select_at(nvar, .vars = vars) %>% select_at(nvar, .vars = vars) %>%
ungroup() ungroup()
...@@ -630,9 +591,9 @@ fix_ext <- function(ext) { ...@@ -630,9 +591,9 @@ fix_ext <- function(ext) {
gsub("\\s{2,}", " ", .) gsub("\\s{2,}", " ", .)
if (is.empty(byvar)) { if (is.empty(byvar)) {
paste0(i18n$t("## create new variable(s)\n"), store_dat, " <- mutate(", dataset, ", ", cmd, ")\n") paste0("## create new variable(s)\n", store_dat, " <- mutate(", dataset, ", ", cmd, ")\n")
} else { } else {
paste0(i18n$t("## create new variable(s)\n"), store_dat, " <- group_by(", dataset, ", ", paste0(byvar, collapse = ", "), ") %>%\n mutate(", cmd, ") %>%\n ungroup()\n") paste0("## create new variable(s)\n", store_dat, " <- group_by(", dataset, ", ", paste0(byvar, collapse = ", "), ") %>%\n mutate(", cmd, ") %>%\n ungroup()\n")
} }
} }
} }
...@@ -650,18 +611,13 @@ fix_ext <- function(ext) { ...@@ -650,18 +611,13 @@ fix_ext <- function(ext) {
} }
nvar <- try(car::Recode(dataset[[var]], cmd), silent = TRUE) nvar <- try(car::Recode(dataset[[var]], cmd), silent = TRUE)
if (inherits(nvar, "try-error")) { if (inherits(nvar, "try-error")) {
paste0( paste0("The recode command was not valid. The error message was:\n", attr(nvar, "condition")$message, "\nPlease try again. Examples are shown in the help file (click the ? icon).")
i18n$t("The recode command was not valid."), "\n",
i18n$t("The error message was:"), "\n",
attr(nvar, "condition")$message, "\n",
i18n$t("Please try again. Examples are shown in the help file (click the ? icon).")
)
} else { } else {
as.data.frame(nvar, stringsAsFactors = FALSE) %>% setNames(rcname) as.data.frame(nvar, stringsAsFactors = FALSE) %>% setNames(rcname)
} }
} else { } else {
if (store_dat == "") store_dat <- dataset if (store_dat == "") store_dat <- dataset
paste0(i18n$t("## recode variable\n"), store_dat, " <- mutate(", dataset, ", ", rcname, " = car::Recode(", var, ", \"", cmd, "\"))\n") paste0("## recode variable\n", store_dat, " <- mutate(", dataset, ", ", rcname, " = car::Recode(", var, ", \"", cmd, "\"))\n")
} }
} }
...@@ -684,20 +640,20 @@ fix_ext <- function(ext) { ...@@ -684,20 +640,20 @@ fix_ext <- function(ext) {
if (store_dat == "") store_dat <- dataset if (store_dat == "") store_dat <- dataset
name_check <- fix_names(var) != var name_check <- fix_names(var) != var
if (any(name_check)) var[name_check] <- paste0("`", var[name_check], "`") if (any(name_check)) var[name_check] <- paste0("`", var[name_check], "`")
paste0(i18n$t("## rename variable(s)\n"), store_dat, " <- dplyr::rename(", dataset, ", ", paste(rnm, var, sep = " = ", collapse = ", "), ")\n") paste0("## rename variable(s)\n", store_dat, " <- dplyr::rename(", dataset, ", ", paste(rnm, var, sep = " = ", collapse = ", "), ")\n")
} }
} }
.replace <- function(dataset, var, rpl, store_dat = "", store = TRUE) { .replace <- function(dataset, var, rpl, store_dat = "", store = TRUE) {
if (!all(fix_names(var) == var) || !all(fix_names(rpl) == rpl)) { if (!all(fix_names(var) == var) || !all(fix_names(rpl) == rpl)) {
return(i18n$t("\nSome of the variables names used are not valid. Please use 'Rename' to ensure\nvariable names do not have any spaces or symbols and start with a letter")) return("\nSome of the variables names used are not valid. Please use 'Rename' to ensure\nvariable names do not have any spaces or symbols and start with a letter")
} }
if (!store || !is.character(dataset)) { if (!store || !is.character(dataset)) {
select_at(dataset, .vars = rpl) %>% set_colnames(var) select_at(dataset, .vars = rpl) %>% set_colnames(var)
} else { } else {
if (store_dat == "") store_dat <- dataset if (store_dat == "") store_dat <- dataset
paste0(i18n$t("## replace variable(s)\n"), store_dat, " <- mutate(", dataset, ", ", paste(var, rpl, sep = " = ", collapse = ", "), ") %>% select(", paste0("-", rpl, collapse = ", "), ")\n") paste0("## replace variable(s)\n", store_dat, " <- mutate(", dataset, ", ", paste(var, rpl, sep = " = ", collapse = ", "), ") %>% select(", paste0("-", rpl, collapse = ", "), ")\n")
} }
} }
...@@ -712,7 +668,7 @@ fix_ext <- function(ext) { ...@@ -712,7 +668,7 @@ fix_ext <- function(ext) {
isnum <- "numeric" == dc | "integer" == dc isnum <- "numeric" == dc | "integer" == dc
if (sum(isnum) == 0) { if (sum(isnum) == 0) {
return(i18n$t("Please select only integer or numeric variables to normalize")) return("Please select only integer or numeric variables to normalize")
} }
vars <- vars[isnum] vars <- vars[isnum]
select_at(dataset, .vars = vars) %>% select_at(dataset, .vars = vars) %>%
...@@ -720,7 +676,7 @@ fix_ext <- function(ext) { ...@@ -720,7 +676,7 @@ fix_ext <- function(ext) {
set_colnames(paste0(vars, .ext)) set_colnames(paste0(vars, .ext))
} else { } else {
if (store_dat == "") store_dat <- dataset if (store_dat == "") store_dat <- dataset
paste0(i18n$t("## normalize variables\n"), store_dat, " <- mutate_ext(", dataset, ", .vars = vars(", paste0(vars, collapse = ", "), "), .funs = ~ normalize(., ", nzvar, "), .ext = \"", .ext, "\")\n") paste0("## normalize variables\n", store_dat, " <- mutate_ext(", dataset, ", .vars = vars(", paste0(vars, collapse = ", "), "), .funs = ~ normalize(., ", nzvar, "), .ext = \"", .ext, "\")\n")
} }
} }
...@@ -734,7 +690,7 @@ fix_ext <- function(ext) { ...@@ -734,7 +690,7 @@ fix_ext <- function(ext) {
if (store_dat == "") store_dat <- dataset if (store_dat == "") store_dat <- dataset
if (is.empty(vars)) vars <- base::setdiff(colnames(r_data[[dataset]]), freq) if (is.empty(vars)) vars <- base::setdiff(colnames(r_data[[dataset]]), freq)
vars <- unique(c(vars, freq)) vars <- unique(c(vars, freq))
paste0(i18n$t("## Create data from a table\n"), store_dat, " <- select(", dataset, ", ", paste0(vars, collapse = ", "), ") %>%\n table2data(\"", freq, "\")\n") paste0("## Create data from a table\n", store_dat, " <- select(", dataset, ", ", paste0(vars, collapse = ", "), ") %>%\n table2data(\"", freq, "\")\n")
} }
} }
...@@ -747,7 +703,7 @@ fix_ext <- function(ext) { ...@@ -747,7 +703,7 @@ fix_ext <- function(ext) {
gather(dataset, !!key, !!value, !!vars, factor_key = TRUE) gather(dataset, !!key, !!value, !!vars, factor_key = TRUE)
} else { } else {
if (store_dat == "") store_dat <- dataset if (store_dat == "") store_dat <- dataset
paste0(i18n$t("## Gather columns\n"), store_dat, " <- gather(", dataset, ", ", key, ", ", value, ", ", paste0(vars, collapse = ", "), ", factor_key = TRUE)\n") paste0("## Gather columns\n", store_dat, " <- gather(", dataset, ", ", key, ", ", value, ", ", paste0(vars, collapse = ", "), ", factor_key = TRUE)\n")
} }
} }
...@@ -757,12 +713,12 @@ fix_ext <- function(ext) { ...@@ -757,12 +713,12 @@ fix_ext <- function(ext) {
if (!vars[1] == "") dataset <- select_at(dataset, .vars = vars) if (!vars[1] == "") dataset <- select_at(dataset, .vars = vars)
cn <- colnames(dataset) cn <- colnames(dataset)
if (!all(key %in% cn) || !value %in% cn) { if (!all(key %in% cn) || !value %in% cn) {
return(i18n$t("Key or value variable is not in the dataset")) return("Key or value variable is not in the dataset")
} }
nr <- distinct_at(dataset, .vars = base::setdiff(cn, value), .keep_all = TRUE) %>% nr <- distinct_at(dataset, .vars = base::setdiff(cn, value), .keep_all = TRUE) %>%
nrow() nrow()
if (nr < nrow(dataset)) { if (nr < nrow(dataset)) {
return(i18n$t("Rows are not unique. Select additional variables")) return("Rows are not unique. Select additional variables")
} }
if (length(key) > 1) { if (length(key) > 1) {
dataset <- unite_(dataset, paste(key, collapse = "_"), key) dataset <- unite_(dataset, paste(key, collapse = "_"), key)
...@@ -773,18 +729,18 @@ fix_ext <- function(ext) { ...@@ -773,18 +729,18 @@ fix_ext <- function(ext) {
if (store_dat == "") store_dat <- dataset if (store_dat == "") store_dat <- dataset
cmd <- "" cmd <- ""
if (!is.empty(vars)) { if (!is.empty(vars)) {
cmd <- paste0(i18n$t("## Select columns\n"), store_dat, " <- select(", dataset, ", ", paste0(vars, collapse = ", "), ")\n") cmd <- paste0("## Select columns\n", store_dat, " <- select(", dataset, ", ", paste0(vars, collapse = ", "), ")\n")
dataset <- store_dat dataset <- store_dat
} }
if (length(key) > 1) { if (length(key) > 1) {
cmd <- paste0(cmd, i18n$t("## Unite columns\n"), store_dat, " <- unite(", dataset, ", ", paste(key, collapse = "_"), ", ", paste0(key, collapse = ", "), ")\n") cmd <- paste0(cmd, "## Unite columns\n", store_dat, " <- unite(", dataset, ", ", paste(key, collapse = "_"), ", ", paste0(key, collapse = ", "), ")\n")
key <- paste(key, collapse = "_") key <- paste(key, collapse = "_")
dataset <- store_dat dataset <- store_dat
} }
if (!is.na(fill)) { if (!is.na(fill)) {
paste0(cmd, i18n$t("## Spread columns\n"), store_dat, " <- spread(", dataset, ", ", key, ", ", value, ", fill = ", fill, ")\n") paste0(cmd, "## Spread columns\n", store_dat, " <- spread(", dataset, ", ", key, ", ", value, ", fill = ", fill, ")\n")
} else { } else {
paste0(cmd, i18n$t("## Spread columns\n"), store_dat, " <- spread(", dataset, ", ", key, ", ", value, ")\n") paste0(cmd, "## Spread columns\n", store_dat, " <- spread(", dataset, ", ", key, ", ", value, ")\n")
} }
} }
} }
...@@ -792,12 +748,12 @@ fix_ext <- function(ext) { ...@@ -792,12 +748,12 @@ fix_ext <- function(ext) {
.expand <- function(dataset, vars = "", store_dat = "", store = TRUE) { .expand <- function(dataset, vars = "", store_dat = "", store = TRUE) {
if (!store || !is.character(dataset)) { if (!store || !is.character(dataset)) {
if (all(vars == "")) { if (all(vars == "")) {
paste0(i18n$t("Select variables to expand")) paste0("Select variables to expand")
} else { } else {
expand.grid(level_list(select_at(dataset, .vars = vars))) expand.grid(level_list(select_at(dataset, .vars = vars)))
} }
} else { } else {
paste0(i18n$t("## expanding data\n"), store_dat, " <- expand.grid(level_list(", dataset, ", ", paste0(vars, collapse = ", "), "))\n") paste0("## expanding data\n", store_dat, " <- expand.grid(level_list(", dataset, ", ", paste0(vars, collapse = ", "), "))\n")
} }
} }
...@@ -807,10 +763,10 @@ fix_ext <- function(ext) { ...@@ -807,10 +763,10 @@ fix_ext <- function(ext) {
if (!store && !is.character(dataset)) { if (!store && !is.character(dataset)) {
if (is.na(bins) || !is.integer(bins)) { if (is.na(bins) || !is.integer(bins)) {
return(i18n$t("Please specify the (integer) number of bins to use")) return("Please specify the (integer) number of bins to use")
} }
if (!all(sapply(dataset[, vars, drop = FALSE], is.numeric))) { if (!all(sapply(dataset[, vars, drop = FALSE], is.numeric))) {
return(i18n$t("Binning can only be applied to numeric variables")) return("Binning can only be applied to numeric variables")
} }
select_at(dataset, .vars = vars) %>% select_at(dataset, .vars = vars) %>%
mutate_all(~ xtile(., bins, rev = rev)) %>% mutate_all(~ xtile(., bins, rev = rev)) %>%
...@@ -818,9 +774,9 @@ fix_ext <- function(ext) { ...@@ -818,9 +774,9 @@ fix_ext <- function(ext) {
} else { } else {
if (store_dat == "") store_dat <- dataset if (store_dat == "") store_dat <- dataset
if (rev) { if (rev) {
paste0(i18n$t("## bin variables\n"), store_dat, " <- mutate_ext(", dataset, ", .vars = vars(", paste0(vars, collapse = ", "), "), .funs = ~ xtile(., ", bins, ", rev = TRUE), .ext = \"", .ext, "\")\n") paste0("## bin variables\n", store_dat, " <- mutate_ext(", dataset, ", .vars = vars(", paste0(vars, collapse = ", "), "), .funs = ~ xtile(., ", bins, ", rev = TRUE), .ext = \"", .ext, "\")\n")
} else { } else {
paste0(i18n$t("## bin variables\n"), store_dat, " <- mutate_ext(", dataset, ", .vars = vars(", paste0(vars, collapse = ", "), "), .funs = ~ xtile(., ", bins, "), .ext = \"", .ext, "\")\n") paste0("## bin variables\n", store_dat, " <- mutate_ext(", dataset, ", .vars = vars(", paste0(vars, collapse = ", "), "), .funs = ~ xtile(., ", bins, "), .ext = \"", .ext, "\")\n")
} }
} }
} }
...@@ -848,9 +804,9 @@ fix_ext <- function(ext) { ...@@ -848,9 +804,9 @@ fix_ext <- function(ext) {
} else { } else {
if (store_dat == "") store_dat <- dataset if (store_dat == "") store_dat <- dataset
if (is.empty(vars)) { if (is.empty(vars)) {
paste0(i18n$t("## created variable to select training sample\n"), store_dat, " <- mutate(", dataset, ", ", name, " = make_train(", n, ", n(), seed = ", seed, "))\n") paste0("## created variable to select training sample\n", store_dat, " <- mutate(", dataset, ", ", name, " = make_train(", n, ", n(), seed = ", seed, "))\n")
} else { } else {
paste0(i18n$t("## created variable to select training sample\n"), store_dat, " <- mutate(", dataset, ", ", name, " = make_train(", n, ", blocks = select(", dataset, ", ", paste0(vars, collapse = ", "), "), seed = ", seed, "))\n") paste0("## created variable to select training sample\n", store_dat, " <- mutate(", dataset, ", ", name, " = make_train(", n, ", blocks = select(", dataset, ", ", paste0(vars, collapse = ", "), "), seed = ", seed, "))\n")
} }
} }
} }
...@@ -868,7 +824,7 @@ fix_ext <- function(ext) { ...@@ -868,7 +824,7 @@ fix_ext <- function(ext) {
} else { } else {
if (store_dat == "") store_dat <- dataset if (store_dat == "") store_dat <- dataset
repl <- if (is.na(repl)) "" else paste0(", repl = \"", repl, "\"") repl <- if (is.na(repl)) "" else paste0(", repl = \"", repl, "\"")
paste0(i18n$t("## change factor levels\n"), store_dat, " <- mutate(", dataset, ", ", name, " = refactor(", fct, ", levs = c(\"", paste0(levs, collapse = "\",\""), "\")", repl, "))\n") paste0("## change factor levels\n", store_dat, " <- mutate(", dataset, ", ", name, " = refactor(", fct, ", levs = c(\"", paste0(levs, collapse = "\",\""), "\")", repl, "))\n")
} }
} }
...@@ -877,7 +833,7 @@ fix_ext <- function(ext) { ...@@ -877,7 +833,7 @@ fix_ext <- function(ext) {
get_data(dataset, vars, filt = "", na.rm = FALSE, envir = r_data) get_data(dataset, vars, filt = "", na.rm = FALSE, envir = r_data)
} else { } else {
if (store_dat == "") store_dat <- dataset if (store_dat == "") store_dat <- dataset
paste0(i18n$t("## reorder/remove variables\n"), store_dat, " <- select(", dataset, ", ", paste0(vars, collapse = ", "), ")\n") paste0("## reorder/remove variables\n", store_dat, " <- select(", dataset, ", ", paste0(vars, collapse = ", "), ")\n")
} }
} }
...@@ -893,7 +849,7 @@ fix_ext <- function(ext) { ...@@ -893,7 +849,7 @@ fix_ext <- function(ext) {
} else { } else {
if (store_dat == "") store_dat <- dataset if (store_dat == "") store_dat <- dataset
if (all(vars == "") || length(unique(vars)) == nr_col) vars <- "." if (all(vars == "") || length(unique(vars)) == nr_col) vars <- "."
paste0(i18n$t("## remove missing values\n"), store_dat, " <- ", dataset, " %>% filter(complete.cases(", paste0(vars, collapse = ", "), "))\n") paste0("## remove missing values\n", store_dat, " <- ", dataset, " %>% filter(complete.cases(", paste0(vars, collapse = ", "), "))\n")
} }
} }
...@@ -907,15 +863,15 @@ fix_ext <- function(ext) { ...@@ -907,15 +863,15 @@ fix_ext <- function(ext) {
} }
if (nrow(dat) == nrow(dataset)) { if (nrow(dat) == nrow(dataset)) {
paste0(i18n$t("No duplicates found (n_distinct = "), nrow(dat), ")") paste0("No duplicates found (n_distinct = ", nrow(dat), ")")
} else { } else {
dat dat
} }
} else { } else {
if (all(vars == "") || length(unique(vars)) == nr_col) { if (all(vars == "") || length(unique(vars)) == nr_col) {
paste0(i18n$t("## remove duplicate rows\n"), store_dat, " <- distinct(", dataset, ")\n") paste0("## remove duplicate rows\n", store_dat, " <- distinct(", dataset, ")\n")
} else { } else {
paste0(i18n$t("## remove rows with duplicate values\n"), store_dat, " <- distinct(", dataset, ", ", paste0(vars, collapse = ", "), ", .keep_all = TRUE)\n") paste0("## remove rows with duplicate values\n", store_dat, " <- distinct(", dataset, ", ", paste0(vars, collapse = ", "), ", .keep_all = TRUE)\n")
} }
} }
} }
...@@ -939,15 +895,15 @@ fix_ext <- function(ext) { ...@@ -939,15 +895,15 @@ fix_ext <- function(ext) {
if (nrow(dat) == 0) { if (nrow(dat) == 0) {
## "No duplicates found" ## "No duplicates found"
paste0(i18n$t("No duplicates found (n_distinct = "), nrow(dataset), ")") paste0("No duplicates found (n_distinct = ", nrow(dataset), ")")
} else { } else {
dat dat
} }
} else { } else {
if (all(vars == "") || length(unique(vars)) == nr_col) { if (all(vars == "") || length(unique(vars)) == nr_col) {
paste0(i18n$t("## show duplicate rows\n"), store_dat, " <- ", dataset, " %>% filter(duplicated(.))\n") paste0("## show duplicate rows\n", store_dat, " <- ", dataset, " %>% filter(duplicated(.))\n")
} else { } else {
paste0(i18n$t("## show rows with duplicate values\n"), store_dat, " <- show_duplicated(", dataset, ", ", paste0(vars, collapse = ", "), ")\n") paste0("## show rows with duplicate values\n", store_dat, " <- show_duplicated(", dataset, ", ", paste0(vars, collapse = ", "), ")\n")
} }
} }
} }
...@@ -955,13 +911,13 @@ fix_ext <- function(ext) { ...@@ -955,13 +911,13 @@ fix_ext <- function(ext) {
.holdout <- function(dataset, vars = "", filt = "", arr = "", rows = NULL, rev = FALSE, .holdout <- function(dataset, vars = "", filt = "", arr = "", rows = NULL, rev = FALSE,
store_dat = "", store = TRUE) { store_dat = "", store = TRUE) {
if (is.empty(filt) && is.empty(rows)) { if (is.empty(filt) && is.empty(rows)) {
return(paste0(i18n$t("No filter or slice found (n = "), nrow(dataset), ")")) return(paste0("No filter or slice found (n = ", nrow(dataset), ")"))
} }
if (!store || !is.character(dataset)) { if (!store || !is.character(dataset)) {
get_data(dataset, vars = vars, filt = filt, arr = arr, rows = rows, na.rm = FALSE, rev = rev, envir = r_data) get_data(dataset, vars = vars, filt = filt, arr = arr, rows = rows, na.rm = FALSE, rev = rev, envir = r_data)
} else { } else {
cmd <- glue("{i18n$t('## create holdout sample')}\n{store_dat} <- get_data(\n {dataset}") # ", vars = {vars}, filt = {filt}, arr = {arr}, rows = {rows}, rev = {rev})\n") cmd <- glue("## create holdout sample\n{store_dat} <- get_data(\n {dataset}") # ", vars = {vars}, filt = {filt}, arr = {arr}, rows = {rows}, rev = {rev})\n")
if (!all(vars == "")) { if (!all(vars == "")) {
cmd <- glue('{cmd},\n vars = c("{paste0(vars, collapse = ", ")}")', .trim = FALSE) cmd <- glue('{cmd},\n vars = c("{paste0(vars, collapse = ", ")}")', .trim = FALSE)
...@@ -988,33 +944,33 @@ transform_main <- reactive({ ...@@ -988,33 +944,33 @@ transform_main <- reactive({
req(input$tr_change_type) req(input$tr_change_type)
if (not_available(input$tr_vars)) { if (not_available(input$tr_vars)) {
if (input$tr_change_type == "none" && length(input$tr_vars) == 0) { if (input$tr_change_type == "none" && length(input$tr_vars) == 0) {
return(i18n$t("Select a transformation type or select variables to summarize")) return("Select a transformation type or select variables to summarize")
} else if (input$tr_change_type == "none" && length(input$tr_vars) > 0) { } else if (input$tr_change_type == "none" && length(input$tr_vars) > 0) {
return(i18n$t("Select a transformation type or select variables to summarize")) return("Select a transformation type or select variables to summarize")
} else if (input$tr_change_type == "type") { } else if (input$tr_change_type == "type") {
return(i18n$t("Select one or more variables to change their type")) return("Select one or more variables to change their type")
} else if (input$tr_change_type == "transform") { } else if (input$tr_change_type == "transform") {
return(i18n$t("Select one or more variables to apply a transformation")) return("Select one or more variables to apply a transformation")
} else if (input$tr_change_type == "rename") { } else if (input$tr_change_type == "rename") {
return(i18n$t("Select one or more variables to rename")) return("Select one or more variables to rename")
} else if (input$tr_change_type == "replace") { } else if (input$tr_change_type == "replace") {
return(i18n$t("Select one or more variables to replace")) return("Select one or more variables to replace")
} else if (input$tr_change_type == "recode") { } else if (input$tr_change_type == "recode") {
return(i18n$t("Select a variable to recode")) return("Select a variable to recode")
} else if (input$tr_change_type == "bin") { } else if (input$tr_change_type == "bin") {
return(i18n$t("Select one or more variables to bin")) return("Select one or more variables to bin")
} else if (input$tr_change_type == "reorg_levs") { } else if (input$tr_change_type == "reorg_levs") {
return(i18n$t("Select a single variable of type factor to change the ordering and/or number of levels")) return("Select a single variable of type factor to change the ordering and/or number of levels")
} else if (input$tr_change_type == "normalize") { } else if (input$tr_change_type == "normalize") {
return(i18n$t("Select one or more variables to normalize")) return("Select one or more variables to normalize")
} else if (input$tr_change_type == "remove_na") { } else if (input$tr_change_type == "remove_na") {
return(i18n$t("Select one or more variables to see the effects of removing missing values")) return("Select one or more variables to see the effects of removing missing values")
} else if (input$tr_change_type %in% c("remove_dup", "show_dup")) { } else if (input$tr_change_type %in% c("remove_dup", "show_dup")) {
return(i18n$t("Select one or more variables to see the effects of removing duplicates")) return("Select one or more variables to see the effects of removing duplicates")
} else if (input$tr_change_type == "gather") { } else if (input$tr_change_type == "gather") {
return(i18n$t("Select one or more variables to gather")) return("Select one or more variables to gather")
} else if (input$tr_change_type == "expand") { } else if (input$tr_change_type == "expand") {
return(i18n$t("Select one or more variables to expand")) return("Select one or more variables to expand")
} }
} }
...@@ -1038,7 +994,7 @@ transform_main <- reactive({ ...@@ -1038,7 +994,7 @@ transform_main <- reactive({
if (input$tr_change_type == "create") { if (input$tr_change_type == "create") {
if (input$tr_create == "") { if (input$tr_create == "") {
return(i18n$t("Specify an equation to create a new variable and press 'return'. **\n** See the help file for examples")) return("Specify an equation to create a new variable and press 'return'. **\n** See the help file for examples")
} else { } else {
return(.create(dat, input$tr_create, byvar = inp_vars("tr_vars"), store = FALSE)) return(.create(dat, input$tr_create, byvar = inp_vars("tr_vars"), store = FALSE))
} }
...@@ -1046,9 +1002,9 @@ transform_main <- reactive({ ...@@ -1046,9 +1002,9 @@ transform_main <- reactive({
if (input$tr_change_type == "tab2dat") { if (input$tr_change_type == "tab2dat") {
if (is.null(input$tr_tab2dat) || input$tr_tab2dat == "none") { if (is.null(input$tr_tab2dat) || input$tr_tab2dat == "none") {
return(i18n$t("Select a frequency variable")) return("Select a frequency variable")
} else if (!is.empty(input$tr_vars) && all(input$tr_vars == input$tr_tab2dat)) { } else if (!is.empty(input$tr_vars) && all(input$tr_vars == input$tr_tab2dat)) {
return(i18n$t("Select at least one variable that is not the frequency variable")) return("Select at least one variable that is not the frequency variable")
} else { } else {
req(available(input$tr_tab2dat)) req(available(input$tr_tab2dat))
return(.tab2dat(dat, input$tr_tab2dat, vars = inp_vars("tr_vars"), store = FALSE)) return(.tab2dat(dat, input$tr_tab2dat, vars = inp_vars("tr_vars"), store = FALSE))
...@@ -1057,13 +1013,13 @@ transform_main <- reactive({ ...@@ -1057,13 +1013,13 @@ transform_main <- reactive({
if (input$tr_change_type == "clip") { if (input$tr_change_type == "clip") {
if (input$tr_paste == "") { if (input$tr_paste == "") {
return(i18n$t("Copy-and-paste data with a header row from a spreadsheet")) return("Copy-and-paste data with a header row from a spreadsheet")
} else { } else {
cpdat <- try(read.table(header = TRUE, comment.char = "", fill = TRUE, sep = "\t", as.is = TRUE, text = input$tr_paste), silent = TRUE) cpdat <- try(read.table(header = TRUE, comment.char = "", fill = TRUE, sep = "\t", as.is = TRUE, text = input$tr_paste), silent = TRUE)
if (inherits(cpdat, "try-error")) { if (inherits(cpdat, "try-error")) {
return(i18n$t("The pasted data was not well formatted. Please make sure the number of rows **\n** in the data in Radiant and in the spreadsheet are the same and try again.")) return("The pasted data was not well formatted. Please make sure the number of rows **\n** in the data in Radiant and in the spreadsheet are the same and try again.")
} else if (nrow(cpdat) != nrow(dat)) { } else if (nrow(cpdat) != nrow(dat)) {
return(i18n$t("The pasted data does not have the correct number of rows. Please make sure **\n** the number of rows in the data in Radiant and in the spreadsheet are the **\n** same and try again.")) return("The pasted data does not have the correct number of rows. Please make sure **\n** the number of rows in the data in Radiant and in the spreadsheet are the **\n** same and try again.")
} else { } else {
return(as.data.frame(cpdat, check.names = FALSE, stringsAsFactors = FALSE) %>% to_fct()) return(as.data.frame(cpdat, check.names = FALSE, stringsAsFactors = FALSE) %>% to_fct())
} }
...@@ -1073,7 +1029,7 @@ transform_main <- reactive({ ...@@ -1073,7 +1029,7 @@ transform_main <- reactive({
## filter data for holdout ## filter data for holdout
if (input$tr_change_type == "holdout") { if (input$tr_change_type == "holdout") {
if (!input$show_filter) { if (!input$show_filter) {
return(i18n$t("\nNo filter, arrange, or slice set. Click the 'Filter' checkbox and enter a\nfilter, arrange, and/or a slice of rows to keep as the main data. The holdout\nwill have have all rows not selected by the filter, arrange, and slice")) return("\nNo filter, arrange, or slice set. Click the 'Filter' checkbox and enter a\nfilter, arrange, and/or a slice of rows to keep as the main data. The holdout\nwill have have all rows not selected by the filter, arrange, and slice")
} }
return(.holdout(dat, inp_vars("tr_vars"), filt = input$data_filter, arr = input$data_arrange, rows = input$data_rows, rev = input$tr_holdout_rev, store = FALSE)) return(.holdout(dat, inp_vars("tr_vars"), filt = input$data_filter, arr = input$data_arrange, rows = input$data_rows, rev = input$tr_holdout_rev, store = FALSE))
} }
...@@ -1082,7 +1038,7 @@ transform_main <- reactive({ ...@@ -1082,7 +1038,7 @@ transform_main <- reactive({
if (input$tr_change_type == "spread") { if (input$tr_change_type == "spread") {
if (is.empty(input$tr_spread_key, "none") || if (is.empty(input$tr_spread_key, "none") ||
is.empty(input$tr_spread_value, "none")) { is.empty(input$tr_spread_value, "none")) {
return(i18n$t("Select a Key and Value pair to spread")) return("Select a Key and Value pair to spread")
} }
return(.spread(dat, key = input$tr_spread_key, value = input$tr_spread_value, fill = input$tr_spread_fill, vars = inp_vars("tr_vars"), store = FALSE)) return(.spread(dat, key = input$tr_spread_key, value = input$tr_spread_value, fill = input$tr_spread_fill, vars = inp_vars("tr_vars"), store = FALSE))
} }
...@@ -1106,7 +1062,7 @@ transform_main <- reactive({ ...@@ -1106,7 +1062,7 @@ transform_main <- reactive({
## gather variables ## gather variables
if (input$tr_change_type == "gather") { if (input$tr_change_type == "gather") {
if (is.empty(input$tr_gather_key) || is.empty(input$tr_gather_value)) { if (is.empty(input$tr_gather_key) || is.empty(input$tr_gather_value)) {
return(i18n$t("Provide a name for the Key and Value variables")) return("Provide a name for the Key and Value variables")
} }
return(.gather(dat, inp_vars("tr_vars"), key = input$tr_gather_key, value = input$tr_gather_value, store = FALSE)) return(.gather(dat, inp_vars("tr_vars"), key = input$tr_gather_key, value = input$tr_gather_value, store = FALSE))
} }
...@@ -1128,7 +1084,7 @@ transform_main <- reactive({ ...@@ -1128,7 +1084,7 @@ transform_main <- reactive({
if (input$tr_change_type == "normalize") { if (input$tr_change_type == "normalize") {
if (is.empty(input$tr_normalizer, "none")) { if (is.empty(input$tr_normalizer, "none")) {
return(i18n$t("Select a normalizing variable")) return("Select a normalizing variable")
} else { } else {
return(.normalize(dat, inp_vars("tr_vars"), input$tr_normalizer, .ext = input$tr_ext_nz, store = FALSE)) return(.normalize(dat, inp_vars("tr_vars"), input$tr_normalizer, .ext = input$tr_ext_nz, store = FALSE))
} }
...@@ -1139,14 +1095,11 @@ transform_main <- reactive({ ...@@ -1139,14 +1095,11 @@ transform_main <- reactive({
rpl <- input$tr_replace rpl <- input$tr_replace
if (available(rpl)) { if (available(rpl)) {
if (length(vars) != length(rpl)) { if (length(vars) != length(rpl)) {
return(i18n$t( return(paste0("The number of replacement variables (", length(rpl), ") is not equal to the number of variables to replace (", length(vars), ")"))
"The number of replacement variables ({rpl_len}) is not equal to the number of variables to replace ({vars_len})",
list(rpl_len = length(rpl), vars_len = length(vars))
))
} }
return(.replace(dat, vars, rpl, store = FALSE)) return(.replace(dat, vars, rpl, store = FALSE))
} else { } else {
return(i18n$t("Select one or more variable replacements")) return("Select one or more variable replacements")
} }
} }
...@@ -1157,7 +1110,7 @@ transform_main <- reactive({ ...@@ -1157,7 +1110,7 @@ transform_main <- reactive({
## change in type is always done in-place ## change in type is always done in-place
if (input$tr_change_type == "type") { if (input$tr_change_type == "type") {
if (input$tr_typefunction == "none") { if (input$tr_typefunction == "none") {
return(i18n$t("Select a transformation type for the selected variables")) return("Select a transformation type for the selected variables")
} else { } else {
if (input$tr_typefunction == "ts") { if (input$tr_typefunction == "ts") {
tr_ts <- list( tr_ts <- list(
...@@ -1175,7 +1128,7 @@ transform_main <- reactive({ ...@@ -1175,7 +1128,7 @@ transform_main <- reactive({
## change in type is always done in-place ## change in type is always done in-place
if (input$tr_change_type == "transform") { if (input$tr_change_type == "transform") {
if (input$tr_transfunction == "none") { if (input$tr_transfunction == "none") {
return(i18n$t("Select a function to apply to the selected variable(s)")) return("Select a function to apply to the selected variable(s)")
} else { } else {
return(.transform(dat, input$tr_transfunction, inp_vars("tr_vars"), input$tr_ext, store = FALSE)) return(.transform(dat, input$tr_transfunction, inp_vars("tr_vars"), input$tr_ext, store = FALSE))
} }
...@@ -1184,7 +1137,7 @@ transform_main <- reactive({ ...@@ -1184,7 +1137,7 @@ transform_main <- reactive({
if (input$tr_change_type == "reorg_levs") { if (input$tr_change_type == "reorg_levs") {
fct <- input$tr_vars[1] fct <- input$tr_vars[1]
if (length(unique(dat[[fct]])) > 100) { if (length(unique(dat[[fct]])) > 100) {
return(i18n$t("Interactive re-ordering is only supported up to 100 levels. See\n?radiant.data::refactor for information on how to re-order levels in R")) return("Interactive re-ordering is only supported up to 100 levels. See\n?radiant.data::refactor for information on how to re-order levels in R")
} else { } else {
return(.reorg_levs(dat, fct, input$tr_reorg_levs, input$tr_rorepl, input$tr_roname, store = FALSE)) return(.reorg_levs(dat, fct, input$tr_reorg_levs, input$tr_rorepl, input$tr_roname, store = FALSE))
} }
...@@ -1192,7 +1145,7 @@ transform_main <- reactive({ ...@@ -1192,7 +1145,7 @@ transform_main <- reactive({
if (input$tr_change_type == "recode") { if (input$tr_change_type == "recode") {
if (is.empty(input$tr_recode)) { if (is.empty(input$tr_recode)) {
return(i18n$t("Specify a recode statement, assign a name to the recoded variable, and press 'return'. **\n** See the help file for examples")) return("Specify a recode statement, assign a name to the recoded variable, and press 'return'. **\n** See the help file for examples")
} else { } else {
return(.recode(dat, inp_vars("tr_vars")[1], input$tr_recode, input$tr_rcname, store = FALSE)) return(.recode(dat, inp_vars("tr_vars")[1], input$tr_recode, input$tr_rcname, store = FALSE))
} }
...@@ -1200,10 +1153,10 @@ transform_main <- reactive({ ...@@ -1200,10 +1153,10 @@ transform_main <- reactive({
if (input$tr_change_type == "rename") { if (input$tr_change_type == "rename") {
if (is.empty(input$tr_rename)) { if (is.empty(input$tr_rename)) {
return(i18n$t("Specify new names for the selected variables (separated by a ',') and press 'return'")) return("Specify new names for the selected variables (separated by a ',') and press 'return'")
} else { } else {
if (any(input$tr_rename %in% varnames())) { if (any(input$tr_rename %in% varnames())) {
return(i18n$t("One or more of the new variables names already exists in the data. **\n** Change the specified names or use the Replace function")) return("One or more of the new variables names already exists in the data. **\n** Change the specified names or use the Replace function")
} else { } else {
return(.rename(dat, inp_vars("tr_vars"), input$tr_rename, store = FALSE)) return(.rename(dat, inp_vars("tr_vars"), input$tr_rename, store = FALSE))
} }
...@@ -1230,7 +1183,7 @@ tr_snippet <- reactive({ ...@@ -1230,7 +1183,7 @@ tr_snippet <- reactive({
output$transform_summary <- renderPrint({ output$transform_summary <- renderPrint({
req(!isTRUE(input$tr_hide)) req(!isTRUE(input$tr_hide))
withProgress(message = i18n$t("Generating summary statistics"), value = 1, { withProgress(message = "Generating summary statistics", value = 1, {
dataset <- transform_main() dataset <- transform_main()
}) })
...@@ -1242,21 +1195,21 @@ output$transform_summary <- renderPrint({ ...@@ -1242,21 +1195,21 @@ output$transform_summary <- renderPrint({
cat("**", dataset, "\n**\n\n") cat("**", dataset, "\n**\n\n")
} else { } else {
if (min(dim(dataset)) == 0) { if (min(dim(dataset)) == 0) {
cat("**", i18n$t("The selected operation resulted in an empty data frame and cannot be executed"), "**\n\n") cat("** The selected operation resulted in an empty data frame and cannot be executed **\n\n")
} else { } else {
if (input$tr_change_type %in% c("", "none")) { if (input$tr_change_type %in% c("", "none")) {
cat("**", i18n$t("Select a transformation type or select variables to summarize"), "**\n\n") cat("** Select a transformation type or select variables to summarize **\n\n")
} else { } else {
cat("**", i18n$t("Press the 'Store' button to add your changes to the data"), "**\n\n") cat("** Press the 'Store' button to add your changes to the data **\n\n")
if (!is.empty(input$tr_vars) && input$tr_change_type == "create") { if (!is.empty(input$tr_vars) && input$tr_change_type == "create") {
cat("**", i18n$t("Results are grouped by"), paste(input$tr_vars, collapse = ", "), "**\n\n") cat("** Results are grouped by", paste(input$tr_vars, collapse = ", "), "**\n\n")
} else if (!is.empty(input$tr_vars) && input$tr_change_type == "training") { } else if (!is.empty(input$tr_vars) && input$tr_change_type == "training") {
cat("**", i18n$t("Results are blocked by"), paste(input$tr_vars, collapse = ", "), "**\n\n") cat("** Results are blocked by", paste(input$tr_vars, collapse = ", "), "**\n\n")
} }
} }
if (input$tr_change_type == "reorg_vars") { if (input$tr_change_type == "reorg_vars") {
cat("**", i18n$t("Drag-and-drop to change ordering. Click the x to remove a variable"), "**") cat("** Drag-and-drop to change ordering. Click the x to remove a variable **")
} else { } else {
cat(paste0(capture.output(get_summary(dataset)), collapse = "\n")) cat(paste0(capture.output(get_summary(dataset)), collapse = "\n"))
} }
...@@ -1293,18 +1246,18 @@ observeEvent(input$tr_store, { ...@@ -1293,18 +1246,18 @@ observeEvent(input$tr_store, {
## adding command to ensure new data is in the datasetlist ## adding command to ensure new data is in the datasetlist
if (df_name == input$dataset) { if (df_name == input$dataset) {
ncmd <- paste0("\n", i18n$t("## register the new dataset"), "\nregister(\"", df_name, "\")") ncmd <- paste0("\n## register the new dataset\nregister(\"", df_name, "\")")
} else { } else {
ncmd <- paste0("\n", i18n$t("## register the new dataset"), "\nregister(\"", df_name, "\", \"", input$dataset, "\")") ncmd <- paste0("\n## register the new dataset\nregister(\"", df_name, "\", \"", input$dataset, "\")")
} }
} else if (!df_name %in% r_info[["datasetlist"]]) { } else if (!df_name %in% r_info[["datasetlist"]]) {
r_info[["datasetlist"]] %<>% c(df_name, .) %>% unique() r_info[["datasetlist"]] %<>% c(df_name, .) %>% unique()
## adding command to ensure new data is in the datasetlist ## adding command to ensure new data is in the datasetlist
if (df_name == input$dataset) { if (df_name == input$dataset) {
ncmd <- paste0("\n", i18n$t("## register the new dataset"), "\nregister(\"", df_name, "\")") ncmd <- paste0("\n## register the new dataset\nregister(\"", df_name, "\")")
} else { } else {
ncmd <- paste0("\n", i18n$t("## register the new dataset"), "\nregister(\"", df_name, "\", \"", input$dataset, "\")") ncmd <- paste0("\n## register the new dataset\nregister(\"", df_name, "\", \"", input$dataset, "\")")
} }
} }
...@@ -1376,12 +1329,7 @@ observeEvent(input$tr_store, { ...@@ -1376,12 +1329,7 @@ observeEvent(input$tr_store, {
r_data[[df_name]][, colnames(dat)] <- dat r_data[[df_name]][, colnames(dat)] <- dat
r_data[[df_name]][, input$tr_replace] <- list(NULL) r_data[[df_name]][, input$tr_replace] <- list(NULL)
} else if (input$tr_change_type == "clip") { } else if (input$tr_change_type == "clip") {
cmd <- paste0( cmd <- paste0("## using the clipboard for data transformation may seem convenient]\n## but it is not 'reproducible' - no command generated\n")
i18n$t("## using the clipboard for data transformation may seem convenient"),
"\n",
i18n$t("## but it is not 'reproducible' - no command generated"),
"\n"
)
r_data[[df_name]][, colnames(dat)] <- dat r_data[[df_name]][, colnames(dat)] <- dat
} }
...@@ -1399,18 +1347,14 @@ observeEvent(input$tr_store, { ...@@ -1399,18 +1347,14 @@ observeEvent(input$tr_store, {
if (input$dataset != df_name) { if (input$dataset != df_name) {
showModal( showModal(
modalDialog( modalDialog(
title = i18n$t("Data Stored"), title = "Data Stored",
span( span(
i18n$t( paste0("Dataset '", df_name, "' was successfully added to
paste0( the datasets dropdown. Add code to Report > Rmd or
"Dataset '", df_name, "' was successfully added to ", Report > R to (re)create the results by clicking the
"the datasets dropdown. Add code to Report > Rmd or ", report icon on the bottom left of your screen.")
"Report > R to (re)create the results by clicking the ",
"report icon on the bottom left of your screen."
)
)
), ),
footer = modalButton(i18n$t("OK")), footer = modalButton("OK"),
size = "m", size = "m",
easyClose = TRUE easyClose = TRUE
) )
......
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