Please run this script below, the following R script gives a shiny dashboard with two boxes. I want to reduce the width between two boxes and display data in the right chart. The data should be based on the on click event that we see in the ggplotly function. Also plotly can be used to do the job, I guess. I want the code to fast and efficient at the same time.
## app.R ##
library(shiny)
library(shinydashboard)
library(bupaR)
library(eventdataR)
library(lubridate)
library(dplyr)
library(XML)
library(edeaR)
library(xml2)
library(data.table)
library(ggplot2)
library(ggthemes)
library(glue)
library(tibble)
library(miniUI)
library(tidyr)
library(shinyTime)
library(magrittr)
library(plotly)
library(DT)
library(splitstackshape)
library(scales)
patients$patient = as.character(patients$patient)
a1 = patients$patient
a2 = patients$handling
a3 = patients$time
a123 = data.frame(a1,a2,a3)
patients_eventlog = simple_eventlog(a123, case_id = "a1",activity_id = "a2",
timestamp = "a3")
dta <- reactive({
tr <- data.frame(traces(patients_eventlog, output_traces = T, output_cases =
F))
tr.df <- cSplit(tr, "trace", ",")
tr.df$af_percent <-
percent(tr.df$absolute_frequency/sum(tr.df$absolute_frequency))
pos <- c(1,4:ncol(tr.df))
tr.df <- tr.df[,..pos]
tr.df <- melt(tr.df, id.vars = c("trace_id","af_percent"))
tr.df
})
patients10 <- reactive({
patients11 <- arrange(patients_eventlog, a1)
patients12 <- patients11 %>% arrange(a1, a2,a3)
patients12 %>%
group_by(a1) %>%
mutate(time = as.POSIXct( a2, format = "%m/%d/%Y %H:%M"),diff_in_sec = a2 -
lag( a2)) %>%
mutate(diff_in_sec = ifelse(is.na(diff_in_sec),0,diff_in_sec)) %>%
mutate(diff_in_hours = as.numeric(diff_in_sec/3600)) %>%
mutate(diff_in_days = as.numeric(diff_in_hours/24))
})
ui <- dashboardPage(
dashboardHeader(title = "Trace Chart"),
dashboardSidebar(
width = 0
),
dashboardBody(
box(title = "Trace Chart", status = "primary",height = "455" ,solidHeader =
T,
plotlyOutput("trace_plot"),style = "height:420px; overflow-y:
scroll;overflow-x: scroll;"),
box( title = "Trace Summary", status = "primary", height = "455",solidHeader
= T,
dataTableOutput("trace_table"))
)
)
server <- function(input, output)
{
output$trace_plot <- renderPlotly({
mp1 = ggplot(data = dta(), aes(x = variable,y = trace_id, fill = value,
label = value,
text=paste("Variable:",variable,"<br> Trace
ID:",trace_id,"<br>
Value:",value,"<br> Actuals:",af_percent))) +
geom_tile(colour = "white") +
geom_text(colour = "white", fontface = "bold", size = 2) +
scale_fill_discrete(na.value="transparent") +
theme(legend.position="none") + labs(x = "Traces", y = "Activities")
ggplotly(mp1, tooltip=c("text"), height = 1226, width = 1205)
})
output$trace_table <- renderDataTable({
req(event_data("plotly_click"))
Values <- dta() %>%
filter(trace_id == event_data("plotly_click")[["y"]]) %>%
select(value)
valueText <- paste0(Values[[1]] %>% na.omit(),collapse = "")
agg <- aggregate(a3~a1, data = patients10(), FUN = function(y){paste0(unique(y),collapse = "")})
currentPatient <- agg$a1[agg$a3 == valueText]
patients10_final <- patients10() %>%
filter(a1 %in% currentPatient)
datatable(patients10_final, options = list(paging = FALSE, searching = FALSE))
})
}
shinyApp(ui, server)
I have created an easy example how You can use coupled events from plotly with some sample data that is close to Your needs:
library(shiny)
library(plotly)
library(DT)
set.seed(100)
data <- data.frame(A=sample(c('a1','a2','a3'),10,replace=T),
B=1:10,
C=11:20,
D=21:30)
shinyApp(
ui = fluidPage(
plotlyOutput("trace_plot"),
DT::dataTableOutput('tbl')),
server = function(input, output) {
output$trace_plot <- renderPlotly({
plot_ly(data, x=~A,y=~B,z=~C, source = "subset") %>% add_histogram2d()})
output$tbl <- renderDataTable({
event.data <- event_data("plotly_click", source = "subset")
if(is.null(event.data) == T) return(NULL)
print(event.data[ ,c(3:4)])
})
}
)
As You can see by pressing on the first plot we get the subset of data below in the table (x and y values), further you can use it to merge with the primary data to display timestamps etc. .
Related
I have a simple application in shiny and I would like to add to the trend lines. I know how to add a linear trend line using the lm and abline functions in ggplot, but how do I add trend lines in R Using only Plotly.
library(shiny)
library(plotly)
library(shinyWidgets)
set.seed(666)
df1 <- data.frame(Date = rep(seq(as.Date("2020-01-03"), by="day", len=12),10,replace = TRUE),
Product = rep(LETTERS[1:10], each = 12),
Value = sample(c(0:300),120, replace = T))
ui <- fluidPage(
pickerInput("All", "Choose", multiple = F, choices = unique(df1$Product) ,
options = list(`max-options` = 4,size = 10)),
plotlyOutput('plot')
)
server <- function(input, output) {
trend<- reactive({
df1 %>%
filter(Product %in% input$All) %>%
arrange(Date) %>%
droplevels()
})
output$plot <- renderPlotly({
plot_ly(data=trend(), x=~Date, y = ~Value,
type = 'scatter', mode = 'lines+markers')
})
}
shinyApp(ui = ui, server = server)
How about adding a line using linear regression?
library(shiny)
library(plotly)
library(shinyWidgets)
set.seed(666)
df1 <- data.frame(Date = rep(seq(as.Date("2020-01-03"), by="day", len=12),10,replace = TRUE),
Product = rep(LETTERS[1:10], each = 12),
Value = sample(c(0:300),120, replace = T))
ui <- fluidPage(
pickerInput("All", "Choose", multiple = F, choices = unique(df1$Product) ,
options = list(`max-options` = 4,size = 10)),
plotlyOutput('plot')
)
server <- function(input, output) {
trend<- reactive({
df1 %>%
filter(Product %in% input$All) %>%
arrange(Date) %>%
droplevels()
})
output$plot <- renderPlotly({
t <- trend()
m <- lm(Value~Date,data = t)
p <-plot_ly(data=t, x=~Date, y = ~Value,
type = 'scatter', mode = 'lines+markers')
p = add_lines(p, x=~Date, y=predict(m), name="Linear")
})
}
shinyApp(ui = ui, server = server)
If you run the R shiny script below, you get two boxes in an R shiny dashboard, The chart on the left displays a plot for all the traces or set of activities that occur in the eventlog data "patients_eventlog". "patients2" is a data in the script that explains each and every case appearing in column "a1", and corresponding activities basides in column "a2". My requirement is that when I click anywhere on a particular trace in the chart on left, I should get the relevant columns "a1","a2" and "a3" with the data having only and only those cases in which the activities in that trace are occurring. E.g. Let's say
a trace in the chart on left has activites "Registration" and "Triage and Assessment", the by clicking on the trace, I want to see the cases with only and only those two activities. This just needs a minor tweak in the "output$sankey_table" server component. Please help and thanks.
## app.R ##
library(shiny)
library(shinydashboard)
library(bupaR)
library(lubridate)
library(dplyr)
library(xml2)
library(ggplot2)
library(ggthemes)
library(glue)
library(tibble)
library(miniUI)
library(tidyr)
library(shinyWidgets)
library(plotly)
library(DT)
library(splitstackshape)
library(scales)
patients$patient = as.character(patients$patient)
a1 = patients$patient
a2 = patients$handling
a3 = patients$time
a123 = data.frame(a1,a2,a3)
patients_eventlog = simple_eventlog(a123, case_id = "a1",activity_id = "a2",
timestamp = "a3")
dta <- reactive({
tr <- data.frame(traces(patients_eventlog, output_traces = T, output_cases =
F))
tr.df <- cSplit(tr, "trace", ",")
tr.df$af_percent <-
percent(tr.df$absolute_frequency/sum(tr.df$absolute_frequency))
pos <- c(1,4:ncol(tr.df))
tr.df <- tr.df[,..pos]
tr.df <- melt(tr.df, id.vars = c("trace_id","af_percent"))
tr.df
})
Purchase_Final <- reactive({
patients1 <- arrange(patients_eventlog, a1)
patients2 <- patients1 %>% arrange(a1, a3,a2)
patients2 %>%
group_by(a1) %>%
mutate(a3 = as.POSIXct(a3, format = "%m/%d/%Y %H:%M"),diff_in_sec = a3 -
lag(a3)) %>%
mutate(diff_in_sec = ifelse(is.na(diff_in_sec),0,diff_in_sec)) %>%
mutate(diff_in_hours = as.numeric(diff_in_sec/3600)) %>%
mutate(diff_in_days = as.numeric(diff_in_hours/24))
})
ui <- dashboardPage(
dashboardHeader(title = "Trace Chart"),
dashboardSidebar(
width = 0
),
dashboardBody(
box(title = "Trace Chart", status = "primary",height = "455" ,solidHeader =
T,
plotlyOutput("trace_plot"),style = "height:420px; overflow-y:
scroll;overflow-x: scroll;"),
box( title = "Trace Summary", status = "primary", height = "455",solidHeader
= T,
dataTableOutput("sankey_table"))
)
)
server <- function(input, output)
{
output$trace_plot <- renderPlotly({
mp1 = ggplot(data = dta(), aes(x = variable,y = trace_id, fill = value,
label = value,
text=paste("Variable:",variable,"<br> Trace
ID:",trace_id,"<br>
Value:",value,"<br> Actuals:",af_percent))) +
geom_tile(colour = "white") +
geom_text(colour = "white", fontface = "bold", size = 2) +
scale_fill_discrete(na.value="transparent") +
theme(legend.position="none") + labs(x = "Traces", y = "Activities")
ggplotly(mp1, tooltip=c("text"), height = 1226, width = 1205)
})
output$sankey_table <- renderDataTable({
d = event_data("plotly_click")
d
})
}
shinyApp(ui, server)
Addon Script for reference
app.R
library(shiny)
library(shinydashboard)
library(bupaR)
library(lubridate)
library(dplyr)
library(xml2)
library(ggplot2)
library(ggthemes)
library(glue)
library(tibble)
library(miniUI)
library(tidyr)
library(shinyWidgets)
library(plotly)
library(DT)
library(splitstackshape)
library(scales)
dta <- reactive({
tr <- data.frame(traces(patients, output_traces = T, output_cases = F))
tr.df <- cSplit(tr, "trace", ",")
tr.df$af_percent <-
percent(tr.df$absolute_frequency/sum(tr.df$absolute_frequency))
pos <- c(1,4:ncol(tr.df))
tr.df <- tr.df[,..pos]
tr.df <- melt(tr.df, id.vars = c("trace_id","af_percent"))
tr.df
})
patients10 <- reactive({
patients11 <- arrange(patients, patient)
patients12 <- patients11 %>% arrange(patient, time,handling_id)
patients12 %>%
group_by(patient) %>%
mutate(time = as.POSIXct(time, format = "%m/%d/%Y %H:%M"),diff_in_sec = time
- lag(time)) %>%
mutate(diff_in_sec = ifelse(is.na(diff_in_sec),0,diff_in_sec)) %>%
mutate(diff_in_hours = as.numeric(diff_in_sec/3600)) %>%
mutate(diff_in_days = as.numeric(diff_in_hours/24))
})
ui <- dashboardPage(
dashboardHeader(title = "Sankey Chart"),
dashboardSidebar(
width = 0
),
dashboardBody(
box(title = "Sankey Chart", status = "primary",height = "455" ,solidHeader =
T,
plotlyOutput("trace_plot")),
box( title = "Case Summary", status = "primary", height = "455",solidHeader
= T,
dataTableOutput("trace_table"))
)
)
server <- function(input, output)
{
output$trace_plot <- renderPlotly({
mp1 = ggplot(data = dta(), aes(x = variable,y = trace_id, fill = value,
label = value,
text=paste("Variable:",variable,"<br> Trace
ID:",trace_id,"<br>
Value:",value,"<br> Actuals:",af_percent))) +
geom_tile(colour = "white") +
geom_text(colour = "white", fontface = "bold", size = 2) +
scale_fill_discrete(na.value="transparent") +
theme(legend.position="none") + labs(x = "Traces", y = "Activities")
ggplotly(mp1, tooltip=c("text"), height = 516, width = 605)
})
output$trace_table <- renderDataTable({
req(event_data("plotly_click"))
Values <- dta() %>%
filter(trace_id == event_data("plotly_click")[["y"]]) %>%
select(value)
valueText <- paste0(Values[[1]] %>% na.omit(),collapse = "")
agg <- aggregate(handling~patient, data = patients10(), FUN = function(y)
{paste0(unique(y),collapse = "")})
currentPatient <- agg$patient[agg$handling == valueText]
patients10_final <- patients10() %>%
filter(patient %in% currentPatient)
datatable(patients10_final, options = list(paging = FALSE, searching =
FALSE))
})
}
shinyApp(ui, server)
Since you have given such a huge example and its hard to decode each and every line in your code, I have removed some code to get the rows for your selected event.
Instead of event_data("plotly_click")[["y"]]) I am using the x as vent_data("plotly_click")$x and getting the trace_id by using paste0 function.
The part of the code that I have modified to get the rows is:
output$trace_table <- renderDataTable({
req(event_data("plotly_click"))
trace = event_data("plotly_click")$x
Values <- dta() %>%
filter(variable == paste0("trace_",trace))# %>%
#select(value)
datatable(Values)
# valueText <- paste0(Values[[1]] %>% na.omit(),collapse = "")
# agg <- aggregate(handling~patient, data = patients10(), FUN = function(y)
# {paste0(unique(y),collapse = "")})
#
# currentPatient <- agg$patient[agg$handling == valueText]
#
# patients10_final <- patients10() %>%
# filter(patient %in% currentPatient)
#
# datatable(patients10_final, options = list(paging = FALSE, searching =
# FALSE))
})
EDIT:
Here is the full code:
library(shiny)
library(shinydashboard)
library(bupaR)
library(lubridate)
library(dplyr)
library(xml2)
library(ggplot2)
library(ggthemes)
library(glue)
library(tibble)
library(miniUI)
library(tidyr)
library(shinyWidgets)
library(plotly)
library(DT)
library(splitstackshape)
library(scales)
dta <- reactive({
tr <- data.frame(traces(patients, output_traces = T, output_cases = F))
tr.df <- cSplit(tr, "trace", ",")
tr.df$af_percent <-
percent(tr.df$absolute_frequency/sum(tr.df$absolute_frequency))
pos <- c(1,4:ncol(tr.df))
tr.df <- tr.df[,..pos]
tr.df <- melt(tr.df, id.vars = c("trace_id","af_percent"))
tr.df
})
patients10 <- reactive({
patients11 <- arrange(patients, patient)
patients12 <- patients11 %>% arrange(patient, time,handling_id)
patients12 %>%
group_by(patient) %>%
mutate(time = as.POSIXct(time, format = "%m/%d/%Y %H:%M"),diff_in_sec = time
- lag(time)) %>%
mutate(diff_in_sec = ifelse(is.na(diff_in_sec),0,diff_in_sec)) %>%
mutate(diff_in_hours = as.numeric(diff_in_sec/3600)) %>%
mutate(diff_in_days = as.numeric(diff_in_hours/24))
})
ui <- dashboardPage(
dashboardHeader(title = "Sankey Chart"),
dashboardSidebar(
width = 0
),
dashboardBody(
box(title = "Sankey Chart", status = "primary",height = "455" ,solidHeader =
T,
plotlyOutput("trace_plot")),
box( title = "Case Summary", status = "primary", height = "455",solidHeader
= T,
dataTableOutput("trace_table"))
)
)
server <- function(input, output)
{
output$trace_plot <- renderPlotly({
mp1 = ggplot(data = dta(), aes(x = variable,y = trace_id, fill = value,
label = value,
text=paste("Variable:",variable,"<br> Trace
ID:",trace_id,"<br>
Value:",value,"<br> Actuals:",af_percent))) +
geom_tile(colour = "white") +
geom_text(colour = "white", fontface = "bold", size = 2) +
scale_fill_discrete(na.value="transparent") +
theme(legend.position="none") + labs(x = "Traces", y = "Activities")
ggplotly(mp1, tooltip=c("text"), height = 516, width = 605)
})
output$trace_table <- renderDataTable({
req(event_data("plotly_click"))
trace = event_data("plotly_click")$x
Values <- dta() %>%
filter(variable == paste0("trace_",trace))# %>%
#select(value)
datatable(Values)
# valueText <- paste0(Values[[1]] %>% na.omit(),collapse = "")
# agg <- aggregate(handling~patient, data = patients10(), FUN = function(y)
# {paste0(unique(y),collapse = "")})
#
# currentPatient <- agg$patient[agg$handling == valueText]
#
# patients10_final <- patients10() %>%
# filter(patient %in% currentPatient)
#
# datatable(patients10_final, options = list(paging = FALSE, searching =
# FALSE))
})
}
shinyApp(ui, server)
Hope it helps!
Please run the script below, there are two charts created using the patients dataset from the bupaR library, the chart on the left displays a sankey chart showing relationship between the resource("employee") and activities("handling") and the chart on the right displays the details of link between the resource and activities when we perform "on-click". Basically, we see a subset of data with corresponding values say "r1" and "Registration" values when we click the link connecting "r1" to "Registration" and so on. However, when I run code with any other resource and activity column, the sankey chart does not get created and I get the following error "non-numeric argument to binary operator". Please try the script with a simple dataset and help:
a1 = c("A","B","C","A","B","B")
a2 = c("D","E","D","E","D","F")
a12 = data.frame(a1,a2)
library(shiny)
library(shinydashboard)
library(devtools)
library(ggplot2)
library(plotly)
library(proto)
library(RColorBrewer)
library(gapminder)
library(stringr)
library(broom)
library(mnormt)
library(DT)
library(bupaR)
library(dplyr)
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)
{
sankeyData <- reactive({
sankeyData <- patients %>%
group_by(employee,handling) %>%
count()
sankeyNodes <- list(label = c(sankeyData$employee,sankeyData$handling))
trace2 <- list(
domain = list(
x = c(0, 1),
y = c(0, 1)
),
link = list(
label = paste0("Case",1:nrow(sankeyData)),
source = sapply(sankeyData$employee,function(e) {which(e ==
sankeyNodes$label) }, USE.NAMES = FALSE) - 1,
target = sapply(sankeyData$handling,function(e) {which(e ==
sankeyNodes$label) }, USE.NAMES = FALSE) - 1,
value = sankeyData$n
),
node = list(label = sankeyNodes$label),
type = "sankey"
)
trace2
})
output$sankey_plot <- renderPlotly({
trace2 <- sankeyData()
p <- plot_ly()
p <- add_trace(p, domain=trace2$domain, link=trace2$link,
node=trace2$node, type=trace2$type)
p
})
output$sankey_table <- renderDataTable({
d <- event_data("plotly_click")
req(d)
trace2 <- sankeyData()
sIdx <- trace2$link$source[d$pointNumber+1]
Source <- trace2$node$label[sIdx + 1 ]
tIdx <- trace2$link$target[d$pointNumber+1]
Target <- trace2$node$label[tIdx+1]
patients %>% filter(employee == Source & handling == Target)
})
}
shinyApp(ui, server)
In order to make this "ready solution" with any dataset I think you need one character (cut and color were turned into character using as.character()) of column b for each character of column a. For example, in the patient dataset, there is only one possibility (registration) for r1; same for r2 to r7. Your app did not work with the full diamonds dataset. But using the same logic, the app works.
diamonds_b <- diamonds %>% filter(cut == "Ideal" & color == "D")
diamonds_c <- diamonds %>% filter(cut == "Fair" & color == "E")
diamonds_d <- rbind(diamonds_b, diamonds_c)
diamonds_d$cut <- as.character(diamonds_d$cut)
diamonds_d$color <- as.character(diamonds_d$color)
and now running the shiny app with the diamonds_d dataset works:
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)
{
sankeyData <- reactive({
sankeyData <- diamonds_d %>%
group_by(cut,color) %>%
count()
sankeyNodes <- list(label = c(sankeyData$cut,sankeyData$color))
trace2 <- list(
domain = list(
x = c(0, 1),
y = c(0, 1)
),
link = list(
label = paste0("Case",1:nrow(sankeyData)),
source = sapply(sankeyData$cut,function(e) {which(e == sankeyNodes$label) }, USE.NAMES = FALSE) - 1,
target = sapply(sankeyData$color,function(e) {which(e == sankeyNodes$label) }, USE.NAMES = FALSE) - 1,
value = sankeyData$n
),
node = list(label = sankeyNodes$label),
type = "sankey"
)
trace2
})
output$sankey_plot <- renderPlotly({
trace2 <- sankeyData()
p <- plot_ly()
p <- add_trace(p, domain=trace2$domain, link=trace2$link,
node=trace2$node, type=trace2$type)
p
})
output$sankey_table <- renderDataTable({
d <- event_data("plotly_click")
req(d)
trace2 <- sankeyData()
sIdx <- trace2$link$source[d$pointNumber+1]
Source <- trace2$node$label[sIdx + 1 ]
tIdx <- trace2$link$target[d$pointNumber+1]
Target <- trace2$node$label[tIdx+1]
diamonds %>% filter(cut == Source & color == Target)
})
}
shinyApp(ui, server)
The script below works on the patients data from bupaR package,and creates a sankey plot listing the relation between a resource from the "employee" column with the activity he is involved in from the "handling" column in the patients data. Besides the plot there is a data table available from DT which gives details of every sankey plot path when clicked. I want a functionality such that when I click on any path, say path connecting "r1" employee and "Registration" handling activity, I want all the rows from patients data with both these fields available in the plot besides, similarly for all other paths, this should be dynamic as I shall apply the functionality on larger datasets. Attaching the snapshot for reference. Thanks and please help.
## app.R ##
library(shiny)
library(shinydashboard)
library(devtools)
library(ggplot2)
library(plotly)
library(proto)
library(RColorBrewer)
library(gapminder)
library(stringr)
library(broom)
library(mnormt)
library(DT)
library(bupaR)
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({
sankeyData <- patients %>%
group_by(employee,handling) %>%
count()
sankeyNodes <- list(label = c(sankeyData$employee,sankeyData$handling))
trace2 <- list(
domain = list(
x = c(0, 1),
y = c(0, 1)
),
link = list(
label = paste0("Case",1:nrow(sankeyData)),
source = sapply(sankeyData$employee,function(e) {which(e ==
sankeyNodes$label) }, USE.NAMES = FALSE) - 1,
target = sapply(sankeyData$handling,function(e) {which(e ==
sankeyNodes$label) }, USE.NAMES = FALSE) - 1,
value = sankeyData$n
),
node = list(label = sankeyNodes$label),
type = "sankey"
)
data2 <- list(trace2)
p <- plot_ly()
p <- add_trace(p, domain=trace2$domain, link=trace2$link,
node=trace2$node, type=trace2$type)
p
})
output$sankey_table <- renderDataTable({
d <- event_data("plotly_click")
d
})
}
shinyApp(ui, server)
Hi I interpreted the output from event_data as such that pointNumber is the index of the link but I might be wrong here. Any way this is my Solution and it works for this data
library(shiny)
library(shinydashboard)
library(devtools)
library(ggplot2)
library(plotly)
library(proto)
library(RColorBrewer)
library(gapminder)
library(stringr)
library(broom)
library(mnormt)
library(DT)
library(bupaR)
library(dplyr)
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)
{
sankeyData <- reactive({
sankeyData <- patients %>%
group_by(employee,handling) %>%
count()
sankeyNodes <- list(label = c(sankeyData$employee,sankeyData$handling) %>% unique())
trace2 <- list(
domain = list(
x = c(0, 1),
y = c(0, 1)
),
link = list(
label = paste0("Case",1:nrow(sankeyData)),
source = sapply(sankeyData$employee,function(e) {which(e ==
sankeyNodes$label) }, USE.NAMES = FALSE) - 1,
target = sapply(sankeyData$handling,function(e) {which(e ==
sankeyNodes$label) }, USE.NAMES = FALSE) - 1,
value = sankeyData$n
),
node = list(label = sankeyNodes$label),
type = "sankey"
)
trace2
})
output$sankey_plot <- renderPlotly({
trace2 <- sankeyData()
p <- plot_ly()
p <- add_trace(p, domain=trace2$domain, link=trace2$link,
node=trace2$node, type=trace2$type)
p
})
output$sankey_table <- renderDataTable({
d <- event_data("plotly_click")
req(d)
trace2 <- sankeyData()
sIdx <- trace2$link$source[d$pointNumber+1]
Source <- trace2$node$label[sIdx + 1 ]
tIdx <- trace2$link$target[d$pointNumber+1]
Target <- trace2$node$label[tIdx+1]
patients %>% filter(employee == Source & handling == Target)
})
}
shinyApp(ui, server)
hope it helps!
I am developing a Shiny app which I hope to look like the picture below:
However, as I try to achieve this, I am only able to get the following form:
I am looking for how to make the output neatly collected, and would appreciate any help. I have looked at a couple of other similar questions here, viz. this and this, but don't think they answer my question (the first talks about adding a mainPanel, but I am using FludiPage and FluidRows. I had thought the columns and rows would automatically adjust to screen size, and that 12 columns are designed to fit into a screen size, but apparently I am wrong?
Many thanks for the help.
The Server.R file for copying/pasting. Apologies, it is a bit long:
#
#
# load libraries, scripts, data
library(shiny)
library(shinyapps)
library(shinydashboard)
library(dplyr)
library(tidyr)
library(lubridate)
library(htmlwidgets)
options(shiny.trace = TRUE,
shiny.maxRequestSize=300*1024^2)
## body of shiny server side program
shinyServer(function(input, output, session) {
dataList <- reactive({
if(is.null(input$uploadFile)){
return(NULL)
}
uploadFileInfo <- input$uploadFile
uploadData <- read.csv(uploadFileInfo$datapath, header = TRUE, stringsAsFactors = FALSE)
uploadedData <- tbl_df(uploadData) %>%
mutate(yearValue = year(dateValues), monthValue = month(dateValues))
sumData1 <- uploadedData %>%
select(yearValue, earnPts, earnCount, redemPts, redemCount, churnCount, acquisCount) %>%
gather(metrics, totals, -yearValue) %>%
group_by(yearValue, metrics) %>%
summarise(yearlyTotals = sum(totals)) %>%
arrange(yearlyTotals)
sumData2 <- uploadedData %>%
select(yearValue, monthValue, earnPts, earnCount, redemPts, redemCount, churnCount, acquisCount) %>%
gather(metrics, totals, -c(yearValue, monthValue)) %>%
group_by(yearValue, monthValue, metrics) %>%
summarise(yearmonthTotals = sum(totals)) %>%
arrange(yearValue, monthValue) %>%
group_by(yearValue, metrics) %>%
mutate(cumulatives = cumsum(yearmonthTotals))
sumData3 <- uploadedData %>%
select(yearValue, monthValue, earnPts, earnCount, redemPts, redemCount, churnCount, acquisCount) %>%
group_by(yearValue, monthValue) %>%
summarise_each(funs(mean)) %>%
round()
sumData4 <- uploadedData %>%
group_by(dateValues) %>%
summarise_each(funs(sum))
earnData <- sumData4 %>%
select(earnPts, earnCount)
row.names(earnData) <- sumData4$dateValues
redempData <- sumData4 %>%
select(redemPts, redemCount)
row.names(earnData) <- sumData4$dateValues
custData <- sumData4 %>%
select(churnCount, acquisCount)
row.names(earnData) <- sumData4$dateValues
sumData5 <- uploadedData %>%
group_by(dateValues) %>%
summarise_each(funs(sum))
earnTSData <- sumData5 %>%
select(earnPts, earnCount)
row.names(earnTSData) <- sumData5$dateValues
redemTSData <- sumData5 %>%
select(redemPts, redemCount)
row.names(redemTSData) <- sumData5$dateValues
custTSData <- sumData5 %>%
select(acquisCount, churnCount)
row.names(custTSData) <- sumData5$dateValues
dfList <- list(sumData1 = sumData1, sumData2 = sumData2, sumData3 = sumData3,
sumData4 = sumData4, earnData = earnData, redempData = redempData,
custData = custData, sumData5 = sumData5, earnTSData = earnTSData,
redemTSData = redemTSData, custTSData = custTSData)
return(dfList)
})
### The main chart
output$outlinesChart <- renderChart2({
myData <- dataList()$sumData1
mainPlot <- nPlot(yearlyTotals ~ metrics,
group = 'yearValue', data = myData, type = 'multiBarChart')
mainPlot$chart(margin=list(left=100))
rm(myData)
return(mainPlot)
})
### Information boxes
output$infoBox1 <- renderInfoBox({
infoBox(
"Progress", 10*2, icon = icon("line-chart"),
color = "blue"
)
})
output$infoBox2 <- renderInfoBox({
infoBox(
"Progress", 10*2, icon = icon("line-chart"),
color = "blue"
)
})
output$infoBox3 <- renderInfoBox({
infoBox(
"Progress", 10*2, icon = icon("line-chart"),
color = "blue"
)
})
output$infoBox4 <- renderInfoBox({
infoBox(
"Progress", 10*2, icon = icon("line-chart"),
color = "blue"
)
})
output$infoBox5 <- renderInfoBox({
infoBox(
"Progress", 10*2, icon = icon("smile-o"),
color = "blue"
)
})
output$infoBox6 <- renderInfoBox({
infoBox(
"Progress", 10*2, icon = icon("frown-o"),
color = "purple", fill = TRUE
)
})
### Cumulative chart for points earned
output$cEarnPtsChart <- renderChart2({
myData <- dataList()$sumData2
interimData <- myData %>% filter( metrics == 'earnPts')
myPlot <- nPlot(cumulatives ~ monthValue, group = 'yearValue',
data = interimData, type = 'lineChart')
rm(myData)
rm(interimData)
return(myPlot)
})
### Cumulative chart for count of earn transactions
output$cEarnCountChart <- renderChart2({
myData <- dataList()$sumData2
interimData <- myData %>% filter( metrics == 'earnCount')
myPlot <- nPlot(cumulatives ~ monthValue, group = 'yearValue',
data = interimData, type = 'lineChart')
rm(myData)
rm(interimData)
return(myPlot)
})
### Cumulative chart for points redeemed
output$cRedemPtsChart <- renderChart2({
myData <- dataList()$sumData2
interimData <- myData %>% filter( metrics == 'redemPts')
myPlot <- nPlot(cumulatives ~ monthValue, group = 'yearValue',
data = interimData, type = 'lineChart')
rm(myData)
rm(interimData)
return(myPlot)
})
### Cumulative chart for count of redemption transactions
output$cRedemCountChart <- renderChart2({
myData <- dataList()$sumData2
interimData <- myData %>% filter( metrics == 'redemCount')
myPlot <- nPlot(cumulatives ~ monthValue, group = 'yearValue',
data = interimData, type = 'lineChart')
rm(myData)
rm(interimData)
return(myPlot)
})
### Cumulative chart for Customer Acquisition
output$cAcquisChart <- renderChart2({
myData <- dataList()$sumData2
interimData <- myData %>% filter( metrics == 'acquisCount')
myPlot <- nPlot(cumulatives ~ monthValue, group = 'yearValue',
data = interimData, type = 'lineChart')
rm(myData)
rm(interimData)
return(myPlot)
})
### Cumulative chart for Customer Acquisition
output$cChurnChart <- renderChart2({
myData <- dataList()$sumData2
interimData <- myData %>% filter( metrics == 'churnCount')
myPlot <- nPlot(cumulatives ~ monthValue, group = 'yearValue',
data = interimData, type = 'lineChart')
rm(myData)
rm(interimData)
return(myPlot)
})
})
The ui.R file:
### load libraries
library(shiny)
library(shinythemes)
### body for Shiny UI
shinyUI(navbarPage("My Sample Dashboard", theme = shinytheme('readable'), inverse = TRUE,
tabPanel("Overview Section",
fluidRow(
column(6,
##current app only supports CSV, since this is a proof of concept...
fileInput(inputId = 'uploadFile', label = 'Please upload your file')
)
),
fluidRow(
column(3,
h4('Main Chart goes here'),
showOutput('outlinesChart', 'nvd3')
),
column(3, offset = 5,
h5('Info boxes go here'),
infoBoxOutput('infoBox1'),
infoBoxOutput('infoBox2'),
infoBoxOutput('infoBox3'),
infoBoxOutput('infoBox4'),
infoBoxOutput('infoBox5'),
infoBoxOutput('infoBox6')
)
),
hr(),
fluidRow(
column(2,
h5('Earned Points chart goes here'),
showOutput('cEarnPtsChart', 'nvd3')
),
column(2, offset = 4,
h5('Earn Count chart goes here'),
showOutput('cEarnCountChart', 'nvd3')
)
),
fluidRow(
column(2,
h5('Redeemed Points chart goes here'),
showOutput('cRedemPtsChart', 'nvd3')
),
column(2, offset = 4,
h5('Redemption Count chart goes here'),
showOutput('cRedemCountChart', 'nvd3')
)
),
fluidRow(
column(2,
h5('Customer Acquisition chart goes here'),
showOutput('cAcquisChart', 'nvd3')
),
column(2, offset = 4,
h5('Customer Churn chart goes here'),
showOutput('cChurnChart', 'nvd3')
)
)
),
tabPanel("Details Section"),
tabPanel("Experiments Section"))
)
Edit:
Following is a code to generate the CSV file to be fed to this app.
earnPtsRange <- 12000:18000
earnCountRange <- 1000:10000
redemPtsRange <- 10000:20000
redemCountRange <- 10000:20000
churnRange <- 1000:10000
acquisitionRange <- 800:15000
### obtained from Dirk Eddelbuettel: https://stackoverflow.com/questions/14720983/efficiently-generate-a-random-sample-of-times-and-dates-between-two-dates
generateDates <- function(N, st="2014/01/01", et="2015/08/31") {
st <- as.POSIXct(as.Date(st))
et <- as.POSIXct(as.Date(et))
dt <- as.numeric(difftime(et,st,unit="sec"))
ev <- sort(runif(N, 0, dt))
rt <- st + ev
rt[order(rt)]
as.Date(rt)
}
## generate data; 10 readings for each month out of 20 months
dateValues <- generateDates(200)
earnPts <- sample(x = earnPtsRange, size = 190)
earnCount <- sample(x = earnCountRange, size = 190)
redemPts <- sample(x = redemPtsRange, size = 190)
redemCount <- sample(x = redemCountRange, size = 190)
churnCount <- sample(x = churnRange, size = 190)
acquisCount <- sample(x = acquisitionRange, size = 190)
## merge the generated data
toyData <- data.frame(dateValues = dateValues, earnPts = earnPts, earnCount = earnCount, redemPts = redemPts, redemCount = redemCount, churnCount = churnCount,
acquisCount = acquisCount)
## write the data to a CSV file
write.csv(x = toyData, file = './toyDataset.csv', row.names = FALSE)
Many thanks in advance.
I have just pushed what I think is a fix to your issue on my fork of rCharts. It solved my issues with responsiveness and auto-resizing with rCharts. The way you use it is by specifying a width and height parameter in showOutput. Default width is 100% and default height is 400px.
Example call would be showOutput("myGraph", "nvd3", height=555)
You can download from: https://github.com/clecocel/rCharts
And you can install it by using: devtools::install_github("clecocel/rCharts")