Ah. You're a legend. Thanks so much! Please see below for a slightly modified version of your solution. The primary differences are that the code for var_recode_default is now stored/executed as a function, as I didn't want to manually code in values here:
vrc <- c(rep("categorical",4),rep("continuous",6))
Also, that same code for var_recode_default was amended to handle other data type structures. In this I mean that the original code expects the output of
sapply(diamonds, class) %>%
data.frame %>%
filter(row_number() == 2) %>% etc.
To be two rowed, due to the presence of ordered factors in diamonds. However, because of this, it breaks when applied to mtcars, which only produces a one-level dataframe as there are no ordered factors. This amended code below makes the process robust to these differences.
library(shiny)
library(shinydashboard)
library(tidyverse)
ui <- dashboardPage(
dashboardHeader(title = "Recode Application", titleWidth = 375),
## dashboard sidebar
dashboardSidebar(
width = 375,
sidebarMenu(
menuItem("Variable Transformations",
uiOutput("selectors")))),
dashboardBody(
tableOutput("table"))
)
server <- function(input, output, session) {
var_orig_func <- function(x) {
sapply(x, function(y) if(is.factor(y)) "factor" else toString(class(y))) %>%
data.frame %>%
rownames_to_column() %>%
set_names(c("var_name", "var_type")) %>%
mutate(var_type = ifelse(var_type %in% c("numeric", "integer"), "continuous", "categorical"))
}
## obtain default classes for data frame
var_recode_default <- var_orig_func(mtcars)
## obtain variable names and default column type
output$selectors <- renderUI({
# re code selectors
var_recode_select <- function(var_name, var_type) {
input_name <- paste0(var_name, "_recode")
radioButtons(inputId = input_name,
label = var_name,
choices = c("continuous", "categorical"),
selected = var_type)
}
## left-side recode number by row (i.e. row 1 = 1, row 2 = 3, row 3 = 5)
recode_row_idx <- var_recode_default %>% nrow %>% seq_len
recode_row_idx <- recode_row_idx[recode_row_idx %% 2 == 1]
recode_row_func <- function(x) {var_recode_default %>% filter(row_number() == x)}
## render re-coding options
recode_row_idx %>%
map(~ if(.x + 1 %in% (var_recode_default %>% nrow %>% seq_len)) {
recode_left_name <- recode_row_func(.x) %>% .$var_name
recode_left_type <- recode_row_func(.x) %>% .$var_type
recode_right_name <- recode_row_func(.x + 1) %>% .$var_name
recode_right_type <- recode_row_func(.x +1) %>% .$var_type
fluidRow(c("left", "right") %>%
map(~column(width = 6,
var_recode_select(var_name = get(paste0("recode_", .x, "_name")),
var_type = get(paste0("recode_", .x, "_type"))))))
} else {
## generate ui when last predictor is an odd number
recode_left_name <- recode_row_func(.x) %>% .$var_name
recode_left_type <- recode_row_func(.x) %>% .$var_type
fluidRow(column(width = 6,
var_recode_select(var_name = recode_left_name,
var_type = recode_left_type)))
})
})
## generate reactive dataframe based on variable recoding
dat <- reactive({
df <- mtcars %>% sample_n(30)
vn <- var_recode_default %>% .$var_name
vrc <- vn %>%
map(~input[[paste0(.x, "_recode")]]) %>% unlist
cat("vn length ", length(vn), " :content: ",vn,"\n")
cat("vrc length ", length(vrc), " :content: ",vrc,"\n")
if (length(vrc)!=length(vn)) {
vrc <- var_orig_func(mtcars) %>%
.$var_type
cat("* ALTERED vrc length ", length(vrc), " :content: ",vrc,"\n")
}
data.frame(var = vn,
var_recode = vrc) %>%
mutate(var_recode_statement = paste0(var, " %>% ",
ifelse(var_recode == "continuous", "as.numeric", "as.factor"))) %>%
pmap(~df %>%
transmute(!! ..1 :=
eval(rlang::parse_expr(..3)))) %>%
bind_cols(.)
})
## render table of numeric columns based on variable transformations
output$table <- renderTable({
dat() %>% select_if(is.numeric)
})
}
shinyApp(ui, server)
Thank you again @nirgrahamuk!