How to reset all checkboxes in a shiny dashboard? - r

Currently have the following code - is there any way in which I can reset all checkboxes within this app - regardless of being selected on one tab - or multiple tabs?
So I have introduced a select and deselect all button into the app as well so hopefully that feature will still remain in there?
code:
library(shiny)
library(shinydashboard)
library(tidyverse)
library(magrittr)
header <- dashboardHeader(
title = "My Dashboard",
titleWidth = 500
)
siderbar <- dashboardSidebar(
sidebarMenu(
# Add buttons to choose the way you want to select your data
radioButtons("select_by", "Select by:",
c("Food Type" = "Food",
"Gym Type" = "Gym",
"TV show" = "TV"))
)
)
body <- dashboardBody(
fluidRow(
uiOutput("Output_panel")
),
tabBox(title = "RESULTS", width = 12,
tabPanel("Visualisation",
width = 12,
height = 800
)
)
)
ui <- dashboardPage(header, siderbar, body, skin = "purple")
server <- function(input, output, session){
nodes_data_1 <- data.frame(id = 1:15,
Food = as.character(c("Edibles", "Fried", "Home Cooked", "packaged", "vending machine")),
Product_name = as.character(c("Bacon", "Cheese", "eggs", "chips", "beans", "oast", "oats and beans", "fried beans", "chickpeas", "broad beans", "garbanzo", "oat bars", "dog meat", "cat food", "horse meat")),
Gym_type = as.character(paste("Gym", 1:15)), TV =
sample(LETTERS[1:3], 15, replace = TRUE))
# build a edges dataframe
edges_data_1 <- data.frame(from = trunc(runif(15)*(15-1))+1,
to = trunc(runif(15)*(15-1))+1)
# create reactive of nodes
nodes_data_reactive <- reactive({
nodes_data_1
}) # end of reactive
# create reacive of edges
edges_data_reactive <- reactive({
edges_data_1
}) # end of reactive
# The output panel differs depending on the how the data is selected
# so it needs to be in the server section, not the UI section and created
# with renderUI as it is reactive
output$Output_panel <- renderUI({
# When selecting by workstream and issues:
if(input$select_by == "Food") {
box(title = "Output PANEL",
collapsible = TRUE,
width = 12,
do.call(tabsetPanel, c(id='t',lapply(1:length(unique(nodes_data_reactive()$Food)), function(i) {
food <- unique(sort(as.character(nodes_data_reactive()$Food)))
tabPanel(food[i],
checkboxGroupInput(paste0("checkboxfood_", i),
label = NULL,
choices = nodes_data_reactive() %>%
filter(Food == food[i]) %>%
select(Product_name) %>%
unlist(use.names = FALSE)),
checkboxInput(paste0("all_", i), "Select all", value = TRUE)
)
})))
) # end of Tab box
# When selecting by the strength of links connected to the issues:
} else if(input$select_by == "Gym") {
box(title = "Output PANEL", collapsible = TRUE, width = 12,
checkboxGroupInput("select_gyms", "Select gyms you want to display", choices = unique(nodes_data_reactive()$Gym_type)
,
selected = NULL,
inline = FALSE
)# end of checkboxGroupInput
) # end of box
} else if(input$select_by == "TV") {
box(title = "Output PANEL", collapsible = TRUE, width = 12,
checkboxGroupInput("select_tvs",
"Select the tv shows you want to see",choices = sort(unique(nodes_data_reactive()$TV)),
selected = NULL,
inline = FALSE
)# end of checkboxGroupInput
) # end of box
} # end of else if
}) # end of renderUI
observe({
lapply(1:length(unique(nodes_data_reactive()$Food)), function(i) {
food <- unique(sort(as.character(nodes_data_reactive()$Food)))
product_choices <- nodes_data_reactive() %>%
filter(Food == food[i]) %>%
select(Product_name) %>%
unlist(use.names = FALSE)
if(!is.null(input[[paste0("all_", i)]])){
if(input[[paste0("all_", i)]] == TRUE) {
updateCheckboxGroupInput(session,
paste0("checkboxfood_", i),
label = NULL,
choices = product_choices,
selected = product_choices)
} else {
updateCheckboxGroupInput(session,
paste0("checkboxfood_", i),
label = NULL,
choices =product_choices)
}
}
})
})
} # end of server
# Run the application
shinyApp(ui = ui, server = server)

