R shinydashboard display sum of selected input in a valuebox - r

My question relates to "value4" which is a valuebox in the below code.
I have created a select input which allows the user to choose a name, based on that name I want the app to find the number of projects that are associated to the name picked (number of projects = "X..setup") and then display the total number of projects in a valuebox("value4").
The problem I am having is getting the sum of all projects.
Please find my code below:
setups <- read.csv("C:/Users/obria/Desktop/setUps/setUp.csv",stringsAsFactors = F, header = TRUE)
View(setups)
head(setups)
searchDF <- setups[c(1,2,3,4,7,8,9,10,11)]
#lst.Owners <- as.list(unique(setups$Owners))
lst.Owners = as.character(setups$Owners)
Owners <- unique(lst.Owners)
userInput <- sum(str_count(setups$Over.all.Status.of.Project,"WIP")) %>% groub_by(Owners)
install.packages("dplyr")
install.packages("ggplot2")
library(ggplot2)
library(dplyr)
library(shiny)
library(shinydashboard)
library(stringr)
library (DT)
ui = dashboardPage(
#Header
dashboardHeader(title = "Set ups dashboard"),
#Sidebar
dashboardSidebar(
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard"),
menuItem("Search", tabName = "search"),
menuItem("Break Down", tabName = "breakDown")
)
),
#Body
dashboardBody(tabItems(
# First tab content
tabItem(tabName = "dashboard",
fluidRow(
valueBoxOutput("value1")
,valueBoxOutput("value2")
,valueBoxOutput("value3"),
fluidRow(
box(
title= "Owner Vs Set Ups"
,status = "primary"
,solidheader = TRUE
,collapsible = TRUE
,plotOutput("nameStatus", height = "300px")
)
,box(
title= " Pant Vs Set Ups"
,status = "primary"
,solidheader = TRUE
,collapsible = TRUE
,plotOutput("plantSetUps", height = "300px"))))
),
# Second tab content #
tabItem(tabName = "search",
fluidRow(
h2("Search Set ups"),
DT::dataTableOutput("mytable")
)),
# Third tab content #
tabItem(tabName = "breakDown",
h2("Search Set ups"),
fluidRow(
box(
selectInput("selectVariable", "Select Variable:",
choices = Owners,
selected = 1))),
fluidRow(
valueBoxOutput("value4")
))))
)
server = function(input, output) {
# Get some data #
# Total Set ups #
totalSetUps <- sum(setups$X..setups)
# Number of WIPs #
workIP1 <- sum(str_count(setups$Over.all.Status.of.Project,"WIP"))
workIP2 <- sum(str_count(setups$Over.all.Status.of.Project,"wip"))
workInProgress <- (workIP1 + workIP2)
# Number of Outstanding #
outstanding <- sum(str_count(setups$Over.all.Status.of.Project,"Outstanding"))
# Colonia - Test Val;ue box #
#colonia <- sum(str_count(setups$Plant,"Colonia"))
setUpByName <- reactive ({
setups %>%
filter(Owners == input$selectVariable) %>%
sum(.$X..setups)
})
# Create the valueBoxOutput Content #
output$value1 <- renderValueBox({
valueBox(
format(totalSetUps, format="d", big.mark=",")
,"Total Number of Set Ups"
,icon = icon("stats",lib="glyphicon")
,color = "purple")
})
output$value2 <- renderValueBox({
valueBox(
format(workInProgress, format="d", big.mark=",")
,"No. of project that are WIP"
,icon = icon("gbp",lib="glyphicon")
,color = "green")
})
output$value3 <- renderValueBox({
valueBox(
format(outstanding, format="d", big.mark=",")
,"No. of project that are Outstanding"
,icon = icon("menu-hamburger",lib="glyphicon")
,color = "yellow")
})
output$value4 <- renderValueBox({
valueBox(
format(setUpByName(), format="d", big.mark=",")
,"total # Set ups"
,icon = icon("menu-hamburger",lib="glyphicon")
,color = "yellow")
})
# Creating plot output content #
output$nameStatus <- renderPlot({
ggplot(data = setups,
aes(x=setups$Owners, y=setups$X..setup, fill=factor(Over.all.Status.of.Project))) +
geom_bar(position = "dodge", stat = "identity") + ylab("No. of Set ups") +
xlab("Owners") + theme(legend.position="bottom"
,plot.title = element_text(size=15, face="bold")) +
ggtitle("Owners vs No. of Set Ups") + labs(fill = "Status")
})
output$plantSetUps <- renderPlot({
ggplot(data=setups, aes(x=setups$Plant, y= setups$X..setup)) +
geom_bar(stat="identity", col="blue", fill="blue") +
labs(title ="No of Set ups by plant")
})
output$mytable = DT::renderDataTable({
setups
})
output$result <- renderText({
paste("You chose", input$selectVariable)
})
}
shinyApp(ui, server)
str(setups)
DF Columns
Error
CodeError2
ShinyError2
Data
Data Types
Any help would be greatly appreciated.
Thank you

