Selecting many items from the list in R - r

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, ...)

Related

R shiny: How to copy data derived from plotly_selection events into a data frame/table and update each time by pressing an actionButton?

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})
})
})
))

Read Reactive Elements from Shiny Module

I'm trying to use some reactive elements from predefined function and call that data from a module to generate plots, but data is not getting updated upon selection. I've also tried to call the function inside reactive() and call that from the module, but still same result. My approach is below:
library(shiny)
library(shinyWidgets)
library(highcharter)
library(data.table)
library(dplyr)
employement_type_count <- function(
data,
category,
...
){
data[employee_category %in% category, .(count = .N), by = employee_category]
}
pie_chart_ui <- function(id) {
ns <- NS(id)
highchartOutput(ns("pie"))
}
pie_chart_server <- function(
id,
data,
var_x = names(data)[1],
var_y = names(data)[2],
lab_x = names(data)[1],
lab_y = names(data)[2],
tooltip_name = names(data)[2],
export_title = NA
) {
moduleServer(
id,
function(input, output, session) {
output$pie <- renderHighchart({
data %>%
hchart(
'pie',
hcaes_(x = var_x, y = var_y),
name = tooltip_name
) %>%
hc_xAxis(title = list(text = lab_x)) %>%
hc_yAxis(title = list(text = lab_y)) %>%
hc_plotOptions(
pie = list(
allowPointSelect = TRUE,
cursor = 'pointer',
dataLabels = list(
enabled = TRUE,
format = '<b>{point.name}</b>: {point.percentage:.1f}%',
style = list(
color = "(Highcharts.theme && Highcharts.theme.contrastTextColor) || 'black'"
)
)
)
) %>%
hc_exporting(
enabled = TRUE,
buttons = list(
contextButton = list(
align = 'right'
)
),
chartOptions = list(
title = list(
text = export_title
)
)
)
})
}
)
}
ui <- fluidPage(
sidebarPanel(
pickerInput(
"employee_type",
"Employee Type",
choices = c("Regular", "Project", "Service", "Part-Time"),
selected = c("Regular", "Project", "Service", "Part-Time"),
multiple = TRUE
)
),
mainPanel(
pie_chart_ui("employee_category")
)
)
server <- function(input, output, session){
# data_common <- fread("data_common.csv")
data_common <- data.table(
id = 1:26,
employee_name = LETTERS,
gender_type = rep(c("Male", "Female"), each = 13),
employee_category = c("Regular", "Project", rep(c("Regular", "Project", "Service", "Part-Time"), times = 6))
)
pie_chart_server(
"employee_category",
employement_type_count(
data_common,
input$employee_type
)
)
}
shinyApp(ui, server)
Note that, data should be imported from server, instead of global, as it is constantly getting updated.
One way to do it is shown below.
library(shiny)
library(shinyWidgets)
library(highcharter)
library(data.table)
library(dplyr)
df1 <- data.table(
id = 1:26,
employee_name = LETTERS,
gender_type = rep(c("Male", "Female"), each = 13),
employee_category = c("Regular", "Project", rep(c("Regular", "Project", "Service", "Part-Time"), times = 6))
)
employement_type_count <- function(
data,
category,
...
){
data <- data()
if (is.null(category())) {df <- data
}else df <- data[employee_category %in% category(), .(count = .N), by = employee_category]
return(df)
}
pie_chart_ui <- function(id) {
ns <- NS(id)
highchartOutput(ns("pie"))
}
pie_chart_server <- function(
id,
data,
var_x = names(data)[1],
var_y = names(data)[2],
lab_x = names(data)[1],
lab_y = names(data)[2],
tooltip_name = names(data)[2],
export_title = NA
) {
moduleServer(
id,
function(input, output, session) {
output$pie <- renderHighchart({
data %>%
hchart(
'pie',
hcaes_(x = var_x, y = var_y),
name = tooltip_name
) %>%
hc_xAxis(title = list(text = lab_x)) %>%
hc_yAxis(title = list(text = lab_y)) %>%
hc_plotOptions(
pie = list(
allowPointSelect = TRUE,
cursor = 'pointer',
dataLabels = list(
enabled = TRUE,
format = '<b>{point.name}</b>: {point.percentage:.1f}%',
style = list(
color = "(Highcharts.theme && Highcharts.theme.contrastTextColor) || 'black'"
)
)
)
) %>%
hc_exporting(
enabled = TRUE,
buttons = list(
contextButton = list(
align = 'right'
)
),
chartOptions = list(
title = list(
text = export_title
)
)
)
})
}
)
}
ui <- fluidPage(
sidebarPanel(
pickerInput(
"employee_type",
"Employee Type",
choices = c("Regular", "Project", "Service", "Part-Time"),
selected = c("Regular", "Project", "Service", "Part-Time"),
multiple = TRUE
)
),
mainPanel(
pie_chart_ui("employee_category")
)
)
server <- function(input, output, session){
# data_common <- fread("data_common.csv")
data_common <- reactive(df1)
employee <- reactive(input$employee_type)
observe({
mydata <- employement_type_count(
data_common,
employee
)
pie_chart_server(
"employee_category",
mydata
)
})
}
shinyApp(ui, server)

