I want to allow the users to see the changes in inputs to be reflected on the table directly. So as soon as the user changes numeric value for inputlower it should reflect the change in column lower_rate in the table and also multiply that value with low_val. Is this possible with observeEvent on numeric input change.
input_data <- data.frame(lower_rate = c (.5, .5, .5),
low_val = c(10,11,12),
upper_rate = c(1.5, 1.5, 1.5),
upp_val = c(20,21,22),
stringsAsFactors = FALSE)
ui <- shinyUI(
fluidPage(
titlePanel("Basic DataTable"),
# Create a new row for the table.
fluidRow(
column(12,
numericInput("low", label = h3("lower"), value = 0.5),
numericInput("up", label = h3("Upper"), value = 1.5),
dataTableOutput(outputId="table")
)
)
)
)
server <- shinyServer(function(input, output) {
d <- reactive({
input_data
})
dat <- reactiveValues(dat=NULL)
observe({
dat$dat <- d()
})
output$table <- renderDataTable({
dat$dat
})
})
shinyApp(ui=ui,server=server)```
I believe it would be best to edit the column value inside the reactive environment renderDataTable. The observe events are not needed. As long as you don't use the <<- notation to write to environment, this wont change the original data.
library(shiny)
library(data.table)
input_data <- data.frame(lower_rate = c(.5, .5, .5),
low_val = c(10,11,12),
upper_rate = c(1.5, 1.5, 1.5),
upp_val = c(20,21,22),
stringsAsFactors = FALSE)
ui <- shinyUI(
fluidPage(
titlePanel("Basic DataTable"),
# Create a new row for the table.
fluidRow(
column(12,
numericInput("low", label = h3("lower"), value = 0.5),
numericInput("up", label = h3("Upper"), value = 1.5),
dataTableOutput(outputId="table")
)
)
)
)
server <- shinyServer(function(input, output) {
output$table <- renderDataTable({
input_data$lower_rate <- input$low
#it is not clear where you want the multiplied value to end up
input_data$new_val <- input$low*input_data$low_val
data.table(input_data)
})
})
shinyApp(ui=ui,server=server)
Related
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)
I am building app where a user can make edits to a datatable and the hit a button to reflect the changes in a non-editable copy of this datatable (in the final project, I will need to have two datasets that need to be matched manually), but for now this small MWE shows the problem I have with making a copy of the reactive table in which changes can be made, without changing the data of the original reactive table. I would like to make this app work, where you click edit a cell in the table dat_joined$data/output$mytable and that those changes do reflect in a new table mydf$data/output$table2. To do mydf$data initially (before any changes are made) needs to be a copy of dat_joined$data This is a follow up on this question and answer: how to make a copy of a reactive value in shiny server function
library(shiny)
library(DT)
library(shinyWidgets)
library(tidyverse)
# create master dataframe
dat_total <- tibble(ID_1 = 1:10, names = letters[1:10],
ID_2 = 11:20, names_2 = LETTERS[c(3:5, 1, 2, 6:8, 10, 9)])
shinyApp(
ui = fluidPage(
title = 'Radio button and a dropdown manue ',
sliderInput("n_rows_table", "Number of rows:",
min = 0, max = 10,
value = 5),
actionBttn(
inputId = "button_1",
label = "Make tables",
size = "sm",
color = "warning"
),
DT::dataTableOutput("mytable"),
actionBttn(
inputId = "button_2",
label = "Process",
size = "sm",
color = "success"),
DT::dataTableOutput("table2")),
server = function(input, output, session) {
# set up reactive values
dat_left <- reactiveValues(data=NULL)
dat_right <- reactiveValues(data=NULL)
dat_joined <- reactiveValues(data=NULL)
# create reactive daraframe
dat <- eventReactive(input$button_1, {
dat_total[1:input$n_rows_table, ] %>%
rowid_to_column()})
# Split the data into a right and a left set
observe({
dat_left$data <- dat() %>%
select(rowid, ID_1, names)
})
observe({
dat_right$data <- dat() %>%
select(rowid, ID_2, names_2,ID_1)
})
# join these again
# This is needed because my actual app will
# be used to manually match 2 datasets
observe({
if (is.null( dat_right$data )) {
NULL
}else{
dat_joined$data <- left_join(dat_left$data,
dat_right$data,
by = "rowid")
}
})
# Print the the datasets
output$mytable <- renderDT({
datatable(dat_joined$data ,
rownames = F,
editable = "cell")
})
# I want to make a copy of the dat_joined$data dataset into dat$mydf
# none of these function as expected
#mydf <- reactiveValues(data=isolate(dat_joined$data))
#mydf <- reactiveValues(data=local(dat_joined$data))
#mydf <- reactiveValues(data=dat_joined$data)
#mydf <- reactiveValues(data=NULL)
# This works, but only saves the cells to w
mydf <- reactiveValues(data=matrix(NA, nrow=10, ncol = 5))
# Ideally the computation only happens when this both an edit is made
# and the button is pressed (now I need to press it between every edit)
# validate_event <- reactive({
# req(input$mytable_cell_edit) & req(input$button_2)
# })
#observeEvent(input$button_2validate_event(), { DOes not work
observeEvent(input$button_2,{
info = input$mytable_cell_edit
str(info)
i = info$row
j = info$col
v = info$value
mydf$data[i, j] <- DT::coerceValue(v, mydf$data[i, j])
})
# print
output[["table2"]] <- renderDT({
datatable(mydf$data)
})
}
)
Any changes you make in the top table is reflected in the bottom table after you press the button "Process". Try this
library(shiny)
library(DT)
library(shinyWidgets)
library(tidyverse)
# create master dataframe
dat_total <- tibble(ID_1 = 1:10, names = letters[1:10],
ID_2 = 11:20, names_2 = LETTERS[c(3:5, 1, 2, 6:8, 10, 9)])
shinyApp(
ui = fluidPage(
title = 'Radio button and a dropdown manue ',
sliderInput("n_rows_table", "Number of rows:",
min = 0, max = 10,
value = 5),
actionBttn(
inputId = "button_1",
label = "Make tables",
size = "sm",
color = "warning"
),
DT::dataTableOutput("mytable"),
actionBttn(
inputId = "button_2",
label = "Process",
size = "sm",
color = "success"),
DT::dataTableOutput("table2")),
server = function(input, output, session) {
# set up reactive values
dat_left <- reactiveValues(data=NULL)
dat_right <- reactiveValues(data=NULL)
dat_joined <- reactiveValues(data=NULL)
dfon <- reactiveValues(top=NULL,
bottom=NULL)
# create reactive daraframe
dat <- eventReactive(input$button_1, {
dat_total[1:input$n_rows_table, ] %>%
rowid_to_column()})
# Split the data into a right and a left set
observe({
req(dat())
dat_left$data <- dat() %>%
dplyr::select(rowid, ID_1, names)
})
observe({
req(dat())
dat_right$data <- dat() %>%
dplyr::select(rowid, ID_2, names_2,ID_1)
})
# join these again
# This is needed because my actual app will
# be used to manually match 2 datasets
observe({
req(dat())
if (!is.null( dat_right$data )) {
dat_joined$data <- left_join(dat_left$data,
dat_right$data,
by = "rowid")
}
})
observe({ ###assign your orig data to a reactiveValues object
req(dat_joined$data)
if (!is.null(dat_joined$data)) {
dfon$top <- dat_joined$data
}
})
# Print the the datasets
output$mytable <- renderDT({
datatable(dfon$top,
rownames = F,
editable = "cell")
})
# Ideally the computation only happens when this both an edit is made
# and the button is pressed (now I need to press it between every edit)
observeEvent(input$mytable_cell_edit, {
info = input$mytable_cell_edit
str(info)
#i = info$row
#j = info$col + 1 # offset by 1
#v = info$value
#dfon$top[i, j] <<- DT::coerceValue(v, dfon$top[i, j])
dfon$top <<- editData(dfon$top, info)
})
observeEvent(input$button_2,{
dfon$bottom <- dfon$top
output$table2 <- renderDT({
datatable(dfon$bottom)
})
})
## further editing of dfon$bottom is performed below...with...observeEvent(input$table2_cell_edit, {...
}
)
In the output below, I have entered cccc for 3rd element in names column, but I have not clicked on the button Process. Therefore, the edited cell is not reflected in the bottom table.
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().
Could anyone can tell me why I get an error when I change a dataset in first selectInput widget? When I change a dataset from diamonds to mtcars I get an error Could not find 'carat' in input$bins and in the plot just for one second and after that everything works fine. Why it happened?
library(shiny)
library(ggplot2)
data(diamonds)
data(mtcars)
ui <- fluidPage(
column(3,
selectInput("data", "", choices = c('mtcars', 'diamonds')),
uiOutput('server_cols'),
uiOutput('server_bins')
),
column(9,
plotOutput("plot")
)
)
server <- function(input, output) {
data <- reactive({
switch(input$data,
diamonds = diamonds,
mtcars = mtcars)
})
output$server_cols <- renderUI({
data <- data()
nam <- colnames(data)
selectInput('cols', "Choose numeric columns:", choices = nam[sapply(data, function(x) is.numeric(x))])
})
output$server_bins <- renderUI({
if (!is.null(input$cols)) {
df <- data()
x <- eval(input$cols)
max_value <- max(df[,x])
sliderInput('bins','Choose number of bins:', min = 0.1,
max = max_value,
value = max_value/2)
}
})
output$plot <- renderPlot({
if (!is.null(input$cols) & !is.null(input$bins)) {
basicData <- data()
var <- eval(input$cols)
ggplot(basicData, aes_string(var)) +
geom_histogram(binwidth = input$bins, color = 'white', fill = 'red')
}
})
}
shinyApp(ui, server)
Your respective output objects respond to any changes of your input variables. Thus, when you change your dataset via input$data, the plot rebuilds itself, although input$cols did not yet adjust. Actually, try inserting some print("a") inside the output$plot to see that it is called up to three times if you change input$data.
The fix is to rethink your reaction logic and let your elements respond only to specific changes, to get some kind of response "thread".
For example, input$data should only trigger output$server_cols. And output$server_bins should only be triggered by input$cols (because this already implies that input$data changed earlier). Ultimately, output$plot just has to listen to changes of input$bins (because changes in input$cols and input$data always result in changes of input$bins since it is at the end of the thread).
Here is my suggestion using isolate.
library(shiny)
library(ggplot2)
data(diamonds)
data(mtcars)
ui <- fluidPage(
column(3,
selectInput("data", "", choices = c('mtcars', 'diamonds')),
uiOutput('server_cols'),
uiOutput('server_bins')
),
column(9,
plotOutput("plot")
)
)
server <- function(input, output) {
data <- reactive({
switch(input$data, diamonds = diamonds, mtcars = mtcars)
})
output$server_cols <- renderUI({
data <- data()
nam <- colnames(data)
selectInput('cols', "Choose numeric columns:", choices = nam[sapply(data, function(x) is.numeric(x))])
})
output$server_bins <- renderUI({
if (!is.null(input$cols)) {
df <- isolate(data())
x <- eval(input$cols)
max_value <- max(df[,x])
sliderInput('bins','Choose number of bins:', min = 0.1, max = max_value, value = max_value/2)
}
})
output$plot <- renderPlot({
if (!is.null(isolate(input$cols)) & !is.null(input$bins)) {
basicData <- isolate(data())
var <- eval(isolate(input$cols))
ggplot(basicData, aes_string(var)) +
geom_histogram(binwidth = input$bins, color = 'white', fill = 'red')
}
})
}
shinyApp(ui, server)
You might also want to look into updateSelectInput and updateSliderInput if you want to alter Input Elements depending on other input.
I would like to update the matrix input based on user-input values for the first row when the button "fill matrix" is pushed. The matrix is updated correctly (as printed), but the input fields do not change accordingly. Any advice would be greatly appreciated!
ui.R
library(shiny)
library(shinyIncubator) #for matrixInput
df <- data.frame(matrix(c("0","0"), 1, 2))
colnames(df) <- c("Input1", "Input2")
shinyUI(
fluidPage(
matrixInput( inputId = "matrix",
label = "matrixLabels",
data = df),
actionButton(inputId = "fillMatrix", label = "Fill matrix"),
verbatimTextOutput(outputId = "matrix")
)
)
server.R
serverFunction <- function(input, output, session){
updateMatrixInput <- function(session, inputId, label = NULL, data = NULL) {
message <- list(label = label, data = data)
session$sendInputMessage(inputId, message)
}
observeEvent(input$fillMatrix, {
oldMatrix <- input$matrix
firstRow <- oldMatrix[1,]
currentProportions <- sum( oldMatrix[,2], na.rm = TRUE )
isMissing <- which( is.na(oldMatrix[,2]) )
nRows <- nrow(oldMatrix)
oldMatrix[2:nRows,1] <- firstRow[1]
oldMatrix[isMissing,2] <- (1 - currentProportions) / length(isMissing)
output$matrix <- renderPrint({ oldMatrix })
updateMatrixInput(session = session, inputId = "matrix",
label = "matrixLabels",
data = oldMatrix)
})
}
serverFunction