calling select works like a select statement in SQL, meaning that after that statement X..setups is the only column that remains. If you want to include only setups for the person selected in input$selectVariable you should first filter the setups data frame. Secondly, the functions in dplyr return objects that are of the same class as the input object. Your are passing a tibble into the function, so it is returning a tibble. However, you need it to be a scalar in order to be rendered in the valueBox. You can make it a scalar by passing the filtered data to the base sum function and only summing the X..setups column.
setUpByName <- reactive ({
setups_filtered <- setups %>%
filter(Owners == input$selectVariable)
sum(setups_filtered$X..setups)
})

Related

Having trouble linking the input to my plot output in Rshiny

I'm creating an Rshiny with two tabs. The data is a list of students, and the plots/tables are to be filtered through the input of grade selection on a drop-down list. The table I have on tab one is working fine, but everything I have tried to do to connect the last two plots on the second tab to the input are not working. Now I have it to where it is just showing totals without using the input filter of grade. Can anyone detail how to connect my input to both output plots? I'll put my code below
library(shiny)
library(tidyverse)
students = read.csv("C:/Users/j062d273/Downloads/RShiny Grade EX.csv",
stringsAsFactors = FALSE)
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
headerPanel("Student Data"),
# tabs set up
tabsetPanel(
tabPanel(title = "Students by Grade",
mainPanel(width = 12, align = "center",
selectInput("grade", "Select Grade", choices=unique(sort(students$Grade,
decreasing = FALSE)), selected = 1),
submitButton("Go"),
tags$h3("Student List"),
div(style = "border:1px black solid;width:80%",tableOutput("student_list"))
)),
tabPanel(title = "Trends by Grade",
mainPanel(width = 12,align = "center",
div(style = "float:left;width:36%;",plotOutput("male_fem_dist")),
div(style = "float:right;width:64%;",plotOutput("ethnicity_plot")))
)))
# Define server logic required to draw plot
server <- function(input, output) {
output$student_list <- renderTable({
gradefilter <- subset(students, students$Grade == input$grade)
})
output$male_fem_dist <- renderPlot({
ggplot(students, aes(x=Gender)) +
geom_bar(fill = "blue", color = "red") +
ggtitle("Gender Count by Selected Grade")
})
output$ethnicity_plot <- renderPlot({
ggplot(students, aes(x=Ethnicity)) +
geom_bar(fill = "red", color = "blue") +
ggtitle("Ethnicity Count by Selected Grade")
})
}
# Run the application
shinyApp(ui = ui, server = server)
Filter the dataset first, and then use it in both table and plot.
Try this
server <- function(input, output) {
gradefilter <- reactive({subset(students, students$Grade == input$grade)})
output$student_list <- renderTable({gradefilter()})
output$male_fem_dist <- renderPlot({
ggplot(gradefilter(), aes(x=Gender)) +
geom_bar(fill = "blue", color = "red") +
ggtitle("Gender Count by Selected Grade")
})
output$ethnicity_plot <- renderPlot({
ggplot(gradefilter(), aes(x=Ethnicity)) +
geom_bar(fill = "red", color = "blue") +
ggtitle("Ethnicity Count by Selected Grade")
})
}

