inst/app/tools/data/transform_ui.R

In radiant-rstats/radiant.data: Data Menu for Radiant: Business Analytics using R and Shiny

## UI-elements for transform
output$ui_tr_vars <- renderUI({
  vars <- varnames()
  req(available(vars))
  selectInput(
    "tr_vars", "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), "Select one or more variables to replace")
  )
  vars <- varnames()
  selectInput(
    "tr_replace", "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", "Normalizing variable:",
    c("None" = "none", vars),
    selected = "none"
  )
})

output$ui_tr_tab2dat <- renderUI({
  isNum <- .get_class() %in% c("numeric", "integer", "ts")
  vars <- varnames()[isNum]
  selectInput(
    "tr_tab2dat", "Frequency variable:",
    c("None" = "none", vars),
    selected = "none"
  )
})

output$ui_tr_gather <- renderUI({
  tagList(
    tags$table(
      tags$td(returnTextInput("tr_gather_key", "Key name:", value = "key")),
      tags$td(returnTextInput("tr_gather_value", "Value name:", value = "value"))
    )
  )
})

output$ui_tr_spread <- renderUI({
  req(input$tr_change_type)
  vars <- c("None" = "none", varnames())
  tagList(
    selectizeInput(
      "tr_spread_key", "Key(s):",
      choices = vars[-1],
      selected = NULL, multiple = TRUE,
      options = list(placeholder = "None", plugins = list("remove_button", "drag_drop"))
    ),
    selectInput("tr_spread_value", "Value:", choices = vars, selected = "none", multiple = FALSE),
    numericInput("tr_spread_fill", "Fill:", value = NA)
  )
})

output$ui_tr_reorg_vars <- renderUI({
  req(input$tr_change_type)
  vars <- varnames()
  validate(
    need(length(vars) < 101, "Interactive re-ordering is only supported up to 100 variables. See ?dplyr::select for information on how to re-order variables in R")
  )
  selectizeInput(
    "tr_reorg_vars", "Reorder/remove variables:",
    choices = vars,
    selected = vars, multiple = TRUE,
    options = list(placeholder = "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), "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, "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", "Reorder/remove levels:",
      choices = levs,
      selected = levs, multiple = TRUE,
      options = list(placeholder = "Select level(s)", plugins = list("remove_button", "drag_drop"))
    ),
    textInput(
      "tr_rorepl", "Replacement level name:",
      placeholder = "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("<label>Transform command log:</label><br>"),
    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", "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", "Variable name extension:",
    value = paste0("_", input$tr_normalizer)
  )
})

output$ui_tr_rcname <- renderUI({
  if (is.empty(input$tr_vars)) {
    return()
  }
  returnTextInput(
    "tr_rcname", "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", "Variable name extension:",
    value = "_dec"
  )
})

output$ui_tr_roname <- renderUI({
  if (is.empty(input$tr_vars)) {
    return()
  }
  returnTextInput(
    "tr_roname", "Variable name:",
    value = input$tr_vars[1]
  )
})

output$ui_tr_typename <- renderUI({
  if (is.empty(input$tr_vars)) {
    return()
  }
  returnTextInput(
    "tr_typename", "Variable name extension:",
    value = "",
    placeholder = "Add extension to variable name"
  )
})

output$ui_tr_rename <- renderUI({
  validate(
    need(available(input$tr_vars), "Select one or more variables to rename")
  )
  if (length(input$tr_vars) < 2) {
    mess <- "Type a new name for the selected variable and press return"
  } else {
    mess <- "Type new names for the selected variables, separated by a , and press return"
  }
  returnTextAreaInput(
    "tr_rename", "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", "Store changes in:", tr_dataset)),
    tags$td(actionButton("tr_store", "Store", icon = icon("plus", verify_fa = FALSE), class = "btn-success"), class = "top")
  )
})

trans_options <- list(
  "None" = "none", "Ln (natural log)" = "log", "Exp" = "exp",
  "Square" = "square", "Square-root" = "sqrt",
  "Center" = "center", "Standardize" = "standardize", "Inverse" = "inverse"
)

type_options <- list(
  "None" = "none", "As factor" = "as_factor",
  "As numeric" = "as_numeric", "As integer" = "as_integer",
  "As character" = "as_character", "As time series" = "ts",
  "As date (mdy)" = "as_mdy", "As date (dmy)" = "as_dmy",
  "As date (ymd)" = "as_ymd",
  "As date/time (mdy_hms)" = "as_mdy_hms",
  "As date/time (mdy_hm)" = "as_mdy_hm",
  "As date/time (dmy_hms)" = "as_dmy_hms",
  "As date/time (dmy_hm)" = "as_dmy_hm",
  "As date/time (ymd_hms)" = "as_ymd_hms",
  "As date/time (ymd_hm)" = "as_ymd_hm"
)