Here is a solution based on a fixed naming convention for your checkboxes (I added the "chk_"-prefix)
Edit: distinguish updateCheckboxInput and updateCheckboxGroupInput
library(shiny)
library(shinydashboard)
library(tidyverse)
library(magrittr)
header <- dashboardHeader(
title = "My Dashboard",
titleWidth = 500
)
siderbar <- dashboardSidebar(
sidebarMenu(
# Add buttons to choose the way you want to select your data
radioButtons("select_by", "Select by:",
c("Food Type" = "Food",
"Gym Type" = "Gym",
"TV show" = "TV"))
)
)
body <- dashboardBody(
fluidRow(
uiOutput("Output_panel"),
tabBox(title = "RESULTS", width = 12,
tabPanel("Visualisation",
br(),
width = 12,
height = 800
)
),
column(12, actionButton(inputId ="resetBtn", label = "Reset Selection", icon = icon("times-circle")))
)
)
ui <- dashboardPage(header, siderbar, body, skin = "purple")
server <- function(input, output, session){
nodes_data_1 <- data.frame(id = 1:15,
Food = as.character(c("Edibles", "Fried", "Home Cooked", "packaged", "vending machine")),
Product_name = as.character(c("Bacon", "Cheese", "eggs", "chips", "beans", "oast", "oats and beans", "fried beans", "chickpeas", "broad beans", "garbanzo", "oat bars", "dog meat", "cat food", "horse meat")),
Gym_type = as.character(paste("Gym", 1:15)), TV =
sample(LETTERS[1:3], 15, replace = TRUE))
# build a edges dataframe
edges_data_1 <- data.frame(from = trunc(runif(15)*(15-1))+1,
to = trunc(runif(15)*(15-1))+1)
# create reactive of nodes
nodes_data_reactive <- reactive({
nodes_data_1
}) # end of reactive
# create reacive of edges
edges_data_reactive <- reactive({
edges_data_1
}) # end of reactive
# The output panel differs depending on the how the data is selected
# so it needs to be in the server section, not the UI section and created
# with renderUI as it is reactive
output$Output_panel <- renderUI({
# When selecting by workstream and issues:
if(input$select_by == "Food") {
box(title = "Output PANEL",
collapsible = TRUE,
width = 12,
do.call(tabsetPanel, c(id='t',lapply(1:length(unique(nodes_data_reactive()$Food)), function(i) {
food <- unique(sort(as.character(nodes_data_reactive()$Food)))
tabPanel(food[i],
checkboxGroupInput(paste0("chkgrp_checkboxfood_", i),
label = NULL,
choices = nodes_data_reactive() %>%
filter(Food == food[i]) %>%
select(Product_name) %>%
unlist(use.names = FALSE)),
checkboxInput(paste0("chksingle_all_", i), "Select all", value = TRUE)
)
})))
) # end of Tab box
# When selecting by the strength of links connected to the issues:
} else if(input$select_by == "Gym") {
box(title = "Output PANEL", collapsible = TRUE, width = 12,
checkboxGroupInput("chkgrp_select_gyms", "Select gyms you want to display", choices = unique(nodes_data_reactive()$Gym_type)
,
selected = NULL,
inline = FALSE
)# end of checkboxGroupInput
) # end of box
} else if(input$select_by == "TV") {
box(title = "Output PANEL", collapsible = TRUE, width = 12,
checkboxGroupInput("chkgrp_select_tvs",
"Select the tv shows you want to see",choices = sort(unique(nodes_data_reactive()$TV)),
selected = NULL,
inline = FALSE
)# end of checkboxGroupInput
) # end of box
} # end of else if
}) # end of renderUI
observe({
lapply(1:length(unique(nodes_data_reactive()$Food)), function(i) {
food <- unique(sort(as.character(nodes_data_reactive()$Food)))
product_choices <- nodes_data_reactive() %>%
filter(Food == food[i]) %>%
select(Product_name) %>%
unlist(use.names = FALSE)
if(!is.null(input[[paste0("chksingle_all_", i)]])){
if(input[[paste0("chksingle_all_", i)]] == TRUE) {
updateCheckboxGroupInput(session,
paste0("chkgrp_checkboxfood_", i),
label = NULL,
choices = product_choices,
selected = product_choices)
} else {
updateCheckboxGroupInput(session,
paste0("chkgrp_checkboxfood_", i),
label = NULL,
choices =product_choices)
}
}
})
})
observeEvent(input$resetBtn, ignoreNULL = TRUE, ignoreInit = TRUE, {
resetChksingleInputs <- names(input)[grepl("^chksingle*", names(input))]
cat("Resetting single checkboxes:", resetChksingleInputs, sep = "\n")
lapply(resetChksingleInputs, updateCheckboxInput, session=session, value = FALSE)
resetChkgrpInputs <- names(input)[grepl("^chkgrp*", names(input))]
cat("Resetting checkbox groups:", resetChkgrpInputs, sep = "\n")
lapply(resetChkgrpInputs, updateCheckboxGroupInput , session=session, selected = character(0))
})
} # end of server
# Run the application
shinyApp(ui = ui, server = server)

Related

swap pickerInput on a button press in Shiny

