R Plotly scatter ternary colorbar - r

I am using Plotly to make a scatter ternary plot. I want to color points by one of the values in the data frame (titled mu). However, the colorbar isn't showing. Here is my code:
library(plotly)
df <- eqData0
# axis layout
axis <- function(title) {
list(
title = title,
titlefont = list(
size = 20
),
tickfont = list(
size = 15
),
tickcolor = 'rgba(0,0,0,0)',
ticklen = 5
)
}
fig <- df %>% plot_ly()
fig <- fig %>% add_trace(
type = 'scatterternary',
mode = 'markers',
a = ~u1eq,
b = ~u2eq,
c = ~bueq,
marker = list(
symbol = 100,
color = ~mu,
size = 14,
line = list('width' = 2),
colorscale = 'YlGnBu'
),
colorbar = list(
xanchor = 'middle',
yanchor = 'middle'
)
)
m <- list(
l = 50,
r = 50,
b = 100,
t = 100,
pad = 4
)
fig <- fig %>% layout(autosize = F, width = 500, height = 500, margin = m,
ternary = list(
sum = 1,
aaxis = axis(TeX("$u_1$")),
baxis = axis(TeX("$u_2$")),
caxis = axis(TeX("$\\bar{u}$"))
)
)
fig <- fig %>% config(mathjax = 'cdn')
fig
Somehow the colorbar is still not showing! I'm not sure why because all the Plotly scatterplot examples online make getting the colorbar to show up seem easy.

It looks like you were missing showscale=TRUE in the trace definition.
Trying:
#fake data:
df <- data.frame(u1eq = c(0.2, 0.3, 0.5), u2eq=c(0.6, 0.3, 0.1), bueq=c(0.2, 0.4, 0.4), mu=c(1, 1.8, 2))
# axis layout
axis <- function(title) {
list(
title = title,
titlefont = list(
size = 20
),
tickfont = list(
size = 15
),
tickcolor = 'rgba(0,0,0,0)',
ticklen = 5
)
}
fig <- df %>% plot_ly()
fig <- fig %>% add_trace(
type = 'scatterternary',
mode = 'markers',
a = ~u1eq,
b = ~u2eq,
c = ~bueq,
marker = list(
colorscale = 'YlGnBu',
symbol = 100,
color = ~mu,
size = 14,
line = list('width' = 2),
showscale = TRUE
)
)
m <- list( l = 50, r = 50, b = 100, t = 100, pad = 4)
fig <- fig %>% layout(autosize = F, width = 500, height = 500, margin = m,
ternary = list(
sum = 1,
aaxis = axis(TeX("$u_1$")),
baxis = axis(TeX("$u_2$")),
caxis = axis(TeX("$\\bar{u}$")) )
) %>% config(mathjax = 'cdn')
fig

Related

How to add multiple shapes on plot_ly slider chart?

