For loop inside output in Shiny - r

I have found similar question here: How to make for loop reactive in shiny server in R?, but it is not answered correctly.
I am using R, version 3.3.1.In shiny. I am trying to make a loop in shiny. Here is my shortened code version:
library(shiny)
library(dplyr)
library(data.table)
library(dtplyr)
library(stringr)
library(jsonlite)
library(httr)
library(mongolite)
library(RCurl)
library(XML)
f1 <- function(lst) lapply(lst, function(x) if (is.list(x)) f1(x) else if (is.null(x)) NA_character_ else x)
ui <- fluidPage(
titlePanel(h1("FORENSIS")),
sidebarLayout(
sidebarPanel(h4("Upute za korištenje:"),
p("Podaci se prikupljaju iz javnih registara"),
br(),
br(),
em("Ukliko imate pitanja, slobodno nas kontaktirajte:")
),
mainPanel(h3("Upit"),
textInput(inputId = "oib", label = "OIB"),
actionButton("kreiraj", "Pretraži"),
br(),
br(),
htmlOutput(outputId = "oib_output"),
h4("STATUS OIB-A"),
htmlOutput(outputId = "oib_status"),
br(),
h4("OSNOVNI PODACI"),
htmlOutput(outputId = "oib_ime"),
htmlOutput(outputId = "oib_prezime"),
htmlOutput(outputId = "oib_spol"),
htmlOutput(outputId = "oib_dob"),
htmlOutput(outputId = "oib_adresa"),
htmlOutput(outputId = "oib_mjesto"),
htmlOutput(outputId = "oib_naselje"),
htmlOutput(outputId = "oib_zip"),
htmlOutput(outputId = "oib_zupanija"),
br(),
h4("PRAVNE FUNKCIJE U POSLOVNIM SUBJEKTIMA"),
htmlOutput(outputId = "oib_funkcija_funkcija")
)
)
)
server <- function(input, output) {
report_exe <- eventReactive(input$kreiraj, {
input$oib
})
output$oib_output <- renderUI({
HTML(paste0('<h3>', 'Upit za OIB: ', report_exe(), '</h3>'))
})
output$oib_status <- renderUI({
req <- list()
oib_status <- NULL
i <- 0
for (i in 1:length(report_exe())) {
reqOP <- rbind(fromJSON(toJSON(content(GET(url = "https://api.data-api.io/v1/oibstatus/",
add_headers('x-dataapi-key' = "xxxx"),
query = list(oib = report_exe())), type = "application/json"), null = "null"), flatten = TRUE))
req[[i]] <- reqOP
}
json <- do.call(rbind, req)
json <- as.data.frame(json)
oib_status <- as.data.frame(lapply(f1(json), unlist), stringsAsFactors=FALSE)
HTML(paste0('<h4>', 'Status: ', ifelse(oib_status$X_status[1] == 1, 'Aktivan', 'Neaktivan'), '</h4>'))
})
preb <- reactive({
req <- list()
my_get <- for (i in 1:length(report_exe())) {
reqOP <- rbind(fromJSON(toJSON(content(GET(url = "https://api.data-api.io/v1/prebivaliste/",
add_headers('x-dataapi-key' = "xxxx"),
query = list(oib = report_exe())), type = "application/json"), null = "null"), flatten = TRUE))
req[[i]] <- reqOP
}
json <- do.call(rbind, req)
json <- as.data.frame(json)
prebivaliste <- as.data.frame(lapply(f1(json), unlist), stringsAsFactors=FALSE)
return(prebivaliste)
})
funkcije <- reactive({
req <- list()
my_get <- for (i in 1:length(report_exe())) {
reqOP <- rbind(fromJSON(toJSON(content(GET(url = "https://api.data-api.io/v1/osobe/",
add_headers('x-dataapi-key' = "xxxxx"),
query = list(oib = report_exe())), type = "application/json"), null = "null"), flatten = TRUE))
req[[i]] <- reqOP
}
json <- do.call(rbind, req)
json <- as.data.frame(json)
povezani_subjekti <- json$povezaniSubjekti
json$povezaniSubjekti <- NULL
funkcije <- as.data.frame(lapply(f1(json), unlist), stringsAsFactors=FALSE)
funkcije <- funkcije[!duplicated(funkcije),]
oibreq_subjekti <- unique(funkcije$subjektOib)
req <- list()
if (is.null(oibreq_subjekti)) {
funkcije <- NULL
} else {
my_get <- for (i in 1:length(oibreq_subjekti)) {
reqOP <- rbind(fromJSON(toJSON(content(GET(url = "https://api.data-api.io/v1/subjekti/",
add_headers('x-dataapi-key' = "xxxxxx"),
query = list(oib = oibreq_subjekti[i])), type = "application/json"), null = "null"), flatten = TRUE))
req[[i]] <- reqOP
}
json <- do.call(rbind, req)
json <- as.data.frame(json)
subjekti <- as.data.frame(lapply(f1(json), unlist), stringsAsFactors=FALSE)
subjekti$isActive <- NULL
colnames(subjekti)[which(colnames(subjekti)=="adresa")] <- "adresa_subjekta"
funkcije <- merge(x = funkcije, y = subjekti, by.x = "subjektOib", by.y = "oib", all.x = TRUE, all.y=FALSE)
return(funkcije)
}
})
output$oib_ime <- renderUI({
HTML(paste0('<h4>', 'Ime: ', preb()$ime, '</h4>'))
})
output$oib_prezime <- renderUI({
HTML(paste0('<h4>', 'Prezime: ', preb()$prezime, '</h4>'))
})
output$oib_adresa <- renderUI({
HTML(paste0('<h4>', 'Adresa: ', preb()$adresa, '</h4>'))
})
output$oib_mjesto <- renderUI({
HTML(paste0('<h4>', 'Mjesto: ', preb()$mjesto, '</h4>'))
})
output$oib_naselje <- renderUI({
HTML(paste0('<h4>', 'Naselje: ', preb()$naselje, '</h4>'))
})
output$oib_naselje <- renderUI({
HTML(paste0('<h4>', 'Poštanski broj: ', preb()$posta, '</h4>'))
})
output$oib_zupanija <- renderUI({
HTML(paste0('<h4>', 'Županija: ', preb()$zupanija, '</h4>'))
})
output$oib_funkcija_funkcija <- renderUI({
for (j in 1:2) {
HTML(paste0('<h4>', 'Funkcija: ', funkcije()$funkcija[j], '</h4>',
'<h4>', 'Naziv tvrtke: ', funkcije()$naziv[j], '</h4>'))
}
})
}
shinyApp(ui = ui, server = server)
It is a big chunk of code so I would like to simplify. I have one text input argument textInput(inputId = "oib", label = "OIB"). In this argument someone has to type some id number. Then, in the reactive part of the code, this input is used to retrieve data from REST API (in the end this reactive object i s simple data frame). I can successfully add reactive object to output, if there is only one row. But if I want to use the for loop inside output, it doesn't give me an answer:
output$oib_funkcija_funkcija <- renderUI({
for (j in 1:2) {
HTML(paste0('<h4>', 'Funkcija: ', funkcije()$funkcija[j], '</h4>',
'<h4>', 'Naziv tvrtke: ', funkcije()$naziv[j], '</h4>'))
}
})