I need to update/reverse two inputs from drop down inputs upon a button press. At the moment when I hit the swap button (reverse_xz), it reacts however the updatePickerInput doesn't switch my x and z inputs.
I wanted to have the functionality where, once the swap button is clicked, switch the already selected pickerInputs. Then, all the drop down choices (including the selected) need to get reversed. The reason we have to remove the selected choices from vector is to prevent duplicate selections in both x and z inputs.
I am not sure if I have to render the pickerInput ui on the server side?!
This is my code below:
#global.R
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyWidgets)
library(shinyjs)
#variable labels
my_vars <- c("None"= "NONE",
"All" = "all_all",
"Pro" = "Pro_",
"Locomania" = "locomania_Type",
"Racer" = "race")
#ui.R
ui <- shinydashboardPlus::dashboardPage(
header = shinydashboardPlus::dashboardHeader( ),
body = shinydashboard::dashboardBody( box(textOutput("inputs") ) ),
sidebar = shinydashboardPlus::dashboardSidebar(
shinyWidgets::pickerInput(
inputId = "xvar",
label = "X Axis: ",
choices = my_vars,
options = list(
size = 5),
multiple = FALSE,
selected = "all_all"
),
# Button to reverse the choices
shiny::fluidRow(
shiny::column(12, offset = 4,
shinyWidgets::actionBttn(
inputId = "reverse_xz",
label = "",
style = "simple",
color = "primary",
icon = icon("retweet")
)
)
),
shinyWidgets::pickerInput(
inputId = "zvar",
label = "Z Axis: ",
choices = my_vars,
options = list(
size = 5),
multiple = FALSE,
selected = "race"
)
)
)
#server.R
server <- function(input, output, session) {
#
observe({
if(!is.null(input$reverse_xz))
shinyWidgets::updatePickerInput(session, "zvar",
choices = my_vars[!(my_vars %in% input$xvar)],
selected = isolate(input$zvar) )
shinyWidgets::updatePickerInput(session, "xvar",
choices = my_vars[!(my_vars %in% input$zvar)],
selected = isolate(input$xvar) )
})
# These observers remove the selected choices so both pickers are unique
observe({
if(!is.null(input$zvar))
shinyWidgets::updatePickerInput(session, "xvar",
choices = my_vars[!(my_vars %in% input$zvar)],
selected = isolate(input$xvar) )
})
observe({
if(!is.null(input$xvar))
shinyWidgets::updatePickerInput(session, "zvar",
choices = my_vars[!(my_vars %in% input$xvar)],
selected = isolate(input$zvar) )
})
# output inputs
output$inputs <- renderText({ paste0("x var: ", input$xvar,
"\n\n\n z var:", input$zvar,
"\n\n\nreverse press: ", input$reverse_xz) })
}
shiny::shinyApp(ui= ui, server= server)
Thank you in advance. I have looked at some relavant posts however they couldn't guide me much:
Updatepickerinput with change in pickerinput in Shiny
updatePickerInput not updating values after changing tabs in R shiny
update pickerInput by using updatePickerInput in shiny
Look at this and check if it would be OK for you:
#global.R
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyWidgets)
library(shinyjs)
#variable labels
my_vars <- c("None"= "NONE",
"All" = "all_all",
"Pro" = "Pro_",
"Locomania" = "locomania_Type",
"Racer" = "race")
#ui.R
ui <- shinydashboardPlus::dashboardPage(
header = shinydashboardPlus::dashboardHeader( ),
body = shinydashboard::dashboardBody( box(textOutput("inputs") ) ),
sidebar = shinydashboardPlus::dashboardSidebar(
shinyWidgets::pickerInput(
inputId = "xvar",
label = "X Axis: ",
choices = my_vars,
options = list(
size = 5),
multiple = FALSE,
selected = "all_all"
),
# Button to reverse the choices
shiny::fluidRow(
shiny::column(12, offset = 4,
shinyWidgets::actionBttn(
inputId = "reverse_xz",
label = "",
style = "simple",
color = "primary",
icon = icon("retweet")
)
)
),
shinyWidgets::pickerInput(
inputId = "zvar",
label = "Z Axis: ",
choices = my_vars,
options = list(
size = 5),
multiple = FALSE,
selected = "race"
)
)
)
#server.R
server <- function(input, output, session) {
#
observeEvent(input$reverse_xz, {
shinyWidgets::updatePickerInput(session, "zvar",
choices = my_vars[!(my_vars %in% input$zvar)],
selected = input$xvar)
shinyWidgets::updatePickerInput(session, "xvar",
choices = my_vars[!(my_vars %in% input$xvar)],
selected = input$zvar)
})
observe({
if (input$xvar == input$zvar && (length(input$zvar) > 0 && length(input$xvar) > 0)) {
shinyWidgets::updatePickerInput(session, "zvar",
selected = "")
shinyWidgets::updatePickerInput(session, "xvar",
selected = "")
}
})
# output inputs
output$inputs <- renderText({ paste0("x var: ", input$xvar,
"\n\n\n z var:", input$zvar,
"\n\n\nreverse press: ", input$reverse_xz) })
}
shiny::shinyApp(ui= ui, server= server)
I think that maybe this needs an explanation:
if (input$xvar == input$zvar && (length(input$zvar) > 0 && length(input$xvar) > 0))
So, when user choose two the same inputs, then we are updating pickerInputs, so both will have "Nothing selected" as a sign for user that something goes wrong (or that she/he did something wrong). However, "Nothing selected" is like NULL and we can't use NULL like this NULL == "something" inside if, so I'm checking if some input is NULL using length(input$) > 0, because length of NULL is 0. Instead of length(input$) > 0 you could use !is.null(input$) and maybe you should as it is probably more readable, but I'm leaving this decision for you.

Is there a way to use picker/selectInput in conjunction with an editable, reactive DT in shiny?