I am trying to visualize multiple periods in a time-series/candlestick chart, highlighting certain dates by vertical lines. Similar to the sinus wave example here: https://plotly.com/r/sliders/
aval <- list(setNames(xts(matrix(data = rnorm(1:28), ncol = 4), as.Date(1:7)), c("Open","High","Low","Close")),
setNames(xts(matrix(data = rnorm(1:52), ncol = 4), as.Date(1:13)), c("Open","High","Low","Close")),
setNames(xts(matrix(data = rnorm(1:20), ncol = 4), as.Date(1:5)), c("Open","High","Low","Close")))
Looping through the list, I can achieve my desired result with respect to the vertical lines:
for (i in 1:length(aval)) {
fig <- plot_ly()
b <- data.frame(Date=index(aval[[i]]), coredata(aval[[i]]))
line <- list(type = "line", line = list(color = 'magenta'), # , dash = "dot", width = 0.5
xref = "x", yref = "paper", x0 = NA, x1 = NA, y0 = 0, y1 = 1)
l <- list(line, line)
l[[1]][['x0']] <- l[[1]][['x1']] <- b[1+1,1]
l[[2]][['x0']] <- l[[2]][['x1']] <- b[nrow(b)-1,1]
fig <- add_trace(fig, type = "candlestick", x = b[,1], open = b[,2], close = b[,5], high = b[,3], low = b[,4],
showlegend = FALSE) %>%
layout(xaxis = list(rangeslider = list(visible = F), type = "category"), shapes = l, font = list(size = 10))
fig <- fig %>% config(displayModeBar = FALSE)
print(fig)
}
However, using the slider layout, I am only able to use one vertical line, see:
n <- length(aval)
steps <- list()
fig <- plot_ly()
for (i in 1:length(aval)) {
b <- data.frame(Date=index(aval[[i]]), coredata(aval[[i]])[,c('Open','High','Low','Close')])
toggle <- ifelse(i == 1, TRUE, FALSE)
line <- list(type = "line", line = list(color = 'magenta', dash = "dot", width = 0.5),
xref = "x", yref = "paper", x0 = b[1+1,1], x1 = b[1+1,1], y0 = 0, y1 = 1)
fig <- add_trace(fig, type = "candlestick", x = b[,1], open = b[,2], close = b[,5], high = b[,3], low = b[,4],
visible = toggle, showlegend = FALSE) %>%
layout(xaxis = list(rangeslider = list(visible = F), type = "category"), shapes = line, font = list(size = 10))
step <- list(args = list('visible', rep(FALSE, length(aval))), label = i, method = 'restyle')
step$args[[2]][i] = TRUE
steps[[i]] = step
}
fig <- fig %>% layout(sliders = list(list(active = 0, steps = steps))) %>% config(displayModeBar = FALSE)
fig
Using a list of shapes, analog to my first example, does not seem to work:
steps <- list()
fig <- plot_ly()
for (i in 1:length(aval)) {
b <- data.frame(Date=index(aval[[i]]), coredata(aval[[i]])[,c('Open','High','Low','Close')])
toggle <- ifelse(i == 1, TRUE, FALSE)
line <- list(type = "line", line = list(color = 'magenta', dash = "dot", width = 0.5),
xref = "x", yref = "paper", x0 = NA, x1 = NA, y0 = 0, y1 = 1)
l <- list(line, line)
l[[1]][['x0']] <- l[[1]][['x1']] <- b[1+1,1] # as.character
l[[2]][['x0']] <- l[[2]][['x1']] <- b[nrow(b)-1,1]
fig <- add_trace(fig, type = "candlestick", x = b[,1], open = b[,2], close = b[,5], high = b[,3], low = b[,4],
visible = toggle, showlegend = FALSE) %>%
layout(xaxis = list(rangeslider = list(visible = F), type = "category"), shapes = l, font = list(size = 10))
step <- list(args = list('visible', rep(FALSE, length(aval))), label = i, method = 'restyle')
step$args[[2]][i] = TRUE
steps[[i]] = step
}
fig <- fig %>% layout(sliders = list(list(active = 0, steps = steps))) %>% config(displayModeBar = FALSE)
fig
Can anybody help me? Is this related to the visibility argument in steps, perhaps?

R plotly: How to connect lines on polar/radar chart?

I am creating a polar chart in R with plotly, but I don't want the values between lines to be filled with color. I found the line_close property for python library, but I can't find the equivalent in R.
Chart code:
library(plotly)
p <- plot_ly(
type = 'scatterpolar',
mode = 'lines',
) %>%
add_trace(
mode = 'lines',
r = c(3, 0, 1),
theta = c('A','B','C'),
name = '1'
) %>%
add_trace(
mode = 'lines',
r = c(1, 2, 3),
theta = c('A','B','C'),
name = '2'
) %>%
layout(
polar = list(
radialaxis = list(
angle = 90,
visible = T,
range = c(0,3),
showline = F,
color = '#bfbfbf',
nticks = 4,
tickangle = 90
)
)
)
p
Chart image:
I've had a good look through plotly::schema, and there doesn't seem to be an option to do this built in to the R port of plotly.
However, it is trivial to define your own add_closed_trace function like this:
add_closed_trace <- function(p, r, theta, ...)
{
plotly::add_trace(p, r = c(r, r[1]), theta = c(theta, theta[1]), ...)
}
You can use this as a drop-in for add_trace, like this:
library(plotly)
p <- plot_ly(
type = 'scatterpolar',
mode = 'lines',
) %>%
add_closed_trace(
mode = 'lines',
r = c(3, 0, 1),
theta = c('A','B','C'),
name = '1'
) %>%
add_closed_trace(
mode = 'lines',
r = c(1, 2, 3),
theta = c('A','B','C'),
name = '2'
) %>%
layout(
polar = list(
radialaxis = list(
angle = 90,
visible = T,
range = c(0,3),
showline = F,
color = '#bfbfbf',
nticks = 4,
tickangle = 90
)
)
)
p

