I have problems in my shiny app. all the inputs show the correct response from the server but, when i select the choice 5 in the checkboxgroup the app return the correct thing. but after, when i try other inputs only show the update of box (dyplot1) and the anothers boxes(dyplot2 and prediction) keep static. this is a sample code:
# funciones ----
addDays <- function(data,date,days) {
for(i in 1:days){
data[length(data)+1] <- NA
date[length(date)+1] <- date[length(date)]+1
}
y <- xts(data,order.by = date)
return(y)
}
addDaysForecast <- function(forecast,date,days) {
data <- rep(NA,length(date))
for(i in 1:days){
data[length(data)+1] <- forecast[i]
date[length(date)+1] <- date[length(date)]+1
}
y <- xts(data,order.by = date)
return(y)
}
plotForecast <- function(table,forecast) {
days <-length(forecast)
date <-as.Date(table[,"ENTRYTIME"])
values <- as.numeric(table[,"CLOSINGPRICE"])
series <- addDays(values,date,days)
serieForecast <- addDaysForecast(forecast,date,days)
day1 <- date[length(date)-days*2]
day2 <- date[length(date)]+7
curvas <- cbind(series,serieForecast)
graf <- dygraph(curvas, main = table[1,1]) %>%
dySeries("..1", label = "datos", color = "black") %>%
dySeries("..2", label = " Forecast", stepPlot = TRUE, color = "green") %>%
dyAxis("y", label = "CLOSINGPRICE") %>%
dyCrosshair(direction = "vertical") %>%
dyRangeSelector(dateWindow = c(day1, day2)) %>%
##dyOptions(maxNumberWidth = 20, stackedGraph = FALSE) %>%
dyLegend(width = 400) %>%
dyHighlight(highlightCircleSize = 3,
highlightSeriesBackgroundAlpha = 0.2,
hideOnMouseOut = FALSE) %>%
dyRangeSelector()
return(graf)
}
plotNormal <- function(table,thing) {
date <-as.Date(table[,"ENTRYTIME"])
values <- as.numeric(table[,thing])
series <- xts(values, order.by = date)
ma1 <- xts(runMean(values, n = 6),order.by = date)
ma2 <- xts(runMean(values, n = 12),order.by = date)
ma3 <- xts(runMean(values, n = 20),order.by = date)
mv1 <- xts(runVar(values, n = 6), order.by = date)
mv2 <- xts(runVar(values, n = 12), order.by = date)
mv3 <- xts(runVar(values, n = 20), order.by = date)
ske1 <- xts(movskew(values,6), order.by = date)
ske2 <- xts(movskew(values,12), order.by = date)
ske3 <- xts(movskew(values,20), order.by = date)
curvas <- cbind(series,ma1,ma2,ma3,mv1,mv2,mv3,ske1,ske2,ske3)
graf <- dygraph(curvas, main = table[1,1], group = "ALL") %>%
dySeries("..1", label = "datos", color = "black") %>%
dySeries("..2", label = "Ma6", color = "red") %>%
dySeries("..3", label = "Ma12", color = "blue") %>%
dySeries("..4", label = "Ma20", color = "green") %>%
dySeries("..5", label = "Mv6",strokePattern = "dashed",axis = 'y2', color = "red") %>%
dySeries("..6", label = "Mv12",strokePattern = "dashed",axis = 'y2', color = "blue") %>%
dySeries("..7", label = "Mv20",strokePattern = "dashed",axis = 'y2',color = "green") %>%
dySeries("..8", label = " as 6", stepPlot = TRUE, color = "red") %>%
dySeries("..9", label = " as 12", stepPlot = TRUE, color = "blue") %>%
dySeries("..10", label = " as 20", stepPlot = TRUE, color = "green") %>%
dyAxis("y", label = thing) %>%
dyCrosshair(direction = "vertical") %>%
##dyOptions(maxNumberWidth = 20, stackedGraph = FALSE) %>%
dyLegend(width = 400) %>%
dyHighlight(highlightCircleSize = 3,
highlightSeriesBackgroundAlpha = 0.2,
hideOnMouseOut = FALSE) %>%
dyRangeSelector()
return(graf)
}
status <- function(table,forecast) {
test <- table[nrow(table)-1:nrow(table),]
last <- test[,"CLOSINGPRICE"]
if(length(forecast)==1|| forecast==-1 ){
return(("No se a realizado predicción para este nemo"))
}else if (last<forecast[1]){
return(paste("A la alza con precio de cierre: ",forecast[1]))
}else if(last>forecast[1]){
return(paste("A la baja con precio de cierre: ",forecast[1]))
}
}
##skewness moving
movskew <- function(values,n) {
values2 <- values
for(i in 1:n){
values2[i] <- NA
}
num <- n
for(i in 1:(length(values)-n)){
num <- num + 1
values2[num] <- as.numeric(skewness(values[i:num]))
}
return(values2)
}
whatshow <- function(array) {
showthis <- vector()
for(i in 1:5){
showthis[i] <- any(array==i)
}
return(showthis)
}
getforecast <- function(path) {
url <- paste0("http://192.168.1.9:3169/api/forecast/", path, "?format=json")
response <- jsonlite::fromJSON(url)
if(length(response)>1){
return(response$forecast)
}else{
return(-1)
}
}
whatPlot <- function(table,name,show,thing) {
if(show[5]==TRUE){
fore <- getforecast(name)
plotForecast(table,fore)
}else{
plotNormal(table,thing) %>%
dyVisibility(visibility=c(show[1],
rep(show[2],3),
rep(show[3],3),
rep(show[4],3)))
}
}
dyVisibility <- function (dygraph, visibility = TRUE){
dygraph$x$attrs$visibility <- visibility
dygraph
}
#creando la tabla de prueba
table <- data.frame(matrix(1, nrow = 100, ncol = 18))
nombres <- c("SYMBOL" ,
"BOOKING_REF_ID",
"BIDQTY",
"BIDPRICE",
"OFFERQTY",
"OFFERPRICE",
"TRADEQTY",
"TRADEPRICE",
"OPENINGPRICE",
"CLOSINGPRICE",
"HIGHPRICE",
"LOWPRICE",
"VWAPPRICE",
"IMBALANCE",
"VOLUME",
"AMOUNT",
"TREND",
"ENTRYTIME")
colnames(table) <- nombres
table$ENTRYTIME <-seq.POSIXt(as.POSIXct("2015-01-01", tz="GMT"),
as.POSIXct("2015-4-10", tz="GMT"), by="1 day")
# estructura pagina ----
header <- dashboardHeader(title = "Basic dashboard")
sidebar <- dashboardSidebar( collapsed = TRUE,
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
menuItem("Widgets", tabName = "widgets", icon = icon("th"))
)
)
body <- dashboardBody(
tabItems(
# First tab content
tabItem(tabName = "dashboard",
fluidRow(
column(width = 9,
box(title = "Grafico 1", status = "primary", width = NULL,
solidHeader = TRUE, collapsible = TRUE,
dygraphOutput("dyPlot1",height = "300px")),
box(title = "Grafico 2", status = "primary", width = NULL,
solidHeader = TRUE, collapsible = TRUE,
dygraphOutput("dyPlot2",height = "300px"))
),
column(width = 3,
box(title = "Inputs", status = "warning", solidHeader = TRUE, width = NULL,
selectInput("var1",
label = "1) variable",
choices = nombres[3:16],
selected = "CLOSINGPRICE"),
selectInput("var2",
label = "2) variable",
choices = nombres[3:16],
selected = "VOLUME"),
checkboxGroupInput("checkGroup", label = h3("Ver:"),
choices = list("Datos" = 1, "Medias" = 2,
"Esperanzas" = 3,"Asimetrias"=4, "Forecast"=5),
selected = 1),
box(title = "Predicción",status = "warning", solidHeader = TRUE, width = NULL,
verbatimTextOutput("prediction"))
)
)
)
),
# Second tab content
tabItem(tabName = "widgets",
h2("Widgets tab content")
)
)
)
# app ----
app <- shinyApp(
#UI
ui <- dashboardPage(header,sidebar,body),
server <- function(input, output) {
observeEvent(input$checkGroup, {
#... # do some work
output$prediction <- renderText({
forecast <- getforecast("CAMANCHACA")
status(table,forecast)
})
#... # do some more work
})
output$dyPlot1 <- renderDygraph({
show <- whatshow(input$checkGroup)
whatPlot(table,"CAMANCHACA",show,input$var1)
})
output$dyPlot2 <- renderDygraph({
show <- whatshow(input$checkGroup)
whatPlot(table,"CAMANCHACA",show,input$var2)
})
}
)
# Run the app ----
runApp(app,host="0.0.0.0",port=3838)
Related
I'm putting together a shiny app to play around with some athlete GPS data. Essentially, I'm looking to structure my script so that each time the user selects an area of interest on the plotly plot and the "Add" actionButton is clicked, the table below will add the calculated Start_time, Time_at_peak, Max_velocity, Time_to_peak, and Distance_to_peak values.
The issue can be seen in the GIF below: - Once the area of interest is selected and the "Add" button clicked, the first values seem correct. However, when the user selects a second area of interest to add to the table, it overwrites the initial entry and will keep overwriting each time a new selection is made. This is seemingly because because the code is inside the observeEvent(event_data("plotly_selected"), which, confusingly, it needs to be in order to calculate the variables of interest.
I'm currently a little stumped and can't seem to find any relevant information. As such, any guidance would be greatly appreciated!
Here is a we transfer link to some test data that can be uploaded to the app: https://wetransfer.com/downloads/5a7c5da5a7647bdbe133eb3fdac79c6b20211119052848/afe3e5
library(shiny)
library(readr)
library(DT)
library(dplyr)
library(plotly)
library(lubridate)
library(tidyr)
library(purrr)
library(htmlwidgets)
library(shinydashboard)
library(dashboardthemes)
library(shinyjs)
x_df <- data.frame(Start_time = character(1), Time_at_peak = character(1), Max_velocity = integer(1),
Time_to_peak = integer(1), Distance_to_peak = integer(1))
x_df$Start_time <- as.character("0:00:00.0")
x_df$Time_at_peak <- as.character("0:00:00.0")
x_df$Max_velocity <- as.integer(0)
x_df$Time_to_peak <- as.integer(0)
x_df$Distance_to_peak <- as.integer(0)
runApp(shinyApp(
ui=(fluidPage(
titlePanel("Event to Table"),
mainPanel(
fileInput(
inputId = "filedata",
label = "Upload data file (.csv)",
accept = c(".csv")),
plotlyOutput('myPlot'),br(),br(),br(),br(),
DTOutput("testing"), br(), br(),
fluidRow(
valueBoxOutput("starttime", width = 2),
valueBoxOutput("endtime", width = 2),
valueBoxOutput("maxvelocity", width = 2),
valueBoxOutput("timediff", width = 3),
valueBoxOutput("distance", width = 3)
),
useShinyjs(),
fluidRow(
div(style = "text-align:center", actionButton("Add", "Add Data to Table"),
downloadButton("export", "Export Table as .CSV"))), br(),
DTOutput(outputId = "table")))
),
server = (function(input, output, session) {
data<-reactive({
req(input$filedata)
read.csv(input$filedata$datapath, header = TRUE)%>%
rename(Velocity = 'Speed..m.s.',
Player = 'Player.Display.Name',
Latitude = 'Lat',
Longtitude = 'Lon',
AccelImpulse = 'Instantaneous.Acceleration.Impulse',
HeartRate = 'Heart.Rate..bpm.')
})
observe({
thedata<-data()
updateSelectInput(session, 'y', choices = names(data))
})
output$myPlot = renderPlotly({
plot_ly(data = data(), x = ~Time, y = ~Velocity, height = 450,
marker =list(color = 'rgb(132,179,202)', size = 0.1),
line = list(color = 'rgb(132,179,202)', size = 0.1, width = 0.9),
type = 'scatter', mode = 'markers+lines') %>%
layout(dragmode = "select",
showlegend = F,
title = list(text = 'Velocity Trace', font = list(size = 20)),
xaxis = list(title = list(text = "", standoff = 0), nticks = 10),
yaxis = list(title = list(text = "Velocity (m/s)"), nticks = 5, gridcolor = "#46505a"),
font = list(color = 'black'),
margin = list(t = 70))
})
observeEvent(event_data("plotly_selected"), {
event.data <- event_data("plotly_selected")
if (max(event.data$y) < 1.5) {
maxvel <- (max(event.data$y))
maxpos <- match(maxvel, event.data$y)
}
else {
filter1 <- filter (event.data, event.data$y > 1.5)
maxvel <- (max(filter1$y))
maxpos <- match(maxvel, event.data$y)
}
zero_val <- function(x) x == 0
zero_index <- event.data$y[1:maxpos] %>% detect_index(zero_val, .dir = "backward")
if (zero_index==0) {starttime <- event.data$x[1]}
else {starttime <- event.data$x[zero_index]}
endvel <- which.max(event.data$y)
endtime <- event.data$x[endvel]
timediff <- paste(today(), endtime) %>% as_datetime() - paste(today(), starttime) %>% as_datetime()
sprint <- as_tibble(event.data$y[zero_index:endvel])
ms <- as_tibble(rep(0.1, count(sprint)))
time_vel <- cbind(ms, sprint)
distance <- sum(time_vel[1]*time_vel[2])
sprintselect <- as_tibble(cbind(Start_time = starttime,
Time_at_peak = endtime,
Max_velocity = round(maxvel, 2),
Time_to_peak = round(timediff, 1),
Distance_to_peak = round(distance, 1)))
values <- reactiveValues()
values$df <- x_df
addData <- observe({
if(input$Add > 0) {
newLine <- isolate(data.frame(Start_time = sprintselect$Start_time, Time_at_peak = sprintselect$Time_at_peak,
Max_velocity = sprintselect$Max_velocity,
Time_to_peak = sprintselect$Time_to_peak,
Distance_to_peak = sprintselect$Distance_to_peak,
stringsAsFactors= FALSE))
values$df <- isolate(rbind(values$df, newLine))}
})
output$testing <- renderDataTable({values$df})
})
})
))
I've managed to figure it out and thought I'd post an answer rather than delete the question - just in case someone out there is looking to do a similar thing and they are unsure how to do it.
Firstly, I removed the pre-populated table x_df from the beginning - it was no longer required.
Although I thought the code needed to sit inside the observeEvent(event_data("plotly_selected") to function correctly, it did not - thankfully, because that was at the root of the issue. Instead, I used observeEvent(input$Add, { (which is the correct code to use as opposed to if(input$Add > 0)) to anchor the event to the click of the Add button.
The values <- reactiveValues() was placed outside the observeEvent() and an IF statement was used to either add the data to the values$df data frame on it's own if it was the first selection, or bind it to the existing saved data.
Here's the new code and a GIF demonstrating.
library(shiny)
library(readr)
library(DT)
library(dplyr)
library(plotly)
library(lubridate)
library(tidyr)
library(purrr)
library(htmlwidgets)
library(shinydashboard)
library(dashboardthemes)
library(shinyjs)
runApp(shinyApp(
ui=(fluidPage(
titlePanel("Event to Table"),
mainPanel(
fileInput(
inputId = "filedata",
label = "Upload data file (.csv)",
accept = c(".csv")),
plotlyOutput('myPlot'),br(),br(),br(),br(),
DTOutput("testing"), br(), br(),
fluidRow(
valueBoxOutput("starttime", width = 2),
valueBoxOutput("endtime", width = 2),
valueBoxOutput("maxvelocity", width = 2),
valueBoxOutput("timediff", width = 3),
valueBoxOutput("distance", width = 3)
),
useShinyjs(),
fluidRow(
div(style = "text-align:center", actionButton("Add", "Add Data to Table"),
downloadButton("export", "Export Table as .CSV"))), br(),
DTOutput(outputId = "table")))
),
server = (function(input, output, session) {
values <- reactiveValues(df_data = NULL)
data<-reactive({
req(input$filedata)
read.csv(input$filedata$datapath, header = TRUE)%>%
rename(Velocity = 'Speed..m.s.',
Player = 'Player.Display.Name',
Latitude = 'Lat',
Longtitude = 'Lon',
AccelImpulse = 'Instantaneous.Acceleration.Impulse',
HeartRate = 'Heart.Rate..bpm.')
})
observe({
thedata<-data()
updateSelectInput(session, 'y', choices = names(data))
})
output$myPlot = renderPlotly({
plot_ly(data = data(), x = ~Time, y = ~Velocity, height = 450,
marker =list(color = 'rgb(132,179,202)', size = 0.1),
line = list(color = 'rgb(132,179,202)', size = 0.1, width = 0.9),
type = 'scatter', mode = 'markers+lines') %>%
layout(dragmode = "select",
showlegend = F,
title = list(text = 'Velocity Trace', font = list(size = 20)),
xaxis = list(title = list(text = "", standoff = 0), nticks = 10),
yaxis = list(title = list(text = "Velocity (m/s)"), nticks = 5, gridcolor = "#46505a"),
font = list(color = 'black'),
margin = list(t = 70))
})
observeEvent(input$Add, {
event.data <- event_data("plotly_selected")
if (max(event.data$y) < 1.5) {
maxvel <- (max(event.data$y))
maxpos <- match(maxvel, event.data$y)
}
else {
filter1 <- filter (event.data, event.data$y > 1.5)
maxvel <- (max(filter1$y))
maxpos <- match(maxvel, event.data$y)
}
zero_val <- function(x) x == 0
zero_index <- event.data$y[1:maxpos] %>% detect_index(zero_val, .dir = "backward")
if (zero_index==0) {starttime <- event.data$x[1]}
else {starttime <- event.data$x[zero_index]}
endvel <- which.max(event.data$y)
endtime <- event.data$x[endvel]
timediff <- paste(today(), endtime) %>% as_datetime() - paste(today(), starttime) %>% as_datetime()
sprint <- as_tibble(event.data$y[zero_index:endvel])
ms <- as_tibble(rep(0.1, count(sprint)))
time_vel <- cbind(ms, sprint)
distance <- sum(time_vel[1]*time_vel[2])
sprintselect <- as_tibble(cbind(Start_time = starttime,
Time_at_peak = endtime,
Max_velocity = round(maxvel, 2),
Time_to_peak = round(timediff, 1),
Distance_to_peak = round(distance, 1)))
newLine <- isolate(data.frame(Start_time = sprintselect$Start_time, Time_at_peak = sprintselect$Time_at_peak,
Max_velocity = sprintselect$Max_velocity,
Time_to_peak = sprintselect$Time_to_peak,
Distance_to_peak = sprintselect$Distance_to_peak,
stringsAsFactors= FALSE))
if (is.null(values$df)){
values$df <- newLine}
else {
values$df <- isolate(rbind(values$df, newLine))}
output$testing <- renderDataTable({values$df})
})
})
))
I am trying to update the value in a plotly chart in R shiny whose calculated value depends on the number of inputs
library(shiny)
library(httr)
library(jsonlite)
library(dplyr)
library(plotly)
library(shinythemes)
library(flexdashboard)
library(shinydashboard)
setwd("X:/Work/Covid-19 Project/Shiny Dashboard")
rp_1 <- read.csv("Data/Risk Profile 1.csv")
rp_2 <- read.csv("Data/Risk Profile 2.csv")
gender <- c("Male","Female")
age <- c("Less than 20 years", "20 to 50 years","More than 50 years")
city <- c("Delhi","Chennai")
diabetes <- c("Have diabetes","Don't have diabetes")
hypertension <- c("Have hypertension","Don't have hypertension")
risk_level_est <- function(city, gender, age, db, ht){
p_inv <- as.numeric(rp_1 %>%
filter(City == city & Gender == gender) %>%
select(Prob))
p_adv <- as.numeric(rp_2 %>%
filter(Age == age & Diabetes == db & Hypertension == ht) %>%
summarise(Hosp + Death))
as.numeric(p_inv*p_adv*100)
}
sar_risk_level_est <- function(age, db, ht){
p_adv <- as.numeric(rp_2 %>%
filter(Age == age & Diabetes == db & Hypertension == ht) %>%
summarise(Hosp + Death))
as.numeric(0.2*p_adv*100)
}
about_page <- tabPanel(
title = "About",
titlePanel("About"),
"Created with R Shiny",
br(),
"2021 April"
)
main_page <- tabPanel(
title = "Estimator",
titlePanel(""),
sidebarLayout(
sidebarPanel(
title = "Inputs",
selectInput("gender", "Select your gender", gender),
selectInput("age", "Select your age", age),
selectInput("city", "Select your city", city),
selectInput("db", "Do you have diabetes", diabetes),
selectInput("ht", "Do you have hypertension", hypertension),
radioButtons("radio", "Do you want to include your household members",
choices = list("No" = 1,"Yes" = 2)),
conditionalPanel("input.radio == 2",
numericInput("members", label = "How many household members do you have?", value='1'),
uiOutput("member_input")
),
actionButton("risk","Calculate my risk profile")
),
mainPanel(
tabsetPanel(
tabPanel(
title = "Risk Profile",
plotlyOutput("risk_profile", height = 250, width = "75%"),
plotlyOutput("overall_risk_profile", height = 250, width = "75%")
)
)
)
)
)
ui <- navbarPage(
title = "Risk Estimator",
theme = shinytheme('united'),
main_page,
about_page
)
server <- function(input, output, session) {
output$member_input <- renderUI({
numMembers <- as.integer(input$members)
lapply(1:numMembers, function(i) {
list(tags$p(tags$u(h4(paste0("Member ", i)))),
selectInput(paste0("age", i), "Select their age", age, selected = NULL),
selectInput(paste0("db", i), "Do they have diabetes", diabetes, selected = NULL),
selectInput(paste0("ht", i), "Do they have hypertension", hypertension, selected = NULL))
})
})
risk_level <- eventReactive(input$risk, {
risk_level_est(input$city, input$gender, input$age, input$db, input$ht)
})
sar_risk_level <- eventReactive(input$risk,{
sar_risk <- 0
lapply(1:input$members, function(i){
sar_risk <- sar_risk + sar_risk_level_est(input[[paste0("age", i)]],input[[paste0("db", i)]],input[[paste0("ht", i)]])
})
as.numeric(sar_risk)
})
output$risk_profile <- renderPlotly({
fig <- plot_ly(
domain = list(x = c(0, 1), y = c(0, 1)),
value = risk_level(),
title = list(text = "Personal Risk Profile"),
type = "indicator",
mode = "gauge+number",
gauge = list(
axis = list(range = list(0, 15)),
bar = list(color = "gray"),
bgcolor = "white",
borderwidth = 2,
bordercolor = "gray",
steps = list(
list(range = c(0, 3.75), color = "darkgreen"),
list(range = c(3.75, 7.5), color = "chartreuse"),
list(range = c(7.5,11.25), color = "orange"),
list(range = c(11.25,15), color = "red")
)))
fig <- fig %>% layout(margin = list(l=30, r=30, t=80, b=30))
fig
})
output$overall_risk_profile <- renderPlotly({
fig <- plot_ly(
domain = list(x = c(0, 1), y = c(0, 1)),
value = risk_level() + sar_risk_level(),
title = list(text = "Overall Risk Profile"),
type = "indicator",
mode = "gauge+number",
gauge = list(
axis = list(range = list(0, 15+(25*input*members))),
bar = list(color = "gray"),
bgcolor = "white",
borderwidth = 2,
bordercolor = "gray",
steps = list(
list(range = c(0, 3.75), color = "darkgreen"),
list(range = c(3.75, 7.5), color = "chartreuse"),
list(range = c(7.5,11.25), color = "orange"),
list(range = c(11.25,15), color = "red")
)))
fig <- fig %>% layout(margin = list(l=30, r=30, t=80, b=30))
fig
})
}
shinyApp(ui, server)
While the risk_profile plot works fine, the overall_risk_profile plot throws the "non-numeric argument to binary operator" error. The sar_risk_level() value in overall_risk_profile is dependent on a calculation (sar_risk_level_est) which depends on the number of inputs. I want this value (sar_risk) to be initizialied to zero and updated everytime the action button is pressed.
Great looking app. I think it is just a typo. The code has 25*input*members instead of 25*input$members on line 151.
I created an application in Shiny where I would like to choose multiple items from the drop-down menu. Unfortunately, I don't know how to make items on the list reduce after a given menu selection. By which all lines merge into a whole. what should I add in the code so that each model is a separate line. Below I put a picture with charts.
My code:
library(shiny)
library(plotly)
library(readxl)
library(shinyWidgets)
library(shinydashboard)
library(shinyjs)
library(DT)
df1 <- data.frame(Month = rep(month.abb[1:12],10,replace = TRUE), Model = paste0('Ferrari ', rep(LETTERS[1:10], each = 12)),
Value = sample(c(0:300),120, replace = T),
Car = rep('Ferrari', 10,each = 12), Year = rep(2019:2020, each = 60),Country = rep(c("USA","DE"), each = 12, times = 5), stringsAsFactors = F)
df2 <- data.frame(Month = rep(month.abb[1:12],10,replace = TRUE), Model = paste0('Porsche ', rep(LETTERS[1:10], each = 12)),
Value = sample(c(0:300),120, replace = T),
Car = rep('Porsche', 10,each = 12), Year = rep(2019:2020, each = 60), Country = rep(c("USA","DE"), each = 12, times = 5),stringsAsFactors = F)
data <-rbind(df1, df2)
ui <- fluidPage(
titlePanel("Test"),
sidebarLayout(
sidebarPanel( width = 3,
uiOutput("category1"),
uiOutput("category2"),
uiOutput("category3"),
uiOutput("category4")),
mainPanel(
tabsetPanel(type = "tabs",
tabPanel("Plot", plotlyOutput("plot", height = 550,width = 1000))
)
)
)
)
server <- function(input, output,session) {
output$category1 <- renderUI({
selectInput('cat1', 'Choose year:', multiple = T, selected = NULL, choices = sort(as.numeric(unique(data$Year))))
})
df_subset <- eventReactive(input$cat1,{
if(input$cat1=="All") {df_subset <- data}
else{df_subset <- data[data$Year == input$cat1,]}
})
df_subset1 <- reactive({
if(is.null(input$cat2)){df_subset()} else {df_subset()[df_subset()$Country %in% input$cat2,]}
})
output$category2 <- renderUI({
selectInput('cat2', 'Choose country:', choices = sort(as.character(unique(df_subset()$Country))), multiple = T, selected = NULL)
})
df_subset2 <- reactive({
if(is.null(input$cat3)){df_subset1()} else {df_subset1()[df_subset1()$Car %in% input$cat3,]}
})
output$category3 <- renderUI({
selectInput('cat3', 'Choose car:', choices = sort(as.character(unique(df_subset1()$Car))), multiple = F, selected = NULL)
})
df_subset3 <- reactive({
if(is.null(input$cat4)){df_subset2()} else {df_subset2()[df_subset2()$Model %in% input$cat4,]}
})
output$category4 <- renderUI({
pickerInput('cat4', 'Choose model:', choices = sort(as.character(unique(df_subset2()$Model))), multiple = TRUE, selected = NULL)
})
output$plot <- renderPlotly({
xform <- list(categoryorder = "array",
categoryarray = df_subset3()$Month,
title = " ",
nticks=12)
plot_ly(data=df_subset3(), x=~Month, y = ~Value, type = 'scatter', mode = 'lines', name = 'Value') %>%
layout(title = " ",xaxis = xform) %>%
layout(legend = list(orientation = 'h', xanchor = "center", y=1.1, x=0.5))
})
}
shinyApp(ui, server)
To display each model as a separate line on the plot, you can assign the Model column of your dataset to the color parameter of plot_ly this way:
plot_ly( data = df_subset3(), x = ~Month, y = ~Value, color = ~Model, ...)
I have the following R codes within the shiny framework. Everything looks good, but the legend (Plese see this screenshot).
I want the legend to be updated on the basis of the users' selection of age group (60+, 65+, 85+), sex, or year. But it is not the case. That is, the legend's values remain unchanged, no matter what is selected from the left menu (Please see this screenshot). This makes the map useless if the 85+ is selected. Following is my entire codes.
I appreciate your help.
Nader
load("/Users/nadermehri/Desktop/map codes/nhmap.RData")
library(shiny)
library(leaflet)
ui <- fluidPage(
tabPanel(
"Interactive Maps",
tags$h5 (
)),
br(),
sidebarLayout(
sidebarPanel(
selectInput(
inputId = "Age_Group_map",
label = "Select the Age Group:",
selected = "60+",
selectize = F,
multiple = F,
choices = sort(unique(nhmap$Age_Group))
),
radioButtons(
inputId = "sex_map",
label = strong("Select Sex:"),
selected = "Both Sexes",
choices = sort(unique(nhmap$Sex))
),
sliderInput(
inputId = "Year_map",
label = "Year",
min = 2010,
max = 2050,
value = 2010,
step = 10,
sep = "",
pre = "",
animate = animationOptions(
interval = 1000,
loop = F,
playButton = tags$button("Play", style =
"background-color: #B61E2E ; color:white; margin-top: 10px; border:solid"),
pauseButton = tags$button("Pause", style =
"background-color: #B61E2E !important; color:white; margin-top: 10px; border:solid")
),
round = T,
width = "150%",
ticks = T
)),
mainPanel("Interactive", leafletOutput("int_map", height=500))))
server <- function(input, output) {
mapdata_ <- reactive ({
nhmap$Per <- round(nhmap$Per, 1)
out_map <- nhmap %>%
filter (
Age_Group %in% input$Age_Group_map,
Sex %in% input$sex_map,
Year %in% input$Year_map)
return(out_map)
})
output$int_map <- renderLeaflet ({
leaflet (mapdata_(),
pal8 <- c("#FFFFE5", "#D9F0A3", "#78C679", "#006837") ,
pal <- colorBin(palette = pal8, domain = NULL, bins=quantile(nhmap$Per), na.color = "#808080", alpha = FALSE, reverse = F)) %>%
addProviderTiles("CartoDB.Positron") %>%
clearControls() %>%
clearShapes()%>%
addPolygons(fillColor = ~pal(Per),
stroke=T,
weight=1,
smoothFactor=0.2,
fillOpacity = 1,
color="black",
popup=~paste(NAME,"<br>",input$sex_map,
input$Age_Group_map,"=",Per,"%"),
highlightOptions = highlightOptions(color = "red",
weight = T,
bringToFront = T),
label=~NAME) %>%
addTiles() %>%
setView(-82.706838, 40.358615, zoom=7) %>%
addLegend(position = "bottomright",
values = ~Per,
pal = pal,
title = (paste("%",input$Age_Group_map, input$sex_map, "in", input$Year_map)) ,
labFormat = labelFormat(
))
})
}
shinyApp(ui = ui, server = server)
You have to define the bins in colorBin, at which you want to cut the data in the different color sections. Something like:
pal <- colorBin(palette = pal8, domain = NULL, bins=quantile(mapdata_()$Per),
na.color = "#808080", alpha = FALSE, reverse = F)
And you also have to remove bins= 4 from the addLegend call, as it will get the information from the color palette.
I created some random data for nhmap and it is working for me with this code:
library(shiny)
library(leaflet)
library(sf)
library(sp)
## Random Data #############
data(meuse, package = "sp")
nhmap <- st_as_sf(meuse, coords = c("x", "y"))
st_crs(nhmap) <- "+init=epsg:28992"
nhmap <- st_buffer(nhmap, 100)
n = length(nhmap$cadmium)
nhmap$Age_Group <- sample(c(15,19,25), size = n, T)
nhmap$Sex <- sample(c("m","f"), size = n, T)
nhmap$Per <- runif(n, 1, 150)
nhmap$NAME <- sample(c("a","b","c"), size = n, T)
nhmap$Age_Group <- sample(c(15,19,25), size = n, T)
nhmap$Year <- sample(c(2010,2020,2030, 2040, 2050), size = n, T)
nhmap <- st_transform(nhmap, 4326)
## UI ###########
ui <- {fluidPage(
tabPanel(
"Interactive Maps",
tags$h5 ()),
br(),
sidebarLayout(
sidebarPanel(
selectInput(
inputId = "Age_Group_map",
label = "Select the Age Group:",
# selected = "60+",
selectize = F,
multiple = F,
choices = sort(unique(nhmap$Age_Group))
),
radioButtons(
inputId = "sex_map",
label = strong("Select Sex:"),
# selected = "Both Sexes",
choices = sort(unique(nhmap$Sex))
),
sliderInput(
inputId = "Year_map",
label = "Year",
min = 2010,
max = 2050,
value = 2010,
step = 10,
sep = "",
pre = "",
animate = animationOptions(
interval = 1000,
loop = F,
playButton = tags$button("Play", style =
"background-color: #B61E2E ; color:white; margin-top: 10px; border:solid"),
pauseButton = tags$button("Pause", style =
"background-color: #B61E2E !important; color:white; margin-top: 10px; border:solid")
),
round = T,
width = "150%",
ticks = T
)),
mainPanel("Interactive", leafletOutput("int_map", height=500)))
)}
## SERVER ###########
server <- function(input, output) {
mapdata_ <- reactive ({
nhmap$Per <- round(nhmap$Per, 1)
# nhmap
nhmap %>%
filter (
Age_Group %in% input$Age_Group_map,
Sex %in% input$sex_map,
Year %in% input$Year_map)
})
output$int_map <- renderLeaflet ({
req(mapdata_())
pal8 <- c("#FFFFE5", "#D9F0A3", "#78C679", "#006837")
# pal <- colorBin(palette = pal8, domain = NULL, bins=quantile(mapdata_()$Per),
pal <- colorBin(palette = pal8, domain = NULL, bins=quantile(nhmap$Per),
na.color = "#808080", alpha = FALSE, reverse = F)
leaflet(data = mapdata_()) %>%
# leaflet(data = nhmap) %>%
clearControls() %>%
clearShapes()%>%
addProviderTiles("CartoDB.Positron") %>%
addTiles() %>%
addPolygons(fillColor = ~pal(Per),
stroke=T,
weight=1,
smoothFactor=0.2,
fillOpacity = 1,
color="black",
label=~NAME,
popup=~paste(NAME,"<br>",input$sex_map,
input$Age_Group_map,"=",Per,"%"),
highlightOptions = highlightOptions(color = "red",
weight = T,
bringToFront = T)) %>%
# setView(-82.706838, 40.358615, zoom=7) %>%
addLegend(position = "bottomright",
values = ~Per,
title = (paste("%",input$Age_Group_map, input$sex_map, "in", input$Year_map)),
pal = pal
)
})
}
shinyApp(ui = ui, server = server)
Here is the answer. As I mentioned in my the last comment, the pal needs to be reactive:
mapdata_ <- reactive ({
nhmap$Per <- round(nhmap$Per, 1)
out_map <- nhmap %>%
filter (
Age_Group %in% input$Age_Group_map,
Sex %in% input$sex_map,
Year %in% input$Year_map)
return(out_map)
list(Per)
})
mapdata_1 <- reactive ({
nhmap$Per <- round(nhmap$Per, 1)
out_map_1 <- nhmap %>%
filter (
Age_Group %in% input$Age_Group_map
)
return(out_map_1)
list(Per)
})
output$int_map <- renderLeaflet ({
pal8 <- c("#FFFFE5", "#D9F0A3", "#78C679", "#006837")
pal <- colorBin(palette = pal8, domain =NULL, bins=quantile(mapdata_1()$Per), na.color = "#808080", alpha = FALSE, reverse = F)
leaflet (mapdata_()) %>%
addProviderTiles("CartoDB.Positron") %>%
clearControls() %>%
clearShapes()%>%
addPolygons(fillColor = ~pal(Per),
stroke=T,
weight=1,
smoothFactor=0.2,
fillOpacity = 1,
color="black",
popup=~paste(NAME,"<br>",input$sex_map,
input$Age_Group_map,"=",Per,"%"),
highlightOptions = highlightOptions(color = "red",
weight = T,
bringToFront = T),
label=~NAME) %>%
addTiles() %>%
setView(-82.706838, 40.358615, zoom=7) %>%
addLegend(position = "bottomright",
values = ~Per,
pal = pal,
title = (paste("%",input$Age_Group_map, input$sex_map, "in", input$Year_map)) ,
labFormat = labelFormat(
))
})
I have a problem with MenuItem in sidebarMenu. When I add a third MenuItem (RFM) it seems that in ui it renders as a subitem and when i click on that item there's nothing being displayed even if in the server.R there's the corresponding function. Here's a screenshot of the sidebarMenu
ui.R
dashboardPage(
dashboardHeader(title= "Acquisti Clienti CC"),
dashboardSidebar(
h4("Explorer"),
textInput("cluster","Digita un Codice cliente CC:","H01621"),
selectizeInput('categ',label="Seleziona una Categoria Merceologica",
choices=unique(user_clustering$DESC_CAT_MERC),
selected=c("NOTEBOOK","PC","TABLET/PDA"),
options = NULL,
multiple=TRUE),
#uiOutput("checkcluster"),
sidebarMenu(id="menu",
tags$style(".fa-stats {color:#f2f4f4}"),
tags$style(".fa-th-list {color:#f2f4f4}"),
menuItem("Dashboard", tabName = "dashboard",icon = icon("stats",lib = "glyphicon")),
menuItem("Data", tabName = "Data",icon = icon("th-list",lib = "glyphicon")),
menuItem("RFM",tabname="RFM",icon = icon("dashboard",lib = "glyphicon")) ## That's the item I ve just added
)
),
dashboardBody(
tabItems(
tabItem("dashboard",
fluidRow(
#valueBoxOutput("Spesa_Grafico",width=3),
valueBoxOutput("Spesa_Totale"),
#valueBoxOutput("Spesa_Cluster",width=3),
valueBoxOutput("Clienti_Totali")
),
fluidRow(
box(title="Cluster 1",plotlyOutput('plot1'),
fluidRow(column(4,offset=3,DT::dataTableOutput("plot1_data",width = 10)))),
#DT::dataTableOutput("plot1_data",width = 8),
box(title="Cluster 2",plotlyOutput('plot2'),
fluidRow(column(4,offset=3,DT::dataTableOutput("plot2_data",width = 10)))),
#DT::dataTableOutput("plot2_data",width = 8),
box(title="Cluster 3",plotlyOutput('plot3'),
fluidRow(column(4,offset=3,DT::dataTableOutput("plot3_data",width = 10)))),
#DT::dataTableOutput("plot3_data",width = 8),
box(title="Cluster 4",plotlyOutput('plot4'),
fluidRow(column(4,offset=3,DT::dataTableOutput("plot4_data",width = 10))))
#DT::dataTableOutput("plot4_data",width = 8)
)
)
,
tabItem("Data",
DT::dataTableOutput("Data"),
downloadButton("downloadCsv", "Download as CSV")
),
tabItem("RFM",
fluidRow(
box(title="RFM",plotOutput('plot_rfm')))
)
)
)
)
server.R
function(input, output, session) {
# Combine the selected variables into a new data frame
# Radar Chart data
selectedData <- reactive({
categ<-input[["categ"]]
data_plot<- user_clustering_raw %>%filter(DESC_CAT_MERC %in% categ)%>%
group_by(CLUSTER,DESC_CAT_MERC)%>%
dplyr::summarise(VAL_INV=sum(VAL_INV))%>%ungroup()%>%
group_by(CLUSTER)%>%mutate(VAL_INV=VAL_INV/sum(VAL_INV))
return (data_plot)
})
# RFM chart (2nd page....)
selectedData_plot2<-reactive({
clust<-user_clustering_raw[user_clustering_raw$CO_CUST==input$cluster,]$CLUSTER[0]
rfm <- RFM_rec %>%
inner_join(user_clustering_raw%>%select(CO_CUST,CLUSTER)%>%distinct(),by="CO_CUST")%>%
filter(CLUSTER %in% clust)
return (rfm)
})
# Data for summary alongside graph
summary_1<-reactive({
categ<-input[["categ"]]
summary_1<-user_clustering_raw%>%
filter(DESC_CAT_MERC%in% categ)
return (summary_1)
})
# Value box
output$Spesa_Totale <- renderValueBox({
valueBox(
value = prettyNum(round(sum(user_clustering$VAL_INV),0),big.mark=",",decimal.mark = "."),
subtitle = "Spesa Totale",
icon = icon("euro"),width=6
)
})
output$Clienti_Totali <- renderValueBox({
valueBox(
length(unique(user_clustering_raw%>%pull(CO_CUST))),
"Numero Clienti Totali",
icon = icon("users"),width=6
)
})
summary_2<-reactive({
outlier<-data.frame(CO_CUST=attributes(big_outliers),FLAG_OUTLIER=1)
colnames(outlier)<-c("CO_CUST","FLAG_OUTLIER")
data_summary_2<- user_clustering_raw%>%left_join(outlier,by="CO_CUST")%>%
replace_na(list(FLAG_OUTLIER=0))
colnames(data_summary_2)<-c("Codice Cliente", "Categoria Merc.",
"Spesa (EUR)","Cluster","Outlier")
data_summary_2
})
# 1 CLUSTER
output$plot1 <- renderPlotly({
categ<-input[["categ"]]
d1<-selectedData()
d1_clust<-d1%>%filter(DESC_CAT_MERC %in% categ)
d1_clust<-d1_clust%>%filter(CLUSTER==1)
plot_ly(
type = 'scatterpolar',
r = d1_clust$VAL_INV,
theta = d1_clust$DESC_CAT_MERC,
fill = 'toself'
) %>%
layout(
polar = list(
radialaxis = list(
visible = T,
range = c(0,1)
)
),
showlegend = F
)
})
output$plot1_data <- DT::renderDataTable({
plot1_data<-summary_1()
plot1_data<-plot1_data%>%filter(CLUSTER==1)%>%
group_by(DESC_CAT_MERC)%>%
summarise(VAL_INV=sum(VAL_INV),NUMERICA_CLIENTI=n_distinct(CO_CUST))%>%
ungroup()%>%
mutate(VAL_INV_PERC=round(VAL_INV/sum(VAL_INV),3)*100)
plot1_data <- plot1_data[c("DESC_CAT_MERC", "VAL_INV", "VAL_INV_PERC","NUMERICA_CLIENTI")]
colnames(plot1_data)<-c("Cat.Merceologica","Fatturato (EUR)","Fatturato %","Numero Clienti")
DT::datatable(plot1_data,rownames = FALSE,options = list(dom = 't',
columnDefs = list(list(className = 'dt-center', targets = "_all"))))%>%formatCurrency(2:2, '')
})
# 2 CLUSTER
output$plot2 <- renderPlotly({
categ<-input[["categ"]]
d1<-selectedData()
d2_clust<-d1%>%filter(DESC_CAT_MERC %in% categ)
d2_clust<-d2_clust%>%filter(CLUSTER==2)
plot_ly(
type = 'scatterpolar',
r = d2_clust$VAL_INV,
theta = d2_clust$DESC_CAT_MERC,
fill = 'toself',mode="markers"
) %>%
layout(
polar = list(
radialaxis = list(
visible = T,
range = c(0,1)
)
),
showlegend = F
)
})
output$plot2_data <- DT::renderDataTable({
plot2_data<-summary_1()
plot2_data<-plot2_data%>%filter(CLUSTER==2)%>%
group_by(DESC_CAT_MERC)%>%
summarise(VAL_INV=sum(VAL_INV),NUMERICA_CLIENTI=n_distinct(CO_CUST))%>%ungroup()%>%
mutate(VAL_INV_PERC=round(VAL_INV/sum(VAL_INV),3)*100)
plot2_data <- plot2_data[c("DESC_CAT_MERC", "VAL_INV", "VAL_INV_PERC","NUMERICA_CLIENTI")]
colnames(plot2_data)<-c("Cat.Merceologica","Fatturato (EUR)","Fatturato %","Numero Clienti")
DT::datatable(plot2_data,rownames = FALSE,
options = list(dom = 't',
columnDefs = list(list(className = 'dt-center', targets = "_all"))))%>%formatCurrency(2:2, '')
})
# 3 CLUSTER
output$plot3 <- renderPlotly({
categ<-input[["categ"]]
d1<-selectedData()
d3_clust<-d1%>%filter(DESC_CAT_MERC %in% categ)
d3_clust<-d3_clust%>%filter(CLUSTER==3)
plot_ly(
type = 'scatterpolar',
r = d3_clust$VAL_INV,
theta = d3_clust$DESC_CAT_MERC,
fill = 'toself'
) %>%
layout(
polar = list(
radialaxis = list(
visible = T,
range = c(0,1)
)
),
showlegend = F
)
})
output$plot3_data <- DT::renderDataTable({
plot3_data<-summary_1()
plot3_data<-plot3_data%>%filter(CLUSTER==3)%>%
group_by(DESC_CAT_MERC)%>%
summarise(VAL_INV=sum(VAL_INV),
NUMERICA_CLIENTI=n_distinct(CO_CUST))%>%ungroup()%>%
mutate(VAL_INV_PERC=round(VAL_INV/sum(VAL_INV),3)*100)
plot3_data <- plot3_data[c("DESC_CAT_MERC", "VAL_INV", "VAL_INV_PERC","NUMERICA_CLIENTI")]
colnames(plot3_data)<-c("Cat.Merceologica","Fatturato (EUR)","Fatturato %","Numero Clienti")
DT::datatable(plot3_data,rownames = FALSE,options = list(dom = 't',
columnDefs = list(list(className = 'dt-center', targets = "_all"))))%>%
formatCurrency(2:2, '')
})
# 4 CLUSTER
output$plot4 <- renderPlotly({
categ<-input[["categ"]]
d1<-selectedData()
d4_clust<-d1%>%filter(DESC_CAT_MERC %in% categ)
d4_clust<-d4_clust%>%filter(CLUSTER==3)
plot_ly(
type = 'scatterpolar',
r = d4_clust$VAL_INV,
theta = d4_clust$DESC_CAT_MERC,
fill = 'toself'
) %>%
layout(
polar = list(
radialaxis = list(
visible = T,
range = c(0,1)
)
),
showlegend = F
)
})
output$plot4_data <- DT::renderDataTable({
plot4_data<-summary_1()
plot4_data<-plot4_data%>%filter(CLUSTER==4)%>%
group_by(DESC_CAT_MERC)%>%
summarise(VAL_INV=sum(VAL_INV),
NUMERICA_CLIENTI=n_distinct(CO_CUST))%>%
ungroup()%>%mutate(VAL_INV_PERC=round(VAL_INV/sum(VAL_INV),3)*100)
plot4_data <- plot4_data[c("DESC_CAT_MERC", "VAL_INV", "VAL_INV_PERC","NUMERICA_CLIENTI")]
colnames(plot4_data)<-c("Cat.Merceologica","Fatturato (EUR)","Fatturato %","Numero Clienti")
DT::datatable(plot4_data,rownames = FALSE,options = list(dom = 't',
columnDefs = list(list(className = 'dt-center', targets = "_all"))))%>%
formatCurrency(2:2, '')
})
# rfm
output$plot_rfm <- renderPlot({
d<-selectedData_plot2()
adding_point<- d[d$CO_CUST==input$cluster,]
p1 <- ggplot(d,aes(x=FREQ))+
geom_histogram(fill="darkblue",col="white")+
ggtitle("Frequenza Acquisti")+labs(x="Frequenza Acquisti",y="Conteggio")+
geom_point(x=adding_point$FREQ,y=0,col="red",size=4)+
theme(axis.text.x = element_text(angle=45,hjust=1,size=12),
axis.title.x = element_blank(),plot.title = element_text(size=14,face="bold"))
breaks <- pretty(range(d$MONET), n = nclass.FD(d$MONET), min.n = 1)
bwidth <- breaks[2]-breaks[1]
p2 <- ggplot(d,aes(x=round(MONET,0)))+
geom_histogram(fill="darkblue",col="white")+
ggtitle("Valore Monetario Acquisti (EUR)")+labs(x="Valore Monetario",y="Conteggio")+
scale_x_continuous(labels=dollar_format(prefix="€"))+
geom_point(x=adding_point$MONET,y=0,col="red",size=4)+
theme(axis.text.x = element_text(angle=45,hjust=1,size=12),
axis.title.x = element_blank(),plot.title = element_text(size=14,face="bold"))
p3 <- ggplot(d,aes(x=LAST_PURCHASE))+
geom_histogram(fill="darkblue",col="white")+
ggtitle("Ultimo Acquisto (Giorni)")+labs(x="Ultimo Acquisto",y="Conteggio")+
geom_point(x=adding_point$LAST_PURCHASE,y=0,col="red",size=4)+
theme(axis.text.x = element_text(angle=45,hjust=1,size=12),
axis.title.x = element_blank(),plot.title = element_text(size=14,face="bold"))
grid.arrange(p1, p2,p3, nrow = 1)
})
# Data being displayed 2 tabitem
output$Data <- DT::renderDataTable({
DT::datatable(summary_2(),rownames = FALSE)%>% formatStyle(
'Outlier',
target = 'row',
color = styleEqual(c(1, 0), c('red', 'black')))%>%formatCurrency(3:3, '')
})
# Check CO_CLIENTE per errori input utente
output$checkcluster <- renderUI({
if (sum(input$cluster%in% user_clustering_raw$CO_CUST)==0)
print ("Errore! Codice Cliente non presente...")})
}
I hope it's clear enough, please don't downgrade
You missed a capital letter:
menuItem("RFM",tabname="RFM",icon = icon("dashboard",lib = "glyphicon")) ## That's the item I ve just added
tabname should be tabName.
Also, tabItem("RFM", should be tabItem("rfm", since it is linked to the id in the tabName parameter.
So, a stripped down working version is given below - minimizing the code is how I found the issue. Hope this helps!
library(shiny)
library(shinydashboard)
library(plotly)
ui <- dashboardPage(
dashboardHeader(title= "Acquisti Clienti CC"),
dashboardSidebar(
sidebarMenu(id="menu",
menuItem(text = "Dashboard", tabName = "dashboard",icon = icon("stats",lib = "glyphicon")),
menuItem(text = "Data", tabName = "Data",icon = icon("th-list",lib = "glyphicon")),
menuItem(text = "RFM", tabName="rfm",icon = icon("th-list",lib = "glyphicon"))
)
),
dashboardBody(
tabItems(
tabItem("dashboard",
p('dashboard')
)
,
tabItem("Data",
p('data')
),
tabItem("rfm",
p('rfm')
)
)
)
)
server <- function(input,output){}
shinyApp(ui,server)