I'm aware of https://plot.ly/r/shinyapp-plotly-events/ and have been using it as a guide. But the ggplot element I'm converting to plotly is the output from the fviz_dend function of the factoextra package. Here's a minimum shiny app example I'm working with:
library(factoextra)
library(plotly)
library(shiny)
library(DT)
ui <- fluidPage(
plotlyOutput("ggp"),
verbatimTextOutput("selected_points"),
DT::dataTableOutput("filtered_table")
)
server <- function(input, output, session) {
## ggplot output
fviz <- fviz_dend(
x = hclust(dist(mtcars)),
k = 5,
show_labels = TRUE,
type = "phylogenic",
phylo_layout = "layout_as_tree",
color_labels_by_k = TRUE,
palette = "igv"
)
## convert to ggplotly
ggfviz <- ggplotly(fviz)
## add keys
for (i in seq(7, 11)) {
ggfviz[["x"]][["data"]][[i-5]][["key"]] <-
as.character(ggfviz[["x"]][["data"]][[i]][["text"]])
}
output$ggp <- renderPlotly({
ggfviz
})
output$selected_points <- renderPrint({
event_data("plotly_selected")[5]
})
output$filtered_table <- DT::renderDataTable(
mtcars[which(rownames(mtcars) == event_data("plotly_selected")[5]), ],
)
}
shinyApp(ui, server)
So I'm trying to use the key accessed with event_data("plotly_selected")[5] in order to filter the data table, and while event_data("plotly_selected")[5] does show the key per output$selected_points, it is somehow not passed to the datatable filter.
It looks like event_data will return a data frame with multiple rows. Instead of filtering with == you will need %in% instead to see which multiple cars are contained within the multiple possible selections from plotly_selected. In addition, even though you subset by column 5, you still have a data frame, and need to include the column key only for filtering (containing a vector of cars). This should work:
mtcars[which(rownames(mtcars) %in% event_data("plotly_selected")$key), ]
Or
mtcars[which(rownames(mtcars) %in% event_data("plotly_selected")[["key"]]), ]
I am making an R shiny app (I am quite new to R shiny) which gets data as an input and projects the data as a table (using DT package). However when new data is inserted and submitted new rows are not being added, but rather the previous observation (previous submitted data is simply updated. Thus, what can I do to make save the new data data ?
The main problem in your code was you were creating a new data frame and replacing it with the previous one. I have slightly modified your server code. I have added a global variable TabData to save the previous data in the data table and rbind it with the new data to be added to the table. Please see the modified code below:
library(shiny)
library(car) # Import library to use recode() function
shinyServer(function(input, output) {
#Global variable to save the previous data in the data table
TabData <- data.frame()
values <- reactiveValues()
# Calculate damage and loss (just ab experiment)
observe({
input$action_Calc
values$int <- isolate({input$reduction * 10})
values$amt <- isolate({input$lost}) + values$int
values$com<-isolate({input$community})
values$disaster <- isolate({input$disaster})
values$name <- isolate({input$name})
})
# Display values entered
output$text_principal <- renderText({
input$action_Calc
paste("reduction: ", isolate(input$reduction))
})
output$text_intrate <- renderText({
input$action_Calc
paste("Vegetation: ", isolate(input$veg))
})
output$text_int <- renderText({
if(input$action_Calc == 0) ""
else
paste("Damage:", values$int)
})
output$text_amt <- renderText({
if(input$action_Calc == 0) ""
else
paste("Loss:", values$amt)
})
Data <- reactive({
browser()
if (input$action_Calc > 0) {
df <- data.frame(
Community= values$com,
Disaster = values$disaster,
Name = values$name,
Damage=values$amt,
Loss=values$int
)
return(list(df=df))
}
})
output$responses <- DT::renderDataTable(DT::datatable({
if (is.null(Data())) {return()}
#Row bind the new data to be added to the table
TabData <<- rbind(TabData, Data()$df)
datum<-TabData
datum
}))
})
Hope it helps!
Im using R and shiny to query an SQL database. The user can search and add to a reactive data frame, the output of which is plotted in ggplot. However, I need to change the columns of the reactive data frames to factors for plotting. I can do this directly with ggplot (aes(factor(...), ). However, if I add the option of changing the plotted variable using a reactive input, I must use aes_string. If I use aes_string it does not like aes(factor(...),. Here is a working example:
Server:
# Create example data
set.seed(10)
MeasurementA <- rnorm(1000, 5, 2)
MeasurementB <- rnorm(1000, 5, 2)
Wafer <- rep(c(1:100), each=10)
ID <- rep(c(101:200), each=10)
Batch <- rep(c(1:10), each=100)
dd <- data.frame(Batch, Wafer, ID, MeasurementA, MeasurementB)
# Create local connection (in reality this will be a connection to a host site)
con <- dbConnect(RSQLite::SQLite(), ":memory:")
dbWriteTable(con, "dd", dd)
query <- function(...) dbGetQuery(con, ...)
# Create empty data frames to populate
wq = data.frame()
sq = data.frame()
shinyServer(function(input, output){
# create data frame to store reactive data set from query
values <- reactiveValues()
values$df <- data.frame()
# Action button for first query
d <- eventReactive(input$do, { input$wafer })
# First stage of reactive query
a <- reactive({ paste("Select ID from dd where Wafer=",d(), sep="") })
wq <- reactive({ query( a() ) })
# Output to confirm query is correct
output$que <- renderPrint({ a() })
output$pos <- renderPrint( wq()[1,1] )
# Action button to add results from query to a data frame
e <- eventReactive(input$do2, { wq()[1,1] })
b <- reactive({ paste("select Wafer, Batch, MeasurementA, MeasurementB from dd where ID=",e()," Order by ID asc ;", sep="") })
# observe e() so that data is not added until user presses action button
observe({
if (!is.null(e())) {
sq <- reactive({ query( b() ) })
# add query to reactive data frame
values$df <- rbind(isolate(values$df), sq())
}
})
# output of results
# Without mesurement choice (works)
output$boxV <- renderPlot({
ggplot(values$df, aes(factor(Wafer), MeasurementA, fill=factor(Batch))) + geom_boxplot()
})
# With measurement choice (doesnt work)
#output$boxV <- renderPlot({
#ggplot(values$df, aes_string(factor('Wafer'), input$char, fill=factor('Batch'))) + geom_boxplot()
#})
})
UI:
library(markdown)
shinyUI(fluidPage(
titlePanel("Generic grapher"),
sidebarLayout(
sidebarPanel(
numericInput("wafer", label = h3("Input wafer ID:"), value = NULL),
actionButton("do", "Search wafer"),
actionButton("do2", "Add to data frame"),
selectInput("char", label="Boxplot choice:",
choices = list("A"="MeasurementA", "B"="MeasurementB"),
selected="Von.fwd")
),
mainPanel(
verbatimTextOutput("que"),
verbatimTextOutput("pos"),
plotOutput("boxV")
)
)
)
)
Ive added output plot code for both working and non-working (non-working is commented out).
Now, ive read this (Formatting reactive data.frames in Shiny) and this (R shiny modify reactive data frame) but im confused. Because im using reactiveValues to store data, I use the code values$df to access the data...but what if i I want to turn a column to a factor for purpose of above? this doesnt seem to work:
new <- reactive(as.factor(values$df$Wafer))
Perhaps I am barking up the wrong tree with this?
Ok, I solved the problem by changing the data type within the query itself:
b <- reactive({ paste("select cast(Wafer as varchar) as Wafer, cast(Batch as varchar) as Batch, MeasurementA, MeasurementB from dd where ID=",e()," Order by ID asc ;", sep="") })
That way I didnt have to mess about afterwards. It works for me but if anyone reading this wants to tell me that its a bad idea, please do. Im new to SQL and R so please correct me so I can learn. Thanks
I have a dataframe df1, and subset it to df1sub and display it in an R shiny renderPlot() call. Similarly, I have df2, and I subset it to df2sub, and render it in R shiny via a separate renderPlot() call. Btw these subsets are created based on user choices in an R Shiny app.
Now, I have a datatable that I want to change to reflect whatever the current dataset is, so I wanted some kind of global like:
buffers[1] <- df1sub
buffers[2] <- df2sub
How would I go about defining this global var? I tried separately doing buffers = array() to initialize a global var but then the assignments as I wrote them above don't work?
Update: attempts to use the the '<<-' operator as suggested below yields the following:
buffers <- NULL #don't know how else to initialize. array() yields same error as below.
buffers[1] <<- df # Error in buffers[1] <<- df : object 'buffers' not found
You can adopt this approach:
library(shiny)
shinyServer(function(input, output) {
...
some.reactive.expression <- reactive1({
...
buffers[1] <<- df1sub
buffers[2] <<- df2sub
...
})
})
With some updates:
#In global.R
buffers <- list()
buffers[[1]] <- data.frame()
buffers[[2]] <- data.frame()
buffers[[1]] <- df1 #original dataset, as a default, before subsets are created
buffers[[2]] <- df2 #ditto.
Then in server.R:
r1 <- reactive({
... #create subset of df, then return it
buffers[[1]] <<- subset(...)
buffers[[1]] #return it as dynamic data for plots
})
r2 <- reactive({...}) #ditto
then in renderplot:
output$blah <- renderplot(r1()...)
output$foo <- renderplot(r2()...)
Leaving the global buffers[] var separately available to a 3rd UI widget (e.g. a data table)...
I'm trying to use a slider to control year in a longitudinal spatial data set, essentially a set of scatter plots. I can't figure out how to assign the slider to this variable - can you do this in ggvis?
A simplified data set:
data <- data.frame(year=rep(2000:2002, each=23),
x=rnorm(23*3,10), y=rnorm(23*3,10),
count=c(rnorm(23,2), rnorm(23,4), rnorm(23,6)))
What I've tried:
### This is what is looks like in ggplot2, I'm aiming to be able to toggle
### between these panels
ggplot(data, aes(x, y, size=count)) + geom_point() + facet_grid(~year)
### Here is where I'm at with ggvis
data %>%
ggvis(~x, ~y, size=~count) %>%
layer_points()
# I'm not sure how to assign a variable (year) to a slider, I've been trying
# within the layer_points() function
### I also tried using the props() function, but I don't fully understand
### how to use it.
data %>%
ggvis(~x, ~y, size=~count) %>%
layer_points() %>%
props(prop("fill", input_slider(min(data$year), max(data$year)))) #error message
Any help is appreciated!
I'm not sure if you want to use the slider to filter the data points (i.e. only show those points from the year selected on the slider), or to show the years in different colors according to the slider's value.
Case 1 (only display the points from a specific year)
data %>%
ggvis(~x, ~y, size=~count) %>%
layer_points(opacity=input_slider(min(data$year), max(data$year), step=1,
map=function(x) ifelse(data$year == x, 1, 0)))
Case 2 (highlight the selected years)
data %>%
ggvis(~x, ~y, size=~count) %>%
layer_points(fill=input_slider(min(data$year), max(data$year), step=1,
map=function(x) factor(x == data$year)))
EDIT2: How to simply wrap a left_right() function.
In the first edit I presented a solution that is not properly considered as wrapping.
I was interested in creating a wrapper of the reactive object returned by left_right(), avoiding modifying create_keyboard_event all together.
After reading the source code of ggvis more thoroughly and more on S4 objects in R,
I realized that yes, you can simply wrap a reactive object, as long as you preserve the broker class and its broker attribute appropriately.
This allows us to write more elegant code, like:
year_lr <- left_right(1997, 2002, value=2000, step=1)
year_wrapper <- reactive({
as.numeric(year_lr() == data$year)
})
class(year_wrapper) <- c("broker", class(year_wrapper))
attr(year_wrapper, "broker") <- attr(year_lr, "broker")
data %>%
ggvis(~x, ~y, size=~count) %>%
layer_points(opacity:=year_wrapper)
EDIT: How to create your own (modified) left_right() function
user3389288 asked me a good question, that since you don't have a map argument for left_right() function, how can you actually bind keyboard event to generate custom parameters. For example, in the context of this question, how can we tailor left_right() as a year filter?
If you dig into the source code of ggvis, you can see that left_right() is simply a thin wrapper function calling create_keyboard_event.
Hence we can create our own version of left_right(), or even h_j_k_l() say if you are fanatic about Vi.
But, here is a big but, if you dig one layer further to look at the implementation of create_keyboard_event, you will find that it is not quite suitable for our task.
This is because in order to show some of the dots, while hide others, we have to let left_right return a vector (that equals to the number of rows in data).
However, both left_right and create_keyboard_event are created with the assumption that the returned value (which is also the current state of the value modified by Left/Right key presses) is a scalar.
In order to separate the return value (vector) from the cached current state (scalar, i.e. the year), we have to create a slightly modified version of left_right() and create_keyboard_event.
Below is the source code that would work.
data <- data.frame(year=rep(1997:2002, each=12),
x=rnorm(24*3,10), y=rnorm(24*3,10),
count=c(rnorm(24,2), rnorm(24,4), rnorm(24,6)))
create_keyboard_event2 <- function(map, default.x = NULL, default.res = NULL) {
# A different version of ggvis::create_keyboard_event function:
# the major different is that the map function returns a list,
# list$x is the current value and list$res the result (returned to a ggvis prop).
# this seperation allows us to return a vector of different
# values instead of a single scalar variable.
if (!is.function(map)) stop("map must be a function")
vals <- shiny::reactiveValues()
vals$x <- default.x
vals$res <- default.res
# A reactive to wrap the reactive value
res <- reactive({
vals$res
})
# This function is run at render time.
connect <- function(session, plot_id) {
key_press_id <- paste0(plot_id, "_key_press")
shiny::observe({
key_press <- session$input[[key_press_id]]
if (!is.null(key_press)) {
# Get the current value of the reactive, without taking a dependency
current_value <- shiny::isolate(vals$x)
updated <- map(key_press, current_value)
vals$x <- updated$x
vals$res <- updated$res
}
})
}
ggvis:::connector_label(connect) <- "key_press"
spec <- list(type = "keyboard")
ggvis:::create_broker(res, connect = connect, spec = spec)
}
# a modified version of left_right. this closure encapsulates the
# data "year", allowing us to perform comparison of the current state of
# left_right (numeric year number) to the year vector.
left_right_year <- function(min, max, value = (min + max) / 2,
step = (max - min) / 40, year) {
# Given the key_press object and current value, return the next value
map <- function(key_press, current_value) {
key <- key_press$value
print(current_value)
if (key == "left") {
new_value <- pmax(min, current_value - step)
} else if (key == "right") {
new_value <- pmin(max, current_value + step)
} else {
new_value = current_value
}
list(x=new_value, res=as.numeric(year == new_value))
}
create_keyboard_event2(map, value, as.numeric(value==year))
}
# now with an additional argument, the data$year
alpha_by_year <- left_right_year(1997, 2002, value=2000, step=1, data$year)
data %>%
ggvis(~x, ~y, size=~count) %>%
layer_points(opacity:=alpha_by_year) # if you let left_right_year return
# a factor vector, you can use fill:=... as well
You can compare left_right_year and create_keyboard_event2 with their vanilla version counterparts.
For example, the original create_keyboard_event is:
create_keyboard_event <- function(map, default = NULL) {
if (!is.function(map)) stop("map must be a function")
vals <- shiny::reactiveValues()
vals$x <- default
# A reactive to wrap the reactive value
res <- reactive({
vals$x
})
# This function is run at render time.
connect <- function(session, plot_id) {
key_press_id <- paste0(plot_id, "_key_press")
shiny::observe({
key_press <- session$input[[key_press_id]]
if (!is.null(key_press)) {
# Get the current value of the reactive, without taking a dependency
current_value <- shiny::isolate(vals$x)
vals$x <- map(key_press, current_value)
}
})
}
connector_label(connect) <- "key_press"
spec <- list(type = "keyboard")
create_broker(res, connect = connect, spec = spec)
}
You can see that our modified version will not only cache the current state vals$x, but also the return vector vals$res.
The variable vals is a reactive value. The concept is borrowed from Shiny. You can check out this document about a high-level overview of reactive values and reactivity in general.
A question yet to be answered
Since vals$x is itself a reactive value. Intuitively, if
x <- left_right(1, 100, value=20, step=10)
then
y <- reactive(x() * 2)
should allow us to implement a quick map function.
However it doesn't work as expected. I am yet to figure out why exactly. If you know the answer, please kindly let me know!
UPDATED: c.f. EDIT2
The answers above are great. Definitively worth study. This is what I came up with for the original question for a quick fix.
Global.R:
library(shiny)
library(ggvis)
data<-data.frame(year=rep(2000:2002, each=23), x=rnorm(23*3,10), y=rnorm(23*3,10),
count=c(rnorm(23,2),rnorm(23,4),rnorm(23,6)))
ui.R:
shinyUI(bootstrapPage(
h3("Ploting Diferent Years Using a Slider",align="center"),
br(),
fluidRow(column(4,ggvisOutput("yearPlot"),offset=3)),
fluidRow(column(3,sliderInput("YearSelect", "Year: ",min=2000,max=2002,step=1,value=2000),offset=5))
))
Server.R:
shinyServer(function(input, output,session) {
plotdata <- reactive({
chosendat <- data[data$year==input$YearSelect, ]
names(chosendat) <- c("year","xvar","yvar","count")
return(chosendat)
})
vis1% ggvis(~xvar, ~yvar, size=~count) %>% layer_points()
})
vis1 %>% bind_shiny("yearPlot")
})