I have struggled with the following issue and have found no suitable solution on SO.
Here is what I require from my DataTable
I would like to edit my DataTable (achieved)
Filter the data in DataTable with my edits intact. Currently, my edits disappear after I change the filters
Save whole DataTable as RDS rather than just the current displayed data based on filters. Currently, I just save the current displayed DataTable based on filters
Thank you for your help in advance!
df <- iris
species <- unique(as.character(df$Species))
width <- unique(df$Petal.Width)
#==========================================UI=======================================================#
ui = navbarPage("CSAT & SA", theme = shinytheme("flatly"),
tabPanel("Sentiment Analysis",
sidebarLayout(
sidebarPanel(
pickerInput(inputId = "species",
label = "Species", selected = species,
choices = species, multiple = T,
options = list(`actions-box` = TRUE, `deselect-all-text` = "None...",
`select-all-text` = "Select All", `none-selected-text` = "None Selected")),
pickerInput(inputId = "width",
label = "Petal Width", selected = width,
choices = width, multiple = T,
options = list(`actions-box` = TRUE, `deselect-all-text` = "None...",
`select-all-text` = "Select All", `none-selected-text` = "None Selected")),
width = 2,
actionButton(inputId = "save", label = "Save"),
actionButton(inputId = "update", label = "Update")
),
mainPanel(
h2("Iris"), fluidRow(
tabPanel("Iris", DT::dataTableOutput("x1"),
width = 12)
)))))
#==========================================SERVER=======================================================#
server <- function(input, output, session) {
SA <- reactive({
df<-df %>%
filter(Species %in% input$species) %>%
filter(Petal.Width %in% input$width)
})
rec_val = reactiveValues(df = NULL)
observe({
rec_val$SA <- SA()
})
output$x1 = renderDT(SA(), selection = 'none', editable = list(target = 'cell', disable = list(columns=c(0,1,2))))
proxy = dataTableProxy('x1')
observeEvent(input$x1_cell_edit, {
info = input$x1_cell_edit
str(info)
i = info$row
j = info$col
v = info$value
rec_val$SA[i, j] <<- DT::coerceValue(v, rec_val$SA[i, j])
replaceData(proxy, rec_val$SA, resetPaging = FALSE)
})
observeEvent(input$save, {
saveRDS(rec_val$SA, "somewhere.rds") # write new data out
})
}
shinyApp(ui = ui, server = server)
Edit:
see here
You need to use updatePickerInput() to update the choices available based on the edits. Also, define row id to keep the modified data. Using reset you can return to the original datatable. Try this
library(shinythemes)
dat <- iris
species <- unique(as.character(dat$Species))
width <- unique(dat$Petal.Width)
#==========================================UI=======================================================#
ui = navbarPage("CSAT & SA", theme = shinytheme("flatly"),
tabPanel("Sentiment Analysis",
sidebarLayout(
sidebarPanel(
pickerInput(inputId = "species",
label = "Species", selected = species,
choices = as.list(species), multiple = T,
options = list(`actions-box` = TRUE, `deselect-all-text` = "None...",
`select-all-text` = "Select All", `none-selected-text` = "None Selected")),
pickerInput(inputId = "width",
label = "Petal Width", selected = width,
choices = as.list(width), multiple = T,
options = list(`actions-box` = TRUE, `deselect-all-text` = "None...",
`select-all-text` = "Select All", `none-selected-text` = "None Selected")),
width = 2,
actionButton(inputId = "save", label = "Save"),
actionButton(inputId = "reset", label = "Reset")
),
mainPanel(
h2("Iris"), fluidRow(
tabPanel("Iris", DT::dataTableOutput("x1"), DTOutput("x2"),
width = 12)
)))))
#==========================================SERVER=======================================================#
server <- function(input, output, session) {
SA <- reactive({
row_id <- c(1:nrow(dat))
data <- data.frame(dat,row_id)
data
})
rv = reactiveValues(df = NULL)
observe({
rv$df <- SA() %>%
filter(Species %in% isolate(input$species)) %>%
filter(Petal.Width %in% isolate(input$width))
})
observeEvent(input$species, {
df1 <- SA() ### orig data
df2 <- rv$df ### modified data
if (is.null(df2)){
rvdf <- SA()
}else{
vn <- colnames(df1)
vnx <- paste0(vn,".x")
vny <- paste0(vn,".y")
rvdf <- left_join(df1, df2, by="row_id") %>% transmute(var1 = get(!!vnx[1]), var2 = get(!!vnx[2]), var3 = get(!!vnx[3]),
var4 = ifelse(is.na(get(!!vny[4])), get(!!vnx[4]), get(!!vny[4])),
var5 = get(!!vnx[5]), # ifelse(is.na(get(!!vny[5])), get(!!vnx[5]), get(!!vny[5])),
row_id)
colnames(rvdf) <- vn
}
rv$df <- rvdf %>%
filter(Species %in% input$species) %>%
filter(Petal.Width %in% input$width)
})
observeEvent(input$width, {
df1 <- SA() ### orig data
df2 <- rv$df ### modified data
if (is.null(df2)){
rvdf <- SA()
}else{
vn <- colnames(df1)
vnx <- paste0(vn,".x")
vny <- paste0(vn,".y")
### keep modified data, if present; if not, keep original data
rvdf <- left_join(df1, df2, by="row_id") %>% transmute(var1 = get(!!vnx[1]), var2 = get(!!vnx[2]), var3 = get(!!vnx[3]),
var4 = ifelse(is.na(get(!!vny[4])), get(!!vnx[4]), get(!!vny[4])), ## keep modified data
var5 = get(!!vnx[5]), # ifelse(is.na(get(!!vny[5])), get(!!vnx[5]), get(!!vny[5])),
row_id)
colnames(rvdf) <- vn
}
rv$df <- rvdf %>%
filter(Species %in% input$species) %>%
filter(Petal.Width %in% input$width)
})
output$x1 <- renderDT(rv$df, selection = 'none',
editable = list(target = 'cell', disable = list(columns=c(0,1,2))),
options = list(
columnDefs = list(
list(
visible = FALSE,
targets = 6
)
)
)
)
proxy <- dataTableProxy('x1')
observeEvent(input$x1_cell_edit, {
info = input$x1_cell_edit
str(info)
i = info$row
j = info$col
v = info$value
rv$df[i, j] <<- DT::coerceValue(v, rv$df[i, j])
#replaceData(proxy, rv$df, resetPaging = FALSE)
})
observeEvent(input$save, {
#choicess <- as.list(unique(c(as.character(rv$df[,5]), as.character(SA()[,5]))))
choicesp <- as.list(unique(c(rv$df[,4], SA()[,4])))
# updatePickerInput(session, inputId = "species", choices = choicess, selected=choicess)
updatePickerInput(session, inputId = "width", choices = choicesp, selected=choicesp)
saveRDS(rv$df, "somewhere.rds") # write new data out
df3 <- readRDS("C:/My Disk Space/_My Work/RStuff/GWS/somewhere.rds")
output$x2 <- renderDT({
df3
})
})
observeEvent(input$reset, {
rv$df <- SA()
# choicess <- unique(as.character(rv$df[,5]))
choicesp <- unique(SA()[,4])
# updatePickerInput(session, inputId = "species", choices = choicess, selected=choicess)
updatePickerInput(session, inputId = "width", choices = choicesp, selected=choicesp)
})
}
shinyApp(ui = ui, server = server)

How to update shiny data frame in real time using checkboxes?

