Update editable DataTable Output in RShiny - shiny

I am new to the world of RShiny and i think reactivity is bit complex to understand. I am trying to make a datatable output based on row and column condition given as per user selectinput dropdown buttons. My DataTable is editable and i want to store the updated table after user edited the cells of the datatable in a new variable but i am stuck.
I tried couple of chunks suggested on stackoverflow but none of them worked for me mostly using proxytable or reactivity. I want to store the datatable after i hit proceed button. Any help would be much appreciated.
Here is my code:
library(shiny)
library(shinyWidgets)
library(shinythemes)
library(DT)
library(data.table)
#ui
shinyApp(
ui = fluidPage(
theme = shinythemes::shinytheme("flatly"),
titlePanel("Trial"),
sidebarLayout(
shiny::sidebarPanel(
#to take multiple user input
shiny::textAreaInput(
"text_input",
label = "Write input"
),
#to slect the columns to be added
shinyWidgets::pickerInput(
inputId = "somevalue",
label = "Columns to add",
choices = colnames(df),
options = list(`actions-box` = TRUE),
multiple = TRUE
),
#action button tot show the table
shinyWidgets::actionBttn(
"show_table",
label = "Show",
size = "sm",
color = "default",
block = TRUE
), width = 2
),
mainPanel(
shiny::tabsetPanel(type = "tabs",
shiny::tabPanel("Table", DT::dataTableOutput("table")),
actionBttn("proceed","proceed")
),width = 10
)
)
),
server = function(input, output,session) {
#to add reactivity to the show button
df_filter <- reactive({
text_input <- trimws(strsplit(input$text_input, ",")[[1]])
df_filter <- df[df$make %chin% text_input, input$somevalue]
})%>% shiny::bindEvent(input$show_table)
#to output hte dt table with the filters
output$table <- DT::renderDT({
DT::datatable(df_filter(),
editable = 'cell',
options = list(scrollX = TRUE , lengthChange = FALSE, autoWidth = TRUE)
# editable = list(target = "row", disable = list(columns = c(2, 4, 5))))
)
})%>% shiny::bindEvent(df_filter())
}
)

Related

Subset the datatable by multiple user input filter separated by comma

I am quite new to R shiny and I am trying to build a small shiny app but I don't know where I went wrong.
I am trying to get multiple user input via text area to filter my table output. Moreover, i want to control the columns to show in the table as well. Code is running fine for showing the columns but it is working only with one input value in the text area, it is not working with multiple user inputs.
I want to filter the table output with multiple user inputs as well.
For example for this code snippet it should return table when I write "honda,audi,bmw" in the text area input.
library(shiny)
library(shinyWidgets)
library(DT)
df <-mtcars
#ui
shinyApp(
ui = fluidPage(
titlePanel("Trial 1"),
sidebarLayout(
sidebarPanel(
#to take multiple user input
textAreaInput(
"text_input",
label = "Write multiple input separated by comma"
),
#to slect the columns to be added
pickerInput(
inputId = "somevalue",
label = "Columns to add",
choices = colnames(df),
options = list(`actions-box` = TRUE),
multiple = TRUE
),
#action button tot show the table
actionBttn(
"show_table",
label = "Show",
size = "sm",
color = "default",
block = TRUE
),
),
mainPanel(
tabsetPanel(type = "tabs",
tabPanel("Table", DT::dataTableOutput("table")),
tabPanel("Summary", verbatimTextOutput("summary"))
)
)
)
),
server = function(input, output,session) {
data <- observeEvent(input$show_table,{
text_input <- trimws(strsplit(input$text_input, ",")[[1]])
output$summary <- renderPrint({
summary(data())
})
output$table <- DT::renderDT({
df_sub <- df[df$make %chin% input$text_input, input$somevalue]
#df_sub = df[ ,input$somevalue]
datatable(df_sub,
caption = "PLease enter the changes by double clicking the cell",
editable = 'cell')
})
})
}
)
There isn't a 'make' variable in the data. I guess you refer to the first word of the row name as the make of the car. Then the strings you entered could be matched with the make of the car.
server = function(input, output,session) {
data <- observeEvent(input$show_table,{
brand <- word(rownames(df), 1)
text_input <- strsplit(input$text_input, ",")[[1]]
df_sub <- df[brand %in% text_input, input$somevalue]
output$summary <- renderPrint({
summary(df_sub)
})
output$table <- DT::renderDT({
datatable(df_sub,
caption = "PLease enter the changes by double clicking the cell",
editable = 'cell')
})
output$test <- renderText({
text_input
})
})}

