UIOutput level plot test

Published by onesixx on

 

library(shinyWidgets)
#draw_data <- readRDS("/home/sixx/d2cm/1.RCodes/4.Etc/9.sixx/draw_data.rds")

init_env0 <- function(){
  env <- new.env()
  env$dd <- NULL
  return(env)
}
env6 <- init_env0()

server <- function(input,output, session){
  uFunc_draw_plot<- function(dd, selected_col, val_limit){
    p <- dd %>% ggplot(aes_string(x="sec", y="val", group="subid", color=selected_col)) +
      coord_cartesian(ylim=val_limit) + 
      geom_point() + geom_line()
    output$O_plt_main <- renderPlot({
      return(p)   
    })
  }
  
  observeEvent(input$I_btn_load_make_dd, {
    if (is.null(env6$dd)){
      # example dataset
      set.seed(666)
      nn   <- 20
      repp <- 10
      subid <- lapply(1:nn, function(x){rep(letters[x],repp)}) %>% unlist()
      col1  <- sample( rep(c("A","B"),nn*repp), nn*repp)
      col2  <- rep("G",nn*repp)
      sec   <- rep(1:repp, nn)
      val   <- rnorm(nn*repp, mean=repp, sd =2)
      dd <- data.frame(subid, col1, col2, sec, val)
      env6$dd <<- dd
    }      
    updateRadioButtons(session, "I_rdo_color_opt", choices=c("subid","col1","col2"), selected="subid",inline=T)
  })
  
  react_color_opt    <- reactive(input$I_rdo_color_opt)
  react_display_each <- reactive(input$I_rdoG_display_each)
  react_level_rng    <- reactive(input$I_sld_subid_level)
  
  observe({
    select_col <- react_color_opt()
    subid_level<- react_level_rng()
    display_each <- react_display_each()
    
    dd <- env6$dd
    if (!is.null(dd)){
      val_limit <- range(env6$dd$val)
      if(!is.null(select_col)){
        if(!is.null(subid_level) & display_each=="on"){
            subid_levels <- levels(env6$dd$subid)
            uFunc_draw_plot(env6$dd[env6$dd$subid==subid_levels[subid_level],], select_col, val_limit)
        }else {
          uFunc_draw_plot(dd, select_col, val_limit)
        }
      }
    }
  })
  
  output$O_dync_slide <- renderUI({
    display_each <- react_display_each()
    if(!is.null(display_each)){
      if(display_each=="on"){
        tags$style(HTML(".js-irs-0 { background:#FFFFFF00; }
                        .js-irs-0 .irs-bar-edge { background:#FFFFFF00; border:1px solid #CCC; border-right:1px solid #FFFFFF00; }
                        .js-irs-0 .irs-line { border: 1px solid #CCC }
                        .js-irs-0 .irs-bar  { background:linear-gradient(to bottom, #DDD -50%, #FFF 150%);
                        border-top:1px solid #CCC; border-bottom:1px solid #CCC; }
                        "))
        sliderInput("I_sld_subid_level", label="", width = "100%",
                    value=0, min=1, max=length(unique(env6$dd$subid)), step=1, 
                    animate = animationOptions(interval = 666))
                        }
                        }
                        })
      }

ui <- fluidPage(
  fluidRow(column(width=12,
                  actionButton("I_btn_load_make_dd", "Load Data!") 
  )),
  fluidRow(column(width=12,
                  plotOutput("O_plt_main", width="100%")
  )),
  radioButtons("I_rdo_color_opt", "Color Option", choices=c("subid","col1","col2"), selected="",inline=T),
  conditionalPanel(condition = 'input.I_rdo_color_opt!="col2"',
                   fluidRow(column(width=12, 
                                   radioGroupButtons("I_rdoG_display_each", "Display each:", choices=c("off", "on"), selected="off",
                                                     status="default", size="normal", checkIcon=list(), choiceNames=NULL, choiceValues=NULL),
                                   uiOutput("O_dync_slide")
                   ))
  )
)

shinyApp(ui, server)

 

Categories: PjR-Shiny

onesixx

Blog Owner

Subscribe
Notify of
guest

0 Comments
Oldest
Newest Most Voted
Inline Feedbacks
View all comments
0
Would love your thoughts, please comment.x
()
x