Set text size within marker in r plotly bubble chart

The labels within bubbles are appearing with size proportional to size argument. However I want to keep the labels in constant sizes.
Which argument should I use to keep them at constant size ?
Code that I am using is provided below.
df = data.frame( x = c( 3, 2, 2, 4, 6, 8 ), y = c( 3, 2, 3, 4, 6, 7 ), size = c( 20, 20, 20, 30, 40, 40 ), labels = letters[1:6] )
evo_bubble <- function(plot_data ,x_var, y_var, z_var, t_var) {
# Trasform data into dataframe and quos
df <- data.frame(plot_data)
xenc <- enquo(x_var)
yenc <- enquo(y_var)
zenc <- enquo(z_var)
tenc <- enquo(t_var)
df <- df %>% mutate( bubble_size = !!zenc*50 ) # Modify the denominator if you want to change the dimension of the bubble
# Set parameters for the plot
bubble_pal <- c("white", "#AECEE8" )
gray_axis <- '#dadada'
font_size <- list(size = 12, family = 'Lato')
width <- 0.5
legend_name <- Hmisc::capitalize( quo_name(zenc) ) # WATCH OUT! it works only with the package with Hmisc
decimal <- ',.2f'
sep <- ','
#x_name <- capitalize(quo_name(xenc))
y_name <- Hmisc::capitalize(quo_name(yenc))
p <- plot_ly(df, x = xenc, y = yenc, name = '', text = tenc, type = "scatter", mode = 'markers+text',
hoverlabel = list(font = font_size), size = zenc, color = zenc, hoverinfo = "text+y", colors= bubble_pal,
marker = list(size = df$bubble_size, line = list(color = gray_axis)) ) %>% hide_colorbar()
p <- p %>% layout(xaxis = list(zeroline = F,
title = '',
linecolor = gray_axis,
titlefont = font_size,
tickfont = font_size,
rangemode='tozero',
gridcolor = gray_axis,
gridwidth = width,
hoverformat = decimal,
mirror = "ticks",
tickmode = 'array',
tickcolor = gray_axis,
linewidth = width,
showgrid = F ),
yaxis = list(title = y_name,
zerolinecolor = gray_axis,
linecolor = gray_axis,
mirror = "ticks",
hoverformat = '.2f',
linewidth = width,
tickcolor = gray_axis,
tickformat = '.2f',
titlefont = font_size,
tickfont = font_size,
showgrid = FALSE) ) %>%
config(displayModeBar = F)
return(p)
}
evo_bubble( df, x, y, size, labels )
Expected image :
Obtained image :
Please ignore the colors in plot.
You can use add_text to get the desired result:
library(plotly)
library(dplyr)
DF = data.frame( x = c( 3, 2, 2, 4, 6, 8 ), y = c( 3, 2, 3, 4, 6, 7 ), size = c( 20, 20, 20, 30, 40, 40 ), labels = letters[1:6] )
evo_bubble <- function(plot_data, x_var, y_var, z_var, t_var) {
# browser()
# Trasform data into dataframe and quos
DF <- data.frame(plot_data)
xenc <- enquo(x_var)
yenc <- enquo(y_var)
zenc <- enquo(z_var)
tenc <- enquo(t_var)
DF <- DF %>% mutate( bubble_size = !!zenc*50 ) # Modify the denominator if you want to change the dimension of the bubble
# Set parameters for the plot
bubble_pal <- c("white", "#AECEE8" )
gray_axis <- '#dadada'
font_size <- list(size = 12, family = 'Lato')
width <- 0.5
legend_name <- Hmisc::capitalize( quo_name(zenc) ) # WATCH OUT! it works only with the package with Hmisc
decimal <- ',.2f'
sep <- ','
#x_name <- capitalize(quo_name(xenc))
y_name <- Hmisc::capitalize(quo_name(yenc))
p <- plot_ly(DF, x = xenc, y = yenc, name = '', type = "scatter", mode = 'markers',
hoverlabel = list(font = font_size), size = zenc, color = zenc, hoverinfo = "text+y", colors= bubble_pal,
marker = list(size = DF$bubble_size, line = list(color = gray_axis))) %>%
add_text(text = tenc, textfont = font_size, textposition = "middle center") %>% hide_colorbar()
p <- p %>% layout(xaxis = list(zeroline = F,
title = '',
linecolor = gray_axis,
titlefont = font_size,
tickfont = font_size,
rangemode='tozero',
gridcolor = gray_axis,
gridwidth = width,
hoverformat = decimal,
mirror = "ticks",
tickmode = 'array',
tickcolor = gray_axis,
linewidth = width,
showgrid = F ),
yaxis = list(title = y_name,
zerolinecolor = gray_axis,
linecolor = gray_axis,
mirror = "ticks",
hoverformat = '.2f',
linewidth = width,
tickcolor = gray_axis,
tickformat = '.2f',
titlefont = font_size,
tickfont = font_size,
showgrid = FALSE) ) %>%
config(displayModeBar = F)
return(p)
}
evo_bubble( DF, x, y, size, labels )