Valuebox with a single date of a table

I am trying to do a valuebox in shiny using a single date of a table. My table looks like this:
Color<-c("blanco","blanco","gris","gris","blanco","gris","gris","gris","blanco","blanco","gris","blanco","gris","blanco","gris")
Tipo<-c("gato","gato","gato","perro","perro","perro","perro",
"buho","buho","buho","buho","tigre","tigre","tigre","tigre")
data<-data.frame(Color,Tipo)
In my UI
tabsetPanel(
position= "left",
tabPanel("Cancelaciones", icon = icon("window-close"),
fluidRow(
uiOutput("Box1")),
sidebarLayout(sidebarPanel(
uiOutput("SelectTipo")
),
mainPanel(
plotlyOutput("barplotx"),
dataTableOutput("summaryx")
) ) )
))
Server
output$SelectTipo<-renderUI({
selectInput("SelectTipo", "Tipo",
data$Tipo, multiple = T, selected = TRUE)
})
df<-reactive({
data %>%
filter(Tipo %in% input$SelectTipo)
})
df1<-reactive({
df2<-df()
df2 %>%
count(Color)%>%
mutate(percent=round(((n/sum(n))*100), digits=2))%>%
arrange(desc(percent))>tmpx
names(tmpx)<- c("Evento","N","Porcentaje")
tmpx
})
valor<-df1[1,2] ##### <-----here is the line
output$Box1 <- renderUI({
valueBox(value = valor(), subtitle = "Valor", ##### <-and here
icon = icon("check-circle"),
color = "green")
})
I want the value box to be the value in column 1, row 2.
You can subset the dataframe to get the required value.
library(shiny)
library(shinydashboard)
ui <- fluidPage({
uiOutput('Box1')
})
server <- function(input, output) {
valor <- reactive(data)
output$Box1 <- renderUI({
valueBox(value = valor()[2, 1], #2nd row, 1st column
subtitle = "Valor",
icon = icon("check-circle"),
color = "green")
})
}
shinyApp(ui, server)

Shiny scatterplot with real-time Kaplan-Meier

