I have a data frame about voices and emotions. Using shiny I want to create a scatter plot graph with a tooltip which shows the name and type of emotions and runs the audio file. When people click on a point, I want to hear the audio of this emotion. However, I cannot find any solution to run an audio file. Audio files in wav format. Basically, I want to know how I add audio files into hoover or tooltip.
I used hchart package for create graph.
This is server part of my shiny app
require(shinydashboard)
require(ggplot2)
require(dplyr)
require(highcharter)
library(readxl)
require(tidyr)
server <- function(input, output) {
output$hcontainer <- renderHighchart ({
data_frame <- data %>% filter(Language == input$language & acoustics == input$acoustic_parameter)
##plot, ADD audio file for points
hchart(data, "scatter", hcaes(x = Emotion , y = values, group = Vocalization)) %>%
hc_exporting(enabled = TRUE) %>%
hc_tooltip(crosshairs = TRUE, backgroundColor = "#FCFFC5",
shared = TRUE, borderWidth = 2) %>%
hc_title(text="Acoustic Parameter",align="center") %>%
hc_subtitle(text="Emotion - Vocalization Graph",align="center") %>%
hc_add_theme(hc_theme_elementary())
})
}
This is the codes for ui
##required packages.
library(shinydashboard)
require(shiny)
require(highcharter)
##there is two input, language: Dutch, Chinese, acoustic parameter: 10 different,
language <- c("Dutch", "Chinese")
acoustic_parameter <- c("loudness_sma3_amean",
"loudness_sma3_pctlrange0-2",
"mfcc3_sma3_amean",
"F1amplitudeLogRelF0_sma3nz_amean",
"hammarbergIndexV_sma3nz_amean",
"F0semitoneFrom27.5Hz_sma3nz_percentile20.0",
"loudness_sma3_percentile50.0",
"mfcc1_sma3_amean",
"HNRdBACF_sma3nz_amean",
"F2amplitudeLogRelF0_sma3nz_amean")
dashboardPage(
#defines header of dashboard
skin = "red",
dashboardHeader(
title="Shiny Project Deneme" ,
dropdownMenu()
),
##define sidebar
dashboardSidebar(
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
menuItem("About", tabName = "about", icon = icon("th")),
menuItem("Project",tabName="unions",icon=icon("signal"))
)
),
##defines body
dashboardBody(
tags$head(
tags$link(rel = "stylesheet", type = "text/css", href = "custom.css")
),
#First TAB Menu-Dashboard
tabItem(tabName = "dashboard",
fluidRow(
column(12,
box(selectInput("language", label = "Language", choices = language))),
column(12,
box(selectInput("acoustic_parameter", label = "acoustic parameter", choices = acoustic_parameter))),
column(12,
box(
highchartOutput("hcontainer"),
width="12") #end of the box
), #close the column
hr(),
h4("Plot of the these Project", align = "center"),
br(),
column(12,
box(
highchartOutput("hc2"), width=12
))
), ## close the row
h4("First trial", strong("Alkim Karakurt")),
), # close the first tab item
#second tab menu
tabItem(tabName = "about",
fluidPage(
br(),
br(),
box(width = 12, height = "300px",
p(style ="font-size:18px", strong("Center for Data Science"), "Project Type"),
) #close box
) #close fluid
), #close tab item
)
)
Related
I have an R shiny app with different download buttons as illustrated in the code below. The issue is that the position of the download button within fluidRow is not automatically aligned with the positions of other input elements like dateInput below.
ui <- dashboardPage(
title = "Test Dashboard", # this is the name of the tab in Chrome browserr
dashboardHeader(title = "Web Portal"),
dashboardSidebar(
sidebarMenu(
menuItem('Retail', tabName = "retail", icon = icon("th"),
menuItem('Dashboard', tabName = 'retail_dashboard'))
)
),
dashboardBody(
tabItem(tabName = "retail_dashboard",
tabsetPanel(type = "tabs",
tabPanel("Dashboard",
h3("Test."),
fluidRow(column(2,
dateInput("idx_muni_tot_ret_start_dt", label = "Start Date:", value = Sys.Date()-10)), # 1yr ago
column(2,
dateInput("idx_muni_tot_ret_end_dt", label = "End Date:", value = Sys.Date())),
column(2,
downloadButton("download_idx_muni_TR_data","Download Data"))
)
)
)
)
)
)
server <- function(input, output, session) {
# code...
}
cat("\nLaunching 'shinyApp' ....")
shinyApp(ui, server)
I found similar questions here How do I align downloadButton and ActionButton in R Shiny app? and here Change download button position in a tab panel in shiny app but they don't seem to answer my questions. I also attach a screenshot with the current button position as well as the expected one.
A workaround is to simulate a label on top of the download button and add 5px of margin-bottom.
column(
width = 2,
div(tags$label(), style = "margin-bottom: 5px"),
div(downloadButton("download_idx_muni_TR_data", "Download Data"))
)
A bit of css does the trick:
ui <- dashboardPage(
title = "Test Dashboard",
dashboardHeader(title = "Web Portal"),
dashboardSidebar(
),
dashboardBody(
h3("Test."),
fluidRow(column(2,
dateInput("idx_muni_tot_ret_start_dt",
label = "Start Date:", value = Sys.Date() - 10)),
column(2,
dateInput("idx_muni_tot_ret_end_dt",
label = "End Date:", value = Sys.Date())),
column(2,
div(style = "margin-bottom:15px",
downloadButton("download_idx_muni_TR_data","Download Data")))
, style = "display:flex;align-items:end")
)
)
Update
If you want to add a selectInput you need yet some new css tweaks to get the input on the same line:
ui <- dashboardPage(
title = "Test Dashboard",
dashboardHeader(title = "Web Portal"),
dashboardSidebar(),
dashboardBody(
h3("Test."),
fluidRow(column(2,
dateInput("idx_muni_tot_ret_start_dt",
label = "Start Date:", value = Sys.Date() - 10)),
column(2,
dateInput("idx_muni_tot_ret_end_dt",
label = "End Date:", value = Sys.Date())),
column(2,
tagAppendAttributes(selectInput("slc", "Select", LETTERS), style="margin-bottom:10px")),
column(2,
div(style = "margin-bottom:15px",
downloadButton("download_idx_muni_TR_data","Download Data"))),
style = "display:flex;align-items:end")
)
)
I´ve been looking for the solution to this but I do not find it
My issue is that I have a shiny dashboard that looks like this:
It is selecting all tabs even If I do not select them (like pre-rendered)
I tried making an observeEvent with a button but It do not know how to make the UI appear after they click it.
My code is
library(shiny)
library(shinydashboard)
gamestop <- tags$img(src = "GSLL.png",
height = '30', width = '170')
ui <- dashboardPage(skin = "yellow",
dashboardHeader(title = gamestop,
dropdownMenu(type = "tasks",
messageItem(
from = "My contact",
message = "x",
icon = icon("glyphicon glyphicon-envelope"),
href = "mailto:x"),
messageItem(
from = "Leads",
message = "y",
icon = icon("glyphicon glyphicon-envelope"),
href = "mailto:y"),
messageItem(
from = "",
message = "z",
icon = icon("glyphicon glyphicon-envelope"),
href = "mailto:z"),
icon = icon("envelope")
)
),
dashboardSidebar(
sidebarMenu(
menuItem("Main menu", tabName = "main_menu", icon = icon("home")),
menuItem("Peripherals", tabName = "peripherals", icon = icon("hdd")),
menuItem("Database repair", tabName = "widgets", icon = icon("th")),
menuItem("Polling", tabName = "polling", icon = icon("cloud")),
menuItem("more issues!!", tabName = "issues", icon = icon("ad"))
)
),
dashboardBody(tags$head(
tags$link(rel = "stylesheet", type = "text/css", href = "Custom.css")),
fluidPage(
tabItem(tabName = "peripherals",
h1("Peripherals",
style = "color:#15942B"),
tabsetPanel(type = "tabs",
tabPanel("Printers",br(),
tabsetPanel(type = "tabs",
tabPanel("M452DW",br(),
tabsetPanel(type = "tabs",
tabPanel("Not pinging"),
tabPanel("Error messages")
)
),
tabPanel("M402DW",br(),
tabsetPanel(type = "tabs",
tabPanel("Not pinging")
),
)
)
),
tabPanel("Pinpad",br(),
tabsetPanel(type = "tabs",
tabPanel("Offline / busy"),
tabPanel("Not turning on")
)
),
tabPanel("Scanners",br(),
tabsetPanel(type = "tabs",
tabPanel("GBT4400"),
tabPanel("DS2278")
)
),
tabPanel("Receipt printer / cashdrawer",br(),
tabsetPanel(type = "tabs",
tabPanel("Receipt printer"),
tabPanel("Cash drawer")
)
),
tabPanel("Label printer",br(),
tabsetPanel(type ="tabs",
tabPanel("ZD410"),
tabPanel("LP2824 & +")
),
)
)
), #Final tab peripherals
tabItem(tabName = "main_menu",
h1("Main menu",
style = "color:#15942B"),
strong("Here we can add the news of the day or a welcome image"),br(),
br(),
br(),
strong("This is a work in progress, to be presented to our team leads so we can make
it an aid page for all of us")
),
tabItem(tabName = "issues",
h1("More issue resolutions to come!!!!!",
style = "color:#15942B" ),
strong("My plan is to add the hardest issue resolutions for our team, so they can access this web page and
with a glipse they can resolve the issue in hand")
),
tabItem(tabName = "polling",
)
)
)
)
)
server <- function(input, output) {
observeEvent(input$tabs,
if(input$sidebarmenu == "Printers"){
})
}
shinyApp(ui, server)
I would like to know how to render the tab when the user clicks on the tab itself and not before
Thanks a lot!!!
If you want to render the tab when the user clicks on the tab, you need to observe the tabsetpanel and check if the tab is clicked.
library(shiny)
library(shinydashboard)
ui <- fluidPage(
tabItem(tabName = "peripherals",
h1("Peripherals",
style = "color:#15942B"),
tabsetPanel(id = "firsttabset",
type = "tabs",
tabPanel("Printers"),
tabPanel("Pinpad1",
h1("Dies ist tab \"Pinpad1\""),
textOutput("text")),
tabPanel("Scanners"),
tabPanel("Receipt printer / cashdrawer"),
tabPanel("Label printer")
)
)
)
server <- function(input, output) {
observeEvent(input$firsttabset, {
if(input$firsttabset == "Pinpad1") {
cat("tab \"Pinpad1\" is now being rendered \n")
output$text <- renderText({"tadaa"})
}
})
}
shinyApp(ui, server)
EDIT: If you want to apply this to nested tabsetpanels, I found a way by observing both tabsetpanel1 and tabsetpanel2 and checking in the conditions which tabs are selected. I suppose the first tab of tabsetpanel2, that is Scanners2 in this example, has to be rendered if you want to render the tab Pinpad1.
Check it out if it works for you. This logic can be extended to further nesting of tabsetpanels, but it will get complicated.
library(shiny)
library(shinydashboard)
ui <- fluidPage(
tabItem(tabName = "peripherals",
h1("Peripherals",
style = "color:#15942B"),
tabsetPanel(id = "firsttabset",
type = "tabs",
tabPanel("Printers"),
tabPanel("Pinpad1",
tabsetPanel(id = "secondtabset",
type = "tabs",
tabPanel("Scanners2",
h1("Dies ist tab \"Scanners2\"")),
tabPanel("Pinpad2",
h1("Dies ist tab \"Pinpad2\""),
textOutput("text2"))),
h1("Dies ist tab \"Pinpad1\""),
textOutput("text")),
tabPanel("Scanners"),
tabPanel("Receipt printer / cashdrawer"),
tabPanel("Label printer")
)
)
)
server <- function(input, output) {
observeEvent(c(input$firsttabset,
input$secondtabset), {
if(input$firsttabset == "Pinpad1" & input$secondtabset == "Scanners2") {
cat("tab \"Pinpad1\" is now being rendered \n")
output$text <- renderText({"tadaa"})
}
if (input$firsttabset == "Pinpad1" & input$secondtabset == "Pinpad2") {
cat("tab2 \"Pinpad2\" is now being rendered \n")
output$text2 <- renderText({"tadooo"})
}
})
}
shinyApp(ui, server)
There is a wrong display in shiny dashboard for the below code. The title "Yet to do" is getting displayed as soon as i run the app. I need that when I click on Bivariate Analysis. What is the issue here. This happened when I introduced selectinput under menu item. Earlier it was working well
library(shinydashboard)
library(shiny)
ui <- dashboardPage(
dashboardHeader(title = "Data Analysis"),
dashboardSidebar(
sidebarMenu(
menuItem("Univariate Analysis", tabName = "Univariate", icon =
icon("question"),selectInput("Factors",h5("Factors"),choices =
c("","A","B"))),
menuItem("Bivariate Analysis", tabName = "Bivariate", icon =
icon("question")))
),
dashboardBody(
tabItems(
tabItem(tabName = "Univariate",fluidRow(box(plotOutput("Plot1"),width =
1000,height = 1000),
box(plotOutput("Plot2"),width =
1000,height = 1000))),
tabItem(tabName = "Bivariate",h1("Yet to do")))
))
server <- function(input, output) {
}
shinyApp(ui, server)
It is related having selectInput() as menuItem(). I tried some options like creating menuSubItem etc. but couldn't get it to work. This is probably some bug so you may have to look around for a fix. For now, I'd suggest moving the selectInput inside dashboardBody() -
ui <- dashboardPage(
dashboardHeader(title = "Data Analysis"),
dashboardSidebar(
sidebarMenu(
menuItem("Univariate Analysis",
tabName = "Univariate", icon = icon("question")
# removing selectInput from here fixes the issue
# ,selectInput("Factors", h5("Factors"), choices = c("","A","B"))
),
# an option is to have selectInput by itself but probably not the layout you want
# selectInput("Factors", h5("Factors"), choices = c("","A","B")),
menuItem("Bivariate Analysis",
tabName = "Bivariate", icon = icon("question")
)
)
),
dashboardBody(
tabItems(
tabItem(tabName = "Univariate",
fluidRow(
# add selectInput somewhere on Univariate page
selectInput("Factors", h5("Factors"), choices = c("","A","B")),
box(plotOutput("Plot1"), width = "50%", height = "50%"),
box(plotOutput("Plot2"), width = "50%", height = "50%")
)
),
tabItem(tabName = "Bivariate",
h1("Yet to do")
)
)
)
)
server <- function(input, output) {}
shinyApp(ui, server)
Hi I am using shinydashboard to build some visualization for some raster files. I am use leafletOutput to display the map.
Under the first tabItem, where it is called 'KmeansOutput', I would like to display the leaflet map. When I do not include selectInput, it display the map, but once I include the selectInput, it do not display the map. I am not sure which part went wrong. Thanks in advance!!
Here is the UI section of the code:
library(shinydashboard)
library(leaflet)
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("KmeansOutput", tabName = "kmeans", icon = icon("kmeans"),
selectInput("run1",
"SoilAllWeatherAll",
choices = c('4' = 1, '5' = 2),
multiple = TRUE)
),
menuItem("HistoricalWeather", icon = icon("weather"), tabName = "weather"),
menuItem("SoilMap", icon = icon("soil"), tabName = "soil")
)
)
body <- dashboardBody(
tabItems(
tabItem(tabName = "kmeans",
leafletOutput("map", height = 700)
),
tabItem(tabName = "weather",
h2("weather")),
tabItem(tabName = "soil",
h2('soil'))
)
)
# Put them together into a dashboardPage
ui <- dashboardPage(
dashboardHeader(title = "Genome Prediction"),
sidebar,
body)
here is the server:
server <- function(input, output) {
output$map <- renderLeaflet({
leaflet() %>%
addTiles()
})
}
shinyApp(ui, server)
You need to add a sub-item to your k-means siderbar item as follows.
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("KmeansOutput", #icon = icon("kmeans"),
menuSubItem(
"K-Means Map", tabName = "kmeans", icon = icon("calendar")
),
selectInput("run1",
"SoilAllWeatherAll",
choices = c('4' = 1, '5' = 2),
multiple = TRUE)
),
menuItem("HistoricalWeather", tabName = "weather"), #icon = icon("weather"),
menuItem("SoilMap", tabName = "soil")#, icon = icon("soil")
)
)
I'm trying to create a dashboard using Shiny. Here is some sample data:
###Creating Data
name <- c("Sharon", "Megan", "Kevin")
x <- c(5, 7,3)
y <- c(3,6,2)
z <- c(2,3,7)
jobForm = data.frame(name, x, y, z)
What I'm trying to figure out is, for every row of names how do I create their own TABLE? I believe there is a way to create a reactive for-loop but I've been at this for a long time and have given up.
Here is the full code of what the dashboard should look like for each name. This code only shows Sharon's scores, and it should run. If there are any issues on getting the code to run completely let me know.
I am using
packages shiny, shinydashboard and tidyverse
##Dashboard Header
header <- dashboardHeader(
title = "My Project")
##Dashboard Sidebar
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("Dashboard", icon = icon("dashboard"),tabName = "dashboard"),
menuItem("Job Positions", icon = icon("address-card"), tabName = "jobposition",
menuSubItem('Sales',
tabName = 'sales',
icon = icon('line-chart'))
)
)
)
##Dashboard Body
body <- dashboardBody(
tabItems(
# Dashboard Tab Content
tabItem(tabName = "dashboard",
fluidRow(
#Random Plot
box( )
)
),
# Associate Tab Content
tabItem(tabName = "sales",
fluidRow(
#Main Box for Candidate
box(
width = 8,
title = "Candidate 001",
status = "primary",
#Box for Table
box(
title = "Table",
status = "info",
tableOutput("stat1")
)
)
)
)
)
)
##User Interface Using Dashboard Function
ui <- dashboardPage(
skin = "yellow",
header,
sidebar,
body
)
##Server: Instructions
server <- function(input, output) {
temp <- data.frame(jobForm %>%
slice(1) %>%
select(x:z))
temp <- as.data.frame(t(temp))
output$stat1 <-renderTable({
temp
},
include.rownames=TRUE,
colnames(temp)<-c("Score")
)
}
##Create Shiny App Object
shinyApp(ui, server)
Thank you for any help
You better solve these kibnd of problems with an renderUI and since you never really know when shiny will evaluate an expression you are much better of using lapply then for loops.
name <- c("Sharon", "Megan", "Kevin")
x <- c(5, 7,3)
y <- c(3,6,2)
z <- c(2,3,7)
jobForm = data.frame(name, x, y, z)
##Dashboard Header
header <- dashboardHeader(
title = "My Project")
##Dashboard Sidebar
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("Dashboard", icon = icon("dashboard"),tabName = "dashboard"),
menuItem("Job Positions", icon = icon("address-card"), tabName = "jobposition",
menuSubItem('Sales',
tabName = 'sales',
icon = icon('line-chart'))
)
)
)
##Dashboard Body
body <- dashboardBody(
tabItems(
# Dashboard Tab Content
tabItem(tabName = "dashboard",
fluidRow(
#Random Plot
box( )
)
),
# Associate Tab Content
tabItem(tabName = "sales",
fluidRow(
#Main Box for Candidate
uiOutput("candidates")
)
)
)
)
##User Interface Using Dashboard Function
ui <- dashboardPage(
skin = "yellow",
header,
sidebar,
body
)
##Server: Instructions
server <- function(input, output) {
temp <- data.frame(jobForm %>%
slice(1) %>%
select(x:z))
temp <- as.data.frame(t(temp))
output$stat1 <-renderTable({
temp
},
include.rownames=TRUE,
colnames(temp)<-c("Score")
)
output$candidates <- renderUI(
tagList(
lapply(1:nrow(jobForm), function(idx){
output[[paste0("stat",idx)]] <- renderTable(
jobForm[idx,-1]
)
box(
width = 8,
title = paste0("Candidate: ",jobForm$name[idx]),
status = "primary",
#Box for Table
box(
title = "Table",
status = "info",
tableOutput(paste0("stat",idx))
)
)
})
)
)
}
##Create Shiny App Object
shinyApp(ui, server)
Hope this helps!!