Maybe this example helps:
ui.R
library(shiny)
shinyUI(fluidPage(
titlePanel("..."),
sidebarLayout(
sidebarPanel(
selectInput("funkcija12", "Funkcija", choices = c("f1", "f2"), selected = "f1"),
selectInput("naziv12", "Naziv", choices = c("n1", "n2"), selected = "n2"),
selectInput("funkcija34", "Funkcija", choices = c("f3", "f4"), selected = "f1"),
selectInput("naziv34", "Naziv", choices = c("n3", "n4"), selected = "n2")
),
mainPanel(
uiOutput("funcijeNaziv")
)
)
))
server.R
library(shiny)
shinyServer(function(input, output) {
funkcije <- reactive({
list(funkcija = c(input$funkcija12, input$funkcija34),
naziv = c(input$naziv12, input$naziv34))
})
funkcijeHTML <- reactive({
tmp <- character()
for (j in 1:2) {
tmp[j] = paste0('<h4>', 'Funkcija: ', funkcije()$funkcija[j], '</h4>','<h4>', 'Naziv tvrtke: ', funkcije()$naziv[j], '</h4>')
}
tmp
})
output$funcijeNaziv <- renderUI(
HTML(funkcijeHTML())
)
})

Related

Capture filtered results from a datatable and store it as a new dataset in Shiny

