From 843cb3a6195ee8ea0349b9aa61f18c3157f5b068 Mon Sep 17 00:00:00 2001 From: Matthew Hamilton Date: Tue, 7 Feb 2023 18:22:28 +1100 Subject: [PATCH] wip on ui --- data-raw/app/app.R | 82 +++++++++++ data-raw/app/app1.R | 69 ++++++++++ data-raw/app/app2.R | 0 data-raw/app/app3.R | 43 ++++++ data-raw/app/functions.R | 286 +++++++++++++++++++++++++++++++++++++++ 5 files changed, 480 insertions(+) create mode 100644 data-raw/app/app.R create mode 100644 data-raw/app/app1.R create mode 100644 data-raw/app/app2.R create mode 100644 data-raw/app/app3.R create mode 100644 data-raw/app/functions.R diff --git a/data-raw/app/app.R b/data-raw/app/app.R new file mode 100644 index 00000000..9e415eae --- /dev/null +++ b/data-raw/app/app.R @@ -0,0 +1,82 @@ +library(shiny) +library(ready4) +source("functions.R") + +mpgData <- mtcars +mpgData$am <- factor(mpgData$am, labels = c("Automatic", "Manual")) +classes_lup <- make_classes_lup(exclude_1L_chr = "S3", + libraries_chr = "ready4show") +# abbreviations_lup <- ready4fun::get_rds_from_pkg_dmt(fl_nm_1L_chr = "abbreviations_lup", +# piggyback_to_1L_chr = "ready4-dev/ready4") +# object_type_lup <- ready4fun::get_rds_from_pkg_dmt(fl_nm_1L_chr = "object_type_lup", +# piggyback_to_1L_chr = "ready4-dev/ready4") +ui <- fluidPage( + headerPanel("ready4 User Interface"), + sidebarLayout( + sidebarPanel( + import_modules_UI("modelmods", + #modules_chr = "Ready4showSynopsis", + classes_lup = classes_lup), + #h3(textOutput("modulename")), + textOutput("testX"), + # p("The checkbox group controls the select input"), + # checkboxGroupInput("inCheckboxGroup", "Input checkbox", + # c("Item A", "Item B", "Item C")), + # selectInput("inSelect", "Select input", + # c("Item A", "Item B", "Item C")), + plot_cars_UI("mpgplot"), + import_csv_UI("datafile", "User data (.csv format)") + ), + mainPanel( + h3(textOutput("caption")), + plotOutput("mpgPlot"), + dataTableOutput("table") + ) + ) +) +server <- function(input, output, session) { + modules_ls <- reactiveValues(X=NULL, + contents_ls = NULL, + names_ls = NULL, + tree_names_ls = NULL + ) + module_meta_ls <- import_modules_Server("modelmods", + classes_lup = classes_lup) + # output$modulename <- renderText({ + # module_meta_ls$module_nm_fn() + # }) + observeEvent(input$modelmods, { + modules_ls$X = module_meta_ls$X_fn() + # modules_ls$contents_ls = make_module_contents_ls(x, classes_lup = classes_lup, what_1L_chr = "contents") + # modules_ls$names_ls = make_module_contents_ls(modules_ls$X, classes_lup = classes_lup) + # modules_ls$tree_names_ls = make_list_tree_nms(modules_ls$names_ls) + }) + # observe({ + # updateSelectInput(session, "inSelect", + # label = paste("Select input label", length(x)), + # choices = unlist(modules_ls$tree_names_ls) + # # , + # # selected = tail(x, 1) + # ) + # }) + output$testX <- renderText({ + #module_meta_ls$X_fn()@outp_formats_chr + module_meta_ls$X_ls_fn()$tree_names_ls %>% length() %>% as.character() #unlist() %>% unname() %>% tail(1) + #slotNames(module_meta_ls$X_fn())[1] + + #"PDF" + # modules_ls$X@outp_formats_chr + }) + caption_fn <- plot_cars_Server("mpgplot", mpgData) + output$caption <- renderText({ + caption_fn() + }) + output$mpgPlot <- renderPlot({ + plot_cars_Server("mpgplot", mpgData, fml_1L_chr = caption_fn()) + }) + datafile <- import_csv_Server("datafile", as_fctrs_1L_lgl = FALSE) + output$table <- renderDataTable({ + datafile() + }) +} +shinyApp(ui, server) diff --git a/data-raw/app/app1.R b/data-raw/app/app1.R new file mode 100644 index 00000000..48056c57 --- /dev/null +++ b/data-raw/app/app1.R @@ -0,0 +1,69 @@ +csvFileUI <- function(id, label = "CSV file") { + # `NS(id)` returns a namespace function, which was save as `ns` and will + # invoke later. + ns <- NS(id) + + tagList( + fileInput(ns("file"), label), + checkboxInput(ns("heading"), "Has heading"), + selectInput(ns("quote"), "Quote", c( + "None" = "", + "Double quote" = "\"", + "Single quote" = "'" + )) + ) +} +# Module server function +csvFileServer <- function(id, stringsAsFactors) { + moduleServer( + id, + ## Below is the module function + function(input, output, session) { + # The selected file, if any + userFile <- reactive({ + # If no file is selected, don't do anything + validate(need(input$file, message = FALSE)) + input$file + }) + + # The user's data, parsed into a data frame + dataframe <- reactive({ + read.csv(userFile()$datapath, + header = input$heading, + quote = input$quote, + stringsAsFactors = stringsAsFactors) + }) + + # We can run observers in here if we want to + observe({ + msg <- sprintf("File %s was uploaded", userFile()$name) + cat(msg, "\n") + }) + + # Return the reactive that yields the data frame + return(dataframe) + } + ) +} +library(shiny) + +ui <- fluidPage( + sidebarLayout( + sidebarPanel( + csvFileUI("datafile", "User data (.csv format)") + ), + mainPanel( + dataTableOutput("table") + ) + ) +) + +server <- function(input, output, session) { + datafile <- csvFileServer("datafile", stringsAsFactors = FALSE) + + output$table <- renderDataTable({ + datafile() + }) +} + +shinyApp(ui, server) diff --git a/data-raw/app/app2.R b/data-raw/app/app2.R new file mode 100644 index 00000000..e69de29b diff --git a/data-raw/app/app3.R b/data-raw/app/app3.R new file mode 100644 index 00000000..d25d910a --- /dev/null +++ b/data-raw/app/app3.R @@ -0,0 +1,43 @@ +library(shiny) +library(stringi) +stack.shiny <- function(){ + dat_set <- mtcars + + all_cars <- row.names(dat_set) + + car_brands <- unique(stri_extract_first_words(all_cars)) + + + + server <- function(input, output, session) { + + output$car_brands <- renderUI({ + selectInput(inputId = 'select1', label = 'choose brand', + choices = car_brands) + }) + + output$cars <- renderUI({ + selectInput(inputId = 'select2', label = 'choose car', + choices = all_cars) + }) + + observeEvent(input$select1, { + x <- input$select1 + find_pat <- sprintf('^%s', x) + these_cars <- all_cars[grepl(find_pat, all_cars, perl = TRUE)] + # Can also set the label and select items + updateSelectInput(session, "select2", + choices = these_cars, + selected = NULL) + }) + } + + ui <- fluidPage( + uiOutput('car_brands'), + uiOutput('cars') + ) + + shinyApp(ui, server) + +} +stack.shiny() diff --git a/data-raw/app/functions.R b/data-raw/app/functions.R new file mode 100644 index 00000000..e4e5e6f4 --- /dev/null +++ b/data-raw/app/functions.R @@ -0,0 +1,286 @@ +# regular fns +manufacture_Ready4Module <- function(x, + classes_lup = NULL, + what_1L_chr = "slots_chr"){ + return_xx <- NULL + if(what_1L_chr == slots_chr){ + if(is.null(classes_lup)) + classes_lup <- make_classes_lup(libraries_chr = NA_character_) + modules_lup <- make_classes_lup(exclude_1L_chr = "S3", template_lup = classes_lup) + submodules_lup <- make_classes_lup(exclude_1L_chr = "S4", template_lup = classes_lup) + elements_lup <- make_classes_lup(exclude_1L_chr = "ready4", template_lup = classes_lup) + slots_chr <- slotNames(x) + slots_ls <- slots_chr %>% + purrr::map(~procureSlot(x, + slot_nm_1L_chr = .x)) %>% + stats::setNames(slots_chr) + classes_ls <- slots_ls %>% purrr::map(~class(.x)) %>% + stats::setNames(slots_chr) + + } +} +make_module_contents_ls <- function(x, s = NULL, classes_lup = NULL, what_1L_chr = "names") { + if(is.null(classes_lup)) + classes_lup <- make_classes_lup(libraries_chr = NA_character_) + modules_lup <- make_classes_lup(exclude_1L_chr = "S3", template_lup = classes_lup) + submodules_lup <- make_classes_lup(exclude_1L_chr = "S4", template_lup = classes_lup) + elements_lup <- make_classes_lup(exclude_1L_chr = "ready4", template_lup = classes_lup) + + if (!inherits(x,"Ready4Module")) { + return(s) + } + slots_ls <- make_slots_ls(x) + classes_ls <- slots_ls %>% purrr::map(~class(.x) %>% unlist() %>% as.character()) %>% + stats::setNames(names(slots_ls)) + summary_ls <- purrr::map2(slots_ls, + names(slots_ls), + ~ make_module_contents_ls(.x, + s = .y, + classes_lup = classes_lup)) + modules_lgl <- classes_ls %>% purrr::map_lgl(~!identical(intersect(.x,modules_lup$type_chr), + character(0))) + submodules_lgl <- classes_ls %>% purrr::map_lgl(~!identical(intersect(.x,submodules_lup$type_chr), + character(0))) + elements_lgl <- !(modules_lgl + submodules_lgl) + summary_ls <- append(summary_ls[modules_lgl], + list(submodules_chr = summary_ls[submodules_lgl] %>% purrr::flatten_chr(), + elements_chr = summary_ls[elements_lgl] %>% purrr::flatten_chr())) + slots_ls <- append(slots_ls[modules_lgl], + list(submodules_chr = summary_ls$submodules_chr, + elements_chr = summary_ls$elements_chr)) + summary_ls <- purrr::pmap(list(summary_ls, + c(rep(T,length(summary_ls)-2),F,F),#modules_lgl, + slots_ls %>% purrr::map_lgl(~{ + ifelse(inherits(.x,"Ready4Module"), + any(make_slots_ls(.x) %>% purrr::map_lgl(~inherits(.x,"Ready4Module"))) + ,F)}), + slots_ls), + ~if(..2){ + if(!..3){ + sub_classes_ls <- sub_slots_ls %>% purrr::map(~class(.x) %>% unlist() %>% as.character()) %>% + stats::setNames(names(sub_slots_ls)) + submodules_chr <- sub_classes_ls %>% purrr::map(~intersect(.x,submodules_lup$type_chr)) %>% purrr::discard(~identical(.x,character(0))) %>% purrr::flatten_chr() + list(submodules_chr = submodules_chr, + elements_chr = setdiff(purrr::flatten_chr(..1),submodules_chr)) + }else{ + make_module_contents_ls(..4, + classes_lup = classes_lup) + } + + }else{ + ..1 + }) + if(what_1L_chr == "names") + return_ls <- summary_ls + if(what_1L_chr == "contents") + return_ls <- slots_ls + return(return_ls) + +} +make_slots_ls <- function(x){ + nms_chr <- slotNames(x) + slots_ls <- nms_chr %>% + purrr::map(~procureSlot(x, + slot_nm_1L_chr = .x)) %>% + stats::setNames(nms_chr) + return(slots_ls) +} + +make_list_tree_nms <- function(list_ls, module_pfx_1L_chr = "",other_pfx_1L_chr = ""){ + if(is.list(list_ls)){ + names_ls <- purrr::map2(list_ls, + names(list_ls), + ~ c(paste0(ifelse(.y %in% c("submodules_chr","elements_chr"), + other_pfx_1L_chr, + module_pfx_1L_chr), + ifelse(.y %in% c("submodules_chr","elements_chr"), + stringr::str_sub(.y,end=-5), + .y), + sep="" ), + make_list_tree_nms(.x, + module_pfx_1L_chr = paste0(module_pfx_1L_chr,.y, "@"), + other_pfx_1L_chr = paste0(module_pfx_1L_chr,.y, " - ")))) + return(names_ls) + } +} +# make_module_contents_ls(x, classes_lup = classes_lup) -> test_ls +# make_module_contents_ls(x, classes_lup = classes_lup, what_1L_chr = "contents") -> test_contents_ls +# make_list_tree_nms(test_ls)-> test_chr +make_classes_lup <- function(exclude_1L_chr = "", + gh_repo_1L_chr = "ready4-dev/ready4", + gh_tag_1L_chr = "Documentation_0.0", + libraries_chr = "", + template_lup = NULL){ + if(all(!is.na(libraries_chr)) & libraries_chr ==""){ + libraries_chr <- c(ready4::make_modules_pkgs_chr(), + "ready4show","ready4use") %>% sort() + } + if(!is.null(template_lup)){ + classes_lup <- template_lup + }else{ + dmt_urls_chr <- piggyback::pb_download_url(repo = gh_repo_1L_chr, + tag = gh_tag_1L_chr, .token = "") + classes_lup <- readRDS(url(dmt_urls_chr[dmt_urls_chr %>% + endsWith("prototype_lup.RDS")])) + class(classes_lup) <- setdiff(class(classes_lup),"ready4class_pt_lup") + } + if(all(!is.na(libraries_chr))){ + if(exclude_1L_chr == "ready4"){ + classes_lup <- classes_lup %>% + dplyr::filter(!pt_ns_chr %in% c(libraries_chr, + "ready4", + "ready4fun", + "ready4class", + "ready4pack")) + }else{ + classes_lup <- classes_lup %>% + dplyr::filter(pt_ns_chr %in% libraries_chr) + } + } + if(exclude_1L_chr == "S3") + classes_lup <- classes_lup %>% + dplyr::filter(!old_class_lgl) + if(exclude_1L_chr == "S4") + classes_lup <- classes_lup %>% + dplyr::filter(old_class_lgl) + return(classes_lup) +} +# shiny module fns +import_csv_UI <- function(id_1L_chr, label_1L_chr = "CSV file") { + ns_fn <- shiny::NS(id_1L_chr) + shiny::tagList( + shiny::fileInput(ns_fn("file"), label_1L_chr), + shiny::checkboxInput(ns_fn("heading"), "Has heading"), + shiny::selectInput(ns_fn("quote"), + "Quote", + c( + "None" = "", + "Double quote" = "\"", + "Single quote" = "'" + )) + ) +} +import_csv_Server <- function(id_1L_chr, as_fctrs_1L_lgl) { + shiny::moduleServer( + id_1L_chr, + function(input, output, session) { + userFile <- shiny::reactive({ + shiny::validate(shiny::need(input$file, + message = FALSE)) + input$file + }) + dataframe <- shiny::reactive({ + utils::read.csv(userFile()$datapath, + header = input$heading, + quote = input$quote, + stringsAsFactors = as_fctrs_1L_lgl) + }) + shiny::observe({ + msg_1L_chr <- sprintf("File %s was uploaded", userFile()$name) + cat(msg_1L_chr, "\n") + }) + return(dataframe) + } + ) +} +import_modules_UI <- function(id_1L_chr, #label_1L_chr = "CSV file" + modules_chr = character(0), + classes_lup = NULL){ + if(is.null(classes_lup)){ + classes_lup <- make_classes_lup(exclude_1L_chr = "S3") + } + if(!identical(modules_chr, character(0))) + classes_lup <- classes_lup %>% + dplyr::filter(type_chr %in% modules_chr) + + ns_fn <- shiny::NS(id_1L_chr) + shiny::tagList( + shiny::selectInput(ns_fn("module"), + "Module", + classes_lup$type_chr) + ) +} +import_modules_Server <- function(id_1L_chr, + classes_lup){ + shiny::moduleServer( + id_1L_chr, + function(input, output, session) { + module_fn <- shiny::reactive({ + shiny::validate(shiny::need(input$module, + message = FALSE)) + input$module + }) + module_nm_fn <- shiny::reactive({ + module_fn() + }) + shiny::observe({ + msg_1L_chr <- sprintf("Module %s was selected", module_fn()) + cat(msg_1L_chr, "\n") + }) + X_fn <- shiny::reactive({ + fn_txt_1L_chr <- ready4::get_from_lup_obj(classes_lup, + match_value_xx = module_fn(), + match_var_nm_1L_chr = "type_chr", + target_var_nm_1L_chr = "val_chr") + parse(text=fn_txt_1L_chr) %>% eval() + }) + X_ls_fn <- shiny::reactive({ + # fn_txt_1L_chr <- ready4::get_from_lup_obj(classes_lup, + # match_value_xx = module_fn(), + # match_var_nm_1L_chr = "type_chr", + # target_var_nm_1L_chr = "val_chr") + X_ls <- list() + X_ls$contents_ls = make_module_contents_ls(X_fn(), classes_lup = classes_lup, what_1L_chr = "contents") + X_ls$names_ls = make_module_contents_ls(X_fn(), classes_lup = classes_lup) + X_ls$tree_names_ls = make_list_tree_nms(X_ls$names_ls) + X_ls + }) + + + module_ls <- list(module_nm_fn = module_nm_fn, + X_fn = X_fn, + X_ls_fn = X_ls_fn) + return(module_ls) + } + ) +} +plot_cars_UI <- function(id_1L_chr, + label_1L_chr = "Variable:", + choices_chr = c("Cylinders" = "cyl", + "Transmission" = "am", + "Gears" = "gear")){ + ns_fn <- shiny::NS(id_1L_chr) + shiny::tagList( + shiny::selectInput(ns_fn("variable"), label_1L_chr,choices_chr), + shiny::checkboxInput(ns_fn("outliers"), "Show outliers", TRUE), + ) +} +plot_cars_Server <- function(id_1L_chr, mpgData,fml_1L_chr = "") { + shiny::moduleServer( + id_1L_chr, + if(fml_1L_chr == ""){ + function(input, output, session) { + variable_fn <- shiny::reactive({ + shiny::validate(shiny::need(input$variable, message = FALSE)) + input$variable + }) + formula_fn <- shiny::reactive({ + paste("mpg ~", variable_fn()) + }) + return(formula_fn) + } + }else{ + function(input, output, session) { + outliers_fn <- shiny::reactive({ + shiny::validate(shiny::need(input$outliers, message = FALSE)) + input$outliers + }) + graphics::boxplot(as.formula(fml_1L_chr), + data = mpgData, + outline = outliers_fn(), + col = "#007bc2", pch = 19) + } + } + ) +} +