I have created a user interface for a mongodb database but am having trouble saving the data to the database. I would like the users to be able to submit form data and then for the app to display this immediately. The form fields also need to be mandatory. I am having trouble submitting the data at present - any help would be greatly appreciated.
library(shiny)
library(jsonlite)
library(mongolite)
## insert into database
DB <- mongo(collection = "test",db = "DB", url = "mongodb://XXX")
fieldsmandatory <- c("name", "data", "Type", "Data ID" )
#func. to labe mandatory fields *
labelMandatory <- function(label) {
tagList(
label,
span("*", class = "mandatory_star")
)
}
appCSS <- ".mandatory_star { color: red; }"
allrownames <- c("name","data", "Type", "Data ID")
ui <- fluidPage(
fluidRow(column(8, "Test_dataset",
dataTableOutput(outputId = "dataset"))),
fluidRow(column(8,
"Add Data",
id = "form",
textInput("name", labelMandatory("Name")),
textInput("date", labelMandatory("date")),
textInput("Type", labelMandatory("Type")),
textInput("DataID", labelMandatory("Data ID")),
actionButton("Submit", "Submit", class = "btn-primary"),
)))
server <- function(input, output, sessiom){
formData <- reactive({
formData <- data.frame(name = input$name,
date = input$date,
Type = input$Type,
DataID = input$DataID,
stringsAsFactors = FALSE)
return(formData)
})
#load dataset
output$dataset <- renderDataTable({
alldata<- DB$find('{}')
print(alldata)
})
#observe if all mandatory fields are filled.
observe({
mandatoryFilled <-
vapply(fieldsMandatory,
function(x) {
!is.null(input[[x]]) && input[[x]] != ""
},
logical(1))
mandatoryFilled <- all(mandatoryFilled)
shinyjs::toggleState(id = "submit",
condition = mandatoryFilled)
})
#Updata Data in the tables fufnction
saveData <- function(data){
DB <- mongo(collection = "test", db = "DB", url = "mongodb://XXX")
data <- as.data.frame(t(data))
DB$insert(data)
}
#Call update to form
observeEvent(input$Submit, {
saveData(formData())
})
}
shinyApp(ui, server)
Related
I have an R6 class that I am using to organize my shiny application. Essentially, I want to connect different R6 classes for an experimental interface I am creating and want to reuse my code. As a simplified working example, see the code below.
library(R6)
library(stringi)
library(shiny)
df <- data.frame(dp = c("dp1", "dp2", "dp3"), desc = c("problem 1", "problem 2", "problem 3"))
app <- R6::R6Class(classname = "App",
private = list(
#unique string id
..id = stringi::stri_rand_strings(1, 18),
#the data to be iterated through
..df = df,
#counter to update text
..counter = 1,
#initiating the dp and desc
..dp = 'dp1',
..desc = 'problem 1',
#the underlying server, to be created like a normal server
.server = function(input, output, session){
output$text <- renderText({
private$..desc
})
observeEvent(input$button, {
private$..counter <- private$..counter + 1
self$update_private()
#check the private content since the print is not updating
print(private$..counter)
print(private$..dp)
print(private$..desc)
})
}
),
public = list(
#create names for ui elements
button = NULL,
text = NULL,
initialize = function(){
self$button <- self$get_id("button")
self$text <- self$get_id("text")
self$update_private()
},
#gives ui outputs unique names tied to the user's id
get_id = function(name, ns = NS(NULL)){
ns <- NS(ns(private$..id))
id <- ns(name)
return(id)
},
#automatically updates the private field based on the counter
update_private = function(){
if(private$..counter == 1){
private$..dp <- "dp1"
} else if(private$..counter == 2){
private$..dp <- "dp2"
} else{
private$..dp <- "dp3"
}
private$..desc <- private$..df[private$..df$dp == private$..dp, "desc"]
},
ui = function(){
fluidPage(
h1("An Example"),
mainPanel(
textOutput(self$text)),
sidebarPanel(
shiny::actionButton(inputId = self$button,
label = 'Update!',
width = '100%'
))
)
},#end ui
server = function(input, output, session){
callModule(module = private$.server, id = private$..id)
}
)
)
test <- app$new()
ui <- test$ui()
server <- function(input, output, session) {
test$server()
}
shinyApp(ui = ui, server = server)
What I want: when someone clicks the action button, the reactive ui will update and the desired text from the data frame will be sliced and displayed.
What I am getting: the internal private data fields are updating but the reactive ui elements are not.
Any ideas what could be causing this or a workaround? I thought about externally trying to use the observe event and then reinitiating the class with a new counter number. But I also can't seem to figure out that option either.
Appreciate your help!
For anyone that comes across this problem... I figured out that even though the private is updating, and even though render is technically a reactive environment, you need to have your data stored publically in a reactive field.
library(R6)
library(stringi)
library(shiny)
df <- data.frame(dp = c("dp1", "dp2", "dp3"), desc = c("problem 1", "problem 2", "problem 3"))
app <- R6::R6Class(classname = "App",
private = list(
#unique string id
..id = stringi::stri_rand_strings(1, 18),
#the data to be iterated through
..df = df,
#counter to update text
..counter = 0,
#initiating the dp and desc
..dp = NA,
..desc = NA,
#the underlying server, to be created like a normal server
.server = function(input, output, session){
output$text <- renderText({
self$desc$text
})
observeEvent(input$button, {
private$..counter <- private$..counter + 1
self$update_private()
self$desc$text <- private$..desc
#check the private content since the print is not updating
print(private$..counter)
print(private$..dp)
print(private$..desc)
})
}
),
active = list(
.counter = function(value){
if(missing(value)){
private$..counter
}else{
private$..counter <- value
}
}
),
public = list(
#create names for ui elements
button = NULL,
text = NULL,
#Need this to update the text***************
desc = reactiveValues(text = NA),
initialize = function(counter = self$.counter){
self$.counter <- counter
self$button <- self$get_id("button")
self$text <- self$get_id("text")
self$update_private()
self$desc$text <- private$..desc
},
#gives ui outputs unique names tied to the user's id
get_id = function(name, ns = NS(NULL)){
ns <- NS(ns(private$..id))
id <- ns(name)
return(id)
},
#automatically updates the private field based on the counter
update_private = function(){
if(private$..counter == 1){
private$..dp <- "dp1"
} else if(private$..counter == 2){
private$..dp <- "dp2"
} else{
private$..dp <- "dp3"
}
private$..desc <- private$..df[private$..df$dp == private$..dp, "desc"]
},
ui = function(){
fluidPage(
h1("An Example"),
mainPanel(
textOutput(self$text)),
sidebarPanel(
shiny::actionButton(inputId = self$button,
label = 'Update!',
width = '100%'
))
)
},#end ui
server = function(input, output, session){
counter <- reactiveVal(private$..counter)
callModule(module = private$.server, id = private$..id)
}
)
)
test <- app$new(counter = 1)
ui <- test$ui()
server <- function(input, output, session) {
test$server()
}
shinyApp(ui = ui, server = server)
I am developing a shiny app which stores the arbitrary data. I have referred This link for the same. I can able to display all the responses including previous responses, but i want to display only the current response, not all response. My code snippet is as given below:
library(shiny)
outputDir <- "C:\\Users/dell/Desktop/"
saveData <- function(data) {
data <- as.data.frame(t(data))
if (exists("responsesiq")) {
responsesiq <<- rbind(responsesiq, data)
} else {
responsesiq <<- data
}
fileName <- "test_irty.csv"
write.csv(
x = responsesiq, sep = ",",
file = file.path(outputDir, fileName),
row.names = FALSE, quote = TRUE
)
}
loadData <- function() {
if (exists("responsesiq")) {
responsesiq
}
}
fields <- c("acc", "staff_name")
shinyApp(
ui = fluidPage(
titlePanel(" System"),
DT::dataTableOutput("responsesiq", width = 300), tags$hr(),
numericInput("acc", "Acc Number", ""),
selectInput("staff_name", "Staff Name",
c("Rajivaksh " = "RT",
"Arvind " = "AKS",
"Ashutosh " = "AS")),
actionButton("submit", "Submit")
),
server = function(input, output, session) {
formData <- reactive({
data <- sapply(fields, function(x) input[[x]])
data
})
observeEvent(input$submit, {
saveData(formData())
})
# Show the previous responses
# (update with current response when Submit is clicked)
output$responsesiq <- DT::renderDataTable({
input$submit
loadData()
})
}
)
Create reactiveValues to hold the current entry, which will trigger when clicking submit
shinyApp(
ui = fluidPage(
titlePanel(" System"),
DT::dataTableOutput("responsesiq", width = 300), tags$hr(),
numericInput("acc", "Acc Number", ""),
selectInput("staff_name", "Staff Name",
c("Rajivaksh " = "RT",
"Arvind " = "AKS",
"Ashutosh " = "AS")),
actionButton("submit", "Submit")
),
server = function(input, output, session) {
formData <- reactive({
data <- sapply(fields, function(x) input[[x]])
data
})
tmp <- reactiveValues(df=NULL)
observeEvent(input$submit, {
saveData(formData())
tmp$df <- t(formData())
})
# Show the previous responses
# (update with current response when Submit is clicked)
output$responsesiq <- DT::renderDataTable({
input$submit
#loadData()
data.frame(tmp$df)
})
}
)
I am developing a shiny application which save the data entered on the user interface. I have refered the url on shiny rstudio page so by using this page, the code i have written is as mentioned below:
outputDir <- "C:\\Users/dell/Desktop/"
saveData <- function(data) {
data <- t(data)
fileName <- sprintf("%s_%s.csv", as.integer(Sys.time()), digest::digest(data))
write.csv(
x = data, sep = ",",
file = file.path(outputDir, fileName),
row.names = FALSE, quote = TRUE
)
}
loadData <- function() {
files <- list.files(outputDir, full.names = TRUE)
data <- lapply(files, read.csv, stringsAsFactors = FALSE)
data <- do.call(rbind, data)
data
}
library(shiny)
fields <- c("name", "staff_name")
shinyApp(
ui = fluidPage(
titlePanel("attendance System"),
DT::dataTableOutput("responses", width = 300), tags$hr(),
textInput("name", "Accession Number", ""),
selectInput("staff_name", "Staff Name",
c("Rajiv" = "RT",
"Arvind " = "AKS",
"Ashutosh " = "AS")),
actionButton("submit", "Submit")
),
server = function(input, output, session) {
formData <- reactive({
data <- sapply(fields, function(x) input[[x]])
data
})
observeEvent(input$submit, {
saveData(formData())
})
output$responses <- DT::renderDataTable({
input$submit
loadData()
})
}
)
The above code create a new file for each entry. I am looking for a single file in which all entry to be added.
This will give you a unique file name based on time of save and content of the file:
fileName <- sprintf("%s_%s.csv", as.integer(Sys.time()), digest::digest(data))
You can give it a single name like:
fileName <- 'input_bu.csv'
Like #ismirsehregal, I'd recommend bookmarking for this though.
after looking various solutions. I reached at below code to save the data in a single file as it is entered.
library(shiny)
outputDir <- "C:\\Users/dell/Desktop/"
saveData <- function(data) {
data <- as.data.frame(t(data))
if (exists("responsesiq")) {
responsesiq <<- rbind(responsesiq, data)
} else {
responsesiq <<- data
}
fileName <- "test_igntu.csv"
write.csv(
x = responsesiq, sep = ",",
file = file.path(outputDir, fileName),
row.names = FALSE, quote = TRUE
)
}
fields <- c("acc", "staff_name")
shinyApp(
ui = fluidPage(
titlePanel("Attendance System"),
DT::dataTableOutput("responsesiq", width = 300), tags$hr(),
numericInput("acc", "AccNumber", ""),
selectInput("staff_name", "Staff Name",
c("Rajiv" = "RT",
"Arvind" = "AKS",
"Ashutosh" = "AS")),
actionButton("submit", "Submit")
),
server = function(input, output, session) {
# Whenever a field is filled, aggregate all form data
formData <- reactive({
data <- sapply(fields, function(x) input[[x]])
data
})
# When the Submit button is clicked, save the form data
observeEvent(input$submit, {
saveData(formData())
})
}
)
Trying to use selectInput in a form.
the choices are fetched from a collection in mongodB.
when user
completes the form and submits (which inserts to another collection
in mongo), data in selectInput is not captured.
tried to make it reactive or use observeEvent /updateSelectInput in the server but could not make it work.
here is the entire code:
library(shiny)
library(mongolite)
library(jsonlite)
# which fields get saved
fieldsAll <- c("Name", "selectOne", "tags")
saveData <- function(data) {
# Connect to the database
}
# load all responses into a data.frame
loadData <- function() {
# Connect to the database
}
fetchData <- function() {
# Connect to the database
}
shinyApp(
ui = tagList(
navbarPage(
tabPanel("Technology",
sidebarPanel(
textInput("Name",label ='Name:'),
selectInput('selectOne',
label ='Select One:',
choices=head(fetchData()),
selected = "",
multiple = FALSE),
selectizeInput("tags", "Tags:", NULL, multiple = TRUE, options=list(create=TRUE)),
actionButton("submit", "Submit", class = "btn-primary")
),
mainPanel(
tabsetPanel(
tabPanel("Table",
uiOutput("adminPanelContainer")
)
)
)
)
)
),
server = function(input, output, session) {
formData <- reactive({
fieldsAll
data <- sapply(fieldsAll, function(x) input[[x]])
data <- t(data)
data
})
observeEvent(input$submit, {
saveData(formData())
},
)
# render the admin panel
output$adminPanelContainer <- renderUI({
DT::dataTableOutput("responsesTable")
})
# Update the responses table whenever a new submission is made
responses_data <- reactive({
input$submit
data <- loadData()
data
})
# Show the responses in the admin table
output$responsesTable <- DT::renderDataTable({
DT::datatable(
responses_data(),
rownames = FALSE,
options = list(searching = TRUE, lengthChange = FALSE)
)
})
}
)
adding a column to the df with selected value worked:
formData <- reactive({
fieldsAll
data <- sapply(fieldsAll, function(x) input[[x]])
data <- c(data,selectOne= input$selectOne) #added line
data <- t(data)
data
})
I am trying to do this autocomplete using a list which would be populated dynamically from a database everytime the applications loads. Unfortunately the following approach isn't working.
rm(list = ls())
library(shinysky)
library(shiny)
library(RMySQL)
loadData <- function(publisherId) {
# Connect to the database
mydb = dbConnect(MySQL(), user='root', password='root',host='localhost',dbname="tq")
# Construct the fetching query
query <- sprintf("select * from tq.publisher_dim where publisher_id = %s",publisherId) # Submit the fetch query and disconnect
data <- dbGetQuery(mydb, query)
dbDisconnect(mydb)
data
}
loadPubIds <- function() {
# Connect to the database
mydb = dbConnect(MySQL(), user='root', password='root', host='localhost', dbname="tq")
# Construct the fetching query
query <- sprintf("select distinct publisher_id from tq.publisher_dim" )
# Submit the fetch query and disconnect
data <- dbGetQuery(mydb, query)
dbDisconnect(mydb)
data
}
my_autocomplete_list <- c(loadPubIds())
ui <- fluidPage(
select2Input("txt","",choices = NULL,selected = NULL),
textInput(inputId ="publisherId", label="choose publisherId", value = "", width = NULL, placeholder = NULL),
actionButton("goButton", "Go!"),
dataTableOutput('mytable')
#textOutput('myquery')
)
server <- function(input, output,session) {
test <- reactive({
pubs <- loadPubIds()
})
observe({
pubs <- loadPubIds()
updateSelect2Input(session, 'txt', choices = as.list(pubs), label = "")
})
output$mytable <- renderDataTable({
if (input$goButton == 0)
return()
isolate({ loadData(input$publisherId) })
})
}
shinyApp(ui = ui, server = server)
Any help would be great.