I have the following app below, it takes a dataframe which is created in the shiny server, and uses this to generate tab Panels, which in turn checkboxes within each tab panel (3 checkboxes per tab panel) - within each tab panel there is a "select all" box which is supposed to essentially check all of the boxes in that tab panel
So what i need help with - is that i would like it so that if i am on tab 1 and "press" the "select all" button, then it will "check" all those boxes in that tab Panel (and of course "un-pressing" that button will deselect those boxes) - But i would also want the functionality, so that if you select a number of checkboxes in different tabs, then it would update accordingly and will not lose any information, (this includes pressing select all on different tabs also)
So for example i would want the following behaviour:
If you select the "Edibles" Tab > then press "select all" - all 3 checkboxes are selected
Now if you then select the "Fried" tab > then press "cheese" which is one of the options for the individual checkboxes - you will now have in total 4 checkboxes selected, all those from the "edibles" tab and just the one from the "fried" tab
So if we now de-select the "select all" button from the first tab "edibles", it loses all information and the checkbox in "Fried" which was "cheese" no longer is checked,
This is not the behaviour i would want - i would like it to update accordingly and have "cheese" still selected as we have unpressed select all
I have printed off the names of what is being selected where and when on the actual app
code is below:
Any thoughts?
library(shiny)
library(shinydashboard)
library(tidyverse)
library(magrittr)
header <- dashboardHeader(
title = "My Dashboard",
titleWidth = 500
)
siderbar <- dashboardSidebar(
sidebarMenu(
# Add buttons to choose the way you want to select your data
radioButtons("select_by", "Select by:",
c("Food Type" = "Food",
"Gym Type" = "Gym",
"TV show" = "TV"))
)
)
body <- dashboardBody(
fluidRow(
uiOutput("Output_panel")
),
tabBox(title = "RESULTS", width = 12,
tabPanel("Visualisation",
width = 12,
height = 800
)
)
)
ui <- dashboardPage(header, siderbar, body, skin = "purple")
server <- function(input, output, session){
nodes_data_1 <- data.frame(id = 1:15,
Food = as.character(c("Edibles", "Fried", "Home Cooked", "packaged", "vending machine")),
Product_name = as.character(c("Bacon", "Cheese", "eggs", "chips", "beans", "oast", "oats and beans", "fried beans", "chickpeas", "broad beans", "garbanzo", "oat bars", "dog meat", "cat food", "horse meat")),
Price = c(1:15), TV =
sample(LETTERS[1:3], 15, replace = TRUE))
# build a edges dataframe
edges_data_1 <- data.frame(from = trunc(runif(15)*(15-1))+1,
to = trunc(runif(15)*(15-1))+1)
# create reactive of nodes
nodes_data_reactive <- reactive({
nodes_data_1
}) # end of reactive
# create reacive of edges
edges_data_reactive <- reactive({
edges_data_1
}) # end of reactive"che
# The output panel differs depending on the how the data is selected
# so it needs to be in the server section, not the UI section and created
# with renderUI as it is reactive
output$Output_panel <- renderUI({
# When selecting by workstream and issues:
if(input$select_by == "Food") {
food <- unique(as.character(nodes_data_reactive()$Food))
food_panel <- lapply(seq_along(food), function(i) {
### filter the data only once
food_dt <- dplyr::filter(nodes_data_reactive(), Food == food[i])
### Use the id, not the price, as the id is unique
food_ids <- as.character(food_dt$id)
selected_ids <- food_ids[food_ids %in% isolate({chosen_food()})] ### use isolate, so as to not be reactive to it
tabPanel(food[i],
checkboxGroupInput(
paste0("checkboxfood_", i),
label = "Random Stuff",
choiceNames = as.character(food_dt$Product_name), ### for some reason it likes characters, not factors with extra levels
choiceValues = food_ids,
selected = selected_ids
),
checkboxInput(
paste0("all_", i),
"Select all",
value = all(food_ids %in% isolate({chosen_food()}))
)
)
})
box(title = "Output PANEL",
collapsible = TRUE,
width = 12,
do.call(tabsetPanel, c(id = 't', food_panel)),
"Items: ", renderText(paste0(chosen_food(), collapse = ", ")),
"Names: ", renderText(paste0(chosen_food_names(), collapse = ", "))
) # end of Tab box
}
}) # end of renderUI
observe({
lapply(1:length(unique(nodes_data_reactive()$Food)), function(i) {
food <- unique(sort(as.character(nodes_data_reactive()$Food)))
product_choices <- nodes_data_reactive() %>%
filter(Food == food[i]) %>%
select(Product_name) %>%
unlist(use.names = FALSE) %>%
as.character()
product_prices <- nodes_data_reactive() %>%
filter(Food == food[i]) %>%
select(Price) %>%
unlist(use.names = FALSE)
if(!is.null(input[[paste0("all_", i)]])){
if(input[[paste0("all_", i)]] == TRUE) {
updateCheckboxGroupInput(session,
paste0("checkboxfood_", i),
label = NULL,
choiceNames = product_choices,
choiceValues = product_prices,
selected = product_prices)
} else {
updateCheckboxGroupInput(session,
paste0("checkboxfood_", i),
label = NULL,
choiceNames = product_choices,
choiceValues = product_prices,
selected = c()
)
}
}
})
})
chosen_food <- reactive({
unlist(lapply(seq_along(unique(nodes_data_reactive()$Food)), function(i) {
# retrieve checkboxfood_NUMBER value
input[[paste0("checkboxfood_", i)]]
}))
})
chosen_food_names <- reactive({
# turn selected chosen food values into names
nodes_data_reactive()$Product_name[as.numeric(chosen_food())]
})
} # end of server
# Run the application
shinyApp(ui = ui, server = server)
The problem was that you were updating all checkbox groups that didn't have the select all option selected. The solution is to add an if condition that checks to see if all the options are selected or not by comparing the length of input[[paste0("checkboxfood_", i)]] with length of product_choices
Code:
library(shiny)
library(shinydashboard)
library(tidyverse)
library(magrittr)
#################################################
#################### UI.R #######################
#################################################
header <- dashboardHeader(
title = "My Dashboard",
titleWidth = 500
)
siderbar <- dashboardSidebar(
sidebarMenu(
# Add buttons to choose the way you want to select your data
radioButtons("select_by", "Select by:",
c("Food Type" = "Food",
"Gym Type" = "Gym",
"TV show" = "TV"))
)
)
body <- dashboardBody(
fluidRow(
uiOutput("Output_panel")
),
tabBox(title = "RESULTS", width = 12,
tabPanel("Visualisation",
width = 12,
height = 800
)
)
)
ui <- dashboardPage(header, siderbar, body, skin = "purple")
#################################################
################## Server.R #####################
#################################################
server <- function(input, output, session){
nodes_data_1 <- data.frame(id = 1:15,
Food = as.character(c("Edibles", "Fried", "Home Cooked", "packaged", "vending machine")),
Product_name = as.character(c("Bacon", "Cheese", "eggs", "chips", "beans", "oast", "oats and beans", "fried beans", "chickpeas", "broad beans", "garbanzo", "oat bars", "dog meat", "cat food", "horse meat")),
Price = c(1:15), TV =
sample(LETTERS[1:3], 15, replace = TRUE))
# build a edges dataframe
edges_data_1 <- data.frame(from = trunc(runif(15)*(15-1))+1,
to = trunc(runif(15)*(15-1))+1)
# create reactive of nodes
nodes_data_reactive <- reactive({
nodes_data_1
}) # end of reactive
# create reacive of edges
edges_data_reactive <- reactive({
edges_data_1
}) # end of reactive"che
# The output panel differs depending on the how the data is selected
# so it needs to be in the server section, not the UI section and created
# with renderUI as it is reactive
output$Output_panel <- renderUI({
#Select Food
if(input$select_by == "Food") {
food <- unique(as.character(nodes_data_reactive()$Food))
food_panel <- lapply(seq_along(food), function(i) {
### filter the data only once
food_dt <- dplyr::filter(nodes_data_reactive(), Food == food[i])
### Use the id, not the price, as the id is unique
food_ids <- as.character(food_dt$id)
selected_ids <- food_ids[food_ids %in% isolate({chosen_food()})] ### use isolate, so as to not be reactive to it
tabPanel(food[i],
checkboxGroupInput(
paste0("checkboxfood_", i),
label = "Random Stuff",
choiceNames = as.character(food_dt$Product_name), ### for some reason it likes characters, not factors with extra levels
choiceValues = food_ids,
selected = selected_ids
),
checkboxInput(
paste0("all_", i),
"Select all",
value = all(food_ids %in% isolate({chosen_food()}))
)
)
})
box(title = "Output PANEL",
collapsible = TRUE,
width = 12,
do.call(tabsetPanel, c(id = 't', food_panel)),
"Items: ", renderText(paste0(chosen_food(), collapse = ", ")),
"Names: ", renderText(paste0(chosen_food_names(), collapse = ", "))
) # end of Tab box
}
}) # end of renderUI
observe({
lapply(1:length(unique(nodes_data_reactive()$Food)), function(i) {
food <- unique(sort(as.character(nodes_data_reactive()$Food)))
product_choices <- nodes_data_reactive() %>%
filter(Food == food[i]) %>%
select(Product_name) %>%
unlist(use.names = FALSE) %>%
as.character()
product_prices <- nodes_data_reactive() %>%
filter(Food == food[i]) %>%
select(Price) %>%
unlist(use.names = FALSE)
if(!is.null(input[[paste0("all_", i)]])){
if(input[[paste0("all_", i)]] == TRUE) {
updateCheckboxGroupInput(session,
paste0("checkboxfood_", i),
label = NULL,
choiceNames = product_choices,
choiceValues = product_prices,
selected = product_prices)
} else {
if((input[[paste0("all_", i)]] != TRUE) & (length(input[[paste0("checkboxfood_", i)]]) == length(product_choices)))
{
updateCheckboxGroupInput(session,
paste0("checkboxfood_", i),
label = NULL,
choiceNames = product_choices,
choiceValues = product_prices,
selected = c()
)
}}
}
})
})
chosen_food <- reactive({
unlist(lapply(seq_along(unique(nodes_data_reactive()$Food)), function(i) {
# retrieve checkboxfood_NUMBER value
input[[paste0("checkboxfood_", i)]]
}))
})
chosen_food_names <- reactive({
# turn selected chosen food values into names
nodes_data_reactive()$Product_name[as.numeric(chosen_food())]
})
}
# Run the application
shinyApp(ui = ui, server = server)

