## 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() })