I would like to include a 3D dynamic (i.e. one can change its perspective just by moving the plot) histogram widget in a R Shiny application.
Unfortunately I didn't find any until now.
So far the results of my searches: with threejs (e.g. here on CRAN and there on GitHub) one can use many different representations (scatterplots, surfaces, etc.) but no 3D histogram. plot3D and plot3Drgl don't have any R Shiny counterpart.
Unless something already exists my intention is to create an HTMLWidget from one of the sub-libraries of vis.js, namely graph3d.
What are your views on this issue?
Best regards,
Olivier
It's possible with plot3Drgl. Here is an example.
library(plot3Drgl)
library(shiny)
options(rgl.useNULL = TRUE)
ui <- fluidPage(
rglwidgetOutput("myWebGL")
)
server <- function(input, output) {
save <- options(rgl.inShiny = TRUE)
on.exit(options(save))
output$myWebGL <- renderRglwidget({
try(rgl.close())
V <- volcano[seq(1, nrow(volcano), by = 5),
seq(1, ncol(volcano), by = 5)] # lower resolution
hist3Drgl(z = V, col = "grey", border = "black", lighting = TRUE)
rglwidget()
})
}
shinyApp(ui, server)
My package graph3d is on CRAN now.
library(graph3d)
dat <- data.frame(x = c(1,1,2,2), y = c(1,2,1,2), z = c(1,2,3,4))
graph3d(dat, type = "bar", zMin = 0, tooltip = TRUE)
You can customize the tooltips:
graph3d(dat, type = "bar", zMin = 0,
tooltip = JS(c("function(xyz){",
" var x = 'X: ' + xyz.x.toFixed(2);",
" var y = 'Y: ' + xyz.y.toFixed(2);",
" var z = 'Z: ' + xyz.z.toFixed(2);",
" return x + '<br/>' + y + '<br/>' + z;",
"}"))
)
I realize I have to add an option to control the size of the axes labels...
Many thanks, DSGym. I didn't know this library.
In my initial message (now amended) I actually forgot to mention the dynamic feature, i.e. the ability to change the perspective of the plot just by moving it with the mouse, like with vis.js-graph3d.
It seems plots from highcharter cannot do that, or am I mistaken?
[EDIT]: I just checked with Shiny: it is static.
Related
So I'm working on a Shiny dashboard, which I deployed on an AWS EC2 instance. It behaves exactly the same both locally and online save for one detail: the labels on the right hand side do not behave properly!
Here is the online version of the Plotly Sankey diagram in question:
Here is what I see locally when I run the app through RStudio.
There's absolutely no difference among any files. I don't see why the rendering of the labels should differ on both versions, but anyway, here's the relevant part of the code inside server.R:
# gender_sankey
nodes <- c('Hombres', 'Mujeres', unique(gender_df$UltimoGradoEstudios))
nodes <- nodes[c(1,2,4,3,5,7,12,10,8,6,11,9)]
gender_df$count <- 1
hom_stud <- aggregate(count ~ UltimoGradoEstudios, FUN = sum,
data = gender_df[gender_df$hom == 1,])
muj_stud <- aggregate(count ~ UltimoGradoEstudios, FUN = sum,
data = gender_df[gender_df$muj == 1,])
# Setting the sources and targets
hom_stud$src <- 0
muj_stud$src <- 1
hom_stud$tgt <- c(2,4,3,11,5,8,6,9,7)
muj_stud$tgt <- c(2,4,3,11,5,8,10,6,9,7)
# Setting the positions for the nodes
node_x <- c(0,0,1,1,1,1,1,1,1,1,1,1)
node_y <- c(0,1,-10:-1) # NOTE: Probably one of the fishy parts (2/2)
colors <- c('#C7FFA9','#E4A9FF','#2424FF','#2477FF','#248EFF','#249FFF',
'#24B3FF','#24C7FF','#24DEFF','#24F8FF','#24FFF8','#24FFEE')
# NOTE: Probably one of the fishy parts (1/2)
# Button to select/de-select all
observe({
if (input$selectall_sankey > 0) {
if (input$selectall_sankey %% 2 == 0){
updateCheckboxGroupInput(session = session,
inputId = "schoolSelect",
choices = list("Doctorado" = 'Doctorado',
"Maestría" = 'Maestría',
"Licenciatura" = 'Licenciatura',
"Pasante/Licenciatura trunca" = 'Pasante/Licenciatura trunca',
"Profesor Normalista" = 'Profesor Normalista',
"Técnico" = "Técnico",
"Preparatoria" = "Preparatoria",
"Secundaria" = 'Secundaria',
"Primaria" = "Primaria",
"No disponible" = 'No disponible'
),
selected = c(choices = list("Doctorado" = 'Doctorado',
"Maestría" = 'Maestría',
"Licenciatura" = 'Licenciatura',
"Pasante/Licenciatura trunca" = 'Pasante/Licenciatura trunca',
"Profesor Normalista" = 'Profesor Normalista',
"Técnico" = "Técnico",
"Preparatoria" = "Preparatoria",
"Secundaria" = 'Secundaria',
"Primaria" = "Primaria",
"No disponible" = 'No disponible'
))
)
} else {
updateCheckboxGroupInput(session = session,
inputId = "schoolSelect",
choices = list("Doctorado" = 'Doctorado',
"Maestría" = 'Maestría',
"Licenciatura" = 'Licenciatura',
"Pasante/Licenciatura trunca" = 'Pasante/Licenciatura trunca',
"Profesor Normalista" = 'Profesor Normalista',
"Técnico" = "Técnico",
"Preparatoria" = "Preparatoria",
"Secundaria" = 'Secundaria',
"Primaria" = "Primaria",
"No disponible" = 'No disponible'
),
selected = c())
}}
})
# Plot
output$gender_sankey <- renderPlotly({
hom_stud <- hom_stud[hom_stud$UltimoGradoEstudios %in% input$schoolSelect,]
muj_stud <- muj_stud[muj_stud$UltimoGradoEstudios %in% input$schoolSelect,]
node_x <- c(node_x[hom_stud$UltimoGradoEstudios %in% input$schoolSelect])
node_y <- c(node_y[hom_stud$UltimoGradoEstudios %in% input$schoolSelect])
colors <- c(colors[hom_stud$UltimoGradoEstudios %in% input$schoolSelect])
fig <- plot_ly(
type = "sankey",
orientation = "h",
arrangement = 'snap',
node = list(
label = nodes,
color = colors,
x = node_x,
y = node_y,
pad = 15,
thickness = 20,
line = list(
color = "black",
width = 0.5
)
),
link = list(
source = c(hom_stud$src, muj_stud$src),
target = c(hom_stud$tgt, muj_stud$tgt),
value = c(hom_stud$count, muj_stud$count)
)
)
fig <- fig %>% layout(
font = list(
size = 10
)
) %>% config(modeBarButtons = list(list('toImage'), list('resetScale2d')), displaylogo = F)
})
Packages used: shiny, shinydashboard, shinythemes and plotly (same versions both locally and on server). dplyr, magrittr, and ggplot2 are on the same version as well.
R version in my computer is 4.0.2, R version in the server is 3.6.3
It's not the cleanest implementation, specially on the button part, but it works perfectly locally! Note that I marked the sketchy practices I used, and where the problem could lie. Basically the default node order wasn't cutting it because the position on the right hand side itself contains information (Doctorado > Maestría > Licenciatura> ...), so I kind of forced a different order for the nodes through node_x and node_y. The thing is, the implementation works locally! What could be the reason for it not to work online?
I'm wondering if i can change the background-color of the plot or at least make it transparent allowing to inherit its parent background ,
I have tried that :
ui:
plotOutput("scatterChart",
width = "80%",
height = "294px")
server:
output$scatterChart <- renderPlot({
par(bg = "yellow")
plot(rules(), col = rainbow(25), cex = input$cex)
})
as shown here : https://stat.ethz.ch/pipermail/r-help/2003-May/033971.html
but nothing changed .
I tried that with css :
#scatterChart{
background-color:red}
i didn't get the expected result .
or :
.shiny-plot-output{
background-color:red
}
that change the entire div background and i even can't see the plot itself(i was exepecting that ).
Here is a picture :
demo
EDITED :
Based on the example that thothal gives me , i discover that the problem was on the data passed to the plot function (it just some association rules obtained using Apriori algorithm) :
rules <- reactive({
head(read.csv(input$file$datapath), input$visualization)
transactions = read.transactions(
file = file(input$file$datapath),
format = "basket",
sep = ","
)
minValue <- min(length(transactions),input$visualization)
rules <-
apriori(transactions[0:minValue],
parameter = list(
support = input$min_supp,
confidence = input$min_conf
))
return(rules)
})
Any suggestions or advice would be appreciated. Thanks.
Actually you can simply change the background color of you plot like this
library(shiny)
ui <- fluidPage(plotOutput("p"), actionButton("go", "Go"))
server <- function(input, output) {
output$p <- renderPlot({
input$go
par(bg = "navyblue")
x <- rnorm(100)
plot(x, 5 * x + rnorm(100, sd = .3), col = "white")
})
}
shinyApp(ui, server)
This produces the following plot on my machine:
As you tried the very same, I was wondering what happens if you try to create the plot outside shiny does it show (with the respective par call) a colorful background?
Maybe some other settings in you app may override this behaviour. Can you try to run my code and see what happens?
If you use another plotting library (ggplot for instance) you have to adapt and use
theme(plot.background = element_rect(...), # plotting canvas
panel.background = element_rect(...)) # panel
Update
It turns out that the culprit is arulesViz:::plot.rules, which is grid based and ignores settings set via par. To get a colored background we have to add a filled rect to the right viewport.
I forked the original repo and provided a quick fix of that:
devtools::install_github("thothal/arulesViz#add_bg_option_scatterplot")
data(Groceries)
rules <- apriori(Groceries, parameter=list(support=0.001, confidence=0.8))
## with my quick fiy you can now specify a 'bg' option to 'control'
plot(rules, control = list(bg = "steelblue")
We can use bg argument inside renderPlot:
output$plot1 <- renderPlot({
# your plot
}, bg = "red")
I have a xts object that has dates as values, I'm using ggplot2 and shiny app for show the result.
But I want to change the default names of the tooltip when the mouse is on the line.
From:
index: 2020-03-19
value: 70
To:
Date: 2020-03-19
Cantidad: 70
Code for XTS:
data<-rnorm(10)
dates <- seq(as.Date("2016-01-01"), length =10, by = "days")
xtsMyData <- xts(x = data, order.by = dates)
Plot:
r <- ggplot(tidy(xtsMyData), aes(x=index,y=value, color=series, type = 'scatter', mode = 'lines')
) + geom_line(size=2)
The result is:
I'm triyng the following code:
r <- ggplot(tidy(xtsMyData), aes(x=index,y=value, color=series, type = 'scatter', mode = 'lines')
) + geom_line(size=2)
return(ggplotly(r, tooltip = **c("x","y", "series" )**) %>% plotly::config(displayModeBar = T) %>%
layout(legend = list(orientation = "h", x = 0.4, y = -0.2)))
And the result is:
How can I change the tooltip? Can I add words? I tried with paste("Dates","x") but doesn't work.
Thanks for your help.
You can use text in style to change the hover text.
The plotly object will have values accessible through a list as below. The date values will need to be converted with as.Date.
Edit: The code includes a full shiny app as a demo.
library(xts)
library(shiny)
data<-rnorm(10)
dates <- seq(as.Date("2016-01-01"), length =10, by = "days")
xtsMyData <- xts(x = data, order.by = dates)
ui <- fluidPage(
plotlyOutput("myplot")
)
server <- function(input, output, session) {
output$myplot <- renderPlotly({
r <- ggplot(tidy(xtsMyData), aes(x=index,y=value, color=series, type = 'scatter', mode = 'lines')) +
geom_line(size=2)
r <- ggplotly(r) %>%
plotly::config(displayModeBar = T) %>%
layout(legend = list(orientation = "h", x = 0.4, y = -0.2))
r %>%
style(text = paste0("Date:", as.Date(r$x$data[[1]]$x),
"</br></br>",
"Cantidad:", r$x$data[[1]]$y))
})
}
shinyApp(ui, server)
Plot
The first answer gave me the idea to change manually all, because I had 2 different geom_lines and that didn't work for me , this labels are stored in r$x$data[[1]]$text (the following line plots are in r$x$data[[2]]$text,r$x$data[[3]]$text... ), so, if you use an gsub, you could change everything you want, it's very dumb but it works. (You can use the same philosophy to delete the last label, manipulating strings)
I put an example for your problem, despite you already solve it, other person could have more than one line plot.
r$x$data[[1]]$text<-gsub(r$x$data[[1]]$text,pattern='index', replacement='Fecha')
r$x$data[[1]]$text<-gsub(r$x$data[[1]]$text,pattern='value', replacement='Valor')
r$x$data[[1]]$text<-gsub(r$x$data[[1]]$text,pattern='series', replacement='Serie')
I am using nPlot, my X-axis is Date variable, I want this to just Date as in my data 'YYYY-MM-DD', tilted vertically (90 degrees). I want nPlot show the chart stacked by default. Please help me out.
output$testChart = renderChart({
testChart = nPlot(Count~Date, data = df, group = 'Category',
type = 'multiBarChart')
testChart$chart(reduceXTicks = F)
testChart$xAxis(staggerLabels = T)
testChart$chart(stacked = T)
testChart$xAxis(tickFormat = "#! d3.time.format('%Y-%m-%d') !#")
return(testChart)
})
and in server.R
output$mytabs = renderUI({
tabs = tabsetPanel(
tabPanel('Tab1', h5("Tab1"),
fluidRow(showOutput("testChart"))
)
)
mainPanel(tabs)
})
in ui.R
uiOutput('mytabs')
Suppose that you stored your plot in the object n1. Here is how you can customize it do what you seek.
n1$chart(stacked = TRUE)
n1$xAxis(
tickFormat = "#! d3.time.format('%Y-%m-%d') !#",
rotateLabels = 90
)
n1
I have no way to verify that this works. So I would suggest that you post your data and the code that you used to generate this plot. Doing so, even this works for you, would be useful as it would help others who come across this question.
I am trying to develop pictorial charts. Is it possible to develop such charts in R ?
myd <- data.frame (categories = c("Planes", "Ships", "Cars", "Trains"),
values = c(15, 18, 22, 11))
Component icons are here:
Hope that this would be helpful four your house / parliament floor
Edit: I forget to mention my reference and I add some explanations.
library(lattice)
library(grid)
imgs.names <- c('WNinq','7dqJM','9E3Wj','tStmx')
library(png)
images <- lapply(imgs.names, function(x)
readPNG(paste(mypath,x,'.png',sep=''),native=TRUE))
## I generate some data because we don't give a reproducible example
x <- c(rep(0,4),rep(10,9),rep(20,3),rep(5,8),rep(4,8),rep(15,4),rep(13,8))
barchart(1:4~x, origin=0, col="yellow",xlim=c(0,30),
xlab ='values',ylab='categories',title = 'Pictorial',
scales = list(
y = list(cex=2,col='blue', at = 1:4,labels = c('Trains','Cars','Ships','Planes')),
x = list(cex=2,col='blue',at=seq(0,30,by=10))
),
panel=function(x, y, ...) {
panel.fill(col = rgb(1,1,205/255)) ## I had to pick up the same yellow color!!
panel.grid()
lapply(1:4,function(id){
grid.raster(images[[id]], x=x[which(y==id)], y=y[which(y==id)],
default.units="native",
just="left",
width =unit(2, "native"),
height=unit(0.7, "native"))
}
)
}
)