I have a shiny application that loads a couple of datasets (diamonds & mtcars) and displays them as datatable in the mainpanel. I am trying to implement a couple of functionality
1. Store datasets: Once the user create filters in the datatable, allow them to store the filtered results as a new dataset.
2. Remove datasets: Allow the users to remove any datasets from the list of created datasets
app.R
library(shiny)
library(shinyWidgets)
library(dplyr)
library(tidyverse)
library(shinyjs)
ui <- fluidPage(
titlePanel("Dataset Tool"),
sidebarLayout(
sidebarPanel(width = 3,
conditionalPanel(
condition = "input.tabs=='Datasets'",
uiOutput("ui_datasets"),
uiOutput("ui_storedataset"),
br(), br(),
wellPanel(
checkboxInput("data_remove", "Remove dataset from memory",
FALSE),
conditionalPanel(
condition = "input.data_remove == true",
uiOutput("ui_removedataset"),
actionButton("removeDataSetButton",
"Remove dataset")
)
)
)
),
mainPanel(
tabsetPanel(id = "tabs",
tabPanel("Datasets",
DT::dataTableOutput("datatable")
)
)
)
)
)
server = function(input, output,session) {
my_data <- new.env()
my_state <- list()
my_info <- reactiveValues()
datasetlist <- c()
my_df <- list()
df <- list()
df_names <- c("diamonds", "mtcars")
for (j in df_names) {
df[[j]] <- get(j)
datasetlist <- c(datasetlist, j)
}
my_info[["datasetlist"]] <- datasetlist
my_df[["df"]] <- df
output$ui_datasets <- renderUI({
tagList(
selectInput(
inputId = "dataset",
label = "Datasets:",
choices = my_info[["datasetlist"]],
multiple = FALSE
)
)
})
output$ui_storedataset <- renderUI({
tagList(
wellPanel(
tags$table(
tags$td(textInput("stored_name",
"Store new dataset as:",
"",
placeholder = "name of the dataset")),
tags$td(actionButton("view_store",
"Store"),
style = "padding-right:30px;")
)
)
)
})
observeEvent(input$datatable_search_columns, {
my_state$datatable_search_columns <<- input$datatable_search_columns
})
observeEvent(input$datatable_state, {
my_state$datatable_state <<-
if (is.null(input$datatable_state)) list() else input$datatable_state
})
output$datatable <- DT::renderDataTable({
dat <- df[[(input$dataset)]]
search <- my_state$datatable_state$search$search
if (is.null(search)) search <- ""
fbox <- if (nrow(dat) > 5e6) "none" else list(position = "top")
DT::datatable(
dat,
filter = fbox,
selection = "none",
rownames = FALSE,
fillContainer = FALSE,
escape = FALSE,
style = "bootstrap",
options = list(
stateSave = TRUE,
searchCols = lapply(my_state$datatable_search_columns, function(x) list(search = x)),
search = list(search = search, regex = TRUE),
order = {
if (is.null(my_state$datatable_state$order)) {
list()
} else {
my_state$datatable_state$order
}
},
columnDefs = list(
list(orderSequence = c("desc", "asc"), targets = "_all"),
list(className = "dt-center", targets = "_all")
),
autoWidth = TRUE,
processing = isTRUE(fbox == "none"),
pageLength = {
if (is.null(my_state$datatable_state$length)) 10 else my_state$datatable_state$length
},
lengthMenu = list(c(5, 10, 25, 50, -1), c("5", "10", "25", "50", "All"))
),
callback = DT::JS('$(window).on("unload", function() { table.state.clear(); })')
)
})
observeEvent(input$view_store, {
req(input$stored_name)
dataset <- (input$stored_name)
if (input$stored_name != dataset) {
updateTextInput(session, inputId = "stored_name", value = dataset)
}
my_data[[dataset]] <- get(input$dataset)
updateSelectInput(session = session, inputId = "dataset",
selected = input$dataset)
})
output$ui_removedataset <- renderUI({
selectInput(
inputId = "removeDataset",
label = NULL,
choices = my_info[["datasetlist"]],
selected = NULL,
multiple = TRUE,
size = length(my_info[["datasetlist"]]),
selectize = FALSE
)
})
observeEvent(input$removeDataSetButton, {
if (is.null(input$removeDataset)) return()
datasets <- my_info[["datasetlist"]]
if (length(datasets) > 1) {
removeDataset <- input$removeDataset
if (length(datasets) == length(removeDataset)) {
removeDataset <- removeDataset[-1]
}
suppressWarnings(rm(list = removeDataset, envir = my_data))
my_info[["datasetlist"]] <- datasets[-which(datasets %in% removeDataset)]
}
})
}
shinyApp(ui = ui, server = server)
I think the "removedatasets" functionality works fine. I am not able to get the "store dataset" functionality to work. I am not sure how to capture the filtered datatable from the environment to store and add it to the list of datasets.
I would really appreciate any help on this. Thanks.
Here is a solution that recreates the filtering on the original data based on the filter inputs stored in my_state$datatable_search_columns. The strings are turned into the correct filter conditions which are then applied to the data set before saving. Note that I haven't tested it with a condition in the global search bar:
library(shiny)
library(shinyWidgets)
library(dplyr)
library(tidyverse)
library(shinyjs)
ui <- fluidPage(
titlePanel("Dataset Tool"),
sidebarLayout(
sidebarPanel(width = 3,
conditionalPanel(
condition = "input.tabs=='Datasets'",
uiOutput("ui_datasets"),
uiOutput("ui_storedataset"),
br(), br(),
wellPanel(
checkboxInput("data_remove", "Remove dataset from memory",
FALSE),
conditionalPanel(
condition = "input.data_remove == true",
uiOutput("ui_removedataset"),
actionButton("removeDataSetButton",
"Remove dataset")
)
)
)
),
mainPanel(
tabsetPanel(id = "tabs",
tabPanel("Datasets",
DT::dataTableOutput("datatable")
)
)
)
)
)
server = function(input, output,session) {
my_data <- new.env()
my_state <- list()
my_info <- reactiveValues()
datasetlist <- c()
my_df <- list()
df <- list()
df_names <- c("diamonds", "mtcars")
for (j in df_names) {
df[[j]] <- get(j)
datasetlist <- c(datasetlist, j)
}
my_info[["datasetlist"]] <- datasetlist
my_df[["df"]] <- df
output$ui_datasets <- renderUI({
tagList(
selectInput(
inputId = "dataset",
label = "Datasets:",
choices = my_info[["datasetlist"]],
multiple = FALSE
)
)
})
output$ui_storedataset <- renderUI({
tagList(
wellPanel(
tags$table(
tags$td(textInput("stored_name",
"Store new dataset as:",
"",
placeholder = "name of the dataset")),
tags$td(actionButton("view_store",
"Store"),
style = "padding-right:30px;")
)
)
)
})
observeEvent(input$datatable_search_columns, {
my_state$datatable_search_columns <<- input$datatable_search_columns
})
observeEvent(input$datatable_state, {
my_state$datatable_state <<-
if (is.null(input$datatable_state)) list() else input$datatable_state
})
output$datatable <- DT::renderDataTable({
dat <- df[[(input$dataset)]]
search <- my_state$datatable_state$search$search
if (is.null(search)) search <- ""
fbox <- if (nrow(dat) > 5e6) "none" else list(position = "top")
DT::datatable(
dat,
filter = fbox,
selection = "none",
rownames = FALSE,
fillContainer = FALSE,
escape = FALSE,
style = "bootstrap",
options = list(
stateSave = TRUE,
searchCols = lapply(my_state$datatable_search_columns, function(x) list(search = x)),
search = list(search = search, regex = TRUE),
order = {
if (is.null(my_state$datatable_state$order)) {
list()
} else {
my_state$datatable_state$order
}
},
columnDefs = list(
list(orderSequence = c("desc", "asc"), targets = "_all"),
list(className = "dt-center", targets = "_all")
),
autoWidth = TRUE,
processing = isTRUE(fbox == "none"),
pageLength = {
if (is.null(my_state$datatable_state$length)) 10 else my_state$datatable_state$length
},
lengthMenu = list(c(5, 10, 25, 50, -1), c("5", "10", "25", "50", "All"))
),
callback = DT::JS('$(window).on("unload", function() { table.state.clear(); })')
)
})
observeEvent(input$view_store, {
req(input$stored_name)
dataset <- (input$stored_name)
if (input$stored_name != dataset) {
updateTextInput(session, inputId = "stored_name", value = dataset)
}
# get filter conditions
filter_conditions <- lapply(my_state$datatable_search_columns, function(column) {
# check if it is a numerical filter and extract the values
if (str_detect(column, "\\.\\.\\.")) {
vals <- strsplit(column, " ")
c(as.numeric(vals[[1]][1]), as.numeric(vals[[1]][3])) # min/max values
} else {
if (column == "") {
NA
} else {
vals <- strsplit(column, "\"")
index <- seq(from = 2, to = length(vals[[1]]), by = 2)
as.character(vals[[1]][index])
}
}
})
# do the filtering
temp <- get(input$dataset)
temp <- as.data.frame(temp)
for (i in seq_along(filter_conditions)) {
current_vals <- filter_conditions[[i]]
if (all(is.numeric(current_vals))) {
# it's a numeric column
temp <- temp[temp[, i] >= current_vals[1] & temp[, i] <= current_vals[2], ]
}
if (all(is.character(current_vals))) {
# it's a character column
temp[, i] <- as.character(temp[, i])
temp <- temp[temp[, i] %in% current_vals, ]
}
}
my_data[[dataset]] <- temp
updateSelectInput(session = session, inputId = "dataset",
selected = input$dataset)
})
output$ui_removedataset <- renderUI({
selectInput(
inputId = "removeDataset",
label = NULL,
choices = my_info[["datasetlist"]],
selected = NULL,
multiple = TRUE,
size = length(my_info[["datasetlist"]]),
selectize = FALSE
)
})
observeEvent(input$removeDataSetButton, {
if (is.null(input$removeDataset)) return()
datasets <- my_info[["datasetlist"]]
if (length(datasets) > 1) {
removeDataset <- input$removeDataset
if (length(datasets) == length(removeDataset)) {
removeDataset <- removeDataset[-1]
}
suppressWarnings(rm(list = removeDataset, envir = my_data))
my_info[["datasetlist"]] <- datasets[-which(datasets %in% removeDataset)]
}
})
}
shinyApp(ui = ui, server = server)
Edit
Here is a version where you can select the changed dataset after storing it:
library(shiny)
library(shinyWidgets)
library(dplyr)
library(tidyverse)
library(shinyjs)
ui <- fluidPage(
titlePanel("Dataset Tool"),
sidebarLayout(
sidebarPanel(width = 3,
conditionalPanel(
condition = "input.tabs=='Datasets'",
uiOutput("ui_datasets"),
uiOutput("ui_storedataset"),
br(), br(),
wellPanel(
checkboxInput("data_remove", "Remove dataset from memory",
FALSE),
conditionalPanel(
condition = "input.data_remove == true",
uiOutput("ui_removedataset"),
actionButton("removeDataSetButton",
"Remove dataset")
)
)
)
),
mainPanel(
tabsetPanel(id = "tabs",
tabPanel("Datasets",
DT::dataTableOutput("datatable")
)
)
)
)
)
server = function(input, output,session) {
my_data <- new.env()
my_state <- list()
my_info <- reactiveValues()
datasetlist <- c()
my_df <- list()
df <- list()
df_names <- c("diamonds", "mtcars")
for (j in df_names) {
df[[j]] <- get(j)
datasetlist <- c(datasetlist, j)
}
my_info[["datasetlist"]] <- datasetlist
my_df[["df"]] <- df
output$ui_datasets <- renderUI({
tagList(
selectInput(
inputId = "dataset",
label = "Datasets:",
choices = my_info[["datasetlist"]],
multiple = FALSE
)
)
})
output$ui_storedataset <- renderUI({
tagList(
wellPanel(
tags$table(
tags$td(textInput("stored_name",
"Store new dataset as:",
"",
placeholder = "name of the dataset")),
tags$td(actionButton("view_store",
"Store"),
style = "padding-right:30px;")
)
)
)
})
observeEvent(input$datatable_search_columns, {
my_state$datatable_search_columns <<- input$datatable_search_columns
})
observeEvent(input$datatable_state, {
my_state$datatable_state <<-
if (is.null(input$datatable_state)) list() else input$datatable_state
})
output$datatable <- DT::renderDataTable({
dat <- df[[(input$dataset)]]
search <- my_state$datatable_state$search$search
if (is.null(search)) search <- ""
fbox <- if (nrow(dat) > 5e6) "none" else list(position = "top")
DT::datatable(
dat,
filter = fbox,
selection = "none",
rownames = FALSE,
fillContainer = FALSE,
escape = FALSE,
style = "bootstrap",
options = list(
stateSave = TRUE,
searchCols = lapply(my_state$datatable_search_columns, function(x) list(search = x)),
search = list(search = search, regex = TRUE),
order = {
if (is.null(my_state$datatable_state$order)) {
list()
} else {
my_state$datatable_state$order
}
},
columnDefs = list(
list(orderSequence = c("desc", "asc"), targets = "_all"),
list(className = "dt-center", targets = "_all")
),
autoWidth = TRUE,
processing = isTRUE(fbox == "none"),
pageLength = {
if (is.null(my_state$datatable_state$length)) 10 else my_state$datatable_state$length
},
lengthMenu = list(c(5, 10, 25, 50, -1), c("5", "10", "25", "50", "All"))
),
callback = DT::JS('$(window).on("unload", function() { table.state.clear(); })')
)
})
observeEvent(input$view_store, {
req(input$stored_name)
dataset <- (input$stored_name)
if (input$stored_name != dataset) {
updateTextInput(session, inputId = "stored_name", value = dataset)
}
# get filter conditions
filter_conditions <- lapply(my_state$datatable_search_columns, function(column) {
# check if it is a numerical filter and extract the values
if (str_detect(column, "\\.\\.\\.")) {
vals <- strsplit(column, " ")
c(as.numeric(vals[[1]][1]), as.numeric(vals[[1]][3])) # min/max values
} else {
if (column == "") {
NA
} else {
vals <- strsplit(column, "\"")
index <- seq(from = 2, to = length(vals[[1]]), by = 2)
as.character(vals[[1]][index])
}
}
})
# do the filtering
temp <- get(input$dataset)
temp <- as.data.frame(temp)
for (i in seq_along(filter_conditions)) {
current_vals <- filter_conditions[[i]]
if (all(is.numeric(current_vals))) {
# it's a numeric column
temp <- temp[temp[, i] >= current_vals[1] & temp[, i] <= current_vals[2], ]
}
if (all(is.character(current_vals))) {
# it's a character column
temp[, i] <- as.character(temp[, i])
temp <- temp[temp[, i] %in% current_vals, ]
}
}
df[[dataset]] <<- temp
my_info[["datasetlist"]] <- c(my_info[["datasetlist"]], input$stored_name)
updateSelectInput(session = session, inputId = "dataset",
selected = input$dataset)
})
output$ui_removedataset <- renderUI({
selectInput(
inputId = "removeDataset",
label = NULL,
choices = my_info[["datasetlist"]],
selected = NULL,
multiple = TRUE,
size = length(my_info[["datasetlist"]]),
selectize = FALSE
)
})
observeEvent(input$removeDataSetButton, {
if (is.null(input$removeDataset)) return()
datasets <- my_info[["datasetlist"]]
if (length(datasets) > 1) {
removeDataset <- input$removeDataset
if (length(datasets) == length(removeDataset)) {
removeDataset <- removeDataset[-1]
}
suppressWarnings(rm(list = removeDataset, envir = my_data))
my_info[["datasetlist"]] <- datasets[-which(datasets %in% removeDataset)]
}
})
}
shinyApp(ui = ui, server = server)
A few issues with your code I've noticed:
I recommend not to use get, this makes it less clear and debuggable where the data comes from; I'd work directly with the lists/reactives where your data is stored to retrieve it
there is something going on with the filters set in the table; they stay even when you switch datasets, I think you have to put some work into that
you have a lot of similar lists (like my_df and df) (and I think you don't use both), which makes your code harder to understand
try to use more observeEvent/updateXXInput as it's a bit faster than doing all the renderUI on the server side

How to return a server object in Ui?

I am creating a appshiny to analyze a statistical model. In it the user places the data set and the model is returned. I would like to implement the removal of non-significant variables, but for that I need the variable names of my file to return to selectInput, is it possible to do this?
library(shiny)
ui <- fluidPage(
titlePanel("-"),
sidebarLayout(
sidebarPanel(
fileInput(inputId="arquivo", "Selecione o arquivo",accept = ".csv"),
selectInput(inputId = "insi", "Selecione as variaveis não significativas", choices = names(k) ,multiple = TRUE )
),
mainPanel(
tabsetPanel(type = "tab",
tabPanel("Dados",tableOutput("dados")),
tabPanel("Ajuste", verbatimTextOutput("model"))
)
)
)
)
server <- function(input, output) {
output$dados <- renderTable({
if(is.null(input$arquivo)) return(NULL)
k <- read.csv(input$arquivo$datapath, header = TRUE, stringsAsFactors = FALSE)
if(input$header==FALSE)
{
return(k)
}
if (input$header==TRUE)
{
return(head(k))
}
})
output$model <- renderPrint({
if(is.null(input$arquivo)) return(NULL)
k <- read.csv(input$arquivo$datapath, header = TRUE, stringsAsFactors = FALSE)
v <- ncol(k)
y <- k[, 1]
h <- k[, -1]
mData <- data.frame(vY = y, mX = h)
colnames(mData) <- c("vY", paste("VX", 2:v, sep = ""))
mod <- glm(vY ~ ., data = mData, family = binomial)
print(summary(mod))
})
}
shinyApp(ui = ui, server = server)
See my comment above and this first answer is not ideal but should work for your purposes (see below for improved answer):
library(shiny)
ui <- fluidPage(
titlePanel("-"),
sidebarLayout(
sidebarPanel(
fileInput(inputId="arquivo", "Selecione o arquivo",accept = ".csv"),
selectInput(inputId = "insi", "Selecione as variaveis não significativas", choices = "" ,multiple = TRUE )
),
mainPanel(
tabsetPanel(type = "tab",
tabPanel("Dados",tableOutput("dados")),
tabPanel("Ajuste", verbatimTextOutput("model"))
)
)
)
)
server <- function(input, output, session) {
output$dados <- renderTable({
if(is.null(input$arquivo)) return(NULL)
k <- read.csv(input$arquivo$datapath, header = TRUE, stringsAsFactors = FALSE)
updateSelectInput(session = session, inputId = "insi", choices = names(k))
return(k)
#if(input$header==FALSE)
#{
# return(k)
#}
#if (input$header==TRUE)
#{
# return(head(k))
#}
})
output$model <- renderPrint({
if(is.null(input$arquivo)) return(NULL)
k <- read.csv(input$arquivo$datapath, header = TRUE, stringsAsFactors = FALSE)
v <- ncol(k)
y <- k[, 1]
h <- k[, -1]
mData <- data.frame(vY = y, mX = h)
colnames(mData) <- c("vY", paste("VX", 2:v, sep = ""))
mod <- glm(vY ~ ., data = mData, family = binomial)
print(summary(mod))
})
}
shinyApp(ui = ui, server = server)
Update - improved answer
library(shiny)
ui <- fluidPage(
titlePanel("-"),
sidebarLayout(
sidebarPanel(
fileInput(inputId="arquivo", "Selecione o arquivo",accept = ".csv"),
selectInput(inputId = "insi", "Selecione as variaveis não significativas", choices = "" ,multiple = TRUE )
),
mainPanel(
tabsetPanel(type = "tab",
tabPanel("Dados",tableOutput("dados")),
tabPanel("Ajuste", verbatimTextOutput("model"))
)
)
)
)
server <- function(input, output, session) {
k <- reactive({
if(is.null(input$arquivo)) return(NULL)
k <- read.csv(input$arquivo$datapath, header = TRUE, stringsAsFactors = FALSE)
updateSelectInput(session = session, inputId = "insi", choices = names(k))
return(k)
})
output$dados <- renderTable({
req(k())
})
output$model <- renderPrint({
k <- req(k())
v <- ncol(k)
y <- k[, 1]
h <- k[, -1]
mData <- data.frame(vY = y, mX = h)
colnames(mData) <- c("vY", paste("VX", 2:v, sep = ""))
mod <- glm(vY ~ ., data = mData, family = binomial)
print(summary(mod))
})
}
shinyApp(ui = ui, server = server)
The main edits:
Making choices = "" in the ui and then using updateSelectInput() once names(k) exists.
Adding session to server.
Making k a reactive.
Using req().
Please ask if anything needs further explaining.

Error: "Invalid JSON response" when I try to update data with DT::replaceData() [shiny]

I'm trying to update a table by changing the class of each variable (string or character). I have tried several methods but most of them just don't render something. With the method used in the code bellow, I can just change one time the type of the variable and then, the table is not reactive anymore.
Do you have an idea of what should I do?
library(DT)
library(shiny)
library(tidyverse)
server = shinyServer(function(input, output, session) {
current_stage <- reactiveValues(data=NULL)
mydata <- reactive({
df <- mtcars %>% rownames_to_column("model")
current_stage$data <- df
df
})
updateData = reactive({
df = mydata()
map(1:ncol(df), function(i){
if(length(input[[paste0("col", i)]])>0){
if (input[[paste0("col", i)]]=="num"){
df[,i] <<- unlist(df[,i]) %>% as.numeric
} else if (input[[paste0("col", i)]]=="cat"){
df[,i] <<- unlist(df[,i]) %>% as.character
}
}
})
#current_stage$data <- df
df
})
output$tableau <- DT::renderDataTable({
df <- current_stage$data
class <- map_df(df, typeof)
class <- gsub("double", "numeric", class)
class <- gsub("integer", "numeric", class)
tableSelectInput <- map(1:ncol(df),
function(i) {
if (class[i] =="numeric"){
opt1 <- "num"
opt2 <- "cat"
}else{
opt1 <- "cat"
opt2 <- "num"
}
selectInput(
inputId = paste0("col", i),
label = NULL, selected = opt1,
choices = c(opt1, opt2))
}
)
# I didn't find a more elegant way to turn '[[ ]]' in '[ ]'
l <- length(tableSelectInput)
selectin <- 1:l
type_cat <- 1:l
for (i in 1:l) {
selectin[i] = as.character(tableSelectInput[[i]])
pos=gregexpr("selected>",selectin[i])[[1]][1]
type_cat[i] = substr(selectin[i],(pos+9),(pos+11))
}
col_names = paste0(colnames(df), " <br/><em>(",type_cat,")</em><br/>", selectin)
isolate(DT::datatable(
current_stage$data,
options = list(
preDrawCallback = JS("function() {
Shiny.unbindAll(this.api().table().node()); }"),
drawCallback = JS("function() { Shiny.bindAll(this.api().table().node());
}")
),
colnames =col_names,
editable = TRUE,
escape=FALSE,
selection = list(target = 'column')))
}, server=FALSE)
output$log <- renderPrint({
updateData()
})
output$log2 <- renderPrint({
map_df(updateData(),class)
})
})
ui = shinyUI(
fluidPage(
titlePanel("My Awesome Shiny App"),
# Show a plot of the generated distribution
mainPanel(
DT::DTOutput("tableau"),
# Show log
verbatimTextOutput("log"),
verbatimTextOutput("log2")
)
)
)
runApp(list(ui = ui, server = server))
I think there is something wrong with the input button call "col1", "col2", etc..
I should maybe create them in a different way but I don't I am just stuck for the moment. Someone could give me an advice?
Kevin
Update:
I have tried this code but it looks to have some trouble with Ajax:
DataTables warning: table id=DataTables_Table_0 - Invalid JSON response. For more information about this error, please see http://datatables.net/tn/1"
library(DT)
library(shiny)
library(tidyverse)
server = shinyServer(function(input, output, session) {
current_stage <- reactiveValues(data=NULL, init=NULL,n=0)
mydata <- reactive({
df <- mtcars %>% rownames_to_column("model")
current_stage$data <- df
current_stage$init <- df
df
})
updateData = reactive({
# input$refresh
# df$ID <<- c(df$ID[n], df$ID[-n])
df = mydata()
if( !is.null(current_stage$data)){
df <- current_stage$data
map(1:ncol(df), function(i){
if(length(input[[paste0("col", i)]])>0){
if (input[[paste0("col", i)]]=="num"){
df[,i] <<- unlist(current_stage$init [,i]) %>% as.numeric
} else if (input[[paste0("col", i)]]=="cat"){
df[,i] <<- unlist(current_stage$init [,i]) %>% as.character
}
}
})}
# if(length(input[[paste0("col", 1)]])>0){
# if (input[[paste0("col", 1)]]=="num"){
# # message(proxy)
# df[,1] <- unlist(df[,1]) %>% as.numeric
# # # mydata()[,1] <- paste(proxy[,1],"ok")
# } else if (input[[paste0("col", 1)]]=="cat"){
# # # message(proxy)
# df[,1] <- unlist(df[,1]) %>% as.character
# }}
current_stage$data <- df
df
})
output$tableau <- DT::renderDataTable({
#df <- mtcars %>% rownames_to_column("model")
df <- mydata()
class <- map_df(df, typeof)
class <- gsub("double", "numeric", class)
class <- gsub("integer", "numeric", class)
tableSelectInput <- map(1:ncol(df),
function(i) {
if (class[i] =="numeric"){
opt1 <- "num"
opt2 <- "cat"
}else{
opt1 <- "cat"
opt2 <- "num"
}
selectInput(
inputId = paste0("col", i),
label = NULL, selected = opt1,
choices = c(opt1, opt2))
}
)
# I didn't find a more elegant way to turn '[[ ]]' in '[ ]'
l <- length(tableSelectInput)
selectin <- 1:l
type_cat <- 1:l
for (i in 1:l) {
selectin[i] = as.character(tableSelectInput[[i]])
pos=gregexpr("selected>",selectin[i])[[1]][1]
type_cat[i] = substr(selectin[i],(pos+9),(pos+11))
}
col_names = paste0( colnames(df), " <br/><em>(",type_cat,")</em><br/>", selectin)
DT::datatable(isolate(
updateData()),
options = list(
preDrawCallback = JS("function() {
Shiny.unbindAll(this.api().table().node()); }"),
drawCallback = JS("function() { Shiny.bindAll(this.api().table().node());
}")
),
colnames =col_names,
editable = TRUE,
escape=FALSE,
selection = list(target = 'column'))
}, server=FALSE)
proxy <- dataTableProxy('tableau')
observe({
replaceData(proxy, updateData(), resetPaging = TRUE )
})
output$log <- renderPrint({
updateData()
})
})
ui = shinyUI(
fluidPage(
titlePanel("My Awesome Shiny App"),
# Show a plot of the generated distribution
mainPanel(
DT::DTOutput("tableau"),
# Show log
verbatimTextOutput("log")
)
)
)
runApp(list(ui = ui, server = server))

R Shiny loop logical operator

I have a running example: I am updating a data.table depending on users input via checkboxes. So far Iam filtering the data explicitly, but I would like to do that with the help of a loop using a for loop or a function of the apply-family. Unfortunately I cannot get either to work.
library(shiny)
library(data.table)
library(DT)
tdata <- data.table(fruit = c(rep("Apple",4),rep( "Ban",4)),
bug1 = c(rep(c("+","+", "-","-"),2)),
bug2 = c(rep(c("+","-"),4)),
value = c(rep(c(0.25),4), 0.6,0.4,0,0))
ui <- (fluidPage(tagList(
sidebarLayout(
sidebarPanel(uiOutput("file_input")),
mainPanel(dataTableOutput('fruit_table'))
))))
server <- function(input, output) {
fileData <- reactive(
return(tdata)
)
colname_list <- reactive(
colnames(fileData())
)
output$file_input <- renderUI ({
if(is.null(fileData())){
return()
}else{
tagList(
lapply(1:(length(fileData())-1), function(i){
choice_list = unique(fileData()[,get(colnames(fileData()[,i, with = FALSE]))])
checkboxGroupInput(inputId = colnames(fileData()[,i, with = FALSE]),
label = colnames(fileData()[,i, with = FALSE]),
choices = choice_list,
inline = TRUE,
selected = fileData()[1, i, with = FALSE])
})
)
}
})
# works fine, but usually the number of columns changes so I want to keep it flexible
fruitFilter <- reactive({
fileData()[[paste0(colname_list()[1])]] %in% input[[paste0(colname_list()[1])]] &
fileData()[[paste0(colname_list()[2])]] %in% input[[paste0(colname_list()[2])]] &
fileData()[[paste0(colname_list()[3])]] %in% input[[paste0(colname_list()[3])]]
})
# fruitFilter <- reactive({
# for(i in 1: ((length(fileData()))-1)){
# fileData()[[paste0(colname_list()[i])]] %in% input[[paste0(colname_list()[i])]]
# }
# })
output$fruit_table <- renderDataTable({
datatable(fileData()[fruitFilter(),])
})
}
shinyApp(ui = ui, server = server)
I still consider myself a newby to Shiny. I appreciate any help! Thanks.
In the loop approach, we could initialize a list and then Reduce the output to a single logical vector
fruitFilter <- reactive({
i1 <- head(seq_along(fileData()), -1)
l1 <- vector('list', length(i1))
for(i in i1){
l1[[i]] <- fileData()[[colname_list()[i]]] %in% input[[colname_list()[i]]]
}
Reduce(`&`, l1)
})
With the full code
library(shiny)
library(data.table)
library(DT)
tdata <- data.table(fruit = c(rep("Apple",4),rep( "Ban",4)),
bug1 = c(rep(c("+","+", "-","-"),2)),
bug2 = c(rep(c("+","-"),4)),
value = c(rep(c(0.25),4), 0.6,0.4,0,0))
ui <- (fluidPage(tagList(
sidebarLayout(
sidebarPanel(uiOutput("file_input")),
mainPanel(dataTableOutput('fruit_table'))
))))
server <- function(input, output) {
fileData <- reactive(
return(tdata)
)
colname_list <- reactive(
colnames(fileData())
)
output$file_input <- renderUI ({
if(is.null(fileData())){
return()
}else{
tagList(
lapply(1:(length(fileData())-1), function(i){
choice_list = unique(fileData()[,get(colnames(fileData()[,i, with = FALSE]))])
checkboxGroupInput(inputId = colnames(fileData()[,i, with = FALSE]),
label = colnames(fileData()[,i, with = FALSE]),
choices = choice_list,
inline = TRUE,
selected = fileData()[1, i, with = FALSE])
})
)
}
})
fruitFilter <- reactive({
i1 <- head(seq_along(fileData()), -1)
l1 <- vector('list', length(i1))
for(i in i1){
l1[[i]] <- fileData()[[colname_list()[i]]] %in% input[[colname_list()[i]]]
}
Reduce(`&`, l1)
})
output$fruit_table <- renderDataTable({
datatable(fileData()[fruitFilter()])
})
}
shinyApp(ui = ui, server = server)
--output

How to loop through multiple upload widegets in shiny?

I want to create multiple fileInput function to allow users to upload files. The main reason I am creating multiple upload widgets is because I want to allow users to upload through different path. What I am trying to accomplish here is to loop through all the fileInputs and save all the files into one dataframe but not able to do it in example of my code.
library(shiny)
library(data.table)
library(DT)
n_attachments <- sprintf("file%s",seq(1:2))
ui <- fluidPage(
titlePanel('File download'),
sidebarLayout(
sidebarPanel(
textInput("LOAN_NUMBER", label = "Fannie Mae Loan Number", placeholder = "Please enter loan #")
, textInput("REO_ID", label = "REO Number", placeholder = "Please enter REO #")
, fileInput("file1", "Attachments1", accept = c("text/csv", "text/comma-separated-values,text/plain",".csv", ".pdf", ".doc", ".xlsx"), multiple = TRUE)
, fileInput("file2", "Attachments2", accept = c("text/csv", "text/comma-separated-values,text/plain",".csv", ".pdf", ".doc", ".xlsx"), multiple = TRUE)
, textOutput('text')
),
mainPanel(
DT::dataTableOutput("table"), tags$hr()
)
)
)
server <- function(input, output) {
bin_data <- reactive({
attachement_data <- data.frame(ATTACHMENT = character(), FILENAME = character(), LOAN_NUMBER = character(), REO_ID = character())
for(x in n_attachments)
{
output$text <- renderText({ input$x })
req(input$x)
# binary_data <- paste(readBin(input$file1$datapath, what="raw", n=1e6), collapse="-")
# attachment_info <- data.frame(ATTACHMENT = binary_data, FILENAME = paste0(input$file1$name))
# attachment_info
binary_data=list()
filenames=list()
for(i in 1:length(input$x[,1])){
binary_data[[i]] <- paste(readBin(input$x[[i, 'datapath']], what = "raw", n=1e6), collapse = "-")
filenames[[i]] <- input$x[[i, 'name']]
}
bin_data_frame <- data.frame(ATTACHMENT = as.character(unlist(binary_data)), FILENAME = as.character(unlist(filenames)))
bin_data_frame$LOAN_NUMBER <- input$LOAN_NUMBER
bin_data_frame$REO_ID <- input$REO_ID
attachement_data <- rbind(attachement_data, bin_data_frame)
}
save(attachement_data, file="attachement_data.RData")
attachement_data
})
output$table <- DT::renderDataTable({
bin_data()
})
}
shinyApp(ui = ui, server = server)
ok I think I figured it out, I have to use input[[x]] instead of input$x, and I added couple lines to check how many fileinputs are uploaded.
server <- function(input, output) {
bin_data <- reactive({
attachement_data <- data.frame(ATTACHMENT = character(), FILENAME = character(), LOAN_NUMBER = character(), REO_ID = character())
k <- 0
for(x in n_attachments)
{
if(!is.null(input[[x]]))
{
k = k + 1
}
}
for(x in n_attachments[0:k])
{
if(!is.null(input[[x]]))
{
output$text <- renderText({ input[[x]] })
req(input[[x]])
# binary_data <- paste(readBin(input$file1$datapath, what="raw", n=1e6), collapse="-")
# attachment_info <- data.frame(ATTACHMENT = binary_data, FILENAME = paste0(input$file1$name))
# attachment_info
binary_data=list()
filenames=list()
for(i in 1:length(input[[x]][,1])){
binary_data[[i]] <- paste(readBin(input[[x]][[i, 'datapath']], what = "raw", n=1e6), collapse = "-")
filenames[[i]] <- input[[x]][[i, 'name']]
}
bin_data_frame <- data.frame(ATTACHMENT = as.character(unlist(binary_data)), FILENAME = as.character(unlist(filenames)))
bin_data_frame$LOAN_NUMBER <- input$LOAN_NUMBER
bin_data_frame$REO_ID <- input$REO_ID
attachement_data <- rbind(attachement_data, bin_data_frame)
}
}
save(attachement_data, file="attachement_data.RData")
attachement_data
})
output$table <- DT::renderDataTable({
bin_data()
})
}
shinyApp(ui = ui, server = server)

Resources