###############################
# Sampling
###############################
## list of function arguments
smp_args <- as.list(formals(sampling))
## list of function inputs selected by user
smp_inputs <- reactive({
## loop needed because reactive values don't allow single bracket indexing
smp_args$data_filter <- if (input$show_filter) input$data_filter else ""
smp_args$arr <- if (input$show_filter) input$data_arrange else ""
smp_args$rows <- if (input$show_filter) input$data_rows else ""
smp_args$dataset <- input$dataset
for (i in r_drop(names(smp_args))) {
smp_args[[i]] <- input[[paste0("smp_", i)]]
}
smp_args
})
output$ui_smp_vars <- renderUI({
vars <- varnames()
selectInput(
inputId = "smp_vars", label = "Variables:",
choices = vars, selected = state_multiple("smp_vars", vars, vars),
multiple = TRUE, selectize = FALSE,
size = min(12, length(vars))
)
})
output$ui_smp_name <- renderUI({
req(input$dataset)
textInput("smp_name", "Store as:", "", placeholder = "Provide a name")
})
output$ui_sampling <- renderUI({
# req(input$dataset)
tagList(
wellPanel(
uiOutput("ui_smp_vars"),
tags$table(
tags$td(numericInput(
"smp_sample_size", "Sample size:",
min = 1,
value = state_init("smp_sample_size", 1)
)),
tags$td(numericInput(
"smp_seed",
label = "Rnd. seed:", min = 0,
value = state_init("smp_seed", init = 1234)
))
),
checkboxInput("smp_sframe", "Show sampling frame ", value = state_init("smp_sframe", FALSE))
),
wellPanel(
tags$table(
tags$td(uiOutput("ui_smp_name")),
tags$td(actionButton("smp_store", "Store", icon = icon("plus", verify_fa = FALSE)), class = "top")
)
),
help_and_report(
modal_title = "Sampling", fun_name = "sampling",
help_file = inclMD(file.path(getOption("radiant.path.design"), "app/tools/help/sampling.md"))
)
)
})
output$sampling <- renderUI({
register_print_output("summary_sampling", ".summary_sampling")
## one output with components stacked
smp_output_panels <- tagList(
tabPanel(
"Summary",
download_link("dl_sample"), br(),
verbatimTextOutput("summary_sampling"),
DT::dataTableOutput("table_sampling"),
conditionalPanel(
"input.smp_sframe == true",
DT::dataTableOutput("table_sampling_frame")
)
)
)
stat_tab_panel(
menu = "Design > Sample",
tool = "Random sampling",
tool_ui = "ui_sampling",
output_panels = smp_output_panels
)
})
.sampling <- reactive({
validate(
need(input$smp_vars, "Select at least one variable"),
need(available(input$smp_vars), "Some selected variables are not available in this dataset")
)
smpi <- smp_inputs()
smpi$envir <- r_data
do.call(sampling, smpi)
})
.summary_sampling <- reactive({
if (not_available(input$smp_vars)) {
"For random sampling each row in the data should be distinct\n(i.e., no duplicates). Please select an appropriate dataset.\n\n" %>%
suggest_data("rndnames")
} else if (is.empty(input$smp_sample_size)) {
"Please select a sample size of 1 or greater"
} else {
summary(.sampling())
}
})
output$table_sampling <- DT::renderDataTable({
req(input$smp_vars, input$smp_sample_size)
withProgress(message = "Generating sample", value = 1, {
smp <- .sampling()$seldat
dom <- ifelse(nrow(smp) <= 10, "t", "tip")
dtab(smp, dom = dom, caption = "Selected cases")
})
})
output$table_sampling_frame <- DT::renderDataTable({
req(input$smp_vars, input$smp_sample_size, input$smp_sframe)
withProgress(message = "Show sampling frame", value = 1, {
smp <- .sampling()
dtab(smp$dataset, dom = "tip", caption = "Sampling frame")
})
})
sampling_report <- function() {
req(input$smp_sample_size)
nr <- min(100, max(input$smp_sample_size, 1))
xcmd <- paste0("# dtab(result$seldat, dom = \"tip\", caption = \"Selected cases\", nr = ", nr, ")")
if (isTRUE(input$smp_sframe)) {
xcmd <- paste0(xcmd, "\n# dtab(result$dataset, dom = \"tip\", caption = \"Sampling frame\", nr = 100)")
}
if (!is.empty(input$smp_name)) {
dataset <- fix_names(input$smp_name)
if (input$smp_name != dataset) {
updateTextInput(session, inputId = "smp_name", value = dataset)
}
xcmd <- paste0(xcmd, "\n", dataset, " <- select(result$seldat, -rnd_number)\nregister(\"", dataset, "\")")
}
update_report(
inp_main = clean_args(smp_inputs(), smp_args),
fun_name = "sampling", outputs = "summary",
xcmd = xcmd, figs = FALSE
)
}
dl_sample <- function(path) {
resp <- .sampling()
if ("seldat" %in% names(resp)) {
seldat <- resp$seldat %>% select_at(setdiff(colnames(.), "rnd_number"))
write.csv(seldat, file = path, row.names = FALSE)
} else {
cat("No valid sample available", file = path)
}
}
download_handler(
id = "dl_sample",
fun = dl_sample,
fn = function() paste0(input$dataset, "_sample"),
type = "csv",
caption = "Save random sample"
)
observeEvent(input$smp_store, {
req(input$smp_name)
resp <- .sampling()
if (!"seldat" %in% names(resp)) {
cat("No valid sample available")
return()
}
dataset <- fix_names(input$smp_name)
if (input$smp_name != dataset) {
updateTextInput(session, inputId = "smp_name", value = dataset)
}
r_data[[dataset]] <- resp$seldat %>% select_at(setdiff(colnames(.), "rnd_number"))
register(dataset)
updateSelectInput(session, "dataset", selected = input$dataset)
## See https://shiny.posit.co/reference/shiny/latest/modalDialog.html
showModal(
modalDialog(
title = "Data Stored",
span(
paste0("Dataset '", dataset, "' 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 = "s",
easyClose = TRUE
)
)
})
observeEvent(input$sampling_report, {
r_info[["latest_screenshot"]] <- NULL
sampling_report()
})
observeEvent(input$sampling_screenshot, {
r_info[["latest_screenshot"]] <- NULL
radiant_screenshot_modal("modal_sampling_screenshot")
})
observeEvent(input$modal_sampling_screenshot, {
sampling_report()
removeModal() ## remove shiny modal after save
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.