## UI-elements for transform
output$ui_tr_vars <- renderUI({
vars <- varnames()
req(available(vars))
selectInput(
"tr_vars", i18n$t("Select variable(s):"),
choices = vars,
multiple = TRUE,
size = min(8, length(vars)),
selectize = FALSE
)
})
output$ui_tr_replace <- renderUI({
validate(
need(available(input$tr_vars), i18n$t("Select one or more variables to replace"))
)
vars <- varnames()
selectInput(
"tr_replace", i18n$t("Select replacement variables:"),
choices = vars,
multiple = TRUE, size = min(2, length(vars)), selectize = FALSE
)
})
output$ui_tr_normalizer <- renderUI({
isNum <- .get_class() %in% c("numeric", "integer", "ts")
vars <- varnames()[isNum]
if (length(vars) == 0) {
return()
}
selectInput(
"tr_normalizer", i18n$t("Normalizing variable:"),
choices = setNames(
c("none", vars),
c(i18n$t("None"), vars)
),
selected = "none"
)
})
output$ui_tr_tab2dat <- renderUI({
isNum <- .get_class() %in% c("numeric", "integer", "ts")
vars <- varnames()[isNum]
selectInput(
"tr_tab2dat", i18n$t("Frequency variable:"),
choices = setNames(
c("none", vars),
c(i18n$t("None"), vars)
),
selected = "none"
)
})
output$ui_tr_gather <- renderUI({
tagList(
tags$table(
tags$td(returnTextInput("tr_gather_key", i18n$t("Key name:"), value = "key")),
tags$td(returnTextInput("tr_gather_value", i18n$t("Value name:"), value = "value"))
)
)
})
output$ui_tr_spread <- renderUI({
req(input$tr_change_type)
vars <- c("None" = "none", varnames())
tagList(
selectizeInput(
"tr_spread_key", i18n$t("Key(s):"),
choices = vars[-1],
selected = NULL, multiple = TRUE,
options = list(placeholder = i18n$t("None"), plugins = list("remove_button", "drag_drop"))
),
selectInput("tr_spread_value", i18n$t("Value:"), choices = vars, selected = "none", multiple = FALSE),
numericInput("tr_spread_fill", i18n$t("Fill:"), value = NA)
)
})
output$ui_tr_reorg_vars <- renderUI({
req(input$tr_change_type)
vars <- varnames()
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"))
)
selectizeInput(
"tr_reorg_vars", i18n$t("Reorder/remove variables:"),
choices = vars,
selected = vars, multiple = TRUE,
options = list(placeholder = i18n$t("Select variable(s)"), plugins = list("remove_button", "drag_drop"))
)
})
output$ui_tr_reorg_levs <- renderUI({
req(input$tr_change_type)
validate(
need(available(input$tr_vars), i18n$t("Select a single variable of type factor or character"))
)
fctCol <- input$tr_vars[1]
fct <- .get_data_transform()[[fctCol]]
levs <- if (is.factor(fct)) levels(fct) else levels(as_factor(fct))
validate(
need(length(levs) < 101, i18n$t("Interactive re-ordering is only supported up to 100 levels. See ?radiant.data::refactor for information on how to re-order levels in R"))
)
tagList(
selectizeInput(
"tr_reorg_levs", i18n$t("Reorder/remove levels:"),
choices = levs,
selected = levs, multiple = TRUE,
options = list(placeholder = i18n$t("Select level(s)"), plugins = list("remove_button", "drag_drop"))
),
textInput(
"tr_rorepl", i18n$t("Replacement level name:"),
placeholder = i18n$t("Provide name for missing levels"),
value = NA
)
)
})
transform_auto_complete <- reactive({
req(input$dataset)
comps <- list(r_info[["datasetlist"]][input$dataset], as.vector(varnames()))
names(comps) <- c("{datasets}", paste0("{", input$dataset, "}"))
comps
})
output$ui_tr_log <- renderUI({
tagList(
HTML(paste0("
")),
shinyAce::aceEditor(
"tr_log",
mode = "r",
theme = getOption("radiant.ace_theme", default = "tomorrow"),
wordWrap = TRUE,
debounce = 0,
value = state_init("tr_log", "") %>% fix_smart(),
vimKeyBinding = getOption("radiant.ace_vim.keys", default = FALSE),
tabSize = getOption("radiant.ace_tabSize", 2),
useSoftTabs = getOption("radiant.ace_useSoftTabs", TRUE),
showInvisibles = getOption("radiant.ace_showInvisibles", FALSE),
autoScrollEditorIntoView = TRUE,
autoComplete = getOption("radiant.ace_autoComplete", "enable"),
autoCompleters = c("static", "rlang"),
autoCompleteList = isolate(transform_auto_complete()),
minLines = 5,
maxLines = 15
)
)
})
transform_annotater <- shinyAce::aceAnnotate("tr_log")
transform_tooltip <- shinyAce::aceTooltip("tr_log")
transform_ac <- shinyAce::aceAutocomplete("tr_log")
observe({
shinyAce::updateAceEditor(
session, "tr_log",
autoCompleters = c("static", "rlang"),
autoCompleteList = transform_auto_complete()
)
})
ext_options <- list(
"none" = "", "log" = "_ln", "exp" = "_exp",
"square" = "_sq", "sqrt" = "_sqrt", "center" = "_ct",
"standardize" = "_st", "inverse" = "_inv"
)
output$ui_tr_ext <- renderUI({
trfun <- input$tr_transfunction
if (is.empty(trfun)) trfun <- "none"
returnTextInput(
"tr_ext", i18n$t("Variable name extension:"),
value = ext_options[[trfun]]
)
})
output$ui_tr_ext_nz <- renderUI({
if (is.empty(input$tr_normalizer, "none")) {
return()
}
returnTextInput(
"tr_ext_nz", i18n$t("Variable name extension:"),
value = paste0("_", input$tr_normalizer)
)
})
output$ui_tr_rcname <- renderUI({
if (is.empty(input$tr_vars)) {
return()
}
returnTextInput(
"tr_rcname", i18n$t("Recoded variable name:"),
value = paste0(input$tr_vars[1], "_rc")
)
})
output$ui_tr_ext_bin <- renderUI({
if (is.empty(input$tr_vars)) {
return()
}
returnTextInput(
"tr_ext_bin", i18n$t("Variable name extension:"),
value = "_dec"
)
})
output$ui_tr_roname <- renderUI({
if (is.empty(input$tr_vars)) {
return()
}
returnTextInput(
"tr_roname", i18n$t("Variable name:"),
value = input$tr_vars[1]
)
})
output$ui_tr_typename <- renderUI({
if (is.empty(input$tr_vars)) {
return()
}
returnTextInput(
"tr_typename", i18n$t("Variable name extension:"),
value = "",
placeholder = i18n$t("Add extension to variable name")
)
})
output$ui_tr_rename <- renderUI({
validate(
need(available(input$tr_vars), i18n$t("Select one or more variables to rename"))
)
if (length(input$tr_vars) < 2) {
mess <- i18n$t("Type a new name for the selected variable and press return")
} else {
mess <- i18n$t("Type new names for the selected variables, separated by a , and press return")
}
returnTextAreaInput(
"tr_rename", i18n$t("Rename variable(s):"),
value = "",
rows = 3,
placeholder = mess
)
})
output$ui_tr_dataset <- renderUI({
tr_dataset <- input$dataset
if (input$tr_change_type == "show_dup") {
tr_dataset <- paste0(tr_dataset, "_dup")
} else if (input$tr_change_type == "holdout") {
tr_dataset <- paste0(tr_dataset, "_holdout")
} else if (input$tr_change_type == "tab2dat") {
tr_dataset <- paste0(tr_dataset, "_dat")
} else if (input$tr_change_type == "gather") {
tr_dataset <- paste0(tr_dataset, "_gathered")
} else if (input$tr_change_type == "spread") {
tr_dataset <- paste0(tr_dataset, "_spread")
} else if (input$tr_change_type == "expand") {
tr_dataset <- paste0(tr_dataset, "_expand")
}
tags$table(
tags$td(textInput("tr_name", i18n$t("Store changes in:"), tr_dataset)),
tags$td(actionButton("tr_store", i18n$t("Store"), icon = icon("plus", verify_fa = FALSE), class = "btn-success"), class = "top")
)
})
trans_options <- setNames(
c("none", "log", "exp", "square", "sqrt", "center", "standardize", "inverse"),
c(
i18n$t("None"),
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(
c(
"none", "as_factor", "as_numeric", "as_integer", "as_character", "ts",
"as_mdy", "as_dmy", "as_ymd",
"as_mdy_hms", "as_mdy_hm", "as_dmy_hms", "as_dmy_hm",
"as_ymd_hms", "as_ymd_hm"
),
c(
i18n$t("None"),
i18n$t("As factor"),
i18n$t("As numeric"),
i18n$t("As integer"),
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(
` ` = i18n$t("None (summarize)"),
`Change variable(s)` = setNames(
c("Bin", "Change type", "Normalize", "Recode", "Remove/reorder levels", "Rename", "Replace", "Transform"),
c(i18n$t("Bin"), i18n$t("Change type"), i18n$t("Normalize"), i18n$t("Recode"),
i18n$t("Remove/reorder levels"), i18n$t("Rename"), i18n$t("Replace"), i18n$t("Transform"))
),
`Create new variable(s)` = setNames(
c("Clipboard", "Create"),
c(i18n$t("Clipboard"), i18n$t("Create"))
),
`Clean data` = setNames(
c("Remove missing values", "Remove/reorder variables", "Remove duplicates", "Show duplicates"),
c(i18n$t("Remove missing values"), i18n$t("Remove/reorder variables"), i18n$t("Remove duplicates"), i18n$t("Show duplicates"))
),
`Expand data` = setNames(
c("Expand grid", "Table‑to‑data"),
c(i18n$t("Expand grid"), i18n$t("Table‑to‑data"))
),
`Split data` = setNames(
c("Holdout sample", "Training variable"),
c(i18n$t("Holdout sample"), i18n$t("Training variable"))
),
`Tidy data` = setNames(
c("Gather columns", "Spread column"),
c(i18n$t("Gather columns"), i18n$t("Spread column"))
)
)
output$ui_Transform <- renderUI({
## Inspired by Ian Fellow's transform ui in JGR/Deducer
tagList(
wellPanel(
checkboxInput("tr_hide", i18n$t("Hide summaries"), state_init("tr_hide", FALSE)),
uiOutput("ui_tr_vars"),
selectizeInput("tr_change_type", i18n$t("Transformation type:"), trans_types, selected = "none"),
conditionalPanel(
condition = "input.tr_change_type == 'type'",
selectInput("tr_typefunction", i18n$t("Change variable type:"), type_options, selected = "none"),
conditionalPanel(
condition = "input.tr_typefunction == 'ts'",
tags$table(
tags$td(numericInput("tr_ts_start_year", label = i18n$t("Start year:"), min = 1, value = NA)),
tags$td(numericInput("tr_ts_start_period", label = i18n$t("Start period:"), min = 1, value = 1))
),
tags$table(
tags$td(numericInput("tr_ts_end_year", label = i18n$t("End year:"), value = NA)),
tags$td(numericInput("tr_ts_end_period", label = i18n$t("End period:"), value = NA))
),
numericInput("tr_ts_frequency", label = i18n$t("Frequency:"), min = 1, value = 52)
)
),
conditionalPanel(
condition = "input.tr_change_type == 'transform'",
selectInput("tr_transfunction", i18n$t("Apply function:"), trans_options)
),
conditionalPanel(
condition = "input.tr_change_type == 'normalize'",
uiOutput("ui_tr_normalizer")
),
conditionalPanel(
condition = "input.tr_change_type == 'tab2dat'",
uiOutput("ui_tr_tab2dat")
),
conditionalPanel(
condition = "input.tr_change_type == 'gather'",
uiOutput("ui_tr_gather")
),
conditionalPanel(
condition = "input.tr_change_type == 'spread'",
uiOutput("ui_tr_spread")
),
conditionalPanel(
condition = "input.tr_change_type == 'create'",
returnTextAreaInput(
"tr_create", i18n$t("Create:"),
rows = 3,
placeholder = i18n$t("Type a formula to create a new variable (e.g., x = y - z) and press return")
)
),
conditionalPanel(
condition = "input.tr_change_type == 'bin'",
numericInput("tr_bin_n", label = i18n$t("Nr bins:"), min = 2, value = 10),
checkboxInput("tr_bin_rev", i18n$t("Reverse order"), value = FALSE),
uiOutput("ui_tr_ext_bin")
),
conditionalPanel(
condition = "input.tr_change_type == 'training'",
tags$table(
tags$td(numericInput("tr_training_n", label = i18n$t("Size:"), min = 0, value = .7)),
tags$td(textInput("tr_training", i18n$t("Variable name:"), "training"))
),
numericInput("tr_training_seed", label = i18n$t("Seed:"), value = 1234)
),
conditionalPanel(
condition = "input.tr_change_type == 'holdout'",
checkboxInput("tr_holdout_rev", i18n$t("Reverse filter and slice"), value = TRUE)
),
conditionalPanel(
condition = "input.tr_change_type == 'clip'",
textAreaInput(
"tr_paste", i18n$t("Paste from spreadsheet:"),
rows = 3,
value = "",
resize = "vertical",
placeholder = i18n$t("Copy-and-paste data with a header row from a spreadsheet"),
)
),
conditionalPanel(
condition = "input.tr_change_type == 'recode'",
returnTextAreaInput(
"tr_recode", i18n$t("Recode:"),
value = "",
rows = 3,
placeholder = i18n$t("Select a variable, specify how it should be recoded (e.g., lo:20 = 0; else = 1), and press return")
)
),
conditionalPanel(
condition = "input.tr_change_type == 'rename'",
uiOutput("ui_tr_rename")
),
conditionalPanel(
condition = "input.tr_change_type == 'replace'",
uiOutput("ui_tr_replace")
),
conditionalPanel(
condition = "input.tr_change_type == 'reorg_vars'",
uiOutput("ui_tr_reorg_vars")
),
conditionalPanel(
condition = "input.tr_change_type == 'reorg_levs'",
uiOutput("ui_tr_reorg_levs")
),
conditionalPanel(
"input.tr_change_type == 'transform'",
uiOutput("ui_tr_ext")
),
conditionalPanel(
"input.tr_change_type == 'recode'",
uiOutput("ui_tr_rcname")
),
conditionalPanel(
"input.tr_change_type == 'normalize'",
uiOutput("ui_tr_ext_nz")
),
conditionalPanel(
"input.tr_change_type == 'reorg_levs'",
uiOutput("ui_tr_roname")
),
conditionalPanel(
"input.tr_change_type == 'type'",
uiOutput("ui_tr_typename")
)
),
conditionalPanel(
"input.tr_change_type != 'none'",
wellPanel(uiOutput("ui_tr_dataset"))
),
help_and_report(
modal_title = i18n$t("Transform"),
fun_name = "transform",
help_file = inclMD(file.path(getOption("radiant.path.data"), "app/tools/help/transform.md")),
lic = "by-sa"
)
)
})
## ensure no variables are selected 'by accident' when creating a new variable
observeEvent(input$tr_change_type, {
if (input$tr_change_type == "create") {
updateSelectInput(session = session, inputId = "tr_vars", label = i18n$t("Group by:"), selected = character(0))
} else if (input$tr_change_type == "training") {
updateSelectInput(session = session, inputId = "tr_vars", label = i18n$t("Block by:"), selected = character(0))
} else if (input$tr_change_type == "spread") {
updateSelectInput(session = session, inputId = "tr_vars", selected = character(0))
} else {
updateSelectInput(session = session, inputId = "tr_vars", label = i18n$t("Select variables:"))
}
})
fix_ext <- function(ext) {
gsub("(^\\s+|\\s+$)", "", ext) %>%
gsub("\\s+", "_", .) %>%
gsub("[[:punct:]]", "_", .) %>%
gsub("\\.{2,}", ".", .) %>%
gsub("_{2,}", "_", .)
}
.change_type <- function(dataset, fun, tr_ts, vars = "", .ext = "",
store_dat = "", store = TRUE) {
.ext <- fix_ext(.ext)
if (!is.empty(tr_ts)) {
tr_ts <- lapply(tr_ts, function(x) x[!is.na(x)]) %>%
(function(x) x[sapply(x, length) > 0])
}
if (!store || !is.character(dataset)) {
fun <- get(fun)
if (is.empty(.ext)) {
do.call(mutate_at, c(list(.tbl = dataset, .vars = vars), .funs = fun, tr_ts))
} else {
do.call(mutate_at, c(list(.tbl = dataset, .vars = vars), .funs = fun, tr_ts)) %>%
set_colnames(paste0(vars, .ext))
}
} else {
if (store_dat == "") store_dat <- dataset
if (is.empty(tr_ts)) {
tr_ts <- ""
} else {
tr_ts <- deparse(tr_ts, control = getOption("dctrl"), width.cutoff = 500L) %>%
sub("list\\(", ", ", .) %>%
sub("\\)$", "", .)
}
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")
} 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")
}
}
}
.transform <- function(dataset, fun, vars = "", .ext = "",
store_dat = "", store = TRUE) {
.ext <- fix_ext(.ext)
if (!store && !is.character(dataset)) {
fun <- get(fun)
if (is.empty(.ext)) {
result <- try(mutate_at(dataset, .vars = vars, .funs = fun), silent = TRUE)
} else {
result <- try(mutate_at(dataset, .vars = vars, .funs = fun) %>% set_colnames(paste0(vars, .ext)), silent = TRUE)
}
if (inherits(result, "try-error")) {
paste0(
"\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 {
result
}
} else {
if (store_dat == "") store_dat <- dataset
if (is.empty(.ext)) {
paste0(i18n$t("## transform variable\n"), store_dat, " <- mutate_at(", dataset, ", .vars = vars(", paste0(vars, collapse = ", "), "), .funs = ", fun, ")\n")
} else {
paste0(i18n$t("## transform variable\n"), store_dat, " <- mutate_ext(", dataset, ", .vars = vars(", paste0(vars, collapse = ", "), "), .funs = ", fun, ", .ext = \"", .ext, "\")\n")
}
}
}
.create <- function(dataset, cmd, byvar = "",
store_dat = "", store = TRUE) {
## replacing problem symbols (e.g., em dash, and curly quotes)
cmd <- fix_smart(cmd)
if (!store || !is.character(dataset)) {
if (is.empty(cmd)) {
return(dataset)
}
cmd <- gsub("\"", "\'", cmd) %>%
gsub("<-", "=", .)
vars <- strsplit(cmd, ";\\s*")[[1]] %>%
strsplit("=") %>%
sapply("[", 1) %>%
gsub("\\s+", "", .)
## in case the create command tries to over-write the group-by variable ...
if (any(byvar %in% vars)) {
byvar <- base::setdiff(byvar, vars)
updateSelectInput(session = session, inputId = "tr_vars", selected = character(0))
}
## useful if functions created in Report > R and Report > Rmd are
## called in Data > Transform > Create
## add environment to do.call call instead?
## https://stackoverflow.com/questions/26028488/do-call-specify-environment-inside-function
attach(r_data)
on.exit(detach(r_data))
if (is.empty(byvar)) {
## using within and do.call because it provides better err messages
nvar <- try(do.call(within, list(dataset, parse(text = cmd))), silent = TRUE)
} else {
dots <- rlang::parse_exprs(cmd) %>%
set_names(vars)
nvar <- try(
group_by_at(dataset, .vars = byvar) %>%
mutate(!!!dots),
silent = TRUE
)
vars <- c(byvar, vars) ## to avoid the 'added group_by variable' message
}
if (inherits(nvar, "try-error")) {
paste0(
"\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 {
select_at(nvar, .vars = vars) %>%
ungroup()
}
} else {
if (store_dat == "") store_dat <- dataset
cmd <- gsub(";", ", ", cmd) %>%
gsub("<-", "=", .) %>%
gsub("\\s{2,}", " ", .)
if (is.empty(byvar)) {
paste0(i18n$t("## create new variable(s)\n"), store_dat, " <- mutate(", dataset, ", ", cmd, ")\n")
} else {
paste0(i18n$t("## create new variable(s)\n"), store_dat, " <- group_by(", dataset, ", ", paste0(byvar, collapse = ", "), ") %>%\n mutate(", cmd, ") %>%\n ungroup()\n")
}
}
}
.recode <- function(dataset, var, cmd, rcname = "",
store_dat = "", store = TRUE) {
cmd <- cmd %>%
gsub("\\n", "", .) %>%
gsub("\"", "\'", .)
if (is.empty(rcname)) rcname <- paste0(var, "_rc")
if (!store || !is.character(dataset)) {
if (cmd == "") {
return(dataset)
}
nvar <- try(car::Recode(dataset[[var]], cmd), silent = TRUE)
if (inherits(nvar, "try-error")) {
paste0(
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 {
as.data.frame(nvar, stringsAsFactors = FALSE) %>% setNames(rcname)
}
} else {
if (store_dat == "") store_dat <- dataset
paste0(i18n$t("## recode variable\n"), store_dat, " <- mutate(", dataset, ", ", rcname, " = car::Recode(", var, ", \"", cmd, "\"))\n")
}
}
.rename <- function(dataset, var, rnm, store_dat = "", store = TRUE) {
rnm <- gsub(";", ",", rnm)
if (gsub("\\s+", "", rnm) != "") {
rnm <- unlist(strsplit(rnm, ",")) %>%
.[1:min(length(.), length(var))] %>%
gsub("^\\s+|\\s+$", "", .)
}
rnm <- fix_names(rnm)
if (!store || !is.character(dataset)) {
if (all(rnm == "")) {
return(dataset)
}
names(dataset)[seq_len(length(rnm))] <- rnm
dataset
} else {
if (store_dat == "") store_dat <- dataset
name_check <- fix_names(var) != var
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")
}
}
.replace <- function(dataset, var, rpl, store_dat = "", store = TRUE) {
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"))
}
if (!store || !is.character(dataset)) {
select_at(dataset, .vars = rpl) %>% set_colnames(var)
} else {
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")
}
}
.normalize <- function(dataset, vars, nzvar, .ext = paste0("_", nzvar),
store_dat = "", store = TRUE) {
.ext <- fix_ext(.ext)
if (!store && !is.character(dataset)) {
nz <- select_at(dataset, .vars = nzvar)
dataset <- select_at(dataset, .vars = vars)
dc <- get_class(dataset)
isnum <- "numeric" == dc | "integer" == dc
if (sum(isnum) == 0) {
return(i18n$t("Please select only integer or numeric variables to normalize"))
}
vars <- vars[isnum]
select_at(dataset, .vars = vars) %>%
(function(x) x / nz[[1]]) %>%
set_colnames(paste0(vars, .ext))
} else {
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")
}
}
.tab2dat <- function(dataset, freq, vars = "",
store_dat = "", store = TRUE) {
if (!store && !is.character(dataset)) {
if (is.empty(vars)) vars <- base::setdiff(colnames(dataset), freq)
select_at(dataset, .vars = unique(c(vars, freq))) %>%
table2data(freq)
} else {
if (store_dat == "") store_dat <- dataset
if (is.empty(vars)) vars <- base::setdiff(colnames(r_data[[dataset]]), 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")
}
}
.gather <- function(dataset, vars, key, value,
store_dat = "", store = TRUE) {
key <- fix_names(key)
value <- fix_names(value)
if (!store && !is.character(dataset)) {
gather(dataset, !!key, !!value, !!vars, factor_key = TRUE)
} else {
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")
}
}
.spread <- function(dataset, key, value, fill = NA,
vars = "", store_dat = "", store = TRUE) {
if (!store && !is.character(dataset)) {
if (!vars[1] == "") dataset <- select_at(dataset, .vars = vars)
cn <- colnames(dataset)
if (!all(key %in% cn) || !value %in% cn) {
return(i18n$t("Key or value variable is not in the dataset"))
}
nr <- distinct_at(dataset, .vars = base::setdiff(cn, value), .keep_all = TRUE) %>%
nrow()
if (nr < nrow(dataset)) {
return(i18n$t("Rows are not unique. Select additional variables"))
}
if (length(key) > 1) {
dataset <- unite_(dataset, paste(key, collapse = "_"), key)
key <- paste(key, collapse = "_")
}
spread(dataset, !!key, !!value, fill = fill)
} else {
if (store_dat == "") store_dat <- dataset
cmd <- ""
if (!is.empty(vars)) {
cmd <- paste0(i18n$t("## Select columns\n"), store_dat, " <- select(", dataset, ", ", paste0(vars, collapse = ", "), ")\n")
dataset <- store_dat
}
if (length(key) > 1) {
cmd <- paste0(cmd, i18n$t("## Unite columns\n"), store_dat, " <- unite(", dataset, ", ", paste(key, collapse = "_"), ", ", paste0(key, collapse = ", "), ")\n")
key <- paste(key, collapse = "_")
dataset <- store_dat
}
if (!is.na(fill)) {
paste0(cmd, i18n$t("## Spread columns\n"), store_dat, " <- spread(", dataset, ", ", key, ", ", value, ", fill = ", fill, ")\n")
} else {
paste0(cmd, i18n$t("## Spread columns\n"), store_dat, " <- spread(", dataset, ", ", key, ", ", value, ")\n")
}
}
}
.expand <- function(dataset, vars = "", store_dat = "", store = TRUE) {
if (!store || !is.character(dataset)) {
if (all(vars == "")) {
paste0(i18n$t("Select variables to expand"))
} else {
expand.grid(level_list(select_at(dataset, .vars = vars)))
}
} else {
paste0(i18n$t("## expanding data\n"), store_dat, " <- expand.grid(level_list(", dataset, ", ", paste0(vars, collapse = ", "), "))\n")
}
}
.bin <- function(dataset, vars = "", bins = 10, rev = FALSE,
.ext = "_dec", store_dat = "", store = TRUE) {
.ext <- fix_ext(.ext)
if (!store && !is.character(dataset)) {
if (is.na(bins) || !is.integer(bins)) {
return(i18n$t("Please specify the (integer) number of bins to use"))
}
if (!all(sapply(dataset[, vars, drop = FALSE], is.numeric))) {
return(i18n$t("Binning can only be applied to numeric variables"))
}
select_at(dataset, .vars = vars) %>%
mutate_all(~ xtile(., bins, rev = rev)) %>%
set_colnames(paste0(vars, .ext))
} else {
if (store_dat == "") store_dat <- dataset
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")
} else {
paste0(i18n$t("## bin variables\n"), store_dat, " <- mutate_ext(", dataset, ", .vars = vars(", paste0(vars, collapse = ", "), "), .funs = ~ xtile(., ", bins, "), .ext = \"", .ext, "\")\n")
}
}
}
.training <- function(dataset, vars = "", n = .7, nr = 100,
name = "training", seed = 1234,
store_dat = "", store = TRUE) {
if (is.empty(name)) {
name <- "training"
} else {
name <- fix_names(name)
}
if (!store && !is.character(dataset)) {
n <- n %>%
(function(x) ifelse(x < 0 || is.na(x) || x > nr, 0.7, x))
if (is.empty(vars)) {
blocks <- NULL
} else {
blocks <- dataset[, vars]
}
make_train(n, nr, blocks = blocks, seed = seed) %>%
data.frame(stringsAsFactors = FALSE) %>%
setNames(name)
} else {
if (store_dat == "") store_dat <- dataset
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")
} 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")
}
}
}
## Make a training variable that selects randomly by ID
# http://rpackages.ianhowson.com/cran/dplyr/man/group_indices.html
# http://rpackages.ianhowson.com/cran/dplyr/man/sample.html
.reorg_levs <- function(dataset, fct, levs, repl = NA, name = fct,
store_dat = "", store = TRUE) {
if (is.empty(name)) name <- fct
if (!store || !is.character(dataset)) {
data.frame(refactor(dataset[[fct]], levs = levs, repl = repl), stringsAsFactors = FALSE) %>%
setNames(name)
} else {
if (store_dat == "") store_dat <- dataset
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")
}
}
.reorg_vars <- function(dataset, vars = "", store_dat = "", store = TRUE) {
if (!store || !is.character(dataset)) {
get_data(dataset, vars, filt = "", na.rm = FALSE, envir = r_data)
} else {
if (store_dat == "") store_dat <- dataset
paste0(i18n$t("## reorder/remove variables\n"), store_dat, " <- select(", dataset, ", ", paste0(vars, collapse = ", "), ")\n")
}
}
.remove_na <- function(dataset, vars = "", store_dat = "",
nr_col = 0, store = TRUE) {
if (!store || !is.character(dataset)) {
if (all(vars == "") || length(unique(vars)) == ncol(dataset)) {
dataset %>% filter(complete.cases(.))
} else {
ind <- select_at(dataset, .vars = vars) %>% complete.cases()
filter(dataset, ind)
}
} else {
if (store_dat == "") store_dat <- dataset
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")
}
}
.remove_dup <- function(dataset, vars = "", store_dat = "",
nr_col = 0, store = TRUE) {
if (!store || !is.character(dataset)) {
if (all(vars == "") || length(unique(vars)) == ncol(dataset)) {
dat <- distinct(dataset)
} else {
dat <- distinct_at(dataset, .vars = vars, .keep_all = TRUE)
}
if (nrow(dat) == nrow(dataset)) {
paste0(i18n$t("No duplicates found (n_distinct = "), nrow(dat), ")")
} else {
dat
}
} else {
if (all(vars == "") || length(unique(vars)) == nr_col) {
paste0(i18n$t("## remove duplicate rows\n"), store_dat, " <- distinct(", dataset, ")\n")
} else {
paste0(i18n$t("## remove rows with duplicate values\n"), store_dat, " <- distinct(", dataset, ", ", paste0(vars, collapse = ", "), ", .keep_all = TRUE)\n")
}
}
}
.show_dup <- function(dataset, vars = "", store_dat = "",
nr_col = 0, store = TRUE) {
if (!store || !is.character(dataset)) {
if (all(vars == "") || length(unique(vars)) == ncol(dataset)) {
dat <- filter(dataset, duplicated(dataset))
} else {
dat <- dataset %>%
group_by_at(.vars = vars) %>%
filter(n() > 1)
if (nrow(dat) > 0) {
dat <- mutate(dat, nr_dup = 1:n()) %>%
arrange_at(.vars = vars) %>%
ungroup()
}
}
if (nrow(dat) == 0) {
## "No duplicates found"
paste0(i18n$t("No duplicates found (n_distinct = "), nrow(dataset), ")")
} else {
dat
}
} else {
if (all(vars == "") || length(unique(vars)) == nr_col) {
paste0(i18n$t("## show duplicate rows\n"), store_dat, " <- ", dataset, " %>% filter(duplicated(.))\n")
} else {
paste0(i18n$t("## show rows with duplicate values\n"), store_dat, " <- show_duplicated(", dataset, ", ", paste0(vars, collapse = ", "), ")\n")
}
}
}
.holdout <- function(dataset, vars = "", filt = "", arr = "", rows = NULL, rev = FALSE,
store_dat = "", store = TRUE) {
if (is.empty(filt) && is.empty(rows)) {
return(paste0(i18n$t("No filter or slice found (n = "), nrow(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)
} 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")
if (!all(vars == "")) {
cmd <- glue('{cmd},\n vars = c("{paste0(vars, collapse = ", ")}")', .trim = FALSE)
}
if (!is.empty(filt)) {
filt <- gsub("\"", "'", filt)
cmd <- glue('{cmd},\n filt = "{filt}"', .trim = FALSE)
}
if (!is.empty(arr)) {
cmd <- glue('{cmd},\n arr = "{arr}"', .trim = FALSE)
}
if (!is.empty(rows)) {
cmd <- glue('{cmd},\n rows = "{rows}"', .trim = FALSE)
}
glue("{cmd},\n rev = {rev}\n)", .trim = FALSE)
}
}
inp_vars <- function(inp, rval = "") {
if (is.empty(input[[inp]]) || !available(input[[inp]])) rval else input[[inp]]
}
transform_main <- reactive({
req(input$tr_change_type)
if (not_available(input$tr_vars)) {
if (input$tr_change_type == "none" && length(input$tr_vars) == 0) {
return(i18n$t("Select a transformation type or select variables to summarize"))
} else if (input$tr_change_type == "none" && length(input$tr_vars) > 0) {
return(i18n$t("Select a transformation type or select variables to summarize"))
} else if (input$tr_change_type == "type") {
return(i18n$t("Select one or more variables to change their type"))
} else if (input$tr_change_type == "transform") {
return(i18n$t("Select one or more variables to apply a transformation"))
} else if (input$tr_change_type == "rename") {
return(i18n$t("Select one or more variables to rename"))
} else if (input$tr_change_type == "replace") {
return(i18n$t("Select one or more variables to replace"))
} else if (input$tr_change_type == "recode") {
return(i18n$t("Select a variable to recode"))
} else if (input$tr_change_type == "bin") {
return(i18n$t("Select one or more variables to bin"))
} 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"))
} else if (input$tr_change_type == "normalize") {
return(i18n$t("Select one or more variables to normalize"))
} else if (input$tr_change_type == "remove_na") {
return(i18n$t("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")) {
return(i18n$t("Select one or more variables to see the effects of removing duplicates"))
} else if (input$tr_change_type == "gather") {
return(i18n$t("Select one or more variables to gather"))
} else if (input$tr_change_type == "expand") {
return(i18n$t("Select one or more variables to expand"))
}
}
## get the active dataset, filter not applied when called from transform tab
dat <- .get_data_transform()
## what data to pass on ...
if (input$tr_change_type %in% c("", "none")) {
return(select_at(dat, .vars = input$tr_vars))
}
## reorganize variables
if (input$tr_change_type == "reorg_vars") {
return(.reorg_vars(dat, inp_vars("tr_reorg_vars"), store = FALSE))
}
## create training variable
if (input$tr_change_type == "training") {
return(.training(dat, n = input$tr_training_n, nr = nrow(dat), name = input$tr_training, vars = inp_vars("tr_vars"), seed = input$tr_training_seed, store = FALSE))
}
if (input$tr_change_type == "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"))
} else {
return(.create(dat, input$tr_create, byvar = inp_vars("tr_vars"), store = FALSE))
}
}
if (input$tr_change_type == "tab2dat") {
if (is.null(input$tr_tab2dat) || input$tr_tab2dat == "none") {
return(i18n$t("Select a frequency variable"))
} 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"))
} else {
req(available(input$tr_tab2dat))
return(.tab2dat(dat, input$tr_tab2dat, vars = inp_vars("tr_vars"), store = FALSE))
}
}
if (input$tr_change_type == "clip") {
if (input$tr_paste == "") {
return(i18n$t("Copy-and-paste data with a header row from a spreadsheet"))
} else {
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")) {
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."))
} 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."))
} else {
return(as.data.frame(cpdat, check.names = FALSE, stringsAsFactors = FALSE) %>% to_fct())
}
}
}
## filter data for holdout
if (input$tr_change_type == "holdout") {
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(.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))
}
## spread a variable
if (input$tr_change_type == "spread") {
if (is.empty(input$tr_spread_key, "none") ||
is.empty(input$tr_spread_value, "none")) {
return(i18n$t("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))
}
## only use the functions below if variables have been selected
if (!is.empty(input$tr_vars)) {
if (not_available(input$tr_vars)) {
return()
}
## remove missing values
if (input$tr_change_type == "remove_na") {
return(.remove_na(dat, inp_vars("tr_vars"), store = FALSE))
}
## bin variables
if (input$tr_change_type == "bin") {
return(.bin(dat, inp_vars("tr_vars"), bins = input$tr_bin_n, rev = input$tr_bin_rev, .ext = input$tr_ext_bin, store = FALSE))
}
## gather variables
if (input$tr_change_type == "gather") {
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(.gather(dat, inp_vars("tr_vars"), key = input$tr_gather_key, value = input$tr_gather_value, store = FALSE))
}
## remove duplicates
if (input$tr_change_type == "remove_dup") {
return(.remove_dup(dat, inp_vars("tr_vars"), store = FALSE))
}
## expand grid
if (input$tr_change_type == "expand") {
return(.expand(dat, inp_vars("tr_vars"), store = FALSE))
}
## show duplicates
if (input$tr_change_type == "show_dup") {
return(.show_dup(dat, inp_vars("tr_vars"), store = FALSE))
}
if (input$tr_change_type == "normalize") {
if (is.empty(input$tr_normalizer, "none")) {
return(i18n$t("Select a normalizing variable"))
} else {
return(.normalize(dat, inp_vars("tr_vars"), input$tr_normalizer, .ext = input$tr_ext_nz, store = FALSE))
}
}
if (input$tr_change_type == "replace") {
vars <- input$tr_vars
rpl <- input$tr_replace
if (available(rpl)) {
if (length(vars) != length(rpl)) {
return(i18n$t(
"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))
} else {
return(i18n$t("Select one or more variable replacements"))
}
}
## selecting the columns to show
dat <- select_at(dat, .vars = input$tr_vars)
vars <- colnames(dat)
## change in type is always done in-place
if (input$tr_change_type == "type") {
if (input$tr_typefunction == "none") {
return(i18n$t("Select a transformation type for the selected variables"))
} else {
if (input$tr_typefunction == "ts") {
tr_ts <- list(
start = c(input$tr_ts_start_year, input$tr_ts_start_period),
end = c(input$tr_ts_end_year, input$tr_ts_end_period),
frequency = input$tr_ts_frequency
)
} else {
tr_ts <- NULL
}
return(.change_type(dat, input$tr_typefunction, tr_ts, inp_vars("tr_vars"), input$tr_typename, store = FALSE))
}
}
## change in type is always done in-place
if (input$tr_change_type == "transform") {
if (input$tr_transfunction == "none") {
return(i18n$t("Select a function to apply to the selected variable(s)"))
} else {
return(.transform(dat, input$tr_transfunction, inp_vars("tr_vars"), input$tr_ext, store = FALSE))
}
}
if (input$tr_change_type == "reorg_levs") {
fct <- input$tr_vars[1]
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"))
} else {
return(.reorg_levs(dat, fct, input$tr_reorg_levs, input$tr_rorepl, input$tr_roname, store = FALSE))
}
}
if (input$tr_change_type == "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"))
} else {
return(.recode(dat, inp_vars("tr_vars")[1], input$tr_recode, input$tr_rcname, store = FALSE))
}
}
if (input$tr_change_type == "rename") {
if (is.empty(input$tr_rename)) {
return(i18n$t("Specify new names for the selected variables (separated by a ',') and press 'return'"))
} else {
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"))
} else {
return(.rename(dat, inp_vars("tr_vars"), input$tr_rename, store = FALSE))
}
}
}
}
return(invisible())
})
output$transform_data <- reactive({
dataset <- transform_main()
if (is.null(dataset) || is.character(dataset) || nrow(dataset) == 0 || ncol(dataset) == 0) {
tr_snippet()
} else {
show_data_snippet(dataset)
}
})
tr_snippet <- reactive({
show_data_snippet(.get_data_transform())
})
output$transform_summary <- renderPrint({
req(!isTRUE(input$tr_hide))
withProgress(message = i18n$t("Generating summary statistics"), value = 1, {
dataset <- transform_main()
})
## with isolate on the summary wouldn't update when the dataset was changed
if (is.null(dataset)) {
return(invisible())
}
if (is.character(dataset)) {
cat("**", dataset, "\n**\n\n")
} else {
if (min(dim(dataset)) == 0) {
cat("**", i18n$t("The selected operation resulted in an empty data frame and cannot be executed"), "**\n\n")
} else {
if (input$tr_change_type %in% c("", "none")) {
cat("**", i18n$t("Select a transformation type or select variables to summarize"), "**\n\n")
} else {
cat("**", i18n$t("Press the 'Store' button to add your changes to the data"), "**\n\n")
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")
} 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")
}
}
if (input$tr_change_type == "reorg_vars") {
cat("**", i18n$t("Drag-and-drop to change ordering. Click the x to remove a variable"), "**")
} else {
cat(paste0(capture.output(get_summary(dataset)), collapse = "\n"))
}
}
}
})
observeEvent(input$tr_store, {
withProgress(message = "Storing transformations", value = 1, {
dat <- transform_main()
})
if (is.null(dat)) {
return()
} else if (is.character(dat)) {
return()
} else if (min(dim(dat)) == 0) {
return()
}
## saving to a new dataset if specified
df_name <- fix_names(input$tr_name)
if (input$tr_name != df_name) {
updateTextInput(session, inputId = "tr_name", value = df_name)
}
ncmd <- ""
if (is.null(r_data[[df_name]])) {
r_data[[df_name]] <- .get_data_transform()
r_info[[paste0(df_name, "_descr")]] <- r_info[[paste0(input$dataset, "_descr")]]
if (!bindingIsActive(as.symbol(df_name), env = r_data)) {
shiny::makeReactiveBinding(df_name, env = r_data)
}
r_info[["datasetlist"]] %<>% c(df_name, .) %>% unique()
## adding command to ensure new data is in the datasetlist
if (df_name == input$dataset) {
ncmd <- paste0("\n", i18n$t("## register the new dataset"), "\nregister(\"", df_name, "\")")
} else {
ncmd <- paste0("\n", i18n$t("## register the new dataset"), "\nregister(\"", df_name, "\", \"", input$dataset, "\")")
}
} else if (!df_name %in% r_info[["datasetlist"]]) {
r_info[["datasetlist"]] %<>% c(df_name, .) %>% unique()
## adding command to ensure new data is in the datasetlist
if (df_name == input$dataset) {
ncmd <- paste0("\n", i18n$t("## register the new dataset"), "\nregister(\"", df_name, "\")")
} else {
ncmd <- paste0("\n", i18n$t("## register the new dataset"), "\nregister(\"", df_name, "\", \"", input$dataset, "\")")
}
}
if (input$tr_change_type == "remove_na") {
cmd <- .remove_na(input$dataset, vars = input$tr_vars, df_name, nr_col = ncol(dat))
r_data[[df_name]] <- dat
} else if (input$tr_change_type == "remove_dup") {
cmd <- .remove_dup(input$dataset, vars = input$tr_vars, df_name, nr_col = ncol(dat))
r_data[[df_name]] <- dat
} else if (input$tr_change_type == "show_dup") {
cmd <- .show_dup(input$dataset, vars = input$tr_vars, df_name, nr_col = ncol(dat))
r_data[[df_name]] <- dat
} else if (input$tr_change_type == "holdout") {
cmd <- .holdout(input$dataset, vars = input$tr_vars, filt = input$data_filter, arr = input$data_arrange, rows = input$data_rows, rev = input$tr_holdout_rev, df_name)
r_data[[df_name]] <- dat
} else if (input$tr_change_type == "tab2dat") {
cmd <- .tab2dat(input$dataset, input$tr_tab2dat, vars = input$tr_vars, df_name)
r_data[[df_name]] <- dat
} else if (input$tr_change_type == "gather") {
cmd <- .gather(input$dataset, vars = input$tr_vars, key = input$tr_gather_key, value = input$tr_gather_value, df_name)
r_data[[df_name]] <- dat
} else if (input$tr_change_type == "spread") {
cmd <- .spread(input$dataset, key = input$tr_spread_key, value = input$tr_spread_value, fill = input$tr_spread_fill, vars = input$tr_vars, df_name)
r_data[[df_name]] <- dat
} else if (input$tr_change_type == "expand") {
cmd <- .expand(input$dataset, vars = input$tr_vars, df_name)
r_data[[df_name]] <- dat
} else if (input$tr_change_type == "reorg_vars") {
cmd <- .reorg_vars(input$dataset, vars = input$tr_reorg_vars, df_name)
r_data[[df_name]] <- dat
} else if (input$tr_change_type == "type") {
if (input$tr_typefunction == "ts") {
tr_ts <- list(
start = c(input$tr_ts_start_year, input$tr_ts_start_period),
end = c(input$tr_ts_end_year, input$tr_ts_end_period),
frequency = input$tr_ts_frequency
)
} else {
tr_ts <- NULL
}
cmd <- .change_type(input$dataset, fun = input$tr_typefunction, tr_ts, vars = input$tr_vars, .ext = input$tr_typename, df_name)
r_data[[df_name]][, colnames(dat)] <- dat
} else if (input$tr_change_type == "transform") {
cmd <- .transform(input$dataset, fun = input$tr_transfunction, vars = input$tr_vars, .ext = input$tr_ext, df_name)
r_data[[df_name]][, colnames(dat)] <- dat
} else if (input$tr_change_type == "training") {
cmd <- .training(input$dataset, n = input$tr_training_n, nr = nrow(dat), name = input$tr_training, vars = input$tr_vars, seed = input$tr_training_seed, df_name)
r_data[[df_name]][, colnames(dat)] <- dat
} else if (input$tr_change_type == "normalize") {
cmd <- .normalize(input$dataset, vars = input$tr_vars, nzvar = input$tr_normalizer, .ext = input$tr_ext_nz, df_name)
r_data[[df_name]][, colnames(dat)] <- dat
} else if (input$tr_change_type == "bin") {
cmd <- .bin(input$dataset, vars = input$tr_vars, bins = input$tr_bin_n, rev = input$tr_bin_rev, .ext = input$tr_ext_bin, df_name)
r_data[[df_name]][, colnames(dat)] <- dat
} else if (input$tr_change_type == "reorg_levs") {
cmd <- .reorg_levs(input$dataset, input$tr_vars[1], input$tr_reorg_levs, input$tr_rorepl, input$tr_roname, df_name)
r_data[[df_name]][, colnames(dat)] <- dat
} else if (input$tr_change_type == "recode") {
cmd <- .recode(input$dataset, input$tr_vars[1], input$tr_recode, input$tr_rcname, df_name)
r_data[[df_name]][, colnames(dat)] <- dat
} else if (input$tr_change_type == "rename") {
cmd <- .rename(input$dataset, input$tr_vars, input$tr_rename, df_name)
r_data[[df_name]] %<>% dplyr::rename(!!!setNames(input$tr_vars, colnames(dat)))
} else if (input$tr_change_type == "create") {
cmd <- .create(input$dataset, cmd = input$tr_create, byvar = input$tr_vars, df_name)
r_data[[df_name]][, colnames(dat)] <- dat
} else if (input$tr_change_type == "replace") {
cmd <- .replace(input$dataset, input$tr_vars, input$tr_replace, df_name)
r_data[[df_name]][, colnames(dat)] <- dat
r_data[[df_name]][, input$tr_replace] <- list(NULL)
} else if (input$tr_change_type == "clip") {
cmd <- paste0(
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
}
## uncomment if you want to revert to resetting the transform UI after Store
# updateTextAreaInput(session, "tr_log", value = paste0(input$tr_log, paste0(cmd, ncmd), "\n"))
## update the command log
shinyAce::updateAceEditor(session, "tr_log", value = paste0(input$tr_log, paste0(cmd, ncmd), "\n"))
## reset input values once the changes have been applied
# updateSelectInput(session = session, inputId = "tr_change_type", selected = "none")
## jumps straight to the new dataset
# updateSelectInput(session = session, inputId = "dataset", selected = df_name)
if (input$dataset != df_name) {
showModal(
modalDialog(
title = i18n$t("Data Stored"),
span(
i18n$t(
paste0(
"Dataset '", df_name, "' 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
)
)
}
})
observeEvent(input$tr_change_type, {
## reset all values when tr_change_type is changed
updateTextInput(session = session, inputId = "tr_create", value = "")
updateTextInput(session = session, inputId = "tr_recode", value = "")
updateTextInput(session = session, inputId = "tr_rename", value = "")
updateTextInput(session = session, inputId = "tr_paste", value = "")
updateTextInput(session = session, inputId = "tr_gather_key", value = "")
updateTextInput(session = session, inputId = "tr_gather_value", value = "")
updateTextInput(session = session, inputId = "tr_spread_key", value = "")
updateTextInput(session = session, inputId = "tr_spread_value", value = "")
updateSelectInput(session = session, inputId = "tr_typefunction", selected = "none")
updateSelectInput(session = session, inputId = "tr_transfunction", selected = "none")
updateSelectInput(session = session, inputId = "tr_replace", selected = "None")
updateSelectInput(session = session, inputId = "tr_normalizer", selected = "none")
updateSelectInput(session = session, inputId = "tr_tab2dat", selected = "none")
})
transform_report <- function() {
cmd <- NULL
if (!is.empty(input$tr_log)) {
cmd <- gsub("\n{2,}", "\n", input$tr_log) %>%
sub("^\n", "", .) %>%
sub("\n$", "", .)
shinyAce::updateAceEditor(session, "tr_log", value = "")
}
update_report(cmd = cmd, outputs = NULL, figs = FALSE)
}
observeEvent(input$transform_report, {
r_info[["latest_screenshot"]] <- NULL
transform_report()
})
observeEvent(input$transform_screenshot, {
r_info[["latest_screenshot"]] <- NULL
radiant_screenshot_modal("modal_transform_screenshot")
})
observeEvent(input$modal_transform_screenshot, {
transform_report()
removeModal()
})