trans_types <- list(
  ` ` = c("None (summarize)" = "none"),
  `Change variable(s)` = c(
    "Bin" = "bin",
    "Change type" = "type",
    "Normalize" = "normalize",
    "Recode" = "recode",
    "Remove/reorder levels" = "reorg_levs",
    "Rename" = "rename",
    "Replace" = "replace",
    "Transform" = "transform"
  ),
  `Create new variable(s)` = c(
    "Clipboard" = "clip",
    "Create" = "create"
  ),
  `Clean data` = c(
    "Remove missing values" = "remove_na",
    "Remove/reorder variables" = "reorg_vars",
    "Remove duplicates" = "remove_dup",
    "Show duplicates" = "show_dup"
  ),
  `Expand data` = c(
    "Expand grid" = "expand",
    "Table-to-data" = "tab2dat"
  ),
  `Split data` = c(
    "Holdout sample" = "holdout",
    "Training variable" = "training"
  ),
  `Tidy data` = c(
    "Gather columns" = "gather",
    "Spread column" = "spread"
  )
)

output$ui_Transform <- renderUI({
  ## Inspired by Ian Fellow's transform ui in JGR/Deducer
  tagList(
    wellPanel(
      checkboxInput("tr_hide", "Hide summaries", state_init("tr_hide", FALSE)),
      uiOutput("ui_tr_vars"),
      selectizeInput("tr_change_type", "Transformation type:", trans_types, selected = "none"),
      conditionalPanel(
        condition = "input.tr_change_type == 'type'",
        selectInput("tr_typefunction", "Change variable type:", type_options, selected = "none"),
        conditionalPanel(
          condition = "input.tr_typefunction == 'ts'",
          tags$table(
            tags$td(numericInput("tr_ts_start_year", label = "Start year:", min = 1, value = NA)),
            tags$td(numericInput("tr_ts_start_period", label = "Start period:", min = 1, value = 1))
          ),
          tags$table(
            tags$td(numericInput("tr_ts_end_year", label = "End year:", value = NA)),
            tags$td(numericInput("tr_ts_end_period", label = "End period:", value = NA))
          ),
          numericInput("tr_ts_frequency", label = "Frequency:", min = 1, value = 52)
        )
      ),
      conditionalPanel(
        condition = "input.tr_change_type == 'transform'",
        selectInput("tr_transfunction", "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", "Create:",
          rows = 3,
          placeholder = "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 = "Nr bins:", min = 2, value = 10),
        checkboxInput("tr_bin_rev", "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 = "Size:", min = 0, value = .7)),
          tags$td(textInput("tr_training", "Variable name:", "training"))
        ),
        numericInput("tr_training_seed", label = "Seed:", value = 1234)
      ),
      conditionalPanel(
        condition = "input.tr_change_type == 'holdout'",
        checkboxInput("tr_holdout_rev", "Reverse filter and slice", value = TRUE)
      ),
      conditionalPanel(
        condition = "input.tr_change_type == 'clip'",
        textAreaInput(
          "tr_paste", "Paste from spreadsheet:",
          rows = 3,
          value = "",
          resize = "vertical",
          placeholder = "Copy-and-paste data with a header row from a spreadsheet",
        )
      ),
      conditionalPanel(
        condition = "input.tr_change_type == 'recode'",
        returnTextAreaInput(
          "tr_recode", "Recode:",
          value = "",
          rows = 3,
          placeholder = "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 = "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 = "Group by:", selected = character(0))
  } else if (input$tr_change_type == "training") {
    updateSelectInput(session = session, inputId = "tr_vars", label = "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 = "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("## change variable type\n", store_dat, " <- mutate_at(", dataset, ", .vars = vars(", paste0(vars, collapse = ", "), "), .funs = ", fun, tr_ts, ")\n")
    } else {
      paste0("## 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("\nThe transformation type you selected generated an error.\n\nThe error message was:\n\n", attr(result, "condition")$message, "\n\nPlease change the selection of variables or the transformation type and try again.")
    } else {
      result
    }
  } else {
    if (store_dat == "") store_dat <- dataset
    if (is.empty(.ext)) {
      paste0("## transform variable\n", store_dat, " <- mutate_at(", dataset, ", .vars = vars(", paste0(vars, collapse = ", "), "), .funs = ", fun, ")\n")
    } else {
      paste0("## 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("\nThe create command was not valid. The command entered was:\n\n", cmd, "\n\nThe error message was:\n\n", attr(nvar, "condition")$message, "\n\nPlease try again. Examples are shown in the help file")
    } 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("## create new variable(s)\n", store_dat, " <- mutate(", dataset, ", ", cmd, ")\n")
    } else {
      paste0("## 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("The recode command was not valid. The error message was:\n", attr(nvar, "condition")$message, "\nPlease try again. Examples are shown in the help file (click the ? icon).")
    } else {
      as.data.frame(nvar, stringsAsFactors = FALSE) %>% setNames(rcname)
    }
  } else {
    if (store_dat == "") store_dat <- dataset
    paste0("## 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("## 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("\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("## 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("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("## 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("## 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("## 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("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("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("## Select columns\n", store_dat, " <- select(", dataset, ", ", paste0(vars, collapse = ", "), ")\n")
      dataset <- store_dat
    }
    if (length(key) > 1) {
      cmd <- paste0(cmd, "## 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, "## Spread columns\n", store_dat, " <- spread(", dataset, ", ", key, ", ", value, ", fill = ", fill, ")\n")
    } else {
      paste0(cmd, "## 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("Select variables to expand")
    } else {
      expand.grid(level_list(select_at(dataset, .vars = vars)))
    }
  } else {
    paste0("## 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("Please specify the (integer) number of bins to use")
    }
    if (!all(sapply(dataset[, vars, drop = FALSE], is.numeric))) {
      return("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("## bin variables\n", store_dat, " <- mutate_ext(", dataset, ", .vars = vars(", paste0(vars, collapse = ", "), "), .funs = ~ xtile(., ", bins, ", rev = TRUE), .ext = \"", .ext, "\")\n")
    } else {
      paste0("## 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("## created variable to select training sample\n", store_dat, " <- mutate(", dataset, ", ", name, " = make_train(", n, ", n(), seed = ", seed, "))\n")
    } else {
      paste0("## created variable to select training sample\n", store_dat, " <- mutate(", dataset, ", ", name, " = make_train(", n, ", blocks = select(", dataset, ", ", paste0(vars, collapse = ", "), "), seed = ", seed, "))\n")
    }
  }
}

## 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("## 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("## 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("## 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("No duplicates found (n_distinct = ", nrow(dat), ")")
    } else {
      dat
    }
  } else {
    if (all(vars == "") || length(unique(vars)) == nr_col) {
      paste0("## remove duplicate rows\n", store_dat, " <- distinct(", dataset, ")\n")
    } else {
      paste0("## 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("No duplicates found (n_distinct = ", nrow(dataset), ")")
    } else {
      dat
    }
  } else {
    if (all(vars == "") || length(unique(vars)) == nr_col) {
      paste0("## show duplicate rows\n", store_dat, " <- ", dataset, " %>% filter(duplicated(.))\n")
    } else {
      paste0("## 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("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("## 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("Select a transformation type or select variables to summarize")
    } else if (input$tr_change_type == "none" && length(input$tr_vars) > 0) {
      return("Select a transformation type or select variables to summarize")
    } else if (input$tr_change_type == "type") {
      return("Select one or more variables to change their type")
    } else if (input$tr_change_type == "transform") {
      return("Select one or more variables to apply a transformation")
    } else if (input$tr_change_type == "rename") {
      return("Select one or more variables to rename")
    } else if (input$tr_change_type == "replace") {
      return("Select one or more variables to replace")
    } else if (input$tr_change_type == "recode") {
      return("Select a variable to recode")
    } else if (input$tr_change_type == "bin") {
      return("Select one or more variables to bin")
    } else if (input$tr_change_type == "reorg_levs") {
      return("Select a single variable of type factor to change the ordering and/or number of levels")
    } else if (input$tr_change_type == "normalize") {
      return("Select one or more variables to normalize")
    } else if (input$tr_change_type == "remove_na") {
      return("Select one or more variables to see the effects of removing missing values")
    } else if (input$tr_change_type %in% c("remove_dup", "show_dup")) {
      return("Select one or more variables to see the effects of removing duplicates")
    } else if (input$tr_change_type == "gather") {
      return("Select one or more variables to gather")
    } else if (input$tr_change_type == "expand") {
      return("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("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("Select a frequency variable")
    } else if (!is.empty(input$tr_vars) && all(input$tr_vars == input$tr_tab2dat)) {
      return("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("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("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("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("\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("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("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("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(paste0("The number of replacement variables (", length(rpl), ") is not equal to the number of variables to replace (", length(vars), ")"))
        }
        return(.replace(dat, vars, rpl, store = FALSE))
      } else {
        return("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("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("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("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("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("Specify new names for the selected variables (separated by a ',') and press 'return'")
      } else {
        if (any(input$tr_rename %in% varnames())) {
          return("One or more of the new variables names already exists in the data. **\n** Change the specified names or use the Replace function")
        } else {
          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 = "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("** 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("** Select a transformation type or select variables to summarize **\n\n")
      } else {
        cat("** Press the 'Store' button to add your changes to the data **\n\n")
        if (!is.empty(input$tr_vars) && input$tr_change_type == "create") {
          cat("** Results are grouped by", paste(input$tr_vars, collapse = ", "), "**\n\n")
        } else if (!is.empty(input$tr_vars) && input$tr_change_type == "training") {
          cat("** Results are blocked by", paste(input$tr_vars, collapse = ", "), "**\n\n")
        }
      }

      if (input$tr_change_type == "reorg_vars") {
        cat("** 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## register the new dataset\nregister(\"", df_name, "\")")
    } else {
      ncmd <- paste0("\n## 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## register the new dataset\nregister(\"", df_name, "\")")
    } else {
      ncmd <- paste0("\n## 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("## using the clipboard for data transformation may seem convenient]\n## 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 = "Data Stored",
        span(
          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("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()
})