Anonymise selected column in R shiny using sapply

I am creating an R Shiny app, where a user can upload their own csv, and the app generates a synthetic dataset. I am trying to add an additional function where the user can select a column they wish to anonymise to make it a shareable file. The rest of the app is currently working, however when I select the column which I want to anonomise, when I press update, the datatable isn't refreshing.
Any help or insight here would be greatly appreciated! I've tried and tried to solve it, but am stuck.
A shortened/reproducible version of the code app is below
`
library(shiny)
library(synthpop)
library(DT)
library(tidyverse)
library(data.table)
library(rsconnect)
library(fontawesome)
library(DT)
library(htmltools)
library(shinythemes)
library(RcppRoll)
library(grid)
library(reactable)
library(shinydashboard)
library(shinydashboardPlus)
library(formattable)
library(dashboardthemes)
library(deidentifyr)
library(anonymizer)
library(digest)
# User interface
ui <- fluidPage(theme = shinytheme("cosmo"),
navbarPage("Synthetic data",
# Upload data tab
tabPanel("Upload data",
sidebarLayout(
sidebarPanel(width = 3,
h4(strong("Upload original data")),
br(),
fileInput(inputId = "datafile", label = "1. Upload a csv file then press 'Update' below.
Note, the larger your dataset, the longer it will take to load", multiple = FALSE, placeholder = "No file selected",
accept = c("text/csv", "text/comma-separated-values,text/plain", ".csv")),
actionButton(inputId = "update", label = "Update", icon = icon("fas fa-sync")),
br(),
br(),
h5(strong("2. To view and download the synthesised dataset, click on the 'Synthetic data' tab at the top"))),
mainPanel(dataTableOutput("table"), style = "font-size:80%"))),
# Synthetic data download
tabPanel("Synthetic data",
sidebarLayout(
sidebarPanel(width = 3,
h4(strong("Anonomise data?")),
br(),
uiOutput(outputId = "anon"),
br(),
actionButton(inputId = "update2", label = "Update", icon = icon("fas fa-sync"))),
mainPanel(dataTableOutput("synth"), style = "font-size:75%"))),
))
# Server function
server <- function(input, output, session) {
options(shiny.maxRequestSize=20*1024^2)
contentsrea <- reactive({
inFile <- input$datafile
if(is.null(inFile))
return(NULL)
dataset <- read_csv(inFile$datapath)
})
observeEvent(input$update, {
if(!is.null(input$datafile)){
original <- read_csv(input$datafile$datapath)
my.seed <- 17914709
synResult <- syn(original, seed = my.seed, maxfaclevels = 150)
# Synthetic data
df <- synResult$syn
# Add 'SYNTH' to column headings
colnames(df) <- paste("SYNTH", colnames(df), sep="_")
# Variable dropdown to anonomise data
output$anon <- renderUI({
selectInput(inputId = "anon",
label="1. Select the variable you'd like to anonomise (i.e., athlete name). If not necessary, leave as blank",
choices = c(" ", colnames(df)),
selected = NULL)
})
## Original
output$table <- DT::renderDataTable(original,
caption = htmltools::tags$caption(
style = 'caption-side: top; text-align: left; color: black; font-size:140%',
h3(strong("Original data"))), server = FALSE, rownames=FALSE,
options = list(bFilter=0, iDisplayLength=18,
columnDefs = list(list(className = 'dt-center', targets = '_all')),
dom = 'frtip'))
# Synthetic dataset
output$synth <- DT::renderDataTable(df,
caption = htmltools::tags$caption(
style = 'caption-side: top; text-align: left; color: black; font-size:140%',
h3(strong("Simulated synthetic data"))),
server = FALSE, rownames=FALSE, extensions = c("Buttons"),
options = list(iDisplayLength=18, bFilter=0,
columnDefs = list(list(className = 'dt-center', targets = '_all')),
dom = 'Bfrtip'))
}})
}
# Synthetic dataset with update for anon
observeEvent(input$update2, {
if(!is.null(input$datafile)){
output$synth <- DT::renderDataTable({
# Anonomise
df$ID <- sapply(input$anon, digest, algo = "crc32")
datatable(df,
caption = htmltools::tags$caption(
style = 'caption-side: top; text-align: left; color: black; font-size:140%',
h3(strong("Simulated synthetic data"))),
server = FALSE, rownames=FALSE, extensions = c("Buttons"),
options = list(iDisplayLength=18, bFilter=0,
columnDefs = list(list(className = 'dt-center', targets = '_all')),
dom = 'Bfrtip'))
})
}})
# Run the app ----
shinyApp(ui, server)
`
I have tried removing the update button ans using a reactive table, as well as other anonomise functions. I am completely stuck.

