Dear All
This is an interesting option to use Multiple sliders to filter datatable. you may use this in predictive analysis to move and see the impact also in other analyses requiring filters.
when you run this code,you will see Get Data on the yellow bar. click that, you will see the mtcars dataset. you can replace this dataset with your own. sliders will get pickedup automatically from you dataset
#First load required library
library(shiny)
library(shinydashboard) # for Dashboard
library(shinydashboardPlus)
library(shinyalert) # for alert message very nice format
library(DT) # for using %>% which works as a pipe in R code
library(shinyjs)
header<- dashboardHeaderPlus(title = "Multi Filter with Slider")
rightsidebar = rightSidebar()
sidebar <- dashboardSidebar()
body <- dashboardBody(
useShinyalert(),
shinyjs::useShinyjs(),
column(
width = 12,
offset = 0,
align = "center",
box (
id = "slidebarbox206",
width = NULL,
height ='100%',
title = HTML(paste('Play with Slider to Filter', actionLink("mgetfileclick", "Get Data", icon = icon("arrow-circle-up")))),
status = "warning",
solidHeader = TRUE,
collapsible = TRUE,
uiOutput(outputId = "muimultisliderplay")
),#box closrue slider input
box(
width = 12,
height = 400,
DT::dataTableOutput('tblmultimodels', height = 385),
)#box closure
) # column closure
) # dashboardBody closure
ui <- dashboardPagePlus(
shinyjs::useShinyjs(),
header = header,
sidebar = sidebar,
body = body,
rightsidebar = rightsidebar
)
server <- function(input, output, session) {
#this is to hide right side bar
shinyjs::addCssClass(selector = "body", class = "sidebar-collapse")
onevent("mouseenter", "sidebarCollapsed", shinyjs::removeCssClass(selector = "body", class = "sidebar-collapse"))
onevent("mouseleave", "sidebarCollapsed", shinyjs::addCssClass(selector = "body", class = "sidebar-collapse"))
inserted <- c()
slidercolrange <- -2
vmy <- reactiveValues(mydata=NULL,lr_models=NULL)
observeEvent(input$mgetfileclick,{
vmy$lr_models <- mtcars
})
output$tblmultimodels <- DT::renderDataTable({
dtdftemp <<- vals_multiplay$data_1()
vmy$dtdf <- dtdftemp
DT::datatable(vmy$dtdf,
class ='cell-border stripe compact white-space: nowrap',
escape=F,
editable = F,
filter = 'none',
options = list(dom = 't',ordering=T, pageLength = -1,class="compact",
initComplete = JS(
"function(settings, json) {",
"$(this.api().table().header()).css({'background-color': '#808080', 'color': '#fff'});",
"}")
) ,
fillContainer = getOption("DT.fillContainer", TRUE)
)
})
my.styleallrows <- function(.) formatStyle(., columns=0, target= 'row',color = 'black',
backgroundColor = '#ffffed',
fontWeight ='normal',lineHeight='75%')
my.styleonecolumn <- function(.) formatStyle(., columns=c("var_name"), target= 'cell',color = 'black',
backgroundColor = '#ffffed',
fontWeight ='bold',lineHeight='70%')
#######- above multimodel datatable end
output$muimultisliderplay <- renderUI({
tryCatch({
slider_options <- names(dplyr::select_if(vmy$lr_models,is.numeric))
# First, create a list of sliders each with a different name
sliders <- lapply(1:length(slider_options), function(i) {
if (slidercolrange==12){
slidercolrange <- 1
}
else{
slidercolrange <- slidercolrange ++ 2
}
inputName1A <- slider_options[i]
column(slidercolrange+3,sliderInput(inputId = inputName1A, label = inputName1A, min=min(vmy$lr_models[,inputName1A]), max=max(vmy$lr_models[,inputName1A]), value=c(min(vmy$lr_models[[inputName1A]]),max(vmy$lr_models[[inputName1A]])), width = "250px")) #if you need percentage symobl , post="%"
})
# Create a tagList of sliders (this is important)
do.call(tagList, sliders)
}, error=function(e){cat("ERROR :",conditionMessage(e), "\n")})
})
vals_multiplay <- reactiveValues(aaa = NULL,bbb=NULL,data_1=NULL,mpredictlist=NULL,
dataalert=NULL,frame2 = NULL,frame2_ = NULL)
vals_multiplay$data_1 <-function(){
tryCatch({
data_ <<- vmy$lr_models
slider_options <- colnames(dplyr::select_if(vmy$lr_models,is.numeric))
# this is how you fetch the input variables from ui component
for(i in slider_options) {
xxtt<<-as.double(eval(parse(text=paste0("input$",i))))
data_ <<- data_[data_[[i]] <= xxtt[2] &
data_[[i]] >= xxtt[1],]
}
data_
}, error=function(e){cat("ERROR :",conditionMessage(e), "\n")})
}
} #server closure
shinyApp(ui, server)