Multiple line graphs using plotly in shiny R

I'm new to shiny R and Plotly. I'm trying to build a dashboard that has two drop-down boxes and we take input through these dropdown boxes and plot Plotly graphs. All the datasets have time, temp, and weight columns. time goes on the x-axis and for y-axis we can select either temp or weight or maybe both.
the first drop-down takes the input to which dataset to select.
second dropdown box takes the input to select the variable from the dataset selected.
Most of the things I have figured out, however, y-axis label does not change dynamically. the label is getting (input$variable) instead of temp or weight.
here is the shiny r output
also here is the reproducible example and my code
library(shiny)
library(plotly)
library(DT)
df1 <- data.frame("time" = 1:10, "temp" = c(21,15,31,12,23,45,67,34,54,10), "weight" = c(10,20,30,40,65,35,68,89,100,23), stringsAsFactors = FALSE)
df2 <- data.frame("time" = 1:10, "temp" = c(31,65,31,22,23,45,67,54,54,45), "weight" = c(30,20,40,40,65,85,68,89,14,24), stringsAsFactors = FALSE)
ui <- fluidPage(
titlePanel( div(column(width = 5, h2('title here')), )),
# Input: Selector for choosing dataset
selectInput(inputId = "dataset",
label = "Choose a dataset:",
choices = c("df1","df2")),
selectInput(inputId = "variable",
label = "Variable selection",
choices = c("temp","weight"),
selected = "weight",
multiple = FALSE),
mainPanel(
# Output
tabsetPanel(type = "tabs",
tabPanel("Plot", plotlyOutput('plot')),
tabPanel("Data", DT::dataTableOutput("table")),
tabPanel("Key_metrics", DT::dataTableOutput("Key_metrics")))
)
)
server <- function(input, output) {
dataDf <- reactive({
temp <- get(input$dataset)
})
output$plot <- renderPlotly(
plot_ly(dataDf(), x = ~time, y =~get(input$variable), type = 'scatter', mode = 'lines', name = "temp") %>%
add_trace(dataDf(), x = ~time, y = ~weight, type = 'scatter', mode = 'lines',name = "weight")
)
output$table <- DT::renderDataTable({
dataDf()
})
output$Key_metrics <- DT::renderDataTable({
})
}
shinyApp(ui,server)
You can specify axis labels in layout(). Note that xaxis and yaxis require a list as argument (see here for more details):
output$plot <- renderPlotly(
plot_ly(dataDf(), x = ~time, y =~get(input$variable), type = 'scatter', mode = 'lines', name = "temp") %>%
add_trace(dataDf(), x = ~time, y = ~weight, type = 'scatter', mode = 'lines',name = "weight") %>%
layout(xaxis = list(title = "Time"), yaxis = list(title = input$variable))
)
Edit: following a comment, here's how to plot two lines if two variables are selected and one otherwise (don't forget to put multiple = TRUE in selectInput():
library(shiny)
library(plotly)
library(DT)
df1 <- data.frame("time" = 1:10, "temp" = c(21,15,31,12,23,45,67,34,54,10), "weight" = c(10,20,30,40,65,35,68,89,100,23), stringsAsFactors = FALSE)
df2 <- data.frame("time" = 1:10, "temp" = c(31,65,31,22,23,45,67,54,54,45), "weight" = c(30,20,40,40,65,85,68,89,14,24), stringsAsFactors = FALSE)
ui <- fluidPage(
titlePanel( div(column(width = 5, h2('title here')), )),
# Input: Selector for choosing dataset
selectInput(inputId = "dataset",
label = "Choose a dataset:",
choices = c("df1","df2")),
selectInput(inputId = "variable",
label = "Variable selection",
choices = c("temp","weight"),
selected = "weight",
multiple = TRUE),
mainPanel(
# Output
tabsetPanel(type = "tabs",
tabPanel("Plot", plotlyOutput('plot')),
tabPanel("Data", DT::dataTableOutput("table")),
tabPanel("Key_metrics", DT::dataTableOutput("Key_metrics")))
)
)
server <- function(input, output) {
dataDf <- reactive({
temp <- get(input$dataset)
})
output$plot <- renderPlotly({
if (length(input$variable) > 1){
plot_ly(dataDf(), x = ~time, y =~get(input$variable[1]),
type = 'scatter', mode = 'lines', name = "temp") %>%
add_trace(dataDf(), x = ~time, y = ~get(input$variable[2]),
type = 'scatter', mode = 'lines',name = "weight") %>%
layout(xaxis = list(title = "Time"))
}
else {
plot_ly(dataDf(), x = ~time, y =~get(input$variable[1]), type = 'scatter', mode = 'lines', name = "temp") %>%
add_trace(dataDf(), x = ~time, y = ~get(input$variable[1]), type = 'scatter', mode = 'lines',name = "weight") %>%
layout(xaxis = list(title = "Time"), yaxis = list(title = input$variable))
}
})
output$table <- DT::renderDataTable({
dataDf()
})
output$Key_metrics <- DT::renderDataTable({
})
}
shinyApp(ui,server)
Put what you want as y-axis label based on the original answer. Note that this answer only works if there are two choices.