Output photos in shiny

Now I need to practice and build a recommender system by using R. Data set is from MovieLens. I want to output the movie photos as well, but not sure what to do. If there's 10000 movies, how should I save them and output them on my shiny APP? And suggestion is welcomed!
ui.R:
library(shiny)
library(shinydashboard)
library(proxy)
library(recommenderlab)
library(reshape2)
library(plyr)
library(dplyr)
library(DT)
library(RCurl)
setwd("C:\\Users\\lili\\Movieshiny")
movies <- read.csv("movies.csv", header = TRUE, stringsAsFactors=FALSE)
movies <- movies[with(movies, order(title)), ]
ratings <- read.csv("ratings100k.csv", header = TRUE)
shinyUI(dashboardPage(skin="blue",
dashboardHeader(title = "Movie Recommenders"),
dashboardSidebar(
sidebarMenu(
menuItem("Movies", tabName = "movies", icon = icon("star-o")),
menuItem("About", tabName = "about", icon = icon("question-circle")),
menuItem("Source code", icon = icon("file-code-o"),
href = "https://github.com/danmalter/Movielense"),
menuItem(
list(
selectInput("select", label = h5("Select 3 Movies That You Like"),
choices = as.character(movies$title[1:length(unique(movies$movieId))]),
selectize = FALSE,
selected = "Shawshank Redemption, The (1994)"),
selectInput("select2", label = NA,
choices = as.character(movies$title[1:length(unique(movies$movieId))]),
selectize = FALSE,
selected = "Forrest Gump (1994)"),
selectInput("select3", label = NA,
choices = as.character(movies$title[1:length(unique(movies$movieId))]),
selectize = FALSE,
selected = "Silence of the Lambs, The (1991)"),
submitButton("Submit")
)
)
)
),
dashboardBody(
tags$head(
tags$style(type="text/css", "select { max-width: 360px; }"),
tags$style(type="text/css", ".span4 { max-width: 360px; }"),
tags$style(type="text/css", ".well { max-width: 360px; }")
),
tabItems(
tabItem(tabName = "about",
h2("About this App"),
HTML('<br/>'),
fluidRow(
box(title = "Author: Danny Malter", background = "black", width=7, collapsible = TRUE,
helpText(p(strong("This application a movie reccomnder using the movielense dataset."))),
helpText(p("Please contact",
a(href ="https://twitter.com/danmalter", "Danny on twitter",target = "_blank"),
" or at my",
a(href ="http://danmalter.github.io/", "personal page", target = "_blank"),
", for more information, to suggest improvements or report errors.")),
helpText(p("All code and data is available at ",
a(href ="https://github.com/danmalter/", "my GitHub page",target = "_blank"),
"or click the 'source code' link on the sidebar on the left."
))
)
)
),
tabItem(tabName = "movies",
fluidRow(
box(
width = 6, status = "info", solidHead = TRUE,
title = "Other Movies You Might Like",
tableOutput("table")),
valueBoxOutput("tableRatings1"),
valueBoxOutput("tableRatings2"),
valueBoxOutput("tableRatings3"),
HTML('<br/>'),
box(DT::dataTableOutput("myTable"), title = "Table of All Movies", width=12, collapsible = TRUE)
)
)
)
)
)
)
server.R:
setwd("C:\\Users\\lili\\Movieshiny")
movies <- read.csv("movies.csv", header = TRUE, stringsAsFactors=FALSE)
movies <- movies[with(movies, order(title)), ]
ratings <- read.csv("ratings100k.csv", header = TRUE)
shinyServer(function(input, output) {
# Text for the 3 boxes showing average scores
formulaText1 <- reactive({
paste(input$select)
})
formulaText2 <- reactive({
paste(input$select2)
})
formulaText3 <- reactive({
paste(input$select3)
})
output$movie1 <- renderText({
formulaText1()
})
output$movie2 <- renderText({
formulaText2()
})
output$movie3 <- renderText({
formulaText3()
})
# Table containing recommendations
output$table <- renderTable({
# Filter for based on genre of selected movies to enhance recommendations
cat1 <- subset(movies, title==input$select)
cat2 <- subset(movies, title==input$select2)
cat3 <- subset(movies, title==input$select3)
# If genre contains 'Sci-Fi' then return sci-fi movies
# If genre contains 'Children' then return children movies
if (grepl("Sci-Fi", cat1$genres) | grepl("Sci-Fi", cat2$genres) | grepl("Sci-Fi", cat3$genres)) {
movies2 <- (movies[grepl("Sci-Fi", movies$genres) , ])
} else if (grepl("Children", cat1$genres) | grepl("Children", cat2$genres) | grepl("Children", cat3$genres)) {
movies2 <- movies[grepl("Children", movies$genres), ]
} else {
movies2 <- movies[grepl(cat1$genre1, movies$genres)
| grepl(cat2$genre1, movies$genres)
| grepl(cat3$genre1, movies$genres), ]
}
movie_recommendation <- function(input,input2,input3){
row_num <- which(movies2[,3] == input)
row_num2 <- which(movies2[,3] == input2)
row_num3 <- which(movies2[,3] == input3)
userSelect <- matrix(NA,length(unique(ratings$movieId)))
userSelect[row_num] <- 5 #hard code first selection to rating 5
userSelect[row_num2] <- 4 #hard code second selection to rating 4
userSelect[row_num3] <- 4 #hard code third selection to rating 4
userSelect <- t(userSelect)
ratingmat <- dcast(ratings, userId~movieId, value.var = "rating", na.rm=FALSE)
ratingmat <- ratingmat[,-1]
colnames(userSelect) <- colnames(ratingmat)
ratingmat2 <- rbind(userSelect,ratingmat)
ratingmat2 <- as.matrix(ratingmat2)
#Convert rating matrix into a sparse matrix
ratingmat2 <- as(ratingmat2, "realRatingMatrix")
#Create Recommender Model
recommender_model <- Recommender(ratingmat2, method = "UBCF",param=list(method="Cosine",nn=30))
recom <- predict(recommender_model, ratingmat2[1], n=30)
recom_list <- as(recom, "list")
recom_result <- data.frame(matrix(NA,30))
recom_result[1:30,1] <- movies2[as.integer(recom_list[[1]][1:30]),3]
recom_result <- data.frame(na.omit(recom_result[order(order(recom_result)),]))
recom_result <- data.frame(recom_result[1:10,])
colnames(recom_result) <- "User-Based Collaborative Filtering Recommended Titles"
return(recom_result)
}
movie_recommendation(input$select, input$select2, input$select3)
})
movie.ratings <- merge(ratings, movies)
output$tableRatings1 <- renderValueBox({
movie.avg1 <- summarise(subset(movie.ratings, title==input$select),
Average_Rating1 = mean(rating, na.rm = TRUE))
valueBox(
value = format(movie.avg1, digits = 3),
subtitle = input$select,
icon = if (movie.avg1 >= 3) icon("thumbs-up") else icon("thumbs-down"),
color = if (movie.avg1 >= 3) "aqua" else "red"
)
})
movie.ratings <- merge(ratings, movies)
output$tableRatings2 <- renderValueBox({
movie.avg2 <- summarise(subset(movie.ratings, title==input$select2),
Average_Rating = mean(rating, na.rm = TRUE))
valueBox(
value = format(movie.avg2, digits = 3),
subtitle = input$select2,
icon = if (movie.avg2 >= 3) icon("thumbs-up") else icon("thumbs-down"),
color = if (movie.avg2 >= 3) "aqua" else "red"
)
})
movie.ratings <- merge(ratings, movies)
output$tableRatings3 <- renderValueBox({
movie.avg3 <- summarise(subset(movie.ratings, title==input$select3),
Average_Rating = mean(rating, na.rm = TRUE))
valueBox(
value = format(movie.avg3, digits = 3),
subtitle = input$select3,
icon = if (movie.avg3 >= 3) icon("thumbs-up") else icon("thumbs-down"),
color = if (movie.avg3 >= 3) "aqua" else "red"
)
})
# Generate a table summarizing each players stats
output$myTable <- renderDataTable({
movies[c("title", "genres")]
})
}
)
For example, I want to insert this into my code:
library(shiny)
Define UI with external image call
ui <- fluidPage(
titlePanel("Look at the image below"),
sidebarLayout(sidebarPanel(),
mainPanel(htmlOutput("picture"))))
Define server with information needed to hotlink image
server <- function(input, output) {
output$picture <-
renderText({
c(
'<img src="',
"http://www.google.com.tw/search?biw=1536&bih=759&tbm=isch&sa=1&q=notebook+movie&oq=notebook+movie&gs_l=psy-ab.3..0l4.5729.7315.0.7708.6.6.0.0.0.0.223.623.4j1j1.6.0....0...1.1.64.psy-ab..0.6.622...0i67k1.0.P-BZX3u-bzo#imgrc=S0E91gxvZcgeMM:",
'">'
)
})
}
shinyApp(ui = ui, server = server)
Every movie has different poster images.

