UIOutput level plot test Published by onesixx on 18-07-19 18-07-19
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)