I have constructed an interactive scatterplot in Shiny. Using plotly, I can select groups of points and render the annotations for this group in a table next to the plot.
library(survival)
library(survminer)
mtcars <- get(data("mtcars"))
attach(mtcars)
mtcars$OS <- sample(100, size = nrow(mtcars), replace = TRUE)
mtcars$status <- sample(0:1, size = nrow(mtcars), replace = TRUE)
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(
menuItem("Test1", tabName = "test1"),
menuItem("Test2", tabName = "test2"),
menuItem("Test3", tabName = "test3"),
radioButtons("radio", h3("Choose groups"),
choices = list("Group 1" = 1, "Group 2" = 2,
"Group 3" = 3),selected = 1),
actionButton("action", "Reset")
)
),
dashboardBody(
tabItems(
tabItem(tabName = "test1",
fluidRow(
column(6,plotlyOutput("plot")),
column(width = 6, offset = 0,
DT::dataTableOutput("brush"),
tags$head(tags$style("#brush{font-size:11px;}")))
)
)
)
)
)
server <- shinyServer(function(input, output, session) {
output$plot <- renderPlotly({
key <- row.names(mtcars)
p <- ggplot(data=mtcars, aes(x=wt,y=mpg,key=key)) +
geom_point(colour="grey", size=2, alpha=1, stroke=0.5)
ggplotly(p) %>% layout(height = 500, width = 500, dragmode = "select")
})
output$brush <- DT::renderDataTable({
d <- event_data("plotly_selected")
req(d)
DT::datatable(mtcars[unlist(d$key), c("mpg", "cyl", "OS", "status")],
options = list(lengthMenu = c(5, 30, 50), pageLength = 30))
}
)
})
shinyApp(ui, server)
Example:
enter image description here
I would like to be able to select (lasso or rectangle) groups of points and display the survival curves between these groups (and p-value if possible) in a separate plot below the table. For example, the user would select 'Group1' on the menu to the left, then outline the desired groups of points, then selct 'Group 2' and select a second group of points, and so on. After each selection, the survival curves appear below the table. Once finished (and would like to restart a new comparison, the user hits 'Reset'). Here's an example output:
Example:
Expected Shiny output
I really don't know where to begin with how to incorporate this. Any help would be great, thank you
See the code below for one possible way to implement this. Throughout, rv is a reactiveValues object holding the data in a data.frame data_df. The group column in data_df tracks group membership as points are selected in the plot, and takes values of 1, 2, 3, or NA depending on whether the row is in one of the three groups. (Note: the groups are assumed to be non-overlapping.)
When the user changes the radio button selection, the plotly selection rectangle should disappear in order to prepare for the selection of the next set of points - the code below uses the shinyjs library to accomplish this, as well as to reset plotly_selected to NULL (otherwise the next rectangular selection will fail to register if it selects the same set of points as the previous one).
library(survival)
library(survminer)
library(plotly)
library(shiny)
library(shinydashboard)
library(shinyjs)
mtcars <- get(data("mtcars"))
attach(mtcars)
mtcars$OS <- sample(100, size = nrow(mtcars), replace = TRUE)
mtcars$status <- sample(0:1, size = nrow(mtcars), replace = TRUE)
jsCode <- "shinyjs.resetSel = function() { Plotly.restyle(plot, {selectedpoints: [null]});}"
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(
menuItem("Test1", tabName = "test1"),
menuItem("Test2", tabName = "test2"),
menuItem("Test3", tabName = "test3"),
radioButtons("radio", h3("Choose groups"),
choices = list("Group 1" = 1, "Group 2" = 2,
"Group 3" = 3), selected = 1),
actionButton("action", "Reset all Groups"),
br(),
uiOutput("currentSelections")
)
),
dashboardBody(
useShinyjs(),
extendShinyjs(text = jsCode, functions = c("resetSel")),
tabItems(
tabItem(tabName = "test1",
fluidRow(
column(6,plotlyOutput("plot")),
column(width = 6, offset = 0,
DT::dataTableOutput("brush"),
tags$head(tags$style("#brush{font-size:11px;}")))
),
fluidRow(
column(6),
column(6, plotOutput("survivalCurve"))
)
)
)
)
)
server <- shinyServer(function(input, output, session) {
## mtcars data.frame with an extra group column (initially set to NA)
rv <- reactiveValues(data_df = mtcars %>% mutate(group = NA))
## when a selection is made, assign group values to data_df based on selected radio button
observeEvent(
event_data("plotly_selected"), {
d <- event_data("plotly_selected")
## reset values for this group
rv$data_df$group <- ifelse(rv$data_df$group == input$radio, NA, rv$data_df$group)
## then re-assign values:
rv$data_df[d$key,"group"] <- input$radio
}
)
## when reset button is pressed, reset the selection rectangle
## and also reset the group column of data_df to NA
observeEvent(input$action, {
js$resetSel()
rv$data_df$group <- NA
})
## when radio button changes, reset the selection rectangle and reset plotly_selected
## (otherwise selecting the same set of points for two groups consecutively will
## not register the selection the second time)
observeEvent(input$radio, {
js$resetSel()
runjs("Shiny.setInputValue('plotly_selected-A', null);")
})
## draw the main plot
output$plot <- renderPlotly({
key <- row.names(mtcars)
p <- ggplot(data=mtcars, aes(x=wt,y=mpg,key=key)) +
geom_point(colour="grey", size=2, alpha=1, stroke=0.5)
ggplotly(p) %>% layout(height = 500, width = 500, dragmode = "select")
})
## for each group, show the number of selected points
## (not required by the rest of the app but useful for debugging)
output$currentSelections <- renderUI({
number_by_class <- summary(factor(rv$data_df$group, levels = c("1","2","3")))
tagList(
h5("Current Selections:"),
p(paste0("Group 1: ",number_by_class[1], " points selected")),
p(paste0("Group 2: ",number_by_class[2], " points selected")),
p(paste0("Group 3: ",number_by_class[3], " points selected"))
)
})
output$brush <- DT::renderDataTable({
d <- event_data("plotly_selected")
req(d)
DT::datatable(mtcars[unlist(d$key), c("mpg", "cyl", "OS", "status")],
options = list(lengthMenu = c(5, 30, 50), pageLength = 30))
})
## draw survival curves if a point has been selected
## if none have been selected then draw a blank plot with matching background color
output$survivalCurve <- renderPlot({
if (any(c(1,2,3) %in% rv$data_df$group)) {
fit <- survfit(Surv(mpg, status) ~ group,
data = rv$data_df)
ggsurvplot(fit, data = rv$data_df, risk.table = FALSE)
} else {
par(bg = "#ecf0f5")
plot.new()
}
})
})
shinyApp(ui, server)