How to trigger a re-render of a plot when a column content of the plotted data changes with the use of reactive element

In the following app the user can select points in the plot by dragging, which should swap their Selected state between 0 and 1
points will get a shape and color depending on their 0 / 1 state, as a visual support for a user to select/deselect model parameters for the next model run.
in the version of the plots I had in my real app, the plotted data is a reactive variable values$RFImp_FP1 but I found out that the plot does not re-render when the content of column Selected of that data.table (or data.frame) changes.
Therefore I am trying to change it to a reactive object, but I'm failing to figure out how to change the Selected column of reactive data.table `RFImp
my attempts (comments in the code) so far produce either an assign error, or an infinite loop.
P.S.: Since i'm coding the stuff with lapply as I am using the code block several times in my app (identical "modules" with different serial number and using different data as the app takes the user through sequential stages of processing data), the second approach with values (app 2) has my preference as this allows me to do things like this:
lapply(c('FP1', 'FP2'), function(FP){
values[[paste('RFAcc', FP, sep = '_')]] <- ".... code to select a dataframe from model result list object values[[paste('RFResults', FP, sep = '_']]$Accuracy...."
which as far as I know can't be done with objectname <- reactive({....}) as you can't paste on the left side of the <- here
REACTIVE OBJECT APPROACH:
library(shiny)
library(plotly)
library(dplyr)
library(data.table)
ui <- fluidPage(
plotlyOutput('RFAcc_FP1', width = 450)
)
server <- function(input, output, session) {
values <- reactiveValues()
observe({
if(!is.null(RFImp_FP1()$Selected)) {
parsToChange <- event_data("plotly_selected", source = 'RFAcc_FP1')$y
if(!is.null(event_data("plotly_selected", source = 'RFAcc_FP1'))){
data_df <- RFImp_FP1()
data_df <- data_df %>% .[, Selected := if_else(Variables %in% parsToChange, 1-Selected, Selected)]
# how to get the reactive Data frame to update the selected
# values$Selected <- data_df$Selected #creates infinite loop.....
# RFImp_FP1$Selected <- data_df$Selected # throws an error
}
}
})
RFImp_FP1 <- reactive({
# in real app the dataframe RFImp_FP1 is a part of a list with randomForest results,
RFImp_FP1 <- data.table( MeanDecreaseAccuracy = runif(10, min = 0, max = 1), Variables = letters[1:10])
RFImp_FP1$Selected <- 1
# RFImp_FP1$Selected <- if(!is.null(values$Selected)){
# values$Selected } else {1 }
RFImp_FP1
})
output$RFAcc_FP1 <- renderPlotly({
RFImp_FP1()[order(MeanDecreaseAccuracy)]
RFImp_score <- RFImp_FP1()
plotheight <- length(RFImp_score$Variables) * 80
p <- plot_ly(data = RFImp_score,
source = 'RFAcc_FP1',
height = plotheight,
width = 450) %>%
add_trace(x = RFImp_score$MeanDecreaseAccuracy,
y = RFImp_score$Variables,
type = 'scatter',
mode = 'markers',
color = factor(RFImp_score$Selected),
colors = c('#1b73c1', '#797979'),
symbol = factor(RFImp_score$Selected),
symbols = c('circle','x'),
marker = list(size = 6),
hoverinfo = "text",
text = ~paste ('<br>', 'Parameter: ', RFImp_score$Variables,
'<br>', 'Mean decrease accuracy: ', format(round(RFImp_score$MeanDecreaseAccuracy*100, digits = 2), nsmall = 2),'%',
sep = '')) %>%
layout(
margin = list(l = 160, r= 20, b = 70, t = 50),
hoverlabel = list(font=list( color = '#1b73c1'), bgcolor='#f7fbff'),
xaxis = list(title = 'Mean decrease accuracy index (%)',
tickformat = "%",
showgrid = F,
showline = T,
zeroline = F,
nticks = 5,
font = list(size = 8),
ticks = "outside",
ticklen = 5,
tickwidth = 2,
tickcolor = toRGB("black")
),
yaxis = list(categoryarray = RFImp_score$Variables,
autorange = T,
showgrid = F,
showline = T,
autotick = T,
font = list(size = 8),
ticks = "outside",
ticklen = 5,
tickwidth = 2,
tickcolor = toRGB("black")
),
dragmode = "select"
) %>% add_annotations(x = 0.5,
y = 1.05,
textangle = 0,
font = list(size = 14,
color = 'black'),
text = "Contribution to accuracy",
showarrow = F,
xref='paper',
yref='paper')
p <- p %>% config(displayModeBar = F)
p
})
}
shinyApp(ui, server)
PREVIOUS reactiveValues() approach:
as you can see, with this app, the plot does not update when selecting a region in the plot even though the code changes the content of column Selected
ui <- fluidPage(
actionButton(inputId = 'Go', label = 'Go'),
plotlyOutput('RFAcc_FP1', width = 450)
)
server <- function(input, output, session) {
values <- reactiveValues()
observe({
if(!is.null(values$RFImp_FP1)) {
parsToChange <- event_data("plotly_selected", source = 'RFAcc_FP1')$y
if(!is.null(event_data("plotly_selected", source = 'RFAcc_FP1'))){
data_df <- values$RFImp_FP1
data_df <- data_df %>% .[, Selected := if_else(Variables %in% parsToChange, 1-Selected, Selected)]
values$RFImp_FP1 <- data_df
}
}
})
observeEvent(input$Go, {
values$RFImp_FP1 <- data.table(MeanDecreaseAccuracy = runif(10, min = 0, max = 1), Variables = letters[1:10])
values$RFImp_FP1$Selected <- 1
})
output$RFAcc_FP1 <- renderPlotly({
if(!is.null(values$RFImp_FP1)) {
RFImp_score <- values$RFImp_FP1[order(MeanDecreaseAccuracy)]
plotheight <- length(RFImp_score$Variables) * input$testme
p <- plot_ly(data = RFImp_score,
source = 'RFAcc_FP1',
height = plotheight,
width = 450) %>%
add_trace(x = RFImp_score$MeanDecreaseAccuracy,
y = RFImp_score$Variables,
type = 'scatter',
mode = 'markers',
color = factor(RFImp_score$Selected),
colors = c('#1b73c1', '#797979'),
symbol = factor(RFImp_score$Selected),
symbols = c('circle','x'),
marker = list(size = 6),
hoverinfo = "text",
text = ~paste ('<br>', 'Parameter: ', RFImp_score$Variables,
'<br>', 'Mean decrease accuracy: ', format(round(RFImp_score$MeanDecreaseAccuracy*100, digits = 2), nsmall = 2),'%',
sep = '')) %>%
layout(
margin = list(l = 160, r= 20, b = 70, t = 50),
hoverlabel = list(font=list( color = '#1b73c1'), bgcolor='#f7fbff'),
xaxis = list(title = 'Mean decrease accuracy index (%)',
tickformat = "%",
showgrid = F,
showline = T,
zeroline = F,
nticks = 5,
font = list(size = 8),
ticks = "outside",
ticklen = 5,
tickwidth = 2,
tickcolor = toRGB("black")
),
yaxis = list(categoryarray = RFImp_score$Variables,
autorange = T,
showgrid = F,
showline = T,
autotick = T,
font = list(size = 8),
ticks = "outside",
ticklen = 5,
tickwidth = 2,
tickcolor = toRGB("black")
),
dragmode = "select"
) %>% add_annotations(x = 0.5,
y = 1.05,
textangle = 0,
font = list(size = 14,
color = 'black'),
text = "Contribution to accuracy",
showarrow = F,
xref='paper',
yref='paper')
p$elementId <- NULL ## to surpress warning of widgetid
p <- p %>% config(displayModeBar = F)
p
} else {
p <- plot_ly( type = 'scatter', mode = 'markers', height = '400px', width = 450) %>% layout(
margin = list(l = 160, r= 20, b = 70, t = 50),
xaxis = list(title = 'Mean decrease accuracy index', range= c(0,1), nticks = 2, showline = TRUE),
yaxis = list(title = 'Model input variables', range = c(0,1), nticks = 2, showline = TRUE)) %>%
add_annotations(x = 0.5, y = 1.1, textangle = 0, font = list(size = 14, color = 'black'),
text = 'Contribution to accuracy',
showarrow = F, xref='paper', yref='paper')
p$elementId <- NULL
p <- p %>% config(displayModeBar = F)
p}
})
}
shinyApp(ui, server)
Not sure if this is what you want (it´s a bit weird that the plot updates with random numbers after selecting points ;-) ), but I hope it helps.
Instead of using a normal observer I use observeEvent that fires when selecting something in the plot. I generally prefer observeEvent to catch an event. This triggers an update ob a reactiveValues value, which will initially be NULL
library(shiny)
library(plotly)
library(dplyr)
library(data.table)
testDF <- data.table( MeanDecreaseAccuracy = runif(10, min = 0, max = 1), Variables = letters[1:10])
testDF$Selected <- T
ui <- fluidPage(
plotlyOutput('RFAcc_FP1', width = 450)
)
server <- function(input, output, session) {
values <- reactiveValues(val = NULL)
observeEvent(event_data("plotly_selected", source = 'RFAcc_FP1')$y, {
values$val <- runif(1, min = 0, max = 1)
})
RFImp_FP1 <- reactive({
RFImp_FP1 <- testDF
if(!is.null(values$val)) {
parsToChange <- event_data("plotly_selected", source = 'RFAcc_FP1')$y
RFImp_FP1 <- RFImp_FP1 %>% .[, Selected := if_else(Variables %in% parsToChange, 1-Selected, Selected)]
} else { }
# in real app the dataframe RFImp_FP1 is a part of a list with randomForest results,
RFImp_FP1
# RFImp_FP1$Selected <- if(!is.null(values$Selected)){
# values$Selected } else {1 }
})
output$RFAcc_FP1 <- renderPlotly({
RFImp_score <- RFImp_FP1()[order(MeanDecreaseAccuracy)]
plotheight <- length(RFImp_score$Variables) * 80
p <- plot_ly(data = RFImp_score,
source = 'RFAcc_FP1',
height = plotheight,
width = 450) %>%
add_trace(x = RFImp_score$MeanDecreaseAccuracy,
y = RFImp_score$Variables,
type = 'scatter',
mode = 'markers',
color = factor(RFImp_score$Selected),
colors = c('#1b73c1', '#797979'),
symbol = factor(RFImp_score$Selected),
symbols = c('circle','x'),
marker = list(size = 6),
hoverinfo = "text",
text = ~paste ('<br>', 'Parameter: ', RFImp_score$Variables,
'<br>', 'Mean decrease accuracy: ', format(round(RFImp_score$MeanDecreaseAccuracy*100, digits = 2), nsmall = 2),'%',
sep = '')) %>%
layout(
margin = list(l = 160, r= 20, b = 70, t = 50),
hoverlabel = list(font=list( color = '#1b73c1'), bgcolor='#f7fbff'),
xaxis = list(title = 'Mean decrease accuracy index (%)',
tickformat = "%",
showgrid = F,
showline = T,
zeroline = F,
nticks = 5,
font = list(size = 8),
ticks = "outside",
ticklen = 5,
tickwidth = 2,
tickcolor = toRGB("black")
),
yaxis = list(categoryarray = RFImp_score$Variables,
autorange = T,
showgrid = F,
showline = T,
autotick = T,
font = list(size = 8),
ticks = "outside",
ticklen = 5,
tickwidth = 2,
tickcolor = toRGB("black")
),
dragmode = "select"
) %>% add_annotations(x = 0.5,
y = 1.05,
textangle = 0,
font = list(size = 14,
color = 'black'),
text = "Contribution to accuracy",
showarrow = F,
xref='paper',
yref='paper')
p <- p %>% config(displayModeBar = F)
p
})
}
shinyApp(ui, server)

How to add Data markers in Waterfall chart in Plotly

I am trying to plot waterfall chart with the following code. The only issue I am facing currently is the data marker which is not at the correct place. I want the data marker to be just below the end of each bar.
source('./r_files/flatten_HTML.r')
library("plotly")
dataset <- data.frame(Category = c("Akash Jain","Ankit Jain","Pankaj Jain","Nitin Pandey","Gopal Pandit","Ramnath Agarwal"),
TH = c(-62,-71,-1010,44,-44,200))
#dataset <- data.frame(Category = Values$Category, TH = Values$TH)
#dataset <- as.data.frame(cbind(Values$Category,Values$TH))
dataset$Category = dataset$Category
dataset$TH = dataset$TH
dataset$SortedCategoryLabel <- sapply(dataset$Category, function(x) gsub(" ", " <br> ", x))
dataset$SortedCategory <- factor(dataset$SortedCategoryLabel, levels = dataset$SortedCategoryLabel)
dataset$id <- seq_along(dataset$TH)
dataset$type <- ifelse(dataset$TH > 0, "in", "out")
dataset$type <- factor(dataset$type, levels = c("out", "in"))
dataset$end <- cumsum(dataset$TH)
dataset$start <- c(0, head(dataset$end, -1))
Hover_Text <- paste(dataset$Category, "= ", dataset$TH, "<br>")
dataset$colors <- ifelse(dataset$type =="out","red","green")
g <- plot_ly(dataset, x = ~SortedCategory, y = ~start, type = 'bar', marker = list(color = 'rgba(1,1,1, 0.0)'), hoverinfo = 'text') %>%
add_trace(y = dataset$TH , marker = list(color = ~colors), hoverinfo = "text", text = Hover_Text ) %>%
layout(title = '',
xaxis = list(title = ""),
yaxis = list(title = ""),
barmode = 'stack',
margin = list(l = 50, r = 30, b = 50, t = 20),
showlegend = FALSE) %>%
add_annotations(text = dataset$TH,
x = dataset$SortedCategoryLabel,
y = dataset$end,
xref = "dataset$SortedCategoryLabel",
yref = "dataset$end",
font = list(family = 'Arial',
size = 14,
color = "black"),
showarrow = FALSE)
g
Attached the screenshot of the waterfall chart.
So for the first bar, I need the data marker to be just below the end of red bar. Currently it is overlapping with the bar. And similarly for others.
Any help would be really appreciated.
Regards,
Akash
You should specify valign and height inside add_annotations:
vert.align <- c("bottom","top")[as.numeric(dataset$TH>0)+1]
g <- plot_ly(dataset, x = ~SortedCategory, y = ~start, type = 'bar',
marker = list(color = 'rgba(1,1,1, 0.0)'), hoverinfo = 'text') %>%
add_trace(y = dataset$TH , marker = list(color = ~colors), hoverinfo = "text",
text = Hover_Text ) %>%
layout(title = '',
xaxis = list(title = ""),
yaxis = list(title = ""),
barmode = 'stack',
margin = list(l = 50, r = 30, b = 50, t = 20),
showlegend = FALSE) %>%
add_annotations(text = dataset$TH,
x = dataset$SortedCategoryLabel,
y = dataset$end,
xref = "x",
yref = "y",
valign=vert.align, height=40,
font = list(family = 'Arial',
size = 14,
color = "black"),
showarrow = FALSE)
g

Resources