Table will not render in Shiny

I have been messing with making a shiny app and I feel as though i am doing everything in the correct manner to get the table to render but no luck. In my app you should you upload an csv and then go to the data frame tab. I have tried many small changes but nothing seems to work. Id imagine this has something to do with the server section but i cant see it.
R ui:
library(readxl)
library(plyr)
library(dplyr)
library(plotly)
library(readr)
library(RColorBrewer)
library(data.table)
library(shiny)
library(shinydashboard)
library(shinythemes)
library(leaflet)
library(DT)
library(xtable)
ui <- fluidPage(theme = shinytheme("slate"), mainPanel(
navbarPage(
"Permian Plots", collapsible = TRUE, fluid = TRUE,
navbarMenu(
"County Plot",
tabPanel(
sidebarPanel( fileInput(
'file1',
'Choose CSV File',
accept = c('text/csv', 'text/comma-separated-values,text/plain', '.csv')
),
tags$hr(),
checkboxInput('header', 'Header', TRUE),
# App buttons comma and quote
radioButtons('sep', 'Separator',
c(
Comma = ',',
Semicolon = ';',
Tab = '\t'
), ','),
radioButtons(
'quote',
'Quote',
c(
None = '',
'Double Quote' = '"',
'Single Quote' = "'"
),
'"'
))
),
tabPanel("Data Frame",
fluidRow(box(DT::dataTableOutput("contents")))),
tabPanel("County Plot", plotlyOutput(
"plotMap", height = 1200, width = 1200
),
actionButton("btn", "Plot")
)
)
)
)
)
Server:
server <- function(input, output, session) {
options(shiny.maxRequestSize = 200*1024^2)
dsnames <- c()
data_set <- reactive({
inFile <- input$file1
if (is.null(inFile)){
return()
}
data_set <- read.csv(
inFile$datapath,
header = input$header,
sep = input$sep,
quote = input$quote
)
})
output$contents <- DT::renderDataTable({
withProgress(message = 'loading...', value = 0.1, {
datatable(data_set(),
options = list(
"pageLength" = 40))
extensions = 'Responsive'
setProgress(1)
})
})
output$choose_dataset <- renderUI({
selectInput("dataset", "Data set", as.list(data_sets))
})
observeEvent(
input$btn,
{
output$plotMap <- renderPlotly({withProgress(message = 'Plotting...', value = 0.1,{
plot <- Plots(data_set(),
"Martin County",
"~/Work/permin/martin county/martin data/f1.csv",
"~/Work/permin/BestMartinPlotSat.html",
32.1511, -101.5715)
setProgress(1)
})
})
}
)
}
shinyApp(ui = ui, server = server)
Function:
Should not be the problem causer in this.
Plots <- function(df, C_name, PathCSV, PathWidg, Lat, Lon){
f1 <- df
f1$Date <- as.POSIXct(f1$Date)
f1$year <- format(as.POSIXct(f1$Date,format="%y-%m-%d"), "%y")
f1$month <- format(as.POSIXct(f1$Date,format="%y-%m-%d"), "%m")
f1$Cell <- as.factor(f1$Cell)
z <- ddply(f1, c("year", "month", "Cell"), summarise,
yearMonth_Max_sum = max(`Cell Sum (Norm)`))
f1 <- inner_join(f1,z, by = c("year", "month", "Cell"))
f1$Changed <- as.numeric(as.factor(f1$Changed))
f1$Changed[f1$Changed == 1] <- 0
f1$Changed[f1$Changed == 2] <- 1
z <- ddply(f1, c("year", "month", "Cell"), summarise,
ChangedX = max(Changed))
f1 <- inner_join(f1,z, by = c("year", "month", "Cell"))
f1$MY <- paste(f1$year, f1$month, sep = "-")
#preapring data for plotly
q <- matrix(quantile(f1$StdDev))
f1$qunat <- NA
up <- matrix(quantile(f1$StdDev, probs = .95))
up
f1$qunat <- ifelse((f1$StdDev > q[4:4,1]) & (f1$StdDev < up[1,1]), 1, 0)
z <- group_by(f1, Cell) %>%
summarize(Median_Cell = median(`Cell Sum (Norm)`, na.rm = FALSE))
f1 <- inner_join(f1,z, by = c("Cell"))
quantile(round(f1$Median_Cell))
f1$NewMedian <- NA
f1$NewMedian[f1$Median_Cell > 4000] <- 0
f1$NewMedian[f1$Median_Cell <= 4000] <- 1
f1$NewSum <- NA
f1$NewSum <- f1$yearMonth_Max_sum * f1$ChangedX * f1$qunat * f1$NewMedian
write_csv(f1, PathCSV )
f2 <- f1[!duplicated(f1$yearMonth_Max_sum), ]
#plolty plot
Sys.setenv('MAPBOX_TOKEN' = 'pk.eyJ1IjoiY3dvb2RzMjIiLCJhIjoiY2prMnlycmduMDJvNjNxdDEzczNjdGt3YSJ9.RNuCSlHyKZpkTQ8mJmg4aw')
p <- f2[which(f2$yearMonth_Max_sum < 9000),] %>%
plot_mapbox(
lon = ~Lon,
lat = ~Lat,
size = ~yearMonth_Max_sum,
color = ~(NewSum),
frame = ~MY,
type = 'scattermapbox',
mode = 'markers',
colors = c("green","blue")
) %>%
add_markers(text = ~paste("Sum", yearMonth_Max_sum, "/<br>",
"Standard Dev", StdDev, "/<br>",
"Mean", Average, "/<br>",
"Median", Median_Cell, "/<br>",
"Changed", ChangedX, "/<br>",
"Latitude", Lat , "/<br>",
"Longitude", Lon)) %>%
layout(title = C_name,
font = list(color = "black"),
mapbox = list(style = "satellite", zoom = 9,
center = list(lat = Lat,
lon = Lon)))
p
htmlwidgets::saveWidget(p, PathWidg)
}
the last thing in your function is what is returned. you are returning setprogress(1) to renderdatatable()
output$contents <- DT::renderDataTable({
withProgress(message = 'loading...', value = 0.1, {
datatable(data_set(),
options = list(
"pageLength" = 40))
extensions = 'Responsive'
setProgress(1)
})
Try this instead
output$contents <- DT::renderDataTable({
withProgress(message = 'loading...', value = 0.1, {
datatab <- datatable(data_set(),
options = list(
"pageLength" = 40))
extensions = 'Responsive'
setProgress(1)
datatab
})

MenuItem rendered as subItem

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)

Resources