Retrieving unique id and input values from datatable in Shiny

I am attempting to use DT in R to create a table for user review with an appended column (new_column) including a selectInput drop-down that allows them to designate the event as either keep or delete. I am stuck on how to retrieve both the unique id and the user input from the datatable to be able to apply the change to a separate dataframe in Shiny. I would like for the user to push a button ('submit') for the app to know when to capture the values -- with this am I able to circumvent rerending the table or is that a necessary part of capturing the value?
I have worked with Shiny quite a bit but am not super familiar with javascript or datatables in general so have been stuck on this for some time and would appreciate any pointers.
Here is a simplified version of my data and code:
library(DT)
library(tidyverse)
library(shiny)
ui <- fluidPage(
DTOutput('myTableOutput'),
br(),
actionButton("submit", "Apply Changes"))
server <- function(input, output, session) {
for (i in 1:nrow(df)) {
df$new_column[i] <- as.character(selectInput(inputId = df$unique_id[i], label=NULL, choices = c('keep'=TRUE, 'delete'=FALSE)))
}
output$myTableOutput <- DT::renderDataTable({
datatable(
df,
escape = FALSE,
filter = "none",
editable = 'new_column',
selection = "none",
options = list(
dom = "t",
initComplete = JS(
"function(settings, json) {",
"$(this.api().table().header()).css({'background-color': 'DimGray', 'color': 'white'});",
"}"),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } '))
)
}, server = FALSE)
observeEvent(input$submit,{
#need to retrieve changes (preferably in a df) so I can apply them to another dataframe
reviewed_table <- as.data.frame(input$mytable_cell_edit)
})
}
You can add reactive value (lgl_vec) that has values of all selectInput's inside your table:
server <- function(input, output, session) {
rv <- reactiveValues()
df[["new_column"]] <- map_chr(
map(
df[["unique_id"]],
selectInput,
label = NULL,
choices = c(keep = TRUE, delete = FALSE)
),
as.character
)
output$myTableOutput <- DT::renderDataTable({
datatable(
df,
escape = FALSE,
filter = "none",
selection = "none",
options = list(
dom = "t",
preDrawCallback =JS(
'function(){Shiny.unbindAll(this.api().table().node());}'
),
drawCallback = JS(
'function(){Shiny.bindAll(this.api().table().node());}'
)
)
)
}
)
observeEvent(input$submit, {
lgl_vec <- as.logical(map_chr(df[["unique_id"]], ~input[[.x]]))
rv$reviewed_table <- df[lgl_vec, -ncol(df), drop = FALSE]
print(rv$reviewed_table)
})
}

Move items between two list boxes shiny

