Trying to edit a reactive database so that updates to the database are reflected in the output.
Have tried numerous variants, but none are working, general idea is shown - where I would like to have the figure update with changes to the database.
library(tidyverse)
library(shiny)
library(DT)
# Define UI for application that draws a histogram
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput("ages", "Max age:", 10, 100, 15),
sliderInput("nsamp",
"Sample size:",
min = 10,
max = 1000,
value = 100)),
mainPanel(dt_output('Sample sizes and weighting', 'x1'),
plotOutput("fig"))
)
)
server <- function(input, output) {
x = reactive({
df = data.frame(age = 1:input$ages,
samples = input$nsamp,
weighting = 1)
})
output$x1 = renderDT(x(),
selection = 'none',
editable = TRUE,
server = TRUE,
rownames = FALSE)
output$fig = renderPlot({
ggplot(x(), aes(age, samples)) +
geom_line() +
geom_point()
})
}
shinyApp(ui = ui, server = server)
We can use input$x1_cell_edit and reactiveValues to modify the data that is passed to the plot.
Note the use of isolate inside renderDT, that is to prevent the table from re-rendering when db$database is modified.
library(tidyverse)
library(shiny)
library(DT)
# Define UI for application that draws a histogram
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput("ages", "Max age:", 10, 100, 15),
sliderInput("nsamp",
"Sample size:",
min = 10,
max = 1000,
value = 100
)
),
mainPanel(
dataTableOutput("x1"),
plotOutput("fig")
)
)
)
server <- function(input, output) {
# all the data will be stored in this two objects
db <- reactiveValues(database = NULL)
# to store the modified values
edited_vals <- reactiveVal(tibble(row = numeric(), col = numeric(), value = numeric()))
# create a new table each time the sliders are changed
observeEvent(c(input$ages, input$nsamp), {
df <- data.frame(
age = 1:input$ages,
samples = input$nsamp,
weighting = 1
)
db$database <- df
})
observeEvent(input$x1_cell_edit, {
db$database[as.numeric(input$x1_cell_edit$row), as.numeric(input$x1_cell_edit$col + 1)] <- as.numeric(input$x1_cell_edit$value)
})
output$x1 <- renderDT(
{
input$ages
input$nsamp
datatable(
isolate(db$database),
selection = "none",
editable = TRUE,
rownames = FALSE,
options = list(stateSave = TRUE)
)
},
server = TRUE
)
output$fig <- renderPlot({
ggplot(db$database, aes(as.numeric(age), as.numeric(samples))) +
geom_point() +
geom_line()
})
}
shinyApp(ui = ui, server = server)
Related
A small example shiny app:
library(shiny)
library(tidyverse)
library(DT)
ui <- fluidPage(
# Application title
titlePanel("blah"),
sidebarLayout(
sidebarPanel(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30)
),
# Show a plot of the generated distribution
mainPanel(
DT::DTOutput('ex_table')
)
)
)
server <- function(input, output) {
output$ex_table <- DT::renderDataTable(mtcars %>% select(cyl) %>% mutate(blah = cyl + 2),
selection = 'none', editable = TRUE)
}
# Run the application
shinyApp(ui = ui, server = server)
If you run that it looks like:
You can edit the cells since I added editable = TRUE within renderDataTable().
My table that feeds the datatable has the line:
mtcars %>% select(cyl) %>% mutate(blah = cyl + 2)
So feature 'blah' should always be whatever is in cyl + 2. In the screen shot I added 10,000, so desired output would be for the datatable to update to show 10,002 after hitting enter.
Is this possible? How can I do this?
You could follow these examples.
Try :
library(shiny)
library(tidyverse)
library(DT)
ui <- fluidPage(
# Application title
titlePanel("blah"),
sidebarLayout(
sidebarPanel(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30)
),
# Show a plot of the generated distribution
mainPanel(
DT::DTOutput('modtable'),
)
)
)
server <- function(input, output,session) {
data <- mtcars %>% select(cyl) %>% mutate(blah = cyl + 2)
output$modtable <- DT::renderDT(data, selection = 'none', editable = TRUE)
proxy = dataTableProxy('modtable')
observeEvent(input$modtable_cell_edit, {
info = input$modtable_cell_edit
str(info)
i = info$row
j = info$col
v = info$value
data <<- editData(data, info)
if(j==1){data[i,j+1]<<-as.numeric(data[i,j])+2}
replaceData(proxy, data, resetPaging = FALSE)
})
}
# Run the application
shinyApp(ui = ui, server = server)
Good morning,
in my dashboard I inserted a checkbox to select one or more output to display. In the ui I entered the checkbox and in the server all the conditions (if ... else if ...). When I launch the app it only shows me a plot, even when I select more than one choice in the checkbox. In addition it gives me this error in console:
"Warning in if (input$checkGroup == 1) { :the condition has length > 1 and only the first element will be used"
I suppose it's telling me that I can't handle more than one choice, how do I view all the plots I choose?
ui <- fluidPage(titlePanel("IULM Dashboard"), sidebarLayout(sidebarPanel(
selectInput("selection", "Choose a Dataset:",
choices = datasets),
("Barplot","Network",'Wordcloud', "LDA-Latent topic"),
#selected = "Barplot", inline = TRUE),
checkboxGroupInput("checkGroup", label = ("Checkbox group"),
choices = list("Barplot" = 1, "Network" = 2), selected = 1, inline = TRUE),
actionButton("update", "Change"))
, mainPanel(
uiOutput("plot")))
server <- function(input, output){
datasetInput <- reactive({
input$update
isolate({
withProgress({
setProgress(message = "Processing corpus...")
getTermMatrix(input$selection)
})
})
})
output$plot <- renderUI({
if(input$checkGroup== 1 ){
output$barplot <- renderPlot({
v=datasetInput()
dtm1 = removeSparseTerms(v, 0.992)
freq <- colSums(as.matrix(dtm1))
wf = data.frame(term = names(freq), occurrences = freq)
wf <- wf[order(wf$occurrences, decreasing = TRUE),]
wf2 = subset(wf[1:input$maxB,])
ggplot(wf2, aes(term, occurrences)) +
geom_bar(stat="identity", fill="darkred", colour="black", width=0.5)+
theme(axis.text.x=element_text(angle=45, hjust=1))+
ggtitle("Word barplot")})
plotOutput(outputId = "barplot", width = 600, height = 400)
}
else if(input$checkGroup== 2 ){
output$network <- renderPlot({
v=datasetInput()
dtm1 = removeSparseTerms(v, 0.992)
rowTotals <- apply(dtm1 , 1, sum)
dtm2 <- dtm1[rowTotals> 0, ]
wdtm <- weightTf(dtm2)
dtm1 <- removeSparseTerms(wdtm, 0.96)
dfm <- as.dfm(dtm1)
textplot_network(dfm, min_freq = 0.5, omit_isolated = TRUE,
edge_color = "#1F78B4", edge_alpha = 0.5, edge_size = 2,
vertex_color = "#4D4D4D", vertex_size = 2,
vertex_labelsize = 5, offset = NULL)})
plotOutput(outputId = "network", width = 600, height = 600)}
})
}
shinyApp(ui = ui, server = server)
You can try
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
checkboxGroupInput("variable", "Variables to show:",
c("Cylinders" = "cyl",
"Transmission" = "am",
"Gears" = "gear"))
),
mainPanel(
uiOutput("plots")
)))
server <- function(input, output) {
output$plots <- renderUI({
req(input$variable)
output = tagList()
if(any(input$variable %in% "cyl")){
tmp <- mtcars$cyl
output[[1]] <- renderPlot({plot(mtcars$mpg, tmp)})
}
if(any(input$variable %in% "am")){
tmp <- mtcars$am
output[[2]] <- renderPlot({boxplot(mtcars$mpg, tmp)})
}
output
})
}
shinyApp(ui = ui, server = server)
I try to use a workaround for the highcharter package to update the chart and not to rerender it which looks much smoother. So far, my functions works fine as long as I run the code in a seperate JS file. But to make it more flexible I want to write with function with R. When I click the input$data button, the code seems to run as many times as the value input$data has got (see the print statement). Why is this happening and what can I do to prevent this issue?
library(highcharter)
library(shiny)
library(shinyjs)
df <- data.frame(
a = floor(runif(10, min = 1, max = 10)),
b = floor(runif(10, min = 1, max = 10))
)
updaterfunction <- function() {
jscode <-
'$("#data").on("click",function() {
console.log("code was run")
Shiny.addCustomMessageHandler("handler1", function(message1){
var chart1 = $("#plot").highcharts()
var newArray1 = new Array(message1.length)
var newArray2 = new Array(message1.length)
for(var i in message1) {
newArray1[i] = message1[i].a
newArray2[i] = message1[i].b
}
chart1.series[0].update({
// type: "line",
data: newArray1
}, false)
chart1.series[1].update({
// type: "line",
data: newArray2
}, false)
chart1.redraw();
})
});'
runjs(jscode)
}
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("Old Faithful Geyser Data"),
#includeScript("www/script.js"),
useShinyjs(),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30),
actionButton("data2", "Generate Data"),
actionButton("data", "Generate Data")
),
# Show a plot of the generated distribution
mainPanel(
highchartOutput("plot"),
highchartOutput("plot2")
)
)
)
server <- function(input, output, session) {
observeEvent(input$data, {
print(input$data)
df <- data.frame(
a = floor(runif(10, min = 1, max = 10)),
b = floor(runif(10, min = 1, max = 10))
)
message1 = jsonlite::toJSON(df)
session$sendCustomMessage("handler1", message1)
updaterfunction()
})
reactivedata <- eventReactive(input$data2, {
df <- data.frame(
a = floor(runif(10, min = 1, max = 10)),
b = floor(runif(10, min = 1, max = 10))
)
})
output$plot <- renderHighchart({
highchart() %>%
hc_add_series(type = "bar", data = df$a) %>%
hc_add_series(type = "bar", data = df$b)
})
output$plot2 <- renderHighchart({
highchart() %>%
hc_add_series(type = "bar", data = reactivedata()$a) %>%
hc_add_series(type = "bar", data = reactivedata()$b)
})
}
# Run the application
shinyApp(ui = ui, server = server)
That's because each time you run the JS code, it attaches a new click event to the button. You can use off("click") to remove the previous event handler:
jscode <-
'$("#data").off("click").on("click",function() {
But I'm not sure this produces the expected behaviour. Is it ?
I was wondering if I can get rows data using nearPoints() from an interactive graph with slider input. My app.R file looks like:
library('shiny')
library('ggplot2')
dt <-read.csv('file.csv')
ui <- fluidPage(
plotOutput("plot1", height = 550, click = "plot1_click"),
fluidRow(
column(3,
sliderInput("Obs", "Number of Books", min = 1, max = nrow(up), value = 50)
),
column(3, offset = 3,
h4("Legends"),
verbatimTextOutput("selected")
)
)
)
server <- function(input, output) {
mydata <- reactive({
dt[1:as.numeric(input$Obs),]
})
output$plot1 <- renderPlot({
test <- mydata()
ggplot(data = test, aes(x = test[,2], y = test[,1])) + geom_point()
})
output$selected <- renderPrint({
file <- mydata()
nearPoints(file, input$plot1_click, threshold = 10, maxpoints = 1,
addDist = FALSE)
})
}
shinyApp(ui = ui, server = server)
Shiny nearPoints() is working perfectly without this slider input. When I used slider input, I can't get the row data until max. Is there any approach to work with the slider input? Any help is appreciated.
The following code works for me. It seems nearPoints is not able to tell which columns of your dataset are displayed because of the aes(x = test[,2], y = test[,1]) statement. Another possible fix sould be to set the parameters xvar and yvar in nearPoints.
library('shiny')
library('ggplot2')
dt <-mtcars
ui <- fluidPage(
plotOutput("plot1", height = 550, click = "plot1_click"),
fluidRow(
column(3,
sliderInput("Obs", "Number of Cars", min = 1, max = nrow(dt), value = 50)
),
column(3, offset = 3,
h4("Legends"),
verbatimTextOutput("selected")
)
)
)
server <- function(input, output) {
mydata <- reactive({
dt[1:as.numeric(input$Obs),]
})
output$plot1 <- renderPlot({
test <- mydata()
ggplot(data = test, aes(mpg, wt)) + geom_point()
})
output$selected <- renderPrint({
file <- mydata()
nearPoints(file, input$plot1_click, threshold = 100, maxpoints = 1,
addDist = FALSE)
})
}
shinyApp(ui = ui, server = server)
Quick note: Please try to make the code in your question reproducible by using one of the default datasets in R. You can get a list of all available datasets by calling data().
I am trying to generate a table/list in Shiny of the values sampled from a probability distribution ( a list of the sampled values in a table format). I'm new to coding so this is like a foreign language to me. There is probably a lot of errors in the code although I can get it to run just not show the table.
library(shiny)
ui <- fluidPage(
sidebarPanel(
selectInput("dis","Please Select Probability Distribution Type:",
choices = c("Normal")),
sliderInput("sampleSize","Please Select Sample Size:",
min = 0,max = 5000,value = 1000,step = 100),
sliderInput("bins","Please Select Number of Bins:",
min = 1,max = 50,value = 10),
numericInput("sampleMean","Please Enter Sample Mean:",
min = 0,max = 5000,value = 2500,step = 10),
numericInput("sampleSd","Please Enter Standard Deviation:",
min = 0,max = 5000,value = 2,step = 10)
),
fluidRow(
column(12,
dataTableOutput("table"))
),
mainPanel(
plotOutput("histogram")
)
)
server <- function(input, output){
output$histogram <- renderPlot({
distType <- input$dis
n <- input$sampleSize
bins <- seq(min(input$bins), max(input$bins), length.out = input$bins + 1)
if(distType=="Normal"){
randomVec <- rnorm(n,mean = as.numeric(input$sampleMean),sd=as.numeric(input$sampleSd))
}
hist(randomVec,breaks=input$bins,col="red")
})
output$table <- renderDataTable({
distType <- input$dis
n <- input$sampleSize
if(distType=="Normal"){
randomVec <- rnorm(n,mean = as.numeric(input$sampleMean),sd= as.numeric(input$sampleSd))
}
sample(randomVec,100,replace = TRUE)
})
}
shinyApp(ui = ui, server = server)
From ?renderDataTable :
Arguments
expr An expression that returns a data frame or a matrix.
So you can do this:
output$table <- renderDataTable({
distType <- input$dis
n <- input$sampleSize
if(distType=="Normal"){
randomVec <- rnorm(n,mean = as.numeric(input$sampleMean),sd= as.numeric(input$sampleSd))
}
data.frame(sample(randomVec,100,replace = TRUE))
})