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()
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
}
#####################################################################
I've just discovered these amazing packages called argonR and argonDash, but ,unfortunatly, I haven't had succes so far using modules with it. Is it possible?
I've tried to ns it, but it doesnt work. It works locally, but It is not able to change tabs when deployed.
# rm(list = ls())
library(shiny)
library(shinydashboard)
library(argonR)
library(argonDash)
library(magrittr)
library(shinyjs)
# Modules
source("sidebar.R", encoding = "utf8")
source("navbar.R", encoding = "utf8")
source("header.R", encoding = "utf8")
source("footer.R", encoding = "utf8")
source("R/mod_home.R", encoding = "utf8")
source("R/mod_stats.R", encoding = "utf8")
source("R/mod_prob.R", encoding = "utf8")
source("R/mod_stat_econ.R", encoding = "utf8")
source("R/mod_econometria.R", encoding = "utf8")
source("R/mod_ML.R", encoding = "utf8")
source("R/mod_quiz.R", encoding = "utf8")
source("R/mod_sobre.R", encoding = "utf8")
# App
ui <- argonDashPage(
title = "TCM",
author = "Guilherme",
description = "Guig's TCM",
sidebar = argonDashSidebar(
vertical = TRUE,
skin = "light",
background = "white",
size = "md",
side = "left",
id = "my_sidebar",
brand_url = "http://www.google.com",
# brand_logo = "https://demos.creative-tim.com/argon-design-system/assets/img/brand/blue.png",
# brand_logo = ,
brand_logo = "https://kdrt.org/sites/default/files/styles/adaptive/public/Rocket%20Radio%20program%20picture.png?itok=-FHCim8R",
argonSidebarHeader(title = "Menu Principal"),
argonSidebarMenu(
argonSidebarItem(
tabName = "home_tab",
style="text-align:center",
"Home"
),
argonSidebarItem(
tabName = "stats_tab",
style="text-align:center",
"Estatística"
),
argonSidebarItem(
tabName = "prob_tab",
style="text-align:center",
"Probabilidade"
),
argonSidebarItem(
tabName = "stat_econ_tab",
style="text-align:center",
"Estatística Econômica"
),
argonSidebarItem(
tabName = "econometria_tab",
style="text-align:center",
"Econometria"
),
argonSidebarItem(
tabName = "ML_tab",
style="text-align:center",
"Machine Learning"
),
argonSidebarItem(
tabName = "quiz_tab",
style="text-align:center",
"Quiz"
),
argonSidebarItem(
tabName = "sobre_tab",
style="text-align:center",
"Sobre"
)
),
argonSidebarDivider(),
argonSidebarHeader(title = "#TCM Versão 0.1")
),
navbar = argonDashNavbar(
argonDropNav(
title = "Powered by R",
# src = "https://demos.creative-tim.com/argon-dashboard/assets/img/theme/team-4-800x800.jpg",
src = "https://encrypted-tbn0.gstatic.com/images?q=tbn:ANd9GcRCLcatfAURCtGHsd71IjruuQqMXjezkwwjZR5inocuNz0imUF5sA",
orientation = "right",
argonDropNavTitle(title = "Este app é formado por"),
argonDropNavItem(
title = "R",
src = "https://www.r-project.org/",
icon = argonIcon("single-02")
),
argonDropNavItem(
title = "RStudio",
src = "https://rstudio.com/",
icon = argonIcon("settings-gear-65")
),
argonDropNavDivider(),
argonDropNavItem(
title = "Guigo's código",
src = "#",
icon = argonIcon("calendar-grid-58")
)
)
),
header = argonDashHeader(
gradient = TRUE,
color = "primary",
separator = TRUE,
separator_color = "secondary"#,
# argonCard(
# title = "Olá, visitante!",
# src = "https://www.linkedin.com/in/guilherme-viegas-1b5b0495/",
# hover_lift = TRUE,
# shadow = TRUE,
# shadow_size = NULL,
# hover_shadow = FALSE,
# border_level = 0,
# # icon = argonIcon("atom"),
# icon = "https://scontent.ffln1-1.fna.fbcdn.net/v/t1.0-9/13669798_1073355219425752_3359245208514920392_n.jpg?_nc_cat=111&_nc_oc=AQk0e2H7_Cjzdx97Vq_sl2v_JrdqSZBK5oFe6Kj6VGu_OKOvO7zFTwta02RVm-Bz8Ck&_nc_ht=scontent.ffln1-1.fna&oh=bad62632b291289b4338d3aec456cbe2&oe=5E2B61E2",
# status = "primary",
# background_color = NULL,
# gradient = FALSE,
# floating = FALSE,
# "Seja muito bem vindo.\nEste é meu cartão, tome."
# )
),
body = argonDashBody(
argonTabItems(
argonTabItem(
tabName = "home_tab",
mod_home_ui("home_ui_1")
),
argonTabItem(
tabName = "stats_tab",
mod_stats_ui("stats_ui_1")
),
argonTabItem(
tabName = "prob_tab",
mod_prob_ui("prob_ui_1")
),
argonTabItem(
tabName = "stat_econ_tab",
mod_stat_econ_ui("stat_econ_ui_1")
),
argonTabItem(
tabName = "econometria_tab",
mod_econometria_ui("econometria_ui_1")
),
argonTabItem(
tabName = "ML_tab",
mod_ML_ui("ML_ui_1")
),
argonTabItem(
tabName = "quiz_tab",
mod_quiz_ui("quiz_ui_1")
),
argonTabItem(
tabName = "sobre_tab",
mod_sobre_ui("sobre_ui_1")
)
)
),
footer = argonDashFooter(
copyrights = "#Guilherme Viegas, 2019",
src = "https://www.linkedin.com/in/guilherme-viegas-1b5b0495/",
argonFooterMenu(
argonFooterItem("Linkedin", src = "https://www.linkedin.com/in/guilherme-viegas-1b5b0495/"),
argonFooterItem("Github", src = "https://github.com/Gui-go"),
argonFooterItem("Facebook", src = "https://www.facebook.com/guilherme.viegas.90"),
argonFooterItem("Instagram", src = "https://demos.creative-tim.com/argon-design-system/index.html")
)
)
)
server <- function(input, output) {
# observeEvent(input$my_sidebar, {
# if (input$my_sidebar != "sobre") {
# updateTabItems(session, inputId = "tabs", selected = "quiz")
# }
# })
callModule(mod_home_server, "home_ui_1")
callModule(mod_stats_server, "stats_ui_1")
callModule(mod_prob_server, "prob_ui_1")
callModule(mod_stat_econ_server, "stat_econ_ui_1")
callModule(mod_econometria_server, "econometria_ui_1")
callModule(mod_ML_server, "ML_ui_1")
callModule(mod_quiz_server, "quiz_ui_1")
callModule(mod_sobre_server, "sobre_ui_1")
}
shinyApp(ui = ui, server = server)
Although It works locally, when I deploy it, It simple doesnt work online. In other words, it works fine locally, but when deplyed it simple doesnt change the tabs. Weird right?
I have found the answer. As for October 2019, the CRAN package version does not allow change of tabs (It's a bug). This error was corrected in their Github package version, and soon will be on CRAN as well. It's just a bug, happens...
you can use modules like this!
I suppose global.R and app.R are in the same directory.
global.R
library(shiny)
library(argonR)
library(argonDash)
app.R
source(file.path("global.R"), local = TRUE)$value
shiny::shinyApp(
ui = argonDashPage(
title = "Argon App",
description = "Your description",
author = "You",
navbar = argonDashNavbar(),
sidebar = argonDashSidebar(
id = "sidebar",
side = "left",
size = "md",
skin = "light",
background = "white",
argonSidebarMenu(
argonSidebarItem(
tabName = "Tab1",
icon = argonIcon(name = "circle-08", color = "success"),
"Tab 1"
),
argonSidebarItem(
tabName = "Tab2",
icon = argonIcon(name = "atom", color = "success"),
"Tab 2"
)
)
),
header = argonDashHeader(),
body = argonDashBody(
argonTabItems(
argonTabItem(
tabName = "Tab1",
argonCard(
status = "primary",
width = 12,
title = "Card 1",
hover_lift = TRUE,
shadow = TRUE,
icon = argonIcon("check-bold"),
src = "#",
"Argon is a great free UI package based on Bootstrap 4
that includes the most important components and features."
)
),
argonTabItem(
tabName = "Tab2",
argonBadge(
text = "My badge",
src = "https://www.google.com",
pill = FALSE,
status = "success"
)
)
)
),
footer = argonDashFooter(copyrights = "Yourself")
),
server = function(input, output, session) {
}
)
The strategy has been fully inspired from https://github.com/daattali/advanced-shiny/tree/master/split-code
I am using library(ygdashboard) from here for build a Right Side control bar in Shiny Apps. Which most like AdminLTE.io template.
In AdminLTE.io Right Side Control Bar there is an option,by enabling it the content part will adjust the width and display accordingly.
Can any body help me out here?? My Try:
Mycode:
UI.R
library(shinydashboard)
library(shinyjs)
library(plotly)
library(shinyWidgets)
library(ygdashboard)
library(c3)
library(flexdashboard)
source("helper.R")
dashboardPage( skin = 'green',
dashboardHeader(title=" Test Stand Report",
tags$li(a(img(src = 'logo.jfif',
height = "30px"),
style = "padding-top:10px; padding-bottom:10px;"),
class = "dropdown")),
dashboardSidebar(sidebarMenu(id="tabs",
menuItem("DashBoard", tabName = "dashboard", icon = icon("dashboard", lib = "glyphicon")),
menuItem("Drill Report",icon = icon("link",lib = "glyphicon"),
menuSubItem("Test Stand",tabName = "test_stand",icon = icon("database")),
menuSubItem("Test Code",tabName = "test_code",icon = icon("folder-open",lib = "glyphicon")),
menuSubItem("Product Based",tabName = "product_based",icon = icon("database")),
menuSubItem("Time Shift",tabName = "time_shift",icon = icon("folder-open",lib = "glyphicon"))
)
)
),
dashboardBody(
shinyjs::useShinyjs(),
tabItems(
tabItem(tabName = "dashboard",
fluidRow(
column(3,
gaugeOutput("gauge1",width = "100%", height = "auto"),
uiOutput("infobox_1")
#gaugeOutput("gauge2",width = "100%", height = "auto")
),
column(3,
gaugeOutput("gauge3",width = "100%", height = "auto"),
uiOutput("infobox_2")
#gaugeOutput("gauge4",width = "100%", height = "100px")
),
column(3,
gaugeOutput("gauge5",width = "100%", height = "auto"),
uiOutput("infobox_3")
#gaugeOutput("gauge6",width = "100%", height = "auto")
),
column(3,
gaugeOutput("gauge7",width = "100%", height = "auto"),
uiOutput("infobox_4")
#gaugeOutput("gauge8",width = "100%", height = "auto")
)
),
fluidRow(
)
),
tabItem(tabName = "test_stand",
fluidRow(
column(3,
wellPanel(
uiOutput("test_stand_select")
)
),
column(3,uiOutput("count_test_code")),
column(3,uiOutput("count_vehicle_tested")),
column(3,uiOutput("count_vehicle_failed"))
),
fluidRow(
box(title = "Success Faliure Ratio",solidHeader = TRUE,width = 4,collapsible = TRUE,height = 'auto',status="success",
plotlyOutput("sucess_faliure_pie",height = '250px')
#tableOutput("sucess_faliure_pie")
),
box(title = "Success Faliure rate with Test_Code",solidHeader = TRUE,width = 8,collapsible = TRUE,height = 'auto',status="success",
#tableOutput("test_stand_test_code_rel")
plotlyOutput("test_stand_test_code_rel",height = '250px')
)
)
),
tabItem(tabName = 'test_code',
fluidRow(
)
)
)
),
dashboardFooter(mainText = "My footer", subText = "2018"),
dashboardControlbar()
)
Server.R
library(shiny)
library(shinyjs)
library(RMySQL)
library(DT)
library(devtools)
library(woe)
library(sqldf)
library(plyr)
library(shinyalert)
source("helper.R")
shinyServer(function(input, output,session) {
######################### Date range Selection ################################
output$date_range<-renderUI({
if(input$tabs=="test_stand")
{
dateRangeInput("selected_date_range_test_stand", "Select Time Period:",
start = Sys.Date()-10,
end = Sys.Date(),
max=Sys.Date())
}
else if(input$tabs=="test_code")
{
dateRangeInput("selected_date_range_test_code", "Select Time Period:",
start = Sys.Date()-10,
end = Sys.Date(),
max=Sys.Date())
}
else if(input$tabs=="product_based")
{
dateRangeInput("selected_date_range_product_based", "Select Time Period:",
start = Sys.Date()-10,
end = Sys.Date(),
max=Sys.Date())
}
})
##########################report buttom ################################
output$action_btn<-renderUI({
if(input$tabs=="test_stand")
{
actionBttn("get_data_test_stand","Get Report")
}
else if(input$tabs=="test_code")
{
actionBttn("get_data_test_code","Get Report")
}
else if(input$tabs=="product_based")
{
actionBttn("get_data_product_based","Get Report")
}
})
#########################product group selection##################################
output$pg_list<-renderUI({
if(input$tabs=="test_stand")
{
selectInput("selected_pg_test_stand","Select your Product Group",choices = c("Back"="BHO","SKD"="SKD","ABC"="ABC"))
}
else if(input$tabs=="test_code")
{
selectInput("selected_pg_test_code","Select your Product Group",choices = c("Back"="BHO","SKD"="SKD","ABC"="ABC"))
}
else if(input$tabs=="product_based")
{
selectInput("selected_pg_product_based","Select your Product Group",choices = c("Back"="BHO","SKD"="SKD","ABC"="ABC"))
}
})
#############################top 8 gauge################################
output$gauge1<-renderGauge({
gauge(0.5,
min = 0,
max = 1,
sectors = gaugeSectors(success = c(0.5, 1),
warning = c(0.3, 0.5),
danger = c(0, 0.3)),label = 'Gauge 1')
})
output$infobox_1<-renderInfoBox({
infoBox("Total Test Stand Active",10 * 2,subtitle = "Subtitle", icon = icon("credit-card"),fill = TRUE,color = "yellow")
})
output$gauge3<-renderGauge({
gauge(0.7,
min = 0,
max = 1,
sectors = gaugeSectors(success = c(0.5, 1),
warning = c(0.3, 0.5),
danger = c(0, 0.3)),label = 'Gauge 3')
})
output$infobox_2<-renderInfoBox({
infoBox("Total Test Code Running ",10 * 2,subtitle = "Subtitle" ,icon = shiny::icon("bar-chart"),color = "fuchsia",width = 4,fill = TRUE)
})
output$gauge5<-renderGauge({
gauge(0.6,
min = 0,
max = 1,
sectors = gaugeSectors(success = c(0.5, 1),
warning = c(0.3, 0.5),
danger = c(0, 0.3)),label = 'Gauge 5')
})
output$infobox_3<-renderInfoBox({
infoBox(
"Total Vehicle Tested", "80%",subtitle = "Subtitle", icon = icon("list"),
color = "green", fill = TRUE
)
})
output$gauge7<-renderGauge({
gauge(0.3,
min = 0,
max = 1,
sectors = gaugeSectors(success = c(0.5, 1),
warning = c(0.3, 0.5),
danger = c(0, 0.3)),label = 'Gauge 7')
})
output$infobox_4<-renderInfoBox({
infoBox("Total Vehicle Passed ",10 * 2,subtitle = "Subtitle", icon = icon("check"),fill = TRUE, color = 'orange')
})
#############################test_stand value_box########################
})
Helper.R (from the link)
dashboardControlbar <- function() {
withTags(
div(
id = "right_sidebar",
# Control Sidebar Open
aside(class = "control-sidebar control-sidebar-dark",
# # # # # # # #
#
# Navigation tabs
#
# # # # # # # #
ul(class = "nav nav-tabs nav-justified control-sidebar-tabs",
# first tabs
li(class = "active",
a(href = "#control-sidebar-first-tab", `data-toggle` = "tab",
i(class = "fa fa-sliders")
)
),
# second tabs
li(
a(href = "#control-sidebar-second-tab", `data-toggle` = "tab",
i(class = "fa fa-search")
)
),
# third tab
li(
a(href = "#control-sidebar-third-tab", `data-toggle` = "tab",
i(class = "fa fa-paint-brush")
)
)
),
# # # # # # # #
#
# Tab Panels
#
# # # # # # # #
div(class = "tab-content",
#########################
# First tab content #
#########################
div(class = "tab-pane active", id = "control-sidebar-first-tab",
h3(class = "control-sidebar-heading", "Controller"),
# write elements here
uiOutput("date_range"),
#textOutput("date_validate"),
uiOutput("pg_list"),
uiOutput("action_btn")
#actionBttn("get_data","Get Report")
),
#########################
# Second tab content #
#########################
div(class = "tab-pane", id = "control-sidebar-second-tab",
h3(class = "control-sidebar-heading", "Search"),
# write other elements here
selectInput("selected_search_topic","Select Content Type to Seacrh",choices = c("Test Stand","Test Code","Product")),
searchInput("searchtext","Enter your Search Topic Here", placeholder = "A placeholder",btnSearch = icon("search"),btnReset = icon("remove"))
),
#########################
# Third tab content #
#########################
div(class = "tab-pane", id = "control-sidebar-third-tab",
# third tab elements here
radioButtons("dist", "Distribution type:",
c("Normal" = "norm",
"Uniform" = "unif",
"Log-normal" = "lnorm",
"Exponential" = "exp")
)
)
)
),
# control-sidebar
# Add the sidebar background. This div must be placed
# immediately after the control sidebar
div(class = "control-sidebar-bg", "")
)
)
}
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'
))
}
})
})
I've built a shinydashboard app. it's working fine but the only problem is that it is not auto-fitting the webpage. Also, when opened in a mobile browser, it shows a desktop site rather than one customized for the mobile. Is there a problem with the bootstrap?
here's my code:
library(shiny)
library(shinyapps)
library(shinydashboard)
library(dygraphs)
library(htmltools)
library(htmlwidgets)
library(metricsgraphics)
library(RColorBrewer)
library(maps)
library(mapproj)
library(ggplot2)
library(dplyr)
library(plyr)
library(ggvis)
library(scales)
library(leaflet)
#library(RJSONIO)
#library(shinybootstrap2)
#shinybootstrap2::withBootstrap2()
#source("helpers.R")
test_bar <- read.csv("test_bar.csv")
channel_bar <- read.csv("channel_bar.csv")
time <- read.csv("time_enroll.csv")
#counties <- readRDS("counties.rds")
ui <- dashboardPage(skin="blue",
dashboardHeader(title="KPI Dashboard"),
dashboardSidebar(
fluidRow(),
fluidRow(),
box(width = 12.5,solidHeader=TRUE,title="Refresh Interval",
status = "warning",
selectInput("interval", "Data Time Period",
choices = c(
"Current Month" = 30,
"3MM" = 60,
"YTD" = 120,
"R12" = 300
),
selected = "30"
)
),
menuItem("", tabName = "widgets"),
menuItem("", tabName = "widgets"),
box(width = 12.5,solidHeader=TRUE,title="Refresh Interval",
status = "warning",
selectInput("interval", "Refresh interval",
choices = c(
"30 seconds" = 30,
"1 minute" = 60,
"2 minutes" = 120,
"5 minutes" = 300,
"10 minutes" = 600
),
selected = "60"
),
uiOutput("timeSinceLastUpdate"),
actionButton("refresh", "Refresh now")
# p(class = "text-muted",
# br(),
# "Source data updates every day."
# )
)
),
dashboardBody(
fluidRow(
infoBox("New Co-Pay Card Users", 100*10, icon = icon("credit-card"), fill = TRUE,color="olive"),
infoBox("Total Co-Pay Card Users", 500*10, icon = icon("credit-card"), fill = TRUE,color="olive"),
infoBox("Total Redemptions", 10000, icon = icon("thumbs-up"), fill = TRUE,color="lime")
),
fluidRow(
box(
title = "Enrollments by Specialty", status = "primary", solidHeader = TRUE,
collapsible = TRUE, width=6,height=315,
plotOutput("plots",click="plot_click1",height=240)
),
box(
title = "Trend", solidHeader = TRUE,status="primary",
collapsible = TRUE,width=6, dygraphOutput("plot2",height=250)
)
),
fluidRow(
box(title = "Enrollments by Channel", status = "primary", solidHeader = TRUE,
collapsible = TRUE, width=6,height=315,
plotOutput("plot_c")),
box(title="Map",
tags$head(tags$style("
.leaflet-container { background-color: white !important; }
")),
leafletMap(
"map", "100%", 500,
# By default OpenStreetMap tiles are used; we want nothing in this case
initialTileLayer = NULL,
initialTileLayerAttribution = NULL,
options=list(
center = c(40, -98.85),
zoom = 4,
maxBounds = list(list(17, -180), list(59, 180))
)
))
))
)
server <- function(input,output,session) {
output$plots <- renderPlot({
ggplot(test_bar,aes(x=factor(Specialty),y=Actual)) +geom_bar(stat="identity")+
theme(panel.background = element_rect(fill="white",
color="white"),panel.grid.major = element_line(color="white"),
axis.title.x=element_blank(),axis.title.y=element_blank())
})
output$plot2 <- renderDygraph({
if (is.null(input$plot_click1$x)) return()
keeprows <- round(input$plot_click1$x) == as.numeric(time$Spec)
time2 <- time[keeprows,]
time3 <- time2[2]
time_ts <- ts(time3$enroll,start=c(2014,1),end=c(2014,12),frequency=12)
dygraph(time_ts) %>% dyRangeSelector(height=20,strokeColor="") %>% dyOptions(fillGraph=TRUE)
})
output$test_table <- renderTable({
if (is.null(input$plot_click1$x)) return()
keeprows <- round(input$plot_click1$x) == as.numeric(time$Spec)
time[keeprows,]
})
output$plot_c <- renderPlot({
print(ggplot(channel_bar,aes(x=factor(Channel),y=Actual)) +geom_bar(stat="identity")+
theme(panel.background = element_rect(fill="white",
color="white"),panel.grid.major = element_line(color="white"),
axis.title.x=element_blank(),axis.title.y=element_blank()))
})
output$map <- reactive(TRUE)
map <- createLeafletMap(session, "map")
# session$onFlushed is necessary to delay the drawing of the polygons until
# after the map is created
session$onFlushed(once=TRUE, function() {
# Get shapes from the maps package
states <- map("state", plot=FALSE, fill=TRUE)
map$addPolygon(states$y, states$x, states$names,
lapply(brewer.pal(9, "Blues"), function(x) {
list(fillColor = x)
}),
list(fill=TRUE, fillOpacity=1,
stroke=TRUE, opacity=1, color="white", weight=1
)
)
})
}
shinyApp(ui, server)
You can try using the code below to control your chart size, place it right after your plotOutput or showOutput function.
HTML('<style>.rChart {width: 100%; height: 500px}</style>')
Example:
fluidRow(
box(
title = "Enrollments by Specialty", status = "primary",
solidHeader = TRUE,
collapsible = TRUE,
width=6,height=315,
plotOutput("plots",click="plot_click1",height=240),
HTML('<style>.rChart {width: 100%; height: 500px}</style>')
)