Wanted to check if we can highlight the active tabs . i mean when the user is in one tab ("agh"), that tab should be underlined. Similarly for other tab as well. Reprex below
app.R
library(shiny)
shinyApp(
navbarPage(
tags$head(
tags$style(
HTML(".tabbable > .nav > li[class=active] > a {text-decoration: underline}")
)
),
tabPanel("Tab1"),
tabPanel("Tab2"),
tabsetPanel(
tabPanel("agh",
numericInput("n", "Number to add", 5),
actionButton("add", "Add"),
verbatimTextOutput("sum", placeholder = TRUE)
),
tabPanel("dfd")
)
),
function(input, output, session) {
nums <- numeric()
c_sum <- eventReactive(input$add, {
nums <<- c(nums, input$n)
sum(nums)
})
output$sum <- renderText({
c_sum()
})
}
)
library(shiny)
shinyApp(
fluidPage(
tags$head(
tags$style(
HTML(".tabbable > .nav > li[class=active] > a {text-decoration: underline}")
)
),
br(),
tabsetPanel(
tabPanel("agh",
numericInput("n", "Number to add", 5),
actionButton("add", "Add"),
verbatimTextOutput("sum", placeholder = TRUE)
),
tabPanel("dfd")
)
),
function(input, output, session) {
nums <- numeric()
c_sum <- eventReactive(input$add, {
nums <<- c(nums, input$n)
sum(nums)
})
output$sum <- renderText({
c_sum()
})
}
)
Related
I need to create conditional 3 levels of tabs the first level or tabPanel includes three tabs
"NUTS","SWEETS","DRINKS"
so the
level1<-list(DRINKS,SWEETS,NUTS)
the second level or is conditional on the first level
for example after selecting DRINKS, would be juices, energydrinks, hotdrinks
the third level would be after selecting energy drinks to "powerhorse","redbull"
tried code but not working is this
lists -------------------------------------------------------------------
library(shiny)
library(reshape2)
library(dplyr)
hotdrinks<-list('hotdrinks'=list("tea","green tea"))
juices<-list('juices'=list("orange","mango") )
energydrinks<-list('energydrinks'=list("powerhorse","redbull"))
drinks<-list('drinks'=list(hotdrinks,juices,energydrinks))
biscuits<-list('bisc'=list("loacker","tuc"))
choc<-list('choc'=list("aftereight","lindt") )
gum<-list('gum'=list("trident","clortes") )
sweets<-list('sweets'=list(gum,juices,energydrinks))
almonds<-list('almonds'=list("salted","roasted") )
pistcio<-list('pistcio'=list("flavourd","roasted"))
nuts<-list('nuts'=list(almonds,pistcio))
all_products<-list(sweets,nuts,drinks)
mt<-melt(all_products)
mt2<-mt%>%mutate("Price"=c(23,34,23,23,54,32,45,23,12,56,76,34,62,12,98,43),
"Quantity"=c(10,20,26,22,51,52,45,23,12,56,76,55,62,12,98,43))
t1<-mt2[,c(5,3,1,8,7)]
t1
colnames(t1)<-c("CAT","PN","SP","Quantity","Price")
t2<-list(unique(t1$CAT))
t2
app ---------------------------------------------------------------------
library(shiny)
server <- function(input, output,session) {
observe({print(input$t)})
observe({print(input$u)})
observe({print(input$v)})
t3<-t1%>%filter(t1$CAT==input$t)
print(t3)
t4<-list(unique(t3$PN))
print(t4)
t5<-t3%>%filter(t3$PN==input$r)
print(t5)
t6<-list(unique(t5$SP))
print(t6)
t7<-reactive({
t1%>%filter(t1$CAT==input$t,t1$PN==input$u,t1$SP==inptut$v)
print(t7())
})
output$mytable <- DT::renderDataTable({
t7
})
lapply(1:5, function(j) {
DT::dataTableOutput("mytable")
})
}
ui <- pageWithSidebar(
headerPanel("xxx"),
sidebarPanel(),
mainPanel(
do.call(tabsetPanel, c(id='t',lapply(unlist(t2), function(i) {
tabPanel(
do.call(tabsetPanel, c(id='u',lapply(unlist(t4), function(i) {
tabPanel(
do.call(tabsetPanel, c(id='v',lapply(unlist(t6), function(i) {
tabPanel(DT::dataTableOutput("mytable")
)
})))
)
})))
)
})))
)
)
shinyApp(ui, server)
the manual steps
hotdrinks<-list("tea","green tea")
juices<-list("orange","mango")
energydrinks<-list("powerhorse","redbull")
drinks<-list(hotdrinks,juices,energydrinks)
biscuits<-list("loacker","tuc")
choc<-list("aftereight","lindt")
gum<-list("trident","clortes")
sweets<-list(gum,juices,energydrinks)
almonds<-list("salted","roasted")
pistcio<-list("flavourd","roasted")
nuts<-list(almonds,pistcio)
all_products<-list(sweets,nuts,drinks)
choc<-
tabsetPanel(
tabPanel("aftereight"),
tabPanel("lindt")
)
bisc<-
tabsetPanel(
tabPanel("loacker"),
tabPanel("tuc")
)
gm<-
tabsetPanel(
tabPanel("trident"),
tabPanel("clortes")
)
hdrinks<-
tabsetPanel(
tabPanel("tea"),
tabPanel("green tea")
)
jcs<-
tabsetPanel(
tabPanel("orange"),
tabPanel("mango")
)
ngdrinks<-
tabsetPanel(
tabPanel("powerhorse"),
tabPanel("redbull")
)
al<-
tabsetPanel(
tabPanel("salted"),
tabPanel("roasted")
)
pst<-
tabsetPanel(
tabPanel("flavourd"),
tabPanel("roasted")
)
runApp(list(
ui = shinyUI( fluidPage(
sidebarLayout(
sidebarPanel(width = 2),
mainPanel(tabsetPanel(id='conditioned',
tabPanel("sweets",value=1,
tabsetPanel(
tabPanel("biscuits",
tabsetPanel(bisc)),
tabPanel("choc",
tabsetPanel(choc)),
tabPanel("gum",
tabsetPanel(gm))
)),
tabPanel("nuts",value=2,
tabsetPanel(
tabPanel("almonds",
tabsetPanel(al)),
tabPanel("pistcio",
tabsetPanel(pst))
)),
tabPanel("drinks",value=3,
tabsetPanel(
tabPanel("hotdrinks",
tabsetPanel(hdrinks)),
tabPanel("juices",
tabsetPanel(jcs)),
tabPanel("energydrinks",
tabsetPanel(ngdrinks))
))
))
))),
server = function(input, output, session) {}
))
as you can see this approach is too vulnerable to mistake, thanks in advance.
hotdrinks<-list("tea","green tea")
juices<-list("orange","mango")
energydrinks<-list("powerhorse","redbull")
drinks<-list("hotdrinks"=hotdrinks, "juices"=juices, "energydrinks"=energydrinks)
lst_drinks <- lapply(seq_along(drinks),
#browser()
#create 2nd level, tab name with the corresponding 3rd level list
function(x) tabPanel(names(drinks[x]),
#create tabsetPanel for hdrinks, jcs, ngdrinks level i.e. 3rd level
do.call("tabsetPanel",
lapply(drinks[[x]], function(y) tabPanel(y))
)
)
)
hdrinks<-
tabsetPanel(
tabPanel("tea"),
tabPanel("green tea")
)
jcs<-
tabsetPanel(
tabPanel("orange"),
tabPanel("mango")
)
ngdrinks<-
tabsetPanel(
tabPanel("powerhorse"),
tabPanel("redbull")
)
runApp(list(
ui = shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(width = 2),
mainPanel(tabsetPanel(id='conditioned',
tabPanel("drinks",value=3,
tabsetPanel(
tabPanel("hotdrinks",
#No need for tabsetPanel as hdrinks already has one, therefore I removed it in lapply
tabsetPanel(hdrinks)),
tabPanel("juices",
tabsetPanel(jcs)),
tabPanel("energydrinks",
tabsetPanel(ngdrinks))
)),
tabPanel("drinks-test",
do.call("tabsetPanel", lst_drinks))
))
))),
server = function(input, output, session) {}
))
The Full solution
hotdrinks<-list("tea","green tea")
juices<-list("orange","mango")
energydrinks<-list("powerhorse","redbull")
drinks<-list("hotdrinks"=hotdrinks,"juices"=juices,"energydrinks"=energydrinks)
biscuits<-list("loacker","tuc")
choc<-list("aftereight","lindt")
gum<-list("trident","clortes")
sweets<-list("gum"=gum,"biscuits"=biscuits,"choc"=choc)
all <- list("drinks"=drinks, "sweets"=sweets)
all_lst <- lapply(seq_along(all), function(z) tabPanel(names(all)[z],
do.call("tabsetPanel",
lapply(seq_along(all[[z]]), function(x) tabPanel(names(all[[z]][x]),
do.call("tabsetPanel",
lapply(all[[z]][[x]], function(y) tabPanel(y, DT::dataTableOutput(y)))
)
)
)
)
)
)
runApp(list(
ui = shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(width = 2),
mainPanel(do.call("tabsetPanel", c(id='conditioned', all_lst)))
))),
server = function(input, output, session) {
observe({
nms = unlist(all)
names(nms) <- sub('\\d', '', names(nms))
for(i in seq_along(nms)){
#browser()
local({
nm = nms[i]
CAT_var = unlist(strsplit(names(nm), '\\.'))[1]
PN_var = unlist(strsplit(names(nm), '\\.'))[2]
SP_var = nm[[1]]
output[[SP_var]] <- DT::renderDataTable({filter(t1, CAT==CAT_var, PN==PN_var, SP==SP_var)})
})
}
})
}
))
this is my UI. R
shinyUI(fluidPage(titlePanel("Getting Iframe"),
sidebarLayout(
sidebarPanel(
fluidRow(
column(6,
selectInput("Member", label=h5("Choose a option"),
choices=c('BCRA1','FITM2'))
))),
mainPanel(fluidRow(
column(3, htmlOutput("frame"))
)
)
)))
This is my server.R
library(shiny)
members <- data.frame(name=c("Name 1", "Name 2"), nr=c('BCRA1','FITM2'))
shinyServer(function(input, output) {
loadframe <- reactive({
validate(
need(input$Member, "Member input is null!!")
)
query <- members[which(members$nr==input$Member),2]
paste0("http://news.scibite.com/scibites/news.html?q=GENE$",query)
})
output$frame <- renderUI({
tags$iframe(src=loadframe(), height=600, width=535)
})
})
I want to get the iframe from the web page but its printing blank any help on this would be appreciated ?
library(shiny)
members <- data.frame(name=c("Name 1", "Name 2"), nr=c('BCRA1','FITM2'))
ui <- fluidPage(titlePanel("Getting Iframe"),
sidebarLayout(
sidebarPanel(
fluidRow(
column(6, selectInput("Member", label=h5("Choose a option"),choices=c('BCRA1','FITM2'))
))),
mainPanel(fluidRow(
htmlOutput("frame")
)
)
))
server <- function(input, output) {
observe({
query <- members[which(members$nr==input$Member),2]
test <<- paste0("http://news.scibite.com/scibites/news.html?q=GENE$",query)
})
output$frame <- renderUI({
input$Member
my_test <- tags$iframe(src=test, height=600, width=535)
print(my_test)
my_test
})
}
shinyApp(ui, server)
How to show h3("Numeric Results") and h3("Summary Statements")? Thank you.
This is my ui.R and server.R.
Below is the code for my ui.R file:
library(shiny)
ui <- shinyUI(fluidPage(
titlePanel("aaaaaaaaaaaaaaaa"),
tabsetPanel(
navbarMenu("Means",
tabPanel("One Mean"),
tabPanel("Two Means",
wellPanel(
checkboxInput(inputId = "s1", label = "S1" , value = FALSE),
checkboxInput(inputId = "s2", label = "S2", value = FALSE)
),
sidebarPanel(
p(strong("Error Rates")),
numericInput("alpha", label="Alpha", min=0, max=1,value=0.05),
numericInput("power", "Power", 0.8),
actionButton("submit","Submit")
),
mainPanel(
tabsetPanel(
tabPanel("Main",
tableOutput("Table"),
verbatimTextOutput("Text")
)
)
)
)
))))
Below is the code for my server.R file:
server <- shinyServer(function(input, output) {
output$Table <- renderTable({
if(input$submit > 0) {
h3("Numeric Results")
output<-data.frame(input$alpha,input$power)
output
}
})
output$Text<-renderPrint({
if(input$submit > 0) {
h3("Summary Statements")
paste("alpha and power are",input$alpha,"and",input$power)
}
})
})
shinyApp(ui = ui, server = server)
For the Table, I guess you are not providing a variable to store/display the text and for the Text, the paste overrides the h3 code. If you comment the paste code, you can see the h3 code. To have multiple lines of text, you can try something like in the code below.
library(shiny)
ui <- shinyUI(fluidPage(
titlePanel("aaaaaaaaaaaaaaaa"),
tabsetPanel(
navbarMenu("Means",
tabPanel("One Mean"),
tabPanel("Two Means",
wellPanel(
checkboxInput(inputId = "s1", label = "S1" , value = FALSE),
checkboxInput(inputId = "s2", label = "S2", value = FALSE)
),
sidebarPanel(
p(strong("Error Rates")),
numericInput("alpha", label="Alpha", min=0, max=1,value=0.05),
numericInput("power", "Power", 0.8),
actionButton("submit","Submit")
),
mainPanel(
tabsetPanel(
tabPanel("Main",
htmlOutput("header"),
tableOutput("Table"),
htmlOutput("Text")
)
)
)
)
))))
server <- shinyServer(function(input, output) {
output$header <- renderText({
if(input$submit > 0) {
HTML(paste0("<h3>","Numeric Results","</h3>"))
}
})
output$Table <- renderTable({
if(input$submit > 0) {
output<-data.frame(input$alpha,input$power)
output
}
})
output$Text<-renderPrint({
if(input$submit > 0) {
str1 <- (paste0("<h3>", "Summary Statements", "</h3>"))
str2 <- paste("alpha and power are",input$alpha,"and",input$power)
HTML(paste(str1, str2, sep = '<br/>'))
}
})
})
shinyApp(ui = ui, server = server)
I have the following in server.R
shinyServer(function(input, output) {
# builds a reactive expression that only invalidates
# when the value of input$goButton becomes out of date
# (i.e., when the button is pressed)
ntext <- eventReactive(input$goButton, {
input$n
})
output$nText <- renderText({
ntext()
})
})
and the following in ui.R
shinyUI(pageWithSidebar(
headerPanel("actionButton test"),
sidebarPanel(
numericInput("n", "N:", min = 0, max = 100, value = 50),
br(),
actionButton("goButton", "Go!"),
p("Click the button to update the value displayed in the main panel.")
),
mainPanel(
verbatimTextOutput("nText")
)
))
My goal is to make the go action button disappear once it is clicked five times and give a pop up window warning if clicked less than five times.
As #daattali is saying, shinyjs make this really easy, you can do it like this:
library(shiny)
library(shinyjs)
ui <- shinyUI(
fluidPage(
useShinyjs(),
sidebarPanel(
actionButton('btn','Click me')
),
mainPanel(
verbatimTextOutput("nText")
)
)
)
server <- shinyServer(function(input,output,session){
n <- 0
makeReactiveBinding('n')
observeEvent(input$btn, {
if(n < 5){
info('Msg')
} else if(n > 5){
hide('btn')
}
n <<- n + 1
})
output$nText <- renderText({
n
})
})
shinyApp(ui=ui,server=server)
Here's how you would hide the button without using shinyjs:
library(shiny)
ui <- shinyUI(
fluidPage(
tags$head(
tags$style(
HTML('#num{display: none;}')
)
),
useShinyjs(),
sidebarPanel(
conditionalPanel(
condition = "input.num < 5",
actionButton('btn','Click me')
),
numericInput('num','',0)
),
mainPanel(
verbatimTextOutput("nText")
)
)
)
server <- shinyServer(function(input,output,session){
n <- 0
makeReactiveBinding('n')
observeEvent(input$btn, {
n <<- n + 1
updateNumericInput(session,'num',value=n)
})
output$nText <- renderText({
n
})
})
shinyApp(ui=ui,server=server)
And finally without using observeEvent:
library(shiny)
ui <- shinyUI(
fluidPage(
tags$head(
tags$style(
HTML('#num{display: none;}')
)
),
useShinyjs(),
sidebarPanel(
conditionalPanel(
condition = "input.num < 5",
actionButton('btn','Click me')
),
numericInput('num','',0)
),
mainPanel(
verbatimTextOutput("nText")
)
)
)
server <- shinyServer(function(input,output,session){
n <- 0
makeReactiveBinding('n')
observe({
input$btn
isolate({
n <<- n + 1
updateNumericInput(session,'num',value=n)
})
})
output$nText <- renderText({
n
})
})
shinyApp(ui=ui,server=server)
You don't need to define a reactive n. It is already the value of input$btn.
library(shiny)
library(shinyjs)
ui <- shinyUI(
fluidPage(
useShinyjs(),
sidebarPanel(
actionButton('btn','Click me')
),
mainPanel(
verbatimTextOutput("nText")
)
)
)
server <- shinyServer(function(input,output,session){
observe({
if(input$btn < 5){
info('Msg')
} else {
hide('btn')
}
})
output$nText <- renderText({
input$btn
})
})
shinyApp(ui=ui,server=server)
this is my UI. R
shinyUI(fluidPage(titlePanel("Getting Iframe"),
sidebarLayout(
sidebarPanel(
fluidRow(
column(6,
selectInput("Member", label=h5("Choose a option"),
choices=c('BCRA1','FITM2'))
))),
mainPanel(fluidRow(
column(3, htmlOutput("frame"))
)
)
)))
This is my server.R
library(shiny)
members <- data.frame(name=c("Name 1", "Name 2"), nr=c('BCRA1','FITM2'))
shinyServer(function(input, output) {
loadframe <- reactive({
validate(
need(input$Member, "Member input is null!!")
)
query <- members[which(members$nr==input$Member),2]
paste0("http://news.scibite.com/scibites/news.html?q=GENE$",query)
})
output$frame <- renderUI({
tags$iframe(src=loadframe(), height=600, width=535)
})
})
I want to get the iframe from the web page but its printing blank any help on this would be appreciated ?
library(shiny)
members <- data.frame(name=c("Name 1", "Name 2"), nr=c('BCRA1','FITM2'))
ui <- fluidPage(titlePanel("Getting Iframe"),
sidebarLayout(
sidebarPanel(
fluidRow(
column(6, selectInput("Member", label=h5("Choose a option"),choices=c('BCRA1','FITM2'))
))),
mainPanel(fluidRow(
htmlOutput("frame")
)
)
))
server <- function(input, output) {
observe({
query <- members[which(members$nr==input$Member),2]
test <<- paste0("http://news.scibite.com/scibites/news.html?q=GENE$",query)
})
output$frame <- renderUI({
input$Member
my_test <- tags$iframe(src=test, height=600, width=535)
print(my_test)
my_test
})
}
shinyApp(ui, server)