Related
new to shiny, I am developing a dynamic application for several users.
(Pages should be displayed according to user credentials)
I thought about doing it with the conditionpanel.
but i have this error: agAssert: Expected an object with class 'shiny.tag'
my questions are: can we put sidebar or dashbarbody in conditionpanel? if this is possible how?
and do you have other proposals or approaches? Thank you
below is my code:
# Shiny dashboard project
# TIDE 2021-2022
# global option for sipnners
options(spinner.color="#0275D8", spinner.color.background="#ffffff", spinner.size=2)
# Define dashboardHeader()
header <- dashboardHeader(title = "GOUZOU",
dropdownMenu(
type = "notifications",
headerText = strong("HELP"),
icon = icon("question"),
badgeStatus = NULL,
notificationItem(
text = "Faire une demande de Geste Commercial",
icon = icon("spinner")
)
),
tags$li(class="dropdown",
tags$a(href="http://icx.gan.fr/icx/ActionXMLAppel.do",
icon("github"),
"A propos d'ICX",
target="_blank")
)
) #close header
ui_first <- fluidPage(
useShinyjs(), #set up shinyjs
sidebarLayout(
shinyjs::hidden(
div(id = "Siderbar", sidebarPanel(
conditionalPanel(
condition = "input.tabselected > 1",
# Define dashboardSidebar()
dashboardSidebar(
sidebarMenu(
menuItem("Demande", tabName = "do_demande",
menuItem("Mouvements", tabName = "mouvement", icon = icon("spinner")),
menuItem("Mutualisation", tabName = "do_mutualisation", icon= icon("spinner")),
menuItem("Avance", tabName = "do_avance", icon= icon("spinner")),
menuItem("PEDA", tabName = "do_peda", icon= icon("spinner"))
),
badgeLabel =icon("info-circle"), badgeColor = "light-blue",
menuItem("Validation", icon = icon("th"), tabName = "do_validation",
badgeLabel =icon("database"),
badgeColor = "light-blue"),
menuItem("Chargement", icon = icon("trophy"), tabName = "do_chargement",
badgeLabel =icon("sort-amount-up"),
badgeColor = "light-blue"),
menuItem("Autres", icon = icon("eye"), tabName = "autres",
badgeLabel =icon("chart-bar"),
badgeColor = "light-blue") )
) #close sidebar
) #conditionpanel
) #close siderbarpanel
) #close div
), #close hidden
# Main-Panel ------
mainPanel(
tabsetPanel(
# > Login -------
tabPanel("Login",
value = 1,
br(),
textInput("username", "Nom utilisateur"),
passwordInput("password", label = "GJ utilisateur"),
# If you want to add custom javascript messages
# tags$head(tags$script(src = "message-handler.js")),
actionButton("login", "Login"),
textOutput("pwd")
), # closes tabPanel
id = "tabselected", type = "pills"
) # closes tabsetPanel
) # closes mainPanel
) #close sidebarLayout
) #close fluidePage ui first
# Define dashboardBody()
body <- dashboardBody(
# Found at https://stackoverflow.com/questions/40985684/r-shiny-present-a-shinybs-modal-popup-on-page-visit-no-user-action
# bsModal("window", "Window",
# title="Project Details", size="large",
# h4("English", align = "justify"),
# h5(description_eng, align = "justify"),
# #h4("", align = "justify"),
# h4("French", align = "justify"),
# h5(description_fr, align = "justify"),
# #footer = h4(actionLink('create_account',),align='center'),
# tags$head(tags$style("#window .modal-footer{display:bloc}
# .modal-header .close{display:none}"),
# tags$script("$(document).ready(function(){
# $('#window').modal();
# });")
# )
# ),
tabItems(
tabItem("mouvement",
# Row srtucture
fluidRow(
column(4,
# Define User inputs
selectInput("ag_file1",
label = "choisir une agence",
choices = code_ag,
selected = NULL
),
selectInput("motifs_mouv",
label = "Choisir un motif",
choices = motifs_mouv,
selected = NULL
),
selectInput("enveloppe_mouv",
label = "Choisir une enveloppe",
choices = ""
),
textOutput("founds"),
selectInput("transaction", label = "Debit ou Credit", choices = c("Debit", "Credit")
),
numericInput("montant", label = "saisir le montant(€)" ,
value = "" ,min = 5, max=50000 )
,
actionBttn("soumettre_mouv",
"Soumettre", icon=NULL, style = "unite", color = "success",
size="md", block = FALSE, no_outline = TRUE)
),
column(8,
uiOutput("infos_mouv"))
)
)
,
tabItem("do_mutualisation",
# Row srtucture
fluidPage( tabsetPanel(
tabPanel("Mutualisation entre enveloppes",
selectInput("agence_mut",
label = "veuillez selectionner une agence",
choices = "",
selected = NULL),
selectInput("env_mutu_deb",
label = "sectionner l'enveloppe à debiter",
choices = c("N500", "N600"), selected = NULL),
selectInput("env_mutu_deb",
label = "selectionner l'enveloppe à crediter",
choices = c("N500", "N600") ,
selected = NULL
),
numericInput("montant_mutu",
label = "Saisir le montant",
value = "",
min = 0,
max= Inf),
bsButton("valider_mutu",
label = "Soumettre",
icon = icon("spinner"),
style = "success")
),
tabPanel("mutualisation entre agences",
column(4,
selectInput(
"Code_agence",
label = "Selctionner le code d' l'agence à debiter",
choices = "",
selected = NULL
),
checkboxGroupInput("env_mut_ag_deb",
label = "cocher l'enveloppe à debiter",
choices = c("N500", "N600"),
width = 5)
),
column(10,
selectInput("code_agence",
label = "selectionner le code de l'agence à crediter",
choices = ""),
checkboxGroupInput("env_mut_ag_deb",
label = "cocher l'enveloppe à crediter",
choices = c("N500", "N600"),
width = 5)
,
bsButton("valider_mutu_ag",
label = "Soumettre",
icon = icon("spinner"),
style = "success"),
column(6,
numericInput("mont_mutu_ag",
label = "saisir le montant",
value = "",
min= 5, max = 50000
),
)
),
)
)
)
)
,
tabItem("do_avance",
fluidRow(
column(4,
selectInput("ag_file2",
label = "choisir une agence",
choices = "",
selected = NULL),
selectInput('motifs_avance',
'Selctionnez le motif',
choices = motifs_avance,
selected = "AVANCE SUR CONTRAT"),
selectInput("enveloppe_avance",
"Selectionner une enveloppe",
choices = "",
selected = NULL),
numericInput("montant_avance",
"Saisir le montant de l'avance demandée ou à recuperer",
value = "",
min = 0, max = Inf
),
actionBttn("soumettre_avance",
"Soumettre", icon=NULL, style = "unite", color = "success",
size="md", block = FALSE, no_outline = TRUE)
)
)
),
tabItem("do_validation"
#fluidPage(
# fluidRow(
# column(4,
# selectInput("tab_fil1",
# label = "Filter Select",
# choices = c("Country","Language", "Genre")
# )
#),#
# column(4,
# selectInput("tab_fil2",
# label = "",
# choices = "")
# ),
# column(4,
# numericInput("tab_fil3",
# label = "Number of observations",
# min = 0,
# max = Inf,
# value = 50
# )
# )
# ),
# textOutput("founds2"),
# dataTableOutput("data_view") %>% withSpinner(type = 6)
# )
),
tabItem("do_chargement"
#fluidPage(
# fluidRow(
# column(6,
# selectInput("HOF_fil1",
# label = "Select filter below",
# choices = c("Decade", "Genre", "Year")
#)
#),
#column(6,
# selectInput("HOF_fil2",
# label = "",
# choices = "")
#)
#),
#fluidRow(
# uiOutput("podium_table")
#)
#)
),
tabItem("autres"
#fluidPage(
#fluidRow(
# column(6,
#
# pickerInput(
# inputId = "dec_fil1",
# label = "Select decade below",
# choices = dec_val,
# multiple = FALSE,
# choicesOpt = list(
# disabled = dec_val %in% dec_val[1:2]
# )
# )
# ),
# column(6,
# verbatimTextOutput("cont")
# )
# ),
# fluidRow(
# plotOutput("countTitleGraph",width = "70%") %>% withSpinner(type = 6)
# )
)
)
) #close body
footer <- dashboardFooter(
left = "Gan",
right = "contact:"
)
# ui out to server
ui<-dashboardPagePlus(header, ui_first, body, footer=footer)
#server :
server <- function(input, output, session) {
user_vec <- c("niang" = "GJ7471",
"gouzou" = "PL4350")
# I usually do run the code below on a real app on a server
# user <- reactiveValues(his = readRDS(file = "logs/user_his.rds"),
# log = readRDS(file = "logs/user_log.rds"),
# vec = readRDS(file = "logs/user_vec.rds"))
#
# where user_his is defined as follows
# user_his <- vector(mode = "integer", length = length(user_vec))
# names(user_his) <- names(user_vec)
observeEvent(input$login, {
if (str_to_lower(input$username) %in% names(user_vec)) { # is username in user_vec?
# Alternatively if you want to limit login attempts to "3" using the user_his file
# if (str_to_lower(input$username) %in% names(user$vec[user$his < 3])) {
if (input$password == unname(user_vec[input$username])) {
# nulls the user_his login attempts and saves this on server
# user$his[str_to_lower(input$username)] <- 0
# saveRDS(user$his, file = "logs/user_his.rds")
# Saves a temp log file
# user_log_temp <- data.frame(username = str_to_lower(input$username),
# timestamp = Sys.time())
# saves temp log in reactive value
# user$log <- rbind(user$log, user_log_temp)
# saves reactive value on server
# saveRDS(user$log, file = "logs/user_log.rds")
# > Add MainPanel and Sidebar----------
shinyjs::show(id ="Siderbar")
appendTab(inputId = "tabselected",
tabPanel("Tab 1",
value = 2
) # closes tabPanel,
)
appendTab(inputId = "tabselected",
tabPanel("Tab 2",
value = 3
) # closes tabPanel,
)
appendTab(inputId = "tabselected",
tabPanel("Tab 3",
value = 4
) # closes tabPanel
)
removeTab(inputId = "tabselected",
target = "1")
} else { # username correct, password wrong
# adds a login attempt to user_his
# user$his[str_to_lower(input$username)] <- user$his[str_to_lower(input$username)] + 1
# saves user_his on server
# saveRDS(user$his, file = "logs/user_his.rds")
# Messge which shows how many log-in tries are left
#
# session$sendCustomMessage(type = 'testmessage',
# message = paste0('Password not correct. ',
# 'Remaining log-in tries: ',
# 3 - user$his[str_to_lower(input$username)]
# )
# )
} # closes if-clause
} else { # username name wrong or more than 3 log-in failures
# Send error messages with javascript message handler
#
# session$sendCustomMessage(type = 'testmessage',
# message = paste0('Wrong user name or user blocked.')
# )
} # closes second if-clause
}) # closes observeEvent
#demande
######### Server Mouvement
observeEvent(
input$motifs_mouv,
updateSelectInput(session,
inputId = "enveloppe_mouv",
label = "Choisir une enveloppe",
choices = enveloppeChoices()
)
)
enveloppeChoices <- reactive({
MOUVEMENT$ENVELOPPES[MOUVEMENT$MOTIFS == input$motifs_mouv] %>% sort()
})
output$founds <- reactive({
paste(MOUVEMENT$ENVELOPPES[MOUVEMENT$MOTIFS == input$motifs_mouv] %>% length(), "enveloppe(s) trouvrées")
})
# filtering data and rendering to htmlTable
output$infos_mouv <- renderUI({
table(
code_agence = input$ag_file1,
titulaires = TABLEICX$TITULAIR[TABLEICX$CODEICX == input$ag_file1],
reseau = TABLEICX$RESEAU[TABLEICX$CODEICX == input$ag_file1],
region = TABLEICX$REGION[TABLEICX$CODEICX== input$ag_file1],
telephone= TABLEICX$TEL[TABLEICX$CODEICX== input$ag_file1],
ICRA= TABLEICX$NOMICRA[TABLEICX$CODEICX == input$ag_file1],
DCR= TABLEICX$NOMDR[TABLEICX$CODEICX == input$ag_file1],
email= TABLEICX$EMAIL[TABLEICX$CODEICX == input$ag_file1]
)
})
observeEvent(input$soumettre_mouv, {
log <- data.frame(
Demandeur = TABLEICX$TITULAIR[TABLEICX$CODEICX == input$ag_file1],
Code = input$ag_file1,
Motif = input$motifs_mouv,
enveloppe = input$enveloppe_mouv,
Date = Sys.time(),
transaction = input$transaction,
montant = input$montant
)
write.table(log,
file = "logs.table",
sep = ";",
append = TRUE,
row.names = FALSE,
col.names = FALSE)
sendSweetAlert(
session = session,
title = "Recapitulatif de votre demande",
text = fluidRow(
column(12,
uiOutput("demande_details"),
style= "font-size: 9pt"
),
column(
width = 12,
DT::DTOutput("logs_table"),
style = "font-size: 8pt"
#tableOutput("logs_table")
),
column(
width=12,
actionBttn("valider_mouv", "Valider", icon=NULL, style = "unite", color = "success",
size="md", block = FALSE, no_outline = TRUE
)
)
),
# style = "margin-top: 50px"
html = TRUE
)
})
logs <- eventReactive(input$soumettre_mouv, {
if (file.exists("logs.table")) {
Sys.sleep(2)
read.table(
"logs.table",
sep = ";",
colClasses = "character",
col.names = c("Demandeur", "Code", "Motif", "enveloppe","Date","transaction", "montant")
)
}
} %>%
arrange(desc(Date), .by_group= FALSE) %>% head(1)
, ignoreNULL = FALSE)
output$demande_details <- renderUI({
req(logs())
tagList(
h4(logs()$Code),
p(paste("Vous allez faire une demander de ", input$transaction," ", "pour le motif " ," ", logs()$Motif, " ", "sur votre enveloppe ", logs()$enveloppe )
)
)
})
output$logs_table <- DT::renderDT({
req(logs())
logs() %>%
select(Demandeur, enveloppe, montant, Date) %>%
DT::datatable(
options = list(pageLength = 10, responsive = TRUE, dom = "tp"),
selection = "single",
class = "display compact",
rownames = FALSE
)
})
observeEvent(input$valider_mouv,
{
#req(logs())
histo_mouv <- data.frame(
Demandeur = logs()$Demandeur,
Code = logs()$Code,
Motif = logs()$Motif,
Enveloppe = logs()$enveloppe,
Date = logs()$Date,
Transaction = logs()$transaction,
Montant = logs()$montant,
ICRA= TABLEICX$NOMICRA[TABLEICX$CODEICX == input$ag_file1],
DCR= TABLEICX$NOMDR[TABLEICX$CODEICX == input$ag_file1]
)
write.table(histo_mouv,
file = "mouv_histo.table",
sep = ";",
append = TRUE,
row.names = FALSE,
col.names = FALSE)
column(
width = 12,
DT::DTOutput("histo_mouv_table"),
style = "font-size: 8pt"
#tableOutput("logs_table")
)
sendSweetAlert(
session = session,
title = "Validé !",
text = "Votre demande a bien été soumise",
type = "success"
)
}
)
mouv_histo <- eventReactive(input$valider_mouv, {
if (file.exists("mouv_histo.table")) {
Sys.sleep(2)
read.table(
"mouv_histo.table",
sep = ";",
colClasses = "character",
col.names = c("Demandeur", "Code", "Motif", "Enveloppe","Date","Transaction", "Montant","ICRA", "DCR")
)
}
} %>%
arrange(desc(Date), .by_group= FALSE)
, ignoreNULL = FALSE)
output$histo_mouv_table <- DT::renderDT({
req(logs())
mouv_histo() %>%
DT::datatable(
options = list(pageLength = 5, responsive = TRUE, dom = "tp"),
selection = "single",
class = "display compact",
rownames = FALSE
)
})
#Avance server
observeEvent(
input$motifs_avance,
updateSelectInput(session,
inputId = "enveloppe_avance",
label = "Choisir une enveloppe",
choices = enveloppeAvance()
)
)
enveloppeAvance <- reactive({
AVANCE$ENVELOPPES[AVANCE$MOTIFS == input$motifs_avance]
})
# filtering data and rendering to htmlTable
#output$infos_mouv <- renderUI({
# })
# output of the findings length afer user input filter
}
#####################################################################
require('BBmisc')
lib('shiny')
lib('shinythemes')
lib('shinydashboard')
lib('shinydashboardPlus')
lib('dashboardthemes')
lib('shinyWidgets')
lib('shinyjs')
lib('memoise')
if(!require('XML')) devtools::install_github('omegahat/XML')
lib('XML')
### creating custom logo object
logo <- shinyDashboardLogoDIY(
boldText = 'ξηg',
mainText = 'Lιαη Ημ',
textSize = 16,
badgeText = '🐉 ®γσ',
badgeTextColor = 'white',
badgeTextSize = 2,
badgeBackColor = "#40E0D0",
badgeBorderRadius = 3)
alignCenter <- memoise(function(el) {
htmltools::tagAppendAttributes(el, style="width:500vw;height:100vh;background-color:#fff;display:flex;align-items:center;justify-content:center;")
})
ui <- shinyUI(
shinydashboardPlus::dashboardPage(#skin = 'midnight',
header = shinydashboardPlus::dashboardHeader(title = logo),
sidebar = shinydashboardPlus::dashboardSidebar(
minified = TRUE, collapsed = FALSE,
sidebarMenu(
id = 'tabs',
menuItem('®️Studio ☁️', tabName = 'menu',
## https://getbootstrap.com/docs/3.4/components/#glyphicons
## https://fontawesome.com/icons
icon = icon('fa-brand fa-linux'), startExpanded = TRUE,
menuSubItem('🏠 Home', tabName = 'home'),
menuSubItem('🇬🇧 ENGLISH', tabName = 'en'),
menuSubItem('🇨🇳 简体中文', tabName = 'cn'),
menuSubItem('🇹🇼 繁体中文', tabName = 'tw'),
menuSubItem('🇯🇵 日本語', tabName = 'jp'),
menuSubItem('🇰🇷 한국어', tabName = 'kr'),
menuSubItem('🇩🇪 Deutsch', tabName = 'de'),
menuSubItem('🇫🇷 français', tabName = 'fr'),
menuSubItem('🇮🇹 Italiano', tabName = 'it'))#,
#menuItem('Appendices', icon = icon('th'), tabName = 'append',
# menuSubItem('Author', tabName = 'author'))
)),
body = dashboardBody(
shinyDashboardThemes(theme = 'blue_gradient'),
tabItems(
tabItem(tabName = 'home', h2('®️Studio ☁️', align = 'center'), alignCenter(
#shinydashboardPlus::box(
prettyRadioButtons(
inputId = 'rb', label = NULL,
choices = c('🇬🇧 ENGLISH' = 'en',
'🇨🇳 简体中文' = 'cn',
'🇹🇼 繁体中文' = 'tw',
'🇯🇵 日本語' = 'jp',
'🇰🇷 한국어' = 'kr',
'🇩🇪 Deutsch' = 'de',
'🇫🇷 Français' = 'fr',
'🇮🇹 Italiano' = 'it'),
shape = 'curve', animation = 'pulse',
selected = character(0), status = 'primary',
thick = TRUE, width = '100%', bigger = TRUE,
icon = icon('registered')))
),
tabItem(tabName = 'en', h2('🇬🇧 ENGLISH', align = 'center'),
tags$iframe(src = 'http://rpubs.com/englianhu/ryo-en',
height = 800, width = '100%', frameborder = 0)#,
#HTML(readLines('www/ryo-en.html')),
#fluidPage(includeHTML('www/ryo-en.html'))
),
tabItem(tabName = 'cn', h2('🇨🇳 简体中文', align = 'center'),
#tags$iframe(src = 'https://rpubs.com/englianhu/ryo-cn',
# height = 800, width = '100%', frameborder = 0),
#HTML(readLines('www/ryo-cn.html')),
fluidPage(includeHTML('www/ryo-cn.html'))),
tabItem(tabName = 'tw', h2('🇹🇼 繁体中文', align = 'center'),
#tags$iframe(src = 'https://rpubs.com/englianhu/ryo-tw',
# height = 800, width = '100%', frameborder = 0),
#HTML(readLines('www/ryo-tw.html')),
fluidPage(includeHTML('www/ryo-tw.html'))),
tabItem(tabName = 'jp', h2('🇯🇵 日本語', align = 'center'),
#tags$iframe(src = 'https://rpubs.com/englianhu/ryo-jp',
# height = 800, width = '100%', frameborder = 0),
#HTML(readLines('www/ryo-jp.html')),
fluidPage(includeHTML('www/ryo-jp.html'))),
tabItem(tabName = 'kr', h2('🇰🇷 한국어', align = 'center'),
#tags$iframe(src = 'https://rpubs.com/englianhu/ryo-kr',
# height = 800, width = '100%', frameborder = 0),
#HTML(readLines('www/ryo-kr.html')),
#fluidPage(includeHTML('www/ryo-kr.html'))
),
tabItem(tabName = 'de', h2('🇩🇪 Deutsch', align = 'center'),
#tags$iframe(src = 'https://rpubs.com/englianhu/ryo-de',
# height = 800, width = '100%', frameborder = 0),
#HTML(readLines('www/ryo-de.html')),
#fluidPage(includeHTML('www/ryo-de.html'))
),
tabItem(tabName = 'fr', h2('🇫🇷 Français', align = 'center'),
#tags$iframe(src = 'https://rpubs.com/englianhu/ryo-fr',
# height = 800, width = '100%', frameborder = 0),
#HTML(readLines('www/ryo-fr.html')),
#fluidPage(includeHTML('www/ryo-fr.html'))
),
tabItem(tabName = 'it', h2('🇮🇹 Italiano', align = 'center'),
#tags$iframe(src = 'https://rpubs.com/englianhu/ryo-fr',
# height = 800, width = '100%', frameborder = 0),
#HTML(readLines('www/ryo-fr.html')),
#fluidPage(includeHTML('www/ryo-fr.html'))
))),
footer = shinydashboardPlus::dashboardFooter(
p('Powered by - Copyright® Intellectual Property Rights of ',
tags$a(href='https://www.scibrokes.com', target = '_blank',
tags$img(height = '20px', alt = 'scibrokes', #align='right',
src='www/Scibrokes.png')),
HTML("<a href='https://www.scibrokes.com'>Sςιβrοκεrs Trαdιηg®</a>"))),
title = 'DashboardPage'))
#shinyApp(server = server, ui = ui)
ui.R as above
require('BBmisc')
lib('shiny')
lib('shinythemes')
lib('shinydashboard')
lib('shinydashboardPlus')
lib('dashboardthemes')
lib('shinyWidgets')
lib('shinyjs')
lib('memoise')
if(!require('XML')) devtools::install_github('omegahat/XML')
lib('XML')
server <- shinyServer(function(input, output, session) {
#observeEvent(input$rb, {
# newtab <- switch(input$tabs,
# "en" = "en",
# "cn" = "cn",
# "tw" = "tw",
# "jp" = "jp")
# updateTabItems(session, "tabs", newtab)
# })
#output$cv_page <- renderUI({
#
# page = switch(input$rb,
# en = 'www/ryo-en.html',
# cn = 'www/ryo-cn.html',
# tw = 'www/ryo-tw.html',
# jp = 'www/ryo-jp.html')
#
#HTML(markdown::markdownToHTML('ryo-en.md'))
#HTML(rmarkdown::render(knit('ryo-en.Rmd')))
# includeHTML(page)
#})
#observeEvent(input$rb, {
# newtab <- switch(input$tabs,
# "home" = "home",
# "en" = "en",
# "cn" = "cn",
# "tw" = "tw",
# "jp" = "jp",
# "author" = "author")
# updateTabItems(session, "tabs", newtab)
#})
observeEvent(input$rb == 'en', {
updateTabItems(session, "tabs", selected = "en")
})
observeEvent(input$rb == 'cn', {
updateTabItems(session, "tabs", selected = "cn")
})
observeEvent(input$rb == 'tw', {
updateTabItems(session, "tabs", selected = "tw")
})
observeEvent(input$rb == 'jp', {
updateTabItems(session, "tabs", selected = "jp")
})
#output$ryo_en <- renderUI({
# #HTML(markdown::markdownToHTML('ryo-en.md'))
# #HTML(rmarkdown::render(knit('ryo-en.Rmd')))
# includeHTML("ryo-en.html")
#})
#output$ryo_cn <- renderUI({
# #HTML(markdown::markdownToHTML('ryo-en.md'))
# #HTML(rmarkdown::render(knit('ryo-en.Rmd')))
# includeHTML("ryo-cn.html")
#})
#output$ryo_tw <- renderUI({
# #HTML(markdown::markdownToHTML('ryo-en.md'))
# #HTML(rmarkdown::render(knit('ryo-en.Rmd')))
# includeHTML("ryo-tw.html")
#})
#output$ryo_jp <- renderUI({
# #HTML(markdown::markdownToHTML('ryo-en.md'))
# #HTML(rmarkdown::render(knit('ryo-en.Rmd')))
# includeHTML("ryo-jp.html")
#})
#observeEvent(input$rb, {
# updateTabItems(session, input$rb,
# selected = input$rb)
#})
#observeEvent(input$rb, {
#tbs <- c('en', 'cn', 'tw', 'jp', 'kr', 'de', 'fr', 'it')
# newtab <- switch(input$tabs,
# 'en' = 'en',
# 'cn' = 'cn',
# 'tw' = 'tw',
# 'jp' = 'jp',
# 'kr' = 'kr',
# 'de' = 'de',
# 'fr' = 'fr',
# 'it' = 'it')
# updateTabItems(session, 'tabs', newtab)#, selected = input$rb)
#})
#observeEvent(input$rb, {
# updatePrettyRadioButtons(
# session = session,
# inputId = 'rb',
# choices = c('en', 'cn', 'tw', 'jp', 'kr', 'de', 'fr', 'it'),
# prettyOptions = list(animation = 'pulse', status = 'info',
# shape = 'curve', status = 'primary',
# thick = TRUE, width = '100%',
# bigger = TRUE, icon = icon('registered')))
#}, ignoreInit = TRUE)
})
#shinyApp(server = server, ui = ui)
server.R as above
Try to use shinyWidgets::prettyRadioButtons() but wonder why the alignment doesn't working fine? Below shows the problem.
Current output as above, the choices do not align same line with radio buttons
Just wonder how to make it work as normal as shows below? I do appreciate if somebody take a look.
Expected output as above, the choices do align same line with radio buttons
Expected output as above will be BEST, the choices do align same line with radio buttons with stepwise effect (animated bounce-in or fly-in will be wonderful)
Source of Question:
GitHub: The alignment of Choices on Radio Button #484
shinyWidgets::prettyRadioButtons() and shinydashboard::updateTabItems()
I'm having issues with a filter option in my R shinydashboard app. I'm able to filter a dataframe column (padj < 1) but when I incorporate this same filter into the app the data is missing padj rows that are very tiny like 1.41103072458963E-14. I get all rows up to 4 decimal places (0.00011014) but not rows with padj smaller than that. This cuts off dozens of wanted rows.
I may be coding something wrong and have tried searching for similar issues but haven't found any.
The select input I chose is:
pickerInput("FDR", "False Discovery Rate", choices = c(1, 0.1, 0.05, 0.01))
when I try to filter using above input:
genes1 <- reactive({
genes <- DEG2 %>% dplyr::filter(padj <= input$FDR) %>% dplyr::filter(log2FoldChange >= input$FC | log2FoldChange <= -input$FC)
})
Any help/advice is greatly appreciated.
data to be loaded here:
datafile.
See below for the app code.
library(shinydashboard)
library(dashboardthemes)
library(shiny)
library(shinythemes)
library(shinyWidgets)
library(shinycssloaders)
library(shinyjs)
library(htmlTable)
library(DT)
library(dplyr)
library(ggpubr)
library(ggplot2)
library(htmlwidgets)
library(plotly)
library(table1)
# load dataset
DEG2 <- read.csv("DEG2.csv")
# to add color to the spinner
options(spinner.color="#287894")
#############################################
### HEADER #################################
#############################################
header <- dashboardHeader(title = tagList(
tags$span(class = "logo-mini", "Cell"),
tags$span( class = "logo-lg", "My 1st App" )),
titleWidth = 300)
#############################################
### SIDEBAR #################################
#############################################
sidebar <- dashboardSidebar(width = 300, sidebarMenu(id = "sidebar", # id important for updateTabItems
menuItem("Pipeline", tabName = "pipe", icon = icon("bezier-curve")),
menuItem("Something", tabName = "plot", icon = icon("braille")),
menuItem("Something else", tabName = "pathways", icon = icon("connectdevelop")),
menuItem("Contact", tabName = "contact", icon = icon("address-card"))
)
)
#############################################
### BODY #################################
#############################################
body <- dashboardBody(
useShinyjs(), # Set up shinyjs
# changing theme
shinyDashboardThemes(theme = "blue_gradient"),
tabItems(
######### Tab 1 #########################################
tabItem("pipe",
fluidPage(
h2("Pipeline"),
#### STEP 1 ####
box(width = 12, title = "Step1: Filter for DEGs", collapsible = TRUE, collapsed = FALSE, status = "primary", solidHeader = TRUE,
fluidRow(
column(4, offset = 0,
sliderTextInput("FC", "Fold-Change (absolute value)", choices = seq(from= 0, to= 5, by=0.5), grid = TRUE),
pickerInput("FDR", "False Discovery Rate", choices = c(1, 0.1, 0.05, 0.01)),
setSliderColor(color = '#EE9B00', sliderId = 1),),
column(6, offset= 1,
valueBoxOutput("genes_filtered", width = 4))),
br(),
fluidRow(
column(10, offset =0,
DT::dataTableOutput("genetable") %>% withSpinner(type = 8, size=1))),
br(),
actionBttn("step1", "Select to advance:step 2", color = "warning", style = "fill", icon = icon("angle-double-down" ))
)),
#### STEP 2 ####
conditionalPanel(
condition = "input.step1 == 1",
fluidPage(
box(width = 12, title = "Step2: Filter for gene regulation", collapsible = TRUE, collapsed = FALSE, status = "primary", solidHeader = TRUE,
"Choose to subset the genes that are up or down regulated",
br(),
br(),
fluidRow(
column(6, offset = 0,
prettyRadioButtons("reg", "Choose:", choices = c("Up-regulated", "Down-regulated", "All"), status = "success", fill=TRUE, inline = TRUE))
),
br(),
fluidRow(
column(6, offset = 0,
valueBoxOutput("value", width = 6)))
) # box
)
) # conditional panel
)# end tab3
) # end tabItems
)#dashboardBody
ui <- dashboardPage(header = header,
sidebar = sidebar,
body = body
)
server <- function(input, output, session) {
############################################
###### TAB1 ##################
############################################
# step 1
genes1 <- reactive({
genes <- DEG2 %>% dplyr::filter(padj <= input$FDR) %>% dplyr::filter(log2FoldChange >= input$FC | log2FoldChange <= -input$FC)
})
output$genes_filtered <- renderValueBox({
valueBox(value=length(genes1()$symbol), subtitle = "Filtered genes", color = "purple", icon=icon("filter"))
})
output$genetable <- DT::renderDataTable({
genes1() }, server = FALSE, extensions =c("Responsive", "Buttons"), rownames = FALSE, options = list(dom = 'Blfrtip', buttons = list('copy', list(extend = "collection",
buttons = c("csv", "excel", "pdf"),
text = "Download")))
)
# step 2
genes2 <- reactive({
g2 <- if (input$reg == "Up-regulated"){
genes1() %>% filter(log2FoldChange > 0)
} else if (input$reg == "Down-regulated"){
genes1() %>% filter(log2FoldChange < 0)
} else {
genes1()
}
})
output$value <- renderValueBox({
if (input$reg == "Up-regulated"){
valueBox(value = length(genes2()$symbol), subtitle = "Up-regulated genes", color = "red", icon = icon("hand-point-up"))
} else if (input$reg == "Down-regulated"){
valueBox(value = length(genes2()$symbol), subtitle = "Down-regulated genes", color = "blue", icon = icon("hand-point-down"))
} else {
valueBox(value = length(genes2()$symbol), subtitle = "All genes", color = "orange", icon = icon("record-vinyl"))
}
})
} #server
shinyApp(ui, server)
Try as.numeric(input$FDR) in your filter as shown below.
genes <- DEG2 %>% dplyr::filter(padj <= as.numeric(input$FDR))
EDIT: I have simplified the application and make it all the code reproducible.
EDIT 2: I just discovered that when I use the navBarPage I must click on Additional Parameters -> Colour. Then is coloured as expected.
I'm developing a shiny app which filters my genes and then plots a heatmap of the remaining genes. Recently, I have found shinyHeatmaply package. I have download their global, UI and Server, and when I try it on my own computer they work as expected. Unfortunately, when I try to combine my filter app and their heatmap using navbarPage, the last one is not rending properly.
I have created a minimalist example adding the shinyheatmap to the second tabPanel of navbarPage in the https://shiny.rstudio.com/gallery/shiny-theme-selector.html app, but I get the same grey render anyway.
Same mistake in a simpler application
The UI:
Navbar 1 belongs to the shinytheme application, whilst the content of Navbar 2 belongs to the shinyheatmaply
tagList(
shinythemes::themeSelector(),
navbarPage(
# theme = "cerulean", # <--- To use a theme, uncomment this
"shinythemes",
tabPanel("Navbar 1",
sidebarPanel(
fileInput("file", "File input:"),
textInput("txt", "Text input:", "general"),
sliderInput("slider", "Slider input:", 1, 100, 30),
tags$h5("Deafult actionButton:"),
actionButton("action", "Search"),
tags$h5("actionButton with CSS class:"),
actionButton("action2", "Action button", class = "btn-primary")
),
mainPanel(
tabsetPanel(
tabPanel("Tab 1",
h4("Table"),
tableOutput("table"),
h4("Verbatim text output"),
verbatimTextOutput("txtout"),
h1("Header 1"),
h2("Header 2"),
h3("Header 3"),
h4("Header 4"),
h5("Header 5")
),
tabPanel("Tab 2", "This panel is intentionally left blank"),
tabPanel("Tab 3", "This panel is intentionally left blank")
)
)
),
tabPanel("Navbar 2",
fluidPage(
sidebarLayout(
sidebarPanel(width=4,
h4('Data Selection'),
fileInput(inputId="mydata", label = "Import Data",multiple = T),
uiOutput('data'),
checkboxInput('showSample','Subset Data'),
conditionalPanel('input.showSample',uiOutput('sample')),
hr(),h4('Data Preprocessing'),
column(width=4,selectizeInput('transpose','Transpose',choices = c('No'=FALSE,'Yes'=TRUE),selected = FALSE)),
column(width=4,selectizeInput("transform_fun", "Transform", c(Identity=".",Sqrt='sqrt',log='log',Scale='scale',Normalize='normalize',Percentize='percentize',"Missing values"='is.na10', Correlation='cor'),selected = '.')),
uiOutput('annoVars'),
br(),hr(),h4('Row dendrogram'),
column(width=6,selectizeInput("distFun_row", "Distance method", c(Euclidean="euclidean",Maximum='maximum',Manhattan='manhattan',Canberra='canberra',Binary='binary',Minkowski='minkowski'),selected = 'euclidean')),
column(width=6,selectizeInput("hclustFun_row", "Clustering linkage", c(Complete= "complete",Single= "single",Average= "average",Mcquitty= "mcquitty",Median= "median",Centroid= "centroid",Ward.D= "ward.D",Ward.D2= "ward.D2"),selected = 'complete')),
column(width=12,sliderInput("r", "Number of Clusters", min = 1, max = 15, value = 2)),
#column(width=4,numericInput("r", "Number of Clusters", min = 1, max = 20, value = 2, step = 1)),
br(),hr(),h4('Column dendrogram'),
column(width=6,selectizeInput("distFun_col", "Distance method", c(Euclidean="euclidean",Maximum='maximum',Manhattan='manhattan',Canberra='canberra',Binary='binary',Minkowski='minkowski'),selected = 'euclidean')),
column(width=6,selectizeInput("hclustFun_col", "Clustering linkage", c(Complete= "complete",Single= "single",Average= "average",Mcquitty= "mcquitty",Median= "median",Centroid= "centroid",Ward.D= "ward.D",Ward.D2= "ward.D2"),selected = 'complete')),
column(width=12,sliderInput("c", "Number of Clusters", min = 1, max = 15, value = 2)),
#column(width=4,numericInput("c", "Number of Clusters", min = 1, max = 20, value = 2, step = 1)),
br(),hr(), h4('Additional Parameters'),
column(3,checkboxInput('showColor','Color')),
column(3,checkboxInput('showMargin','Layout')),
column(3,checkboxInput('showDendo','Dendrogram')),
hr(),
conditionalPanel('input.showColor==1',
hr(),
h4('Color Manipulation'),
uiOutput('colUI'),
sliderInput("ncol", "Set Number of Colors", min = 1, max = 256, value = 256),
checkboxInput('colRngAuto','Auto Color Range',value = T),
conditionalPanel('!input.colRngAuto',uiOutput('colRng'))
),
conditionalPanel('input.showDendo==1',
hr(),
h4('Dendrogram Manipulation'),
selectInput('dendrogram','Dendrogram Type',choices = c("both", "row", "column", "none"),selected = 'both'),
selectizeInput("seriation", "Seriation", c(OLO="OLO",GW="GW",Mean="mean",None="none"),selected = 'OLO'),
sliderInput('branches_lwd','Dendrogram Branch Width',value = 0.6,min=0,max=5,step = 0.1)
),
conditionalPanel('input.showMargin==1',
hr(),
h4('Widget Layout'),
column(4,textInput('main','Title','')),
column(4,textInput('xlab','X Title','')),
column(4,textInput('ylab','Y Title','')),
sliderInput('row_text_angle','Row Text Angle',value = 0,min=0,max=180),
sliderInput('column_text_angle','Column Text Angle',value = 45,min=0,max=180),
sliderInput("l", "Set Margin Width", min = 0, max = 200, value = 130),
sliderInput("b", "Set Margin Height", min = 0, max = 200, value = 40)
)
),
mainPanel(
tabsetPanel(
tabPanel("Heatmaply",
tags$a(id = 'downloadData', class = paste("btn btn-default shiny-download-link",'mybutton'), href = "", target = "_blank", download = NA, icon("clone"), 'Download Heatmap as HTML'),
tags$head(tags$style(".mybutton{color:white;background-color:blue;} .skin-black .sidebar .mybutton{color: green;}") ),
plotlyOutput("heatout",height='600px')
),
tabPanel("Data",
DT::dataTableOutput('tables')
)
)
)
)
)
),
tabPanel("Navbar 3", "This panel is intentionally left blank")
)
)
The server:
Regarding to the server, first two output correspond to the shinytheme and the others belong to shinyheatmaply
d=data(package='datasets')$results[,'Item']
d=d[!grepl('[\\()]',d)]
d=d[!d%in%c('UScitiesD','eurodist','sleep','warpbreaks')]
d=d[unlist(lapply(d,function(d.in) eval(parse(text=paste0('ncol(as.data.frame(datasets::',d.in,'))')))))>1]
d=d[-which(d=='mtcars')]
d=c('mtcars',d)
server <- shinyServer(function(input, output,session) {
####This to output belongs to the shinytheme application####
output$txtout <- renderText({
paste(input$txt, input$slider, format(input$date), sep = ", ")
})
output$table <- renderTable({
head(cars, 4)
})
#######################################################
#Up to here the code belongs to shinyheatmaply
output$txtout <- renderText({
paste(input$txt, input$slider, format(input$date), sep = ", ")
})
output$table <- renderTable({
head(cars, 4)
})
TEMPLIST<-new.env()
TEMPLIST$d<-d
#Annotation Variable UI ----
observeEvent(data.sel(),{
output$annoVars<-renderUI({
data.in=data.sel()
NM=NULL
if(any(sapply(data.in,class)=='factor')){
NM=names(data.in)[which(sapply(data.in,class)=='factor')]
}
column(width=4,
selectizeInput('annoVar','Annotation',choices = names(data.in),selected=NM,multiple=T,options = list(placeholder = 'select columns',plugins = list("remove_button")))
)
})
#Sampling UI ----
output$sample<-renderUI({
list(
column(4,textInput(inputId = 'setSeed',label = 'Seed',value = sample(1:10000,1))),
column(4,numericInput(inputId = 'selRows',label = 'Number of Rows',min=1,max=pmin(500,nrow(data.sel())),value = pmin(500,nrow(data.sel())))),
column(4,selectizeInput('selCols','Columns Subset',choices = names(data.sel()),multiple=T))
)
})
})
#Data Selection UI ----
output$data=renderUI({
if(!is.null(input$mydata)) TEMPLIST$d=c(input$mydata$name,TEMPLIST$d)
selData=head(TEMPLIST$d,1)
selectInput("data","Select Data",TEMPLIST$d,selected = selData)
})
#Color Pallete UI ----
output$colUI<-renderUI({
colSel='Vidiris'
if(input$transform_fun=='cor') colSel='RdBu'
if(input$transform_fun=='is.na10') colSel='grey.colors'
selectizeInput(inputId ="pal", label ="Select Color Palette",
choices = c('Vidiris (Sequential)'="viridis",
'Magma (Sequential)'="magma",
'Plasma (Sequential)'="plasma",
'Inferno (Sequential)'="inferno",
'Magma (Sequential)'="magma",
'Magma (Sequential)'="magma",
'RdBu (Diverging)'="RdBu",
'RdYlBu (Diverging)'="RdYlBu",
'RdYlGn (Diverging)'="RdYlGn",
'BrBG (Diverging)'="BrBG",
'Spectral (Diverging)'="Spectral",
'BuGn (Sequential)'='BuGn',
'PuBuGn (Sequential)'='PuBuGn',
'YlOrRd (Sequential)'='YlOrRd',
'Heat (Sequential)'='heat.colors',
'Grey (Sequential)'='grey.colors'),
selected=colSel)
})
#Manual Color Range UI ----
output$colRng=renderUI({
if(!is.null(data.sel())) {
rng=range(data.sel(),na.rm = TRUE)
}else{
rng=range(mtcars) # TODO: this should probably be changed
}
# sliderInput("colorRng", "Set Color Range", min = round(rng[1],1), max = round(rng[2],1), step = .1, value = rng)
n_data = nrow(data.sel())
min_min_range = ifelse(input$transform_fun=='cor',-1,-Inf)
min_max_range = ifelse(input$transform_fun=='cor',1,rng[1])
min_value = ifelse(input$transform_fun=='cor',-1,rng[1])
max_min_range = ifelse(input$transform_fun=='cor',-1,rng[2])
max_max_range = ifelse(input$transform_fun=='cor',1,Inf)
max_value = ifelse(input$transform_fun=='cor',1,rng[2])
a_good_step = 0.1 # (max_range-min_range) / n_data
list(
numericInput("colorRng_min", "Set Color Range (min)", value = min_value, min = min_min_range, max = min_max_range, step = a_good_step),
numericInput("colorRng_max", "Set Color Range (max)", value = max_value, min = max_min_range, max = max_max_range, step = a_good_step)
)
})
#Import/Select Data ----
data.sel=eventReactive(input$data,{
if(input$data%in%d){
eval(parse(text=paste0('data.in=as.data.frame(datasets::',input$data,')')))
}else{
data.in=importSwitch(input$mydata[input$mydata$name%in%input$data,])
}
data.in=as.data.frame(data.in)
# data.in=data.in[,sapply(data.in,function(x) class(x))%in%c('numeric','integer')] # no need for this
return(data.in)
})
#Building heatmaply ----
interactiveHeatmap<- reactive({
data.in=data.sel()
if(input$showSample){
if(!is.null(input$selRows)){
set.seed(input$setSeed)
if((input$selRows >= 2) & (input$selRows < nrow(data.in))){
# if input$selRows == nrow(data.in) then we should not do anything (this save refreshing when clicking the subset button)
if(length(input$selCols)<=1) data.in=data.in[sample(1:nrow(data.in),pmin(500,input$selRows)),]
if(length(input$selCols)>1) data.in=data.in[sample(1:nrow(data.in),pmin(500,input$selRows)),input$selCols]
}
}
}
# ss_num = sapply(data.in,function(x) class(x)) %in% c('numeric','integer') # in order to only transform the numeric values
if(length(input$annoVar)>0){
if(all(input$annoVar%in%names(data.in)))
data.in <- data.in%>%mutate_at(funs(factor),.vars=vars(input$annoVar))
}
ss_num = sapply(data.in, is.numeric) # in order to only transform the numeric values
if(input$transpose) data.in=t(data.in)
if(input$transform_fun!='.'){
if(input$transform_fun=='is.na10'){
updateCheckboxInput(session = session,inputId = 'showColor',value = T)
data.in[, ss_num]=is.na10(data.in[, ss_num])
}
if(input$transform_fun=='cor'){
updateCheckboxInput(session = session,inputId = 'showColor',value = T)
updateCheckboxInput(session = session,inputId = 'colRngAuto',value = F)
data.in=cor(data.in[, ss_num],use = "pairwise.complete.obs")
}
if(input$transform_fun=='log') data.in[, ss_num]= apply(data.in[, ss_num],2,log)
if(input$transform_fun=='sqrt') data.in[, ss_num]= apply(data.in[, ss_num],2,sqrt)
if(input$transform_fun=='normalize') data.in=heatmaply::normalize(data.in)
if(input$transform_fun=='scale') data.in[, ss_num] = scale(data.in[, ss_num])
if(input$transform_fun=='percentize') data.in=heatmaply::percentize(data.in)
}
if(!is.null(input$tables_true_search_columns))
data.in=data.in[activeRows(input$tables_true_search_columns,data.in),]
if(input$colRngAuto){
ColLimits=NULL
}else{
ColLimits=c(input$colorRng_min, input$colorRng_max)
}
distfun_row = function(x) dist(x, method = input$distFun_row)
distfun_col = function(x) dist(x, method = input$distFun_col)
hclustfun_row = function(x) hclust(x, method = input$hclustFun_row)
hclustfun_col = function(x) hclust(x, method = input$hclustFun_col)
p <- heatmaply(data.in,
main = input$main,xlab = input$xlab,ylab = input$ylab,
row_text_angle = input$row_text_angle,
column_text_angle = input$column_text_angle,
dendrogram = input$dendrogram,
branches_lwd = input$branches_lwd,
seriate = input$seriation,
colors=eval(parse(text=paste0(input$pal,'(',input$ncol,')'))),
distfun_row = distfun_row,
hclustfun_row = hclustfun_row,
distfun_col = distfun_col,
hclustfun_col = hclustfun_col,
k_col = input$c,
k_row = input$r,
limits = ColLimits) %>%
layout(margin = list(l = input$l, b = input$b, r='0px'))
p$elementId <- NULL
p
})
#Render Plot ----
observeEvent(input$data,{
output$heatout <- renderPlotly({
if(!is.null(input$data))
interactiveHeatmap()
})
})
#Render Data Table ----
output$tables=DT::renderDataTable(data.sel(),server = T,filter='top',
extensions = c('Scroller','FixedHeader','FixedColumns','Buttons','ColReorder'),
options = list(
dom = 't',
buttons = c('copy', 'csv', 'excel', 'pdf', 'print','colvis'),
colReorder = TRUE,
scrollX = TRUE,
fixedColumns = TRUE,
fixedHeader = TRUE,
deferRender = TRUE,
scrollY = 500,
scroller = TRUE
))
#Clone Heatmap ----
observeEvent({interactiveHeatmap()},{
h<-interactiveHeatmap()
l<-list(main = input$main,xlab = input$xlab,ylab = input$ylab,
row_text_angle = input$row_text_angle,
column_text_angle = input$column_text_angle,
dendrogram = input$dendrogram,
branches_lwd = input$branches_lwd,
seriate = input$seriation,
colors=paste0(input$pal,'(',input$ncol,')'),
distfun_row = input$distFun_row,
hclustfun_row = input$hclustFun_row,
distfun_col = input$distFun_col,
hclustfun_col = input$hclustFun_col,
k_col = input$c,
k_row = input$r,
limits = paste(c(input$colorRng_min, input$colorRng_max),collapse=',')
)
#l=l[!l=='']
l=data.frame(Parameter=names(l),Value=do.call('rbind',l),row.names = NULL,stringsAsFactors = F)
l[which(l$Value==''),2]='NULL'
paramTbl=print(xtable::xtable(l),type = 'html',include.rownames=FALSE,print.results = F,html.table.attributes = c('border=0'))
h$width='100%'
h$height='800px'
s<-tags$div(style="position: relative; bottom: 5px;",
HTML(paramTbl),
tags$em('This heatmap visualization was created using',
tags$a(href="https://github.com/yonicd/shinyHeatmaply/",target="_blank",'shinyHeatmaply'),
Sys.time()
)
)
output$downloadData <- downloadHandler(
filename = function() {
paste("heatmaply-", gsub(' ','_',Sys.time()), ".html", sep="")
},
content = function(file) {
libdir <- paste(tools::file_path_sans_ext(basename(file)),"_files", sep = "")
htmltools::save_html(htmltools::browsable(htmltools::tagList(h,s)),file=file,libdir = libdir)
if (!htmlwidgets:::pandoc_available()) {
stop("Saving a widget with selfcontained = TRUE requires pandoc. For details see:\n",
"https://github.com/rstudio/rmarkdown/blob/master/PANDOC.md")
}
htmlwidgets:::pandoc_self_contained_html(file, file)
unlink(libdir, recursive = TRUE)
}
)
})
#End of Code ----
})
Thanks in advance to the hero who solves this problem.
Best rewards, Daniel.
The problem was a conflict between a conditional panel (which uses js) and the navbar page, for any reason default parameters were not read, thus autocoloring which should be enabled wasn't. I just removed this conditional panel and set always its options.
I am doing some timeseries analysis and have created a shiny app where when the app starts sample timeseries data is uploaded or the user can upload csv dataset from his local directory....
Sample Dataset:
df
month passengers
1 01-01-2000 2072798
2 01-02-2000 2118150
3 01-03-2000 2384907
4 01-04-2000 2260620
5 01-05-2000 2386165
6 01-06-2000 2635018
7 01-07-2000 2788843
8 01-08-2000 2942082
9 01-09-2000 2477000
10 01-10-2000 2527969
11 01-11-2000 2161170
12 01-12-2000 2175314
13 01-01-2001 2307525
14 01-02-2001 2196415
15 01-03-2001 2545863
library(signal)
library(shiny)
library(AnomalyDetection) #devtools::install_github("twitter/AnomalyDetection")
library(ggplot2)
# Define UI for application that draws a histogram
library(shinydashboard)
library(shinycssloaders)
library(googleVis)
shinyUI(dashboardPage(skin = "green",
dashboardHeader(title = "Anomaly Detection in Time series",
titleWidth = 350),
dashboardSidebar(
sidebarUserPanel("Nishant Upadhyay",
image = "nishantcofyshop.jpg"
),
sidebarMenu(
menuItem("Data", tabName = "data", icon = icon("database")),
menuItem("Filters", tabName = "filter", icon = icon("filter")),
menuItem("Anomalies", tabName = "anomaly", icon = icon("check")),
#menuItem("Save Data", tabName = "save", icon = icon("save"))
menuItem("About The App", tabName = "Help", icon = icon("info-circle"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "data",
fluidRow(
box(
title = "Data scatter Chart",
status = "primary",
solidHeader = T,
collapsible = T,
width = 12,
shinycssloaders::withSpinner(htmlOutput("dataChart"),type = getOption("spinner.type", default = 8),color = "red")
)
),
fluidRow(
box(
radioButtons(
"data_input","",
choices = list("Load sample data" = 1,
"Upload csv file" = 2
)
),
conditionalPanel(
condition = "input.data_input=='1'",
h5("Sample dataset of Lebron James basketball shots over the years")
),
conditionalPanel(
condition = "input.data_input=='2'",
fileInput('file1', 'Choose file to upload',
accept = c(
'text/csv',
'text/comma-separated-values',
'text/tab-separated-values',
'text/plain',
'.csv',
'.tsv'
)),
checkboxInput('header', 'Header', TRUE),
radioButtons('sep', 'Separator',
c(Comma=',',
Semicolon=';',
Tab='\t'),','),
radioButtons('quote', 'Quote',
c('None'='',
'Double Quote'='"',
'Single Quote'="'"),
'')
),
title = "Select Dataset",
status = "info",
solidHeader = T,
collapsible = T
),
box(
title = "Data",
status = "info",
solidHeader = T,
collapsible = T,
shinycssloaders::withSpinner(htmlOutput('contents'),type = getOption("spinner.type", default = 8),color = "red")
)# end of box
)## end of Fluid row
), ## end of tab item
tabItem(
tabName = "filter",
fluidRow(
box(
title = "Data Chart",
status = "primary",
solidHeader = T,
collapsible = T,
width = 12,
shinycssloaders::withSpinner(htmlOutput('dataChartFiltered'),type = getOption("spinner.type", default = 8),color = "red")
)
),
fluidRow(
box(
title = "Filters",
status = "info",
solidHeader = T,
collapsible = T,
width = 4,
radioButtons("filt", NULL,
c("None" = "none",
"Butterworth" = "butt",
"Type-II Chebyshev" = "cheby2")),
submitButton("Filter")
),
box(
title = "Butterworth",
status = "info",
solidHeader = T,
collapsible = T,
width = 4,
textInput("buttern", label = "Filter Order", value = "3"),
textInput("butterf", label = "Critical Frequencies", value = "0.1"),
radioButtons("buttert", "Type",
c("Low-Pass" = "low",
"High-Pass" = "high"))
),
box(
title = "Chebyshev",
status = "info",
solidHeader = T,
collapsible = T,
width = 4,
textInput("chebyn", label = "Filter Order", value = "5"),
textInput("chebyd", label = "dB of Pass Band", value = "20"),
textInput("chebyf", label = "Critical Frequencies", value = "0.2"),
radioButtons("chebyt", "Type",
c("Low-Pass" = "low",
"High-Pass" = "high"))
)
)
)
) ## end of tab items
) ## end of Dashboard
)
)
shinyServer(function(input, output){
dataframe<-reactive({
if (input$data_input == 1) {
tab <- read.csv("df.csv",header = T,stringsAsFactors = F)
} else if (input$data_input == 2) {
inFile <- input$file1
if (is.null(inFile))
return(data.frame(x = "Select your datafile"))
tab = read.csv(inFile$datapath, header = input$header,
sep = input$sep, quote = input$quote)
}
tt <- tryCatch(as.POSIXct(tab[,1]),error=function(e) e, warning=function(w) w)
if (is(tt,"warning") | is(tt,"error")) {
tab$Old = tab[,1]
tab[,1] = as.POSIXct(1:nrow(tab), origin = Sys.time())
} else {
tab[,1] = as.POSIXct(tab[,1])
}
tab
})
output$dataChart <- renderGvis({
if (!is.null(dataframe()))
gvisLineChart(dataframe()[,c(1,2)], xvar = colnames(dataframe())[1], yvar = colnames(dataframe())[2],
options = list(
crosshair.trigger = 'selection',
enableInteractivity = TRUE,
hAxis.maxTextLines = 10,
tooltip.trigger = 'none'
))
})
output$contents <- renderGvis({
if (!is.null(dataframe()))
gvisTable(dataframe(),
options = list(page='enable'))
})
output$dataChartFiltered <- renderGvis({
if (input$filt == "none") {
return(NULL)
} else if (input$filt == "butt") {
bf <- butter(as.numeric(input$buttern), as.numeric(input$butterf), type = input$buttert)
filtered = data.frame(timestamp = dataframe()[,1],
count = as.numeric(filter(bf, dataframe()[,2])))
gvisLineChart(filtered, xvar = colnames(filtered)[1], yvar = colnames(filtered)[2],
options = list(
crosshair.trigger = 'selection',
enableInteractivity = TRUE,
hAxis.maxTextLines = 10,
tooltip.trigger = 'none'
))
} else if (input$filt == "cheby2") {
ch <- cheby2(as.numeric(input$chebyn), as.numeric(input$chebyd),
as.numeric(input$chebyf), type = input$chebyt)
filtered = data.frame(timestamp = dataframe()[,1],
count = as.numeric(filter(ch, dataframe()[,2])))
gvisLineChart(filtered, xvar = colnames(filtered)[1], yvar = colnames(filtered)[2],
options = list(
crosshair.trigger = 'selection',
enableInteractivity = TRUE,
hAxis.maxTextLines = 10,
tooltip.trigger = 'none'
))
}
})
})
The problem i am facing is that once the shiny app is executed , the sample data is loaded properly as the this data is placed in the app folder in the directory (one can use R inbuilt data set or use the data i gave in the start) and subsequently all steps gets executed properly.
But if i want to upload some other csv file from local directory, the upload button selection does not get activated even after selecting it.But,in fact, if one goes to the second menu item in the sidebar panel i.e. filter tab and clicks on the filter button (under Filters box ) and then if i go back to Data menu in the sidebar panel again, i can see that now my upload csv file button has got activated and now i can browse the csv file in local directory and upload the same into the app and now everything works fine.
It seems somewhere the condition that makes the upload file button is not getting active initially when the app opens....
Need help to sort out the issue...Sorry for posting large chunk of code....
conditionalPanel and submitButton do not work well together. Replace your submitButton("Filter") with actionButton("Filter", "").
EDIT:
As per the comment, for the plot to be generated only after the actionButton is clicked you can put output$dataChartFiltered inside observeEvent of Filter with isolate for `input objects as follows:
observeEvent(input$Filter,{
output$dataChartFiltered <- renderGvis({
if (isolate(input$filt) == "none") {
return(NULL)
} else if (isolate(input$filt) == "butt") {
bf <- butter(as.numeric(isolate(input$buttern)), as.numeric(isolate(input$butterf)), type = isolate(input$buttert))
filtered = data.frame(timestamp = dataframe()[,1],
count = as.numeric(filter(bf, dataframe()[,2])))
gvisLineChart(filtered, xvar = colnames(filtered)[1], yvar = colnames(filtered)[2],
options = list(
crosshair.trigger = 'selection',
enableInteractivity = TRUE,
hAxis.maxTextLines = 10,
tooltip.trigger = 'none'
))
} else if (isolate(input$filt) == "cheby2") {
ch <- cheby2(as.numeric(isolate(input$chebyn)), as.numeric(isolate(input$chebyd)),
as.numeric(isolate(input$chebyf)), type = isolate(input$chebyt))
filtered = data.frame(timestamp = dataframe()[,1],
count = as.numeric(filter(ch, dataframe()[,2])))
gvisLineChart(filtered, xvar = colnames(filtered)[1], yvar = colnames(filtered)[2],
options = list(
crosshair.trigger = 'selection',
enableInteractivity = TRUE,
hAxis.maxTextLines = 10,
tooltip.trigger = 'none'
))
}
})
})