Is there an easy way to create something like this in shiny?
RStudio is currently working on the sortable package: RStudio/sortable
Beware that it's currently in development (tagged as experimental), so major changes are possible and it's only accessble through GitHub
# install.packages("remotes")
# remotes::install_github("rstudio/sortable")
library(shiny)
library(sortable)
ui <- fluidPage(
fluidRow(
column(
width = 12,
bucket_list(
header = "Drag the items in any desired bucket",
group_name = "bucket_list_group",
add_rank_list(
text = "Drag from here",
labels = c("Ant", "Cat", "Eagle", "Giraffe", "Bear", "Frog","Dog"),
input_id = "rank_list_1"
),
add_rank_list(
text = "to here",
labels = NULL,
input_id = "rank_list_2"
)
)
)
)
)
shinyApp(ui, function(input,output) {})
This results in:

Chart not rendering with Shiny R and NVD3

I have been attempting to create a Shiny timeseries plot using NVD3 library. Am relatively new to R, Shiny and NVD3. The problem is that when I run the ShinyApp, no chart renders on the browser. Using chromes developer tools, I can see that the div for myChart is created and populated with data, but not understanding why I cannot see the chart itself.
Would appreciate any and all help on this matter...
My code is like so:
#ui.R
require(rCharts)
shinyUI(pageWithSidebar(
headerPanel("Population Trend By Age Group:"),
sidebarPanel(
selectInput(inputId = "agegrp",
label = "Choose Agegroup",
choices = c("0-4",
"5-9",
"10-14",
"15-19",
"20-24",
"25-29",
"30-34",
"35-39",
"40-44",
"45-49",
"50-54",
"55-59",
"60-64",
"65-69",
"70-74",
"75-79",
"80-84",
"85+"
),
selected = "0-4")
),
mainPanel(
showOutput("myChart", "nvd3")
)
))
server.R:
#server.R
require(rCharts)
data <- read.csv("https://raw.githubusercontent.com/kilimba/data/master/data2.csv")
agegroup_mapping <- read.csv("https://raw.githubusercontent.com/kilimba/data/master/agegroup.csv")
data <- merge(data,agegroup_mapping,by.x="agegrp",by.y="agegroup")
shinyServer(function(input, output) {
output$myChart <- renderChart({
selection <- subset(data,mapping == input$agegrp)
plot <- nPlot(n ~ year,
data = selection,
type = "lineChart",
group = "sex")
# Add axis labels and format the tooltip
plot$yAxis(axisLabel = "Population", width = 62)
plot$xAxis(axisLabel = "Year")
plot$save("ac.html")
return(plot)
})
})
Thanks,
Tumaini
Use renderChart2 instead of renderChart.
rm(list = ls())
library(shiny)
library(rCharts)
data <- read.csv("https://raw.githubusercontent.com/kilimba/data/master/data2.csv")
agegroup_mapping <- read.csv("https://raw.githubusercontent.com/kilimba/data/master/agegroup.csv")
data <- merge(data,agegroup_mapping,by.x="agegrp",by.y="agegroup")
ui =pageWithSidebar(
headerPanel("Population Trend By Age Group:"),
sidebarPanel(
selectInput(inputId = "agegrp",
label = "Choose Agegroup",
choices = c("0-4","5-9","10-14","15-19","20-24","25-29","30-34","35-39",
"40-44","45-49","50-54","55-59","60-64","65-69","70-74","75-79","80-84","85+"),selected = "0-4"),width=2),
mainPanel(
showOutput("myChart", "nvd3")
)
)
server = function(input, output) {
output$myChart <- renderChart2({
#selection <- data[data$mapping == "0-4",]
selection <- data[data$mapping == input$agegrp,]
selection <- subset(data,mapping == input$agegrp)
plot <- nPlot(n ~ year,
data = selection,
type = "lineChart",
group = "sex")
# Add axis labels and format the tooltip
plot$yAxis(axisLabel = "Population", width = 62)
plot$xAxis(axisLabel = "Year")
plot$set(width=1600, height=800)
plot$save("ac.html")
plot
})
}
runApp(list(ui = ui, server = server))