Filter data table output using user input in R shiny

I am working on an app which allows the user to select specific inputs. In this case the app provides two selectizeInput options to select from the various options.
The following is the dataset:
data_test = data.frame(Name = c ("ABC","ABC","ABC","DEF","DEF", "XYZ", "XYZ", "PQR"),
Country = c("US, Japan","US, Japan","US, Japan","Canada, US","Canada, US", "UK, US", "UK, US", "Germany"),
Region = c("North America, Asia","North America, Asia","North America, Asia","North America","North America", "Europe, North America", "Europe, North America", "Europe"),
Contact = c(1234,1234,1234,7578,7578,9898,9898,7660),
ContactPerson = c("Geoff","Mary","Mike","Don","Sean","Jessica","Justin","John"))
In ui.R
dashboardPage(skin = "blue",
dashboardHeader(title = 'My APP'),
dashboardSidebar(
sidebarMenu(
menuItem("Profiles", tabName = "profiles", icon=icon("user")),
menuItem("Search", tabName = "search", icon=icon("search")),
menuItem("About App", tabName="about", icon = icon("info"))
)
),
dashboardBody(
tabItems(
tabItem(tabName ="profiles",
tabBox( title = "",
width = 12, id = "tabset1", height = "850px",
tabPanel("People",
fluidRow(
box(title = "Filters", solidHeader = TRUE,
background = "blue" , collapsible = TRUE, width = 12,
fluidRow(
column(4,selectizeInput("country",label="Country",choices= NULL, multiple = TRUE)),
column(4,selectizeInput("geogPref",label="Region",choices= NULL, multiple = TRUE))
)
)
),
box(title = "Filtered Results",
collapsible = TRUE, status = "success",
width = 12, DT::dataTableOutput('results'))
),
tabPanel("Details",
fluidRow(
box(width = 4, background = "blue",
collapsible = TRUE, solidHeader = TRUE)
)
)
)
),
tabItem(tabName ="search",
titlePanel("Search"),
fluidRow(
)
),
tabItem(tabName="about",
titlePanel("About APP"),
HTML("This is an app.")
)
)
)
)
In server.R
library(shiny)
trim.leading <- function (x) sub("^\\s+", "", x)
uniqueValues <- function(x){
values <- c()
s <- (unlist(strsplit(x, ",", fixed = TRUE)))
v <- trim.leading(s)
}
geog <- c()
geog <- unique(unlist(c(geog, sapply(data_set$Region, uniqueValues))))
shinyServer(function(input, output, session) {
updateSelectizeInput(session, 'country', choices = unique(data_set$Country), server = TRUE)
updateSelectizeInput(session, 'geogPref', choices = geog, server = TRUE)
country <- reactive({
c <- c()
c <- c(c, input$country)
})
dataset <- reactive({
data <- data_set
if (input$country){
data$c1 <- grepl(paste(country(), collapse = "|"), data$Country)
}
else {
data$c1 <- TRUE
}
if (input$geogPref){
data$c2 <- grepl(input$geogPref, data$Region)
}
else {
data$c2 <- TRUE
}
data <- data[which(data$c1 == TRUE & data$c2 == TRUE ),c("Name", "Contact", "ContactPerson")]
return (data)
})
output$results <- DT::renderDataTable(
DT::datatable( unique(dataset()),
rownames = FALSE, options = list(searchable = FALSE)
)
})
So based on the user selection, I need to filter out the rows that contain all those strings and update the table with only those relevant rows. I am not able to update the table with the filters. With this code I am getting, this error:
Error in if: argument is of length zero
Stack trace (innermost first):
96: <reactive:dataset> [D:\shinyapps\myapp/server.R#21]
85: dataset
84: unique
83: DT::datatable
82: exprFunc
Can someone help with what I am doing wrong?
You can simplify the server code:
shinyServer(function(input, output, session) {
updateSelectizeInput(session, 'country', choices = unique(data_set$Country), server = TRUE)
updateSelectizeInput(session, 'geogPref', choices = geog, server = TRUE)
dataset <- reactive({
data <- data_set
if (length(input$country)){
data$c1 <- grepl(paste(input$country, collapse = "|"), data$Country)
}
else {
data$c1 <- TRUE
}
if (length(input$geogPref)){
data$c2 <- grepl(paste(input$geogPref, collapse = "|"), data$Region)
}
else {
data$c2 <- TRUE
}
data[data$c1 & data$c2 ,c("Name", "Contact", "ContactPerson")]
})
output$results <- DT::renderDataTable(
DT::datatable( dataset(),
rownames = FALSE, options = list(searchable = FALSE)
))
})

Resources