Deployment of R-program in shiny not working

I did a sample app in R and it is working fine in R-studio. I managed to deploy the code successfully into www.shinyapps.io. After deployment the app link is not working. It is hang-up by "please wait" for long time then show error "disconnected from server". Could anyone please help me with this.
ui.r
library(shiny)
require(shinydashboard)
library(ggplot2)
library(dplyr)
head(recommendation)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody()
)
server <- function(input, output) { }
header <- dashboardHeader(title = "Basic Dashboard")
#Sidebar content of the dashboard
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
menuItem("Visit-us", icon = icon("send",lib='glyphicon'),
href = "https://www.salesforce.com")
)
)
frow1 <- fluidRow(
valueBoxOutput("value1")
,valueBoxOutput("value2")
,valueBoxOutput("value3")
)
frow2 <- fluidRow(
box(
title = "Revenue per Account"
,status = "primary"
,solidHeader = TRUE
,collapsible = TRUE
,plotOutput("revenuebyPrd", height = "300px")
)
,box(
title = "Revenue per Product"
,status = "primary"
,solidHeader = TRUE
,collapsible = TRUE
,plotOutput("revenuebyRegion", height = "300px")
)
)
# combine the two fluid rows to make the body
body <- dashboardBody(frow1, frow2)
ui <- dashboardPage(title = 'This is my Page title', header, sidebar, body, skin='red')
shinyApp(ui, server)
library(rsconnect)
rsconnect::setAccountInfo(name='', token='', secret='')
deployApp(appName="myApp")
server.R
server <- function(input, output) {
#some data manipulation to derive the values of KPI boxes
total.revenue <- sum(recommendation$Revenue)
sales.account <- recommendation %>% group_by(Account) %>% summarise(value = sum(Revenue)) %>% filter(value==max(value))
prof.prod <- recommendation %>% group_by(Product) %>% summarise(value = sum(Revenue)) %>% filter(value==max(value))
#creating the valueBoxOutput content
output$value1 <- renderValueBox({
valueBox(
formatC(sales.account$value, format="d", big.mark=',')
,paste('Top Account:',sales.account$Account)
,icon = icon("stats",lib='glyphicon')
,color = "purple")
})
output$value2 <- renderValueBox({
valueBox(
formatC(total.revenue, format="d", big.mark=',')
,'Total Expected Revenue'
,icon = icon("gbp",lib='glyphicon')
,color = "green")
})
output$value3 <- renderValueBox({
valueBox(
formatC(prof.prod$value, format="d", big.mark=',')
,paste('Top Product:',prof.prod$Product)
,icon = icon("menu-hamburger",lib='glyphicon')
,color = "yellow")
})
#creating the plotOutput content
output$revenuebyPrd <- renderPlot({
ggplot(data = recommendation,
aes(x=Product, y=Revenue, fill=factor(Region))) +
geom_bar(position = "dodge", stat = "identity") + ylab("Revenue (in Euros)") +
xlab("Product") + theme(legend.position="bottom"
,plot.title = element_text(size=15, face="bold")) +
ggtitle("Revenue by Product") + labs(fill = "Region")
})
output$revenuebyRegion <- renderPlot({
ggplot(data = recommendation,
aes(x=Account, y=Revenue, fill=factor(Region))) +
geom_bar(position = "dodge", stat = "identity") + ylab("Revenue (in Euros)") +
xlab("Account") + theme(legend.position="bottom"
,plot.title = element_text(size=15, face="bold")) +
ggtitle("Revenue by Region") + labs(fill = "Region")
})
}
shinyApp(ui, server)
Log file is not showing any error. Any help is much appreciated.

Displaying the value of bar created in R using shiny and plotly

If you run the R shiny script below, we get two boxes in a dashboard, the left box has a bar chart and right has a DT table, when I click on any bar of the chart using event_data("plotly_click"), I want the corresponding Employee to be displayed in the table besides, like when clicked on first bar, "r1" should be displayed in the table besides. I tried doing "user_cases$base1[d[3]]" but it throws an error as "Error: invalid subscript type 'list'". I will attach the snapshot for the reference, please help me with the same.
## app.R ##
library(shiny)
library(shinydashboard)
library(ggplot2)
library(plotly)
library(DT)
ui <- dashboardPage(
dashboardHeader(title = "Sankey Chart"),
dashboardSidebar(
width = 0
),
dashboardBody(
box(title = "Sankey Chart", status = "primary",height = "455" ,solidHeader =
T,
plotlyOutput("sankey_plot")),
box( title = "Case Summary", status = "primary", height = "455",solidHeader
= T,
dataTableOutput("sankey_table"))
)
)
server <- function(input, output)
{
output$sankey_plot <- renderPlotly({
height2 = c(56,45,23,19,8)
base1 = c("r1","r4","r2","r5","r3")
user_cases = data.frame(base1,height2)
pp1 <<- ggplot(user_cases, aes(x = reorder(base1,-height2), y = height2)) +
geom_bar(stat = "identity", fill = "#3399ff" ) + scale_y_discrete(name
="Cases") + scale_x_discrete(name = "Employee")
ggplotly(pp1, tooltip="text",height = 392)
})
output$sankey_table <- renderDataTable({
d <- event_data("plotly_click")
user_cases$base1[d[3]]
})
}
shinyApp(ui, server)
Dataset to be fetched
I am trying to fetch subset of the data from the patients dataset from bupaR library. The code for doing it is as follows:
patients_final <- patients[patients$employee == as.data.frame(
user_time$employee[as.numeric(d[3])])]
but the error I get is: "Can't use matrix or array for column indexing" attaching the snapshot for the help.
Have a look at the modified code, I have changed user_cases$base1[d[3]] to as.data.frame(user_cases$base1[as.numeric(d[3])])
## app.R ##
library(shiny)
library(shinydashboard)
library(ggplot2)
library(plotly)
library(DT)
height2 = c(56,45,23,19,8)
base1 = c("r1","r4","r2","r5","r3")
user_cases = data.frame(base1,height2)
ui <- dashboardPage(
dashboardHeader(title = "Sankey Chart"),
dashboardSidebar(
width = 0
),
dashboardBody(
box(title = "Sankey Chart", status = "primary",height = "455" ,solidHeader =
T,
plotlyOutput("sankey_plot")),
box( title = "Case Summary", status = "primary", height = "455",solidHeader
= T,
dataTableOutput("sankey_table"))
)
)
server <- function(input, output)
{
output$sankey_plot <- renderPlotly({
pp1 <<- ggplot(user_cases, aes(x = reorder(base1,-height2), y = height2)) +
geom_bar(stat = "identity", fill = "#3399ff" ) + scale_y_discrete(name
="Cases") + scale_x_discrete(name = "Employee")
ggplotly(pp1, tooltip="text",height = 392)
})
output$sankey_table <- renderDataTable({
d <- event_data("plotly_click")
as.data.frame( user_cases$base1[as.numeric(d[3])])
})
}
shinyApp(ui, server)
The output is as below:
You can modify the dataframe output as per your requirement.
Hope it helps!

Resources