Related
The below "MWE code 1" works as intended. It interpolates the values the user inputs into the matrix (id = input2) over the slider input periods (id = input1). Additional scenarios are generated with the click of the single action button which triggers a modal (for later purposes). For illustrative purposes, each scenario is linearly adjusted by a random variable.
I'm trying to adapt the above where additional user inputs into the matrix (always in column groupings of 2, for the 2 values to interpolate) are automatically added to the results function and plotted, without clicking the action button.
The below "MWE code 2" is my beginning of this implementation, and I end at my current knowledge. (Note the input matrix which expands in groups of 2 columns, and the elimination of the runif() inflator since presumably each added scenario will be different). How can I modify MWE code 2 to accomplish this? I am stuck.
MWE code 1:
library(shiny)
library(tidyverse)
library(ggplot2)
library(shinyMatrix)
interpol <- function(a,b){ # a = periods, b = matrix inputs
c <- rep(NA,a)
c[1] <- b[1]
c[a] <- b[2]
c <- approx(seq_along(c)[!is.na(c)],c[!is.na(c)],seq_along(c))$y # this interpolates
return(c)}
ui <- fluidPage(
sliderInput('input1','Periods to interpolate (input1):',min=2,max=10,value=10),
matrixInput("input2",
label = "Values to interpolate (input2):",
value = matrix(c(1,5),1,2,dimnames = list(NULL,c("Value 1","Value 2"))),
rows = list(names = FALSE),
class = "numeric"),
actionButton("add", "Add scenario"),
plotOutput("plot")
)
server <- function(input, output, session) {
results <- function(){interpol(req(input$input1),req(input$input2))}
numScenarios <- reactiveValues(numS=1)
observeEvent(input$add, {showModal(modalDialog(footer = modalButton("Close")))
numScenarios$numS <- (numScenarios$numS+1)})
output$plot <- renderPlot({
req(input$input1,input$input2)
v <- lapply(1:numScenarios$numS,
function(i) tibble(Scenario=i,X=1:input$input1,Y=runif(1)+results())
) %>% bind_rows()
v %>% ggplot() + geom_line(aes(x=X, y=Y, colour=as.factor(Scenario)))
})
}
shinyApp(ui, server)
MWE code 2:
library(shiny)
library(tidyverse)
library(ggplot2)
library(shinyMatrix)
interpol <- function(a,b){ # a = periods, b = matrix inputs
c <- rep(NA,a)
c[1] <- b[1]
c[a] <- b[2]
c <- approx(seq_along(c)[!is.na(c)],c[!is.na(c)],seq_along(c))$y # this interpolates
return(c)}
ui <- fluidPage(
sliderInput('input1','Periods to interpolate (input1):',min=2,max=10,value=10),
matrixInput("input2",
label = "Values to interpolate (input2) where first row lists scenario number:",
value = matrix(c(1,5),1,2,dimnames = list(NULL,c("Value 1","Value 2"))),
cols = list(extend = TRUE, delta = 2, delete = TRUE, names = TRUE,
editableNames = FALSE, multiheader=TRUE),
rows = list(names = FALSE),
class = "numeric"),
actionButton("add", "Add scenario"),
plotOutput("plot")
)
server <- function(input, output, session) {
results <- function(){interpol(req(input$input1),req(input$input2))}
numScenarios <- reactiveValues(numS=1)
observeEvent(input$add, {showModal(modalDialog(footer = modalButton("Close")))
numScenarios$numS <- (numScenarios$numS+1)})
output$plot <- renderPlot({
req(input$input1,input$input2)
v <- lapply(1:numScenarios$numS,
function(i) tibble(Scenario=i,X=1:input$input1,Y=results())
) %>% bind_rows()
v %>% ggplot() + geom_line(aes(x=X, y=Y, colour=as.factor(Scenario)))
})
observe({
req(input$input2)
mm <- input$input2
colnames(mm) <- trunc(1:ncol(mm)/2)+1
isolate(updateMatrixInput(session, "input2", mm))
})
}
shinyApp(ui, server)
See explanatory images below:
Edit: I'd suggest using a row-based matrixInput. This makes your life much easier, as you don't have to reshape the matrix before passing it to your custom function etc.
Please check the following:
library(shiny)
library(shinyMatrix)
library(dplyr)
library(ggplot2)
interpol <- function(a, b) {
# a = periods, b = matrix inputs
c <- rep(NA, a)
c[1] <- b[1]
c[a] <- b[2]
c <- approx(seq_along(c)[!is.na(c)], c[!is.na(c)], seq_along(c))$y # this interpolates
return(c)
}
ui <- fluidPage(
titlePanel("myMatrixInput"),
sidebarLayout(
sidebarPanel(
matrixInput(
"myMatrixInput",
label = "Values to interpolate (myMatrixInput) where first row lists scenario number:",
value = matrix(c(10, 1, 5), 1, 3, dimnames = list("Scenario 1", c("Periods", "Value 1", "Value 2"))),
cols = list(
extend = FALSE,
names = TRUE,
editableNames = FALSE
),
rows = list(names = TRUE,
delete = TRUE,
extend = TRUE,
delta = 1),
class = "numeric"
),
actionButton("add", "Add scenario")
),
mainPanel(
plotOutput("plot")
)
)
)
server <- function(input, output, session) {
sanitizedMat <- reactiveVal()
observeEvent(input$myMatrixInput, {
if(any(rownames(input$myMatrixInput) == "")){
tmpMatrix <- input$myMatrixInput
rownames(tmpMatrix) <- paste("Scenario", seq_len(nrow(input$myMatrixInput)))
updateMatrixInput(session, inputId = "myMatrixInput", value = tmpMatrix)
}
sanitizedMat(na.omit(input$myMatrixInput))
})
plotData <- reactive({
req(dim(sanitizedMat())[1] >= 1)
lapply(seq_len(nrow(sanitizedMat())),
function(i){
tibble(
Scenario = rownames(sanitizedMat())[i],
X = seq_len(sanitizedMat()[i, 1]),
Y = interpol(sanitizedMat()[i, 1], sanitizedMat()[i, 2:3])
)
}) %>% bind_rows()
})
output$plot <- renderPlot({
req(nrow(plotData()) > 0)
plotData() %>% ggplot() + geom_line(aes(
x = X,
y = Y,
colour = as.factor(Scenario)
))
})
}
shinyApp(ui, server)
Initial Answer
There is no need to calulate the numScenarios as they are defined by the dimensions of your matrix. The same applies to the modal you'll add later - just monitor the dimensions of the data to change the plot - no matter which input changes the reactive dataset.
As a general advice I'd recommend working with data.frames in long format instead of a matrix to prepare plots (using e.g. ggplot or plotly). See my answer here for an example.
Please check the following:
library(shiny)
library(shinyMatrix)
library(dplyr)
library(ggplot2)
interpol <- function(a, b) {
# a = periods, b = matrix inputs
c <- rep(NA, a)
c[1] <- b[1]
c[a] <- b[2]
c <- approx(seq_along(c)[!is.na(c)], c[!is.na(c)], seq_along(c))$y # this interpolates
return(c)
}
ui <- fluidPage(
sliderInput(
'mySliderInput',
'Periods to interpolate (mySliderInput):',
min = 2,
max = 10,
value = 10
),
matrixInput(
"myMatrixInput",
label = "Values to interpolate (myMatrixInput):",
value = matrix(c(1, 5), 1, 2, dimnames = list(NULL, c("Value 1", "Value 2"))),
cols = list(
extend = TRUE,
delta = 2,
delete = TRUE
),
rows = list(names = FALSE),
class = "numeric"
),
actionButton("add", "Add scenario"),
plotOutput("plot")
)
server <- function(input, output, session) {
observeEvent(input$add, {
showModal(modalDialog(footer = modalButton("Close")))
})
plotData <- reactive({
req(dim(input$myMatrixInput)[2] >= 2)
# req(dim(input$myMatrixInput)[2]%%2 == 0)
req(input$mySliderInput)
if(as.logical(dim(input$myMatrixInput)[2]%%2)){
myVector <- head(as.vector(input$myMatrixInput), -1)
} else {
myVector <- as.vector(input$myMatrixInput)
}
myMatrix <- matrix(myVector, ncol = 2)
lapply(seq_len(length(myVector)/2),
function(i){
tibble(
Scenario = i,
X = seq_len(input$mySliderInput),
Y = interpol(req(input$mySliderInput), req(myMatrix[i,]))
)
}) %>% bind_rows()
})
output$plot <- renderPlot({
req(nrow(plotData()) > 0)
plotData() %>% ggplot() + geom_line(aes(
x = X,
y = Y,
colour = as.factor(Scenario)
))
})
}
shinyApp(ui, server)
The above Edit works BEAUTIFULLY. Wow. Now the below simple edit of your edit simply pull the periods to interpolate out of the input matrix and back into a single slider input since in the full model this is meant for, modeled periods have to be the same for all input variables. However your 3 column matrix inputs also help me on another matter so THANK YOU. Also, I removed the "Add scenarios" action button since it is no longer needed with the automatically expanding input matrix. I sure learned a lot with this.
Edit of your edit:
ui <- fluidPage(
titlePanel("myMatrixInput"),
sidebarLayout(
sidebarPanel(
sliderInput('periods','Periods to interpolate:',min=2,max=10,value=10),
matrixInput(
"myMatrixInput",
label = "Values to interpolate (myMatrixInput):",
value = matrix(c(1, 5), 1, 2, dimnames = list("Scenario 1", c("Value 1", "Value 2"))),
cols = list(extend = FALSE,
names = TRUE,
editableNames = FALSE),
rows = list(names = TRUE,
delete = TRUE,
extend = TRUE,
delta = 1),
class = "numeric"
),
),
mainPanel(
plotOutput("plot")
)
)
)
server <- function(input, output, session) {
sanitizedMat <- reactiveVal()
observeEvent(input$myMatrixInput, {
if(any(rownames(input$myMatrixInput) == "")){
tmpMatrix <- input$myMatrixInput
rownames(tmpMatrix) <- paste("Scenario", seq_len(nrow(input$myMatrixInput)))
updateMatrixInput(session, inputId = "myMatrixInput", value = tmpMatrix)
}
sanitizedMat(na.omit(input$myMatrixInput))
})
plotData <- reactive({
req(dim(sanitizedMat())[1] >= 1)
lapply(seq_len(nrow(sanitizedMat())),
function(i){
tibble(
Scenario = rownames(sanitizedMat())[i],
X = 1:input$periods,
Y = interpol(input$periods, sanitizedMat()[i, 1:2])
)
}) %>% bind_rows()
})
output$plot <- renderPlot({
req(nrow(plotData()) > 0)
plotData() %>% ggplot() + geom_line(aes(
x = X,
y = Y,
colour = as.factor(Scenario)
))
})
}
shinyApp(ui, server)
I have the dataframe below:
DF2 = data.frame(agency_postcode = factor(rep(c(12345,45678,24124,32525,32325),2)),
car_group=factor(rep(c("Microcar","City car","Supermini","Compact","SUV"),2)),
transmission=factor(rep(c("automatic","manual"),5)))
which I use and display as rhandsontable in order to create a second table. First you are supposed to select one or more options from filter by input and then a level from the selected filter(s). Then you press search. What I basically want to do is subset the second table based on the first row of every selected column of the first table. The issue is in line 30 of server.r in which I should give the input$sel
#ui.r
library(shiny)
library(rhandsontable)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(width=2,
selectInput("sel","Filter by:",
choices = c("agency_postcode","date_start","days","car_group","transmission","driver_age"),
multiple=T,selected = "agency_postcode"),
actionButton("sr","Search")
),
mainPanel(
fluidRow(
column(4,offset = 0, style='padding:0px;',rHandsontableOutput("hot")),
column(8,offset = 0, style='padding:0px;',rHandsontableOutput("hot2"))
)
)
)
)
#server.r
#server.r
library(shiny)
library(rhandsontable)
library(jsonlite)
server <- function(input, output) {
#Create rhandsontable as a reactive expression
DFR2<-reactive({
rhandsontable(DF2[1,1:2], rowHeaders = NULL,height = 200)%>%
hot_col(colnames(DF2)[1:2])
})
#Display the rhandsontable
output$hot <- renderRHandsontable({
DFR2()
})
#Convert the rhandsontable to a daraframe
DFR3<-reactive({
req(input$hot)
hot_to_r(input$hot)
})
#Subset the initial dataframe by value of the 1st row-1st column cell of DF3
DFR4 <- reactive({
req(DFR3())
D<-DF2[ which(DF2[,1] %in% DFR3()[1, 1]), ] #input$sel is supposed to be used here instead of 1
for(i in 1:ncol(D)){
D[,i] <- factor(D[,i])
}
D
})
#Display the new rhandsontable
output$hot2 <- renderRHandsontable({
input$sr
isolate(rhandsontable(DFR4()[1,], rowHeaders = NULL,height = 200)%>%
hot_col(colnames(DFR4())) )
})
}
OK. Here is an app that uses a small table to filter a larger one using inner_join. I am not sure this will match the design you had in mind. It is still unclear to me where the filter levels are coming from, or what the hands on tables are for. But you should be able to adapt this approach to your design. Note also that I am not using hands on tables. A direct replacement of the calls to renderTable with renderRHandsontable should work too.
library(shiny)
library(dplyr)
library(purrr)
sub_cars <- mtcars[, c("cyl", "gear", "am")]
ui <- fluidPage(
column(width=3,
selectInput(
inputId = "sel_col",
label = "Select variables",
multiple = TRUE,
choices = c("cyl", "gear", "am"),
selectize = TRUE),
uiOutput("cyl"),
uiOutput("gear"),
uiOutput("am")
),
column(width = 3,
tableOutput("filter_table")),
column(width = 6,
tableOutput("large_table"))
)
server <- function(input, output) {
output$cyl <- renderUI({
if ("cyl" %in% input$sel_col) {
selectInput(
inputId = "sel_cyl",
label = "Select cylinders",
choices = unique(sub_cars$cyl),
multiple = TRUE,
selectize = TRUE
)
}
})
output$gear <- renderUI({
if ("gear" %in% input$sel_col) {
selectInput(
inputId = "sel_gear",
label = "Select gears",
choices = unique(sub_cars$gear),
multiple = TRUE,
selectize = TRUE
)
}
})
output$am <- renderUI({
if ("am" %in% input$sel_col) {
selectInput(
inputId = "sel_am",
label = "Select am",
choices = unique(sub_cars$am),
multiple = TRUE,
selectize = TRUE
)
}
})
# make a small filter table
filter_df <- reactive({
validate(
need(!is_null(input$sel_col),
message = "Please select a column"))
cols <- input$sel_col
cols_vals <- map(cols, function(x) input[[paste0("sel_", x, collapse="")]])
df <- map2_dfr(cols, cols_vals, function(x, y)
filter(sub_cars,!!as.name(x) %in% y)) %>%
select(one_of(cols)) %>%
distinct()
return(df)
})
output$filter_table <- renderTable({
validate(
need(nrow(filter_df()) > 0,
message = "Please select filter values"))
filter_df()
})
# inner join the larger table
large_df <- reactive({
validate(
need(nrow(filter_df()) > 0,
message = "Please select filter values"))
cols <- input$sel_col
inner_join(x=filter_df(), y=mtcars, by = cols)
})
output$large_table <- renderTable({large_df()})
}
shinyApp(ui, server)
Here is a gif of what it does.
I know it might be duplicated, and I have sought for several questions that is similar with, but I still can not find why my code not work on.
The error occurs when two input sources are compiled to the eventReactive part.
My bug code like this:
library(shiny)
library(rio)
library(DescTools)
options(shiny.maxRequestSize=500*1024^2,shiny.usecairo = FALSE)
ui <- fluidPage(
titlePanel("See the file table"),
fluidRow(
column(4,
fileInput("theFile","upload your file")
),
column(4,
radioButtons("encode", "encoding way",
choices = c("Default" = "default",
"UTF-8" = "utf_8"),selected = "default")
),
column(4,
uiOutput("a_input")
),
column(4,
uiOutput("b_input")
),
column(4,
actionButton("choice3", "Show two variables comparing")
),
column(12,
verbatimTextOutput("console_comp")
),
column(12,
plotOutput("plot_Desc_comp")
)
)
)
server <- function(input,output, session){
allData <- reactive({
theFile <- input$theFile
req(input$theFile)
# Changes in read.table
if(input$encode == "default"){
df <- import(theFile$datapath)
} else{
df <- import(theFile$datapath,encoding = "UTF-8")
return(df)
}
})
output$a_input <- renderUI({
cn <- colnames(allData())
selectInput("a_input", "Select A variable to compare with Desc",
choices = cn,
size=10,
multiple=F, selectize=FALSE)
})
output$b_input <- renderUI({
cn <- colnames(allData())
selectInput("b_input", "Select B variable to compare with Desc",
choices = cn,
size=10,
multiple=F, selectize=FALSE)
})
data_Desc_a <- eventReactive(input$choice3, {
req(allData())
dat <- allData()
dat[,input$a_input, drop = FALSE]
})
data_Desc_b <- eventReactive(input$choice3, {
req(allData())
dat <- allData()
dat[,input$b_input, drop = FALSE]
})
output$console_comp <- renderPrint({
dat <- allData()
var_a <- data_Desc_a()
var_b <- data_Desc_b()
mylist2 <- Desc(var_a ~ var_b, dat)
print(mylist2)
})
output$plot_Desc_comp <- renderPlot({
dat <- allData()
var_a <- data_Desc_a()
var_b <- data_Desc_b()
mylist2 <- Desc(var_a ~ var_b, dat)
plot(mylist2)
})
}
shinyApp(ui, server)
The error code occurs when I want to press the "Show two variables comparing" buttom after I uploaded one file and chose two vars, and the error like this:
unused arguments (var_a ~ var_b, dat)
Even if I just use one source, it can work things out.
My work code like this:
ui <- fluidPage(
titlePanel("See the file table"),
fluidRow(
column(6,
fileInput("theFile","upload your file")
),
column(6,
radioButtons("encode", "encoding way",
choices = c("Default" = "default",
"UTF-8" = "utf_8"),selected = "default")
),
column(8,
uiOutput("colToDesc")
),
column(4,
actionButton("choice2", "Show variables Desc")
),
column(12,
verbatimTextOutput("console")
),
column(12,
plotOutput("plot_Desc")
)
)
)
server <- function(input,output, session){
allData <- reactive({
theFile <- input$theFile
req(input$theFile)
# Changes in read.table
if(input$encode == "default"){
df <- import(theFile$datapath)
} else{
df <- import(theFile$datapath,encoding = "UTF-8")
return(df)
}
})
output$colToDesc <- renderUI({
cn <- colnames(allData())
selectInput("colToDesc", "Select variable to Desc",
choices = cn,
size=10,
multiple=T, selectize=FALSE)
})
data_Desc <- eventReactive(input$choice2, {
req(allData())
dat <- allData()
dat[,input$colToDesc, drop = FALSE]
})
output$console <- renderPrint({
variables <- data_Desc()
mylist <- Desc(variables,main = names(variables))
print(mylist)
})
output$plot_Desc <- renderPlot({
variables <- data_Desc()
mylist <- Desc(variables,main = names(variables))
plot(mylist)
})
}
And I can sure the function of Desc from DescTools package can work well like this :
Desc(temp[,91]~temp[,5],temp)
So what's wrong with my bug code.
UpdateSliderInput not working...
Hi All,
Seems like a challenge updating sliderInput. So i wanted to develop an application in a way so that filter can be applied dynamically wherein one of the variables needs to be provided with a slider.
Any help can be really appriciable.
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
fluidRow(
column(6, actionButton('addFilter', 'Add filter')),
offset = 6
),
tags$hr(),
tags$div(id = 'placeholderAddRemFilt'),
tags$div(id = 'placeholderFilter'),
tags$div(id = 'placeholderFilter')
# width = 4 # sidebar
),
mainPanel(
tableOutput("data")
)
)
)
server <- function(input, output,session) {
filter <- character(0)
makeReactiveBinding("aggregFilterObserver")
aggregFilterObserver <- list()
observeEvent(input$addFilter, {
add <- input$addFilter
filterId <- paste0('Filter_', add)
colfilterId <- paste0('Col_Filter_', add)
rowfilterId <- paste0('Row_Filter_', add)
removeFilterId <- paste0('Remove_Filter_', add)
headers <- names(mtcars)
insertUI(
selector = '#placeholderFilter',
# ui = tags$div(id = filterId,
# actionButton(removeFilterId, label = "Remove filter", style = "float: right;"),
# selectInput(colfilterId, label = "Some Filter", choices = as.list(headers), selected = 1),
# sliderInput(rowfilterId, label = "Select variable values",
# min = 1, max = 2, value = 1:4)
# )
ui = tags$div(column(9,id = filterId,
actionButton(removeFilterId, label = "Remove filter", style = "float: right;"),
selectInput(colfilterId, label = "Some Filter", choices = headers, selected = NULL),
conditionalPanel(condition = paste0("input.",colfilterId," != 'mpg'"),
checkboxGroupInput(rowfilterId, label = "Select variable values",
choices = NULL, selected = NULL, width = 4000)),
conditionalPanel(condition = paste0("input.",colfilterId," == 'mpg'"),
sliderInput(rowfilterId,
label = 'select values',
min = 1,#min(datafile$Age),
max = 10,#max(datafile$Age),
value = 1:5))#c(min(datafile$Age),max(datafile$Age))))
)
)
)
observeEvent(input[[colfilterId]], {
col <- input[[colfilterId]]
values <- as.list(unique(mtcars[col]))[[1]]
print(values)
print(paste0("example",as.list(unique(mtcars[col]))))
#
# updateCheckboxGroupInput(session, rowfilterId , label = "Select variable values",
# choices = values, selected = values, inline = TRUE)
#
updateSliderInput(session, rowfilterId , min = min(values), max = max(values), value = c(min(values),max(values)))
updateCheckboxGroupInput(session, rowfilterId , label = "Select variable values",
choices = values, selected = values, inline = TRUE)
aggregFilterObserver[[filterId]]$col <<- col
aggregFilterObserver[[filterId]]$rows <<- NULL
})
observeEvent(input[[rowfilterId]], {
rows <- input[[rowfilterId]]
aggregFilterObserver[[filterId]]$rows <<- rows
})
observeEvent(input[[removeFilterId]], {
removeUI(selector = paste0('#', filterId))
aggregFilterObserver[[filterId]] <<- NULL
})
})
output$data <- renderTable({
dataSet <- mtcars
invisible(lapply(aggregFilterObserver, function(filter){
dataSet <<- dataSet[which((dataSet[[filter$col]] %in% filter$rows)), ]
}))
dataSet
})
}
shinyApp(ui = ui, server = server)
Mpg values are not being updated, Is this due to conditionalPanel because of which the sliderInput is not being updated?
Everything seems to be perfect apart from the inputid you are using for 2 input types.
I just created one more variable for Sliderinput which will create dynamic input id.
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
fluidRow(
column(6, actionButton('addFilter', 'Add filter')),
offset = 6
),
tags$hr(),
tags$div(id = 'placeholderAddRemFilt'),
tags$div(id = 'placeholderFilter'),
width = 4 # sidebar
),
mainPanel(
tableOutput("data")
)
)
)
server <- function(input, output,session) {
filter <- character(0)
makeReactiveBinding("aggregFilterObserver")
aggregFilterObserver <- list()
observeEvent(input$addFilter, {
add <- input$addFilter
filterId <- paste0('Filter_', add)
colfilterId <- paste0('Col_Filter_', add)
rowfilterId <- paste0('Row_Filter_', add)
rowfilterId_num <- paste0('Row_Filter_num_', add)
removeFilterId <- paste0('Remove_Filter_', add)
headers <- names(mtcars)
insertUI(
selector = '#placeholderFilter',
ui = tags$div(id = filterId,
actionButton(removeFilterId, label = "Remove filter", style = "float: right;"),
selectInput(colfilterId, label = "Some Filter", choices = as.list(headers), selected = 1),
sliderInput(rowfilterId_num, label = "Select variable values",
min = 1, max = 2, value = 1:4)
)
)
observeEvent(input[[colfilterId]], {
print(rowfilterId)
print(paste0(input[[colfilterId]]))
col <- input[[colfilterId]]
values <- as.list(unique(mtcars[col]))[[1]]
print(values)
print(paste0("example",as.list(unique(mtcars[col]))))
updateCheckboxGroupInput(session, rowfilterId , label = "Select variable values",
choices = values, selected = values, inline = TRUE)
updateSliderInput(session, rowfilterId_num , label = "Select variable",min = min(values), max = max(values), value = c(min(values),max(values)))
aggregFilterObserver[[filterId]]$col <<- col
aggregFilterObserver[[filterId]]$rows <<- NULL
})
observeEvent(input[[rowfilterId]], {
rows <- input[[rowfilterId]]
aggregFilterObserver[[filterId]]$rows <<- rows
})
observeEvent(input[[removeFilterId]], {
removeUI(selector = paste0('#', filterId))
aggregFilterObserver[[filterId]] <<- NULL
})
})
output$data <- renderTable({
dataSet <- mtcars
invisible(lapply(aggregFilterObserver, function(filter){
dataSet <<- dataSet[which((dataSet[[filter$col]] %in% filter$rows)), ]
}))
dataSet
})
}
shinyApp(ui = ui, server = server)
just check and let me know that this is what you wanted to achieve. let me know incase any thing else is required.
I am trying to create a shiny-app that load data-set, present the variable list and their classes and allow the user to modify the class of a selected variable. All the functions in the following code are working except to the last function in the server- observeEvent which not working when trying to modify the variable class. Any suggestions?
Thank you in advance,
Rami
`
rm(list = ls())
library(shiny)
library(shinydashboard)
library(DT)
ui <- dashboardPage(
dashboardHeader(title = "Shiny Example"),
#--------------------------------------------------------------------
dashboardSidebar(
sidebarMenu(
menuItem("Data", tabName = "data", icon = icon("th"))
)
),
#--------------------------------------------------------------------
dashboardBody(
#--------------------------------------------------------------------
tabItem(tabName = "data",
fluidPage(
fluidRow(
box(
selectInput('dataset', 'Select Dataset', list(GermanCredit = "GermanCredit",
cars = "cars",
iris = "iris")),
title = "Datasets",width = 4, status = "primary",
checkboxInput("select_all", "Select All Variable", value = TRUE),
conditionalPanel(condition = "input.select_all == false",
uiOutput("show.var"))
),
box(
title = "Variable Summary", width = 4, status = "primary",
DT::dataTableOutput('summary.data')
),
box(
title = "Modify the Variable Class", width = 4, status = "primary",
radioButtons("choose_class", label = "Modify the Variable Class",
choices = list(Numeric = "numeric", Factor = "factor",
Character = "character"),
selected = "numeric"),
actionButton("var_modify", "Modify")
)
)
)
)
)
)
#--------------------------------------------------------------------
# Server Function
#--------------------------------------------------------------------
server <- function(input, output,session) {
#--------------------------------------------------------------------
# loading the data
get.df <- reactive({
if(input$dataset == "GermanCredit"){
data("GermanCredit")
GermanCredit
}else if(input$dataset == "cars"){
data(cars)
cars
}else if(input$dataset == "iris"){
data("iris")
iris
}
})
# Getting the list of variable from the loaded dataset
var_list <- reactive(names(get.df()))
# Choosing the variable - checkbox option
output$show.var <- renderUI({
checkboxGroupInput('show_var', 'Select Variables', var_list(), selected = var_list())
})
# Setting the data frame based on the variable selction
df <- reactive({
if(input$select_all){
df <- get.df()
} else if(!input$select_all){
df <- get.df()[, input$show_var, drop = FALSE]
}
return(df)
})
# create list of variables
col.name <- reactive({
d <- data.frame(names(df()), sapply(df(),class))
names(d) <- c("Name", "Class")
return(d)
})
# render the variable list into table
output$summary.data <- DT::renderDataTable(col.name(), server = FALSE, rownames = FALSE,
selection = list(selected = 1, mode = 'single'),
options = list(lengthMenu = c(5, 10, 15, 20), pageLength = 20, dom = 'p'))
# storing the selected variable from the variables list table
table.sel <- reactive({
df()[,which(colnames(df()) == col.name()[input$summary.data_rows_selected,1])]
})
# Trying to modify the variable class
observeEvent(input$var_modify,{
modify.row <- which(colnames(df()) == col.name()[input$summary.data_rows_selected,1])
if( input$choose_class == "numeric"){
df()[, modify.row] <- as.numeric(df()[, modify.row])
} else if( input$choose_class == "factor"){
df()[, modify.row] <- as.factor(df()[, modify.row])
} else if( input$choose_class == "character"){
df()[, modify.row] <- as.character(df()[, modify.row])
}
})
}
shinyApp(ui = ui, server = server)
`
I would use reactiveValues() instead.
library(shiny)
# Define UI for application that draws a histogram
ui <- shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("classType", "Class Type:", c("as.numeric", "as.character"))
),
mainPanel(
textOutput("class")
)
)
))
server <- shinyServer(function(input, output) {
global <- reactiveValues(sample = 1:9)
observe({
global$sample <- get(input$classType)(global$sample)
})
output$class <- renderText({
print(class(global$sample))
})
})
shinyApp(ui = ui, server = server)
In case you are interested:
Concerning your attempt: reactive() is a function and you called the output of the function by df()[, modify.row]. So in your code you try to change the output of the function, but that does not change the output of futures calls of that function.
Maybe it is easier to see in a simplified version:
mean(1:3) <- 1
The code can not change the mean function to output 1 in future. So thats what reactiveValues() help with :). Hope that helps!