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
Related
I've been trying to apply the solution in post Shiny App: How to get total sum by column to my situation but am unable to get it to work. I simply want the "Total" row at the bottom of the table to recalculate every time the user changes one of the fields above it, but I get an error message when un-commenting the observe() that is commented-out in the below code. This observe() is my attempt to implement the solution offered in the aforementioned post. What am I doing wrong here, and more generally what is the proper method of summing a column in rhandsontable?
Code:
library(rhandsontable)
library(shiny)
rowNames <- c('Hello A','Hello B','Hello C','Hello D','Total')
data <- data.frame(row.names = rowNames,'Col 1' = c(10,20,-5,18,43),check.names = FALSE)
ui <- fluidPage(br(),
rHandsontableOutput('hottable'),br(),
actionButton("addCol", "Add column"),br(),br(),
uiOutput("delCol_step1")
)
server <- function(input, output) {
uiTable <- reactiveVal(data)
observeEvent(input$hottable,{uiTable(hot_to_r(input$hottable))})
output$hottable <- renderRHandsontable({
rhandsontable(uiTable(),rowHeaderWidth = 100, useTypes = TRUE)
})
# observe({
# req(input$hottable)
# DF <- hot_to_r(input$hottable)
# DF[setdiff(rowNames, "Total"),]
# DF["Total",] <- colSums(DF[setdiff(rowNames, "Total"),], na.rm = TRUE)
# uiTable(DF)
# })
observeEvent(input$addCol, {
newCol2 <- data.frame(c(10,20,-5,18,43))
names(newCol2) <- paste("Col", ncol(hot_to_r(input$hottable)) + 1)
uiTable(cbind(uiTable(), newCol2))
})
output$delCol_step1 <-
renderUI(
selectInput(
"delCol_step2",
label = "Select column to delete:",
choices = colnames(hot_to_r(input$hottable)),
selected = "",
multiple = TRUE
)
)
observeEvent(input$delCol_step2,{
tmp <- uiTable()
if(ncol(tmp) > 1){
delCol <- input$delCol_step2
tmp <-tmp[,!(names(tmp) %in% delCol),drop=FALSE]
newNames <- sprintf("Col %d",seq(1:ncol(tmp)))
names(tmp) <- newNames
uiTable(tmp)
}
})
}
shinyApp(ui,server)
Unfortunately #MichaelDewar's answer is not correct.
colSums can handle single column data.frames just fine:
colSums(data.frame(1:10))
However, when indexing data.frames you have to make sure to avoid dimensions being dropped - as colSums does not work on vectors. Just use drop = FALSE to achive this:
library(rhandsontable)
library(shiny)
rowNames <- c('Hello A','Hello B','Hello C','Hello D','Total')
data <- data.frame(row.names = rowNames,'Col 1' = c(10,20,-5,18,43),check.names = FALSE)
ui <- fluidPage(br(),
rHandsontableOutput('hottable'),br(),
actionButton("addCol", "Add column"),br(),br(),
uiOutput("delCol_step1")
)
server <- function(input, output) {
uiTable <- reactiveVal(data)
observeEvent(input$hottable,{uiTable(hot_to_r(input$hottable))})
output$hottable <- renderRHandsontable({
rhandsontable(uiTable(),rowHeaderWidth = 100, useTypes = TRUE)
})
observe({
req(input$hottable)
DF <- hot_to_r(input$hottable)
DF[setdiff(rowNames, "Total"),]
DF["Total",] <- colSums(DF[setdiff(rowNames, "Total"),, drop = FALSE], na.rm = TRUE)
uiTable(DF)
})
observeEvent(input$addCol, {
newCol2 <- data.frame(c(10,20,-5,18,43))
names(newCol2) <- paste("Col", ncol(hot_to_r(input$hottable)) + 1)
uiTable(cbind(uiTable(), newCol2))
})
output$delCol_step1 <-
renderUI(
selectInput(
"delCol_step2",
label = "Select column to delete:",
choices = colnames(hot_to_r(input$hottable)),
selected = "",
multiple = TRUE
)
)
observeEvent(input$delCol_step2,{
tmp <- uiTable()
if(ncol(tmp) > 1){
delCol <- input$delCol_step2
tmp <-tmp[,!(names(tmp) %in% delCol),drop=FALSE]
newNames <- sprintf("Col %d",seq(1:ncol(tmp)))
names(tmp) <- newNames
uiTable(tmp)
}
})
}
shinyApp(ui,server)
Please see ?`[`, this related article or my earlier answer here.
The problem is that colSums doesn't work for a data frame with a single column. You have to use sum in that case. Put this in the server.
observe({
req(input$hottable)
DF <- hot_to_r(input$hottable)
if(ncol(DF)==1){
DF["Total",] <- sum(DF[setdiff(rowNames, "Total"),], na.rm = TRUE)
} else {
DF["Total",] <- colSums(DF[setdiff(rowNames, "Total"),], na.rm = TRUE)
}
uiTable(DF)
})
I am trying to make an app which can dynamically create multiple tabs with tables in the 1st tab (Input tab), and use the dynamically created tables to do calculations in the 2nd tab (Results tab). However, I am not sure how to use the hot_to_r function to access the values from the tables created in the Input tab to do calculations in the Results tab. As an example, I want to take column i+1 divide by column i in the tables in the Input tab and display the results in the Results tab.
Below are the sample codes:
library(shiny)
library(rhandsontable)
ui <- navbarPage("App",
tabPanel("Input",
numericInput('num_of_table', "Number of sub tabs: ", value = 1, min = 1, max = 10),
uiOutput("input")),
tabPanel("Results",
uiOutput("results"))
)
server <- function(input, output,session) {
### Input ###
input_table<- reactive({
list_of_input_table = list()
for (i in c(1:input$num_of_table)){
mat <- matrix(c(1:25) * i, ncol = 5, nrow = 5)
list_of_input_table[[i]] = mat
}
index = c(1:i)
list_of_input_table[index]
})
observeEvent(input$num_of_table, {
lapply(seq_len(input$num_of_table), function(i) {
output[[paste0('input_table_', i)]] <- renderRHandsontable({
rhandsontable(input_table()[[i]])
})
})
})
output$input <- renderUI({
nTabs = input$num_of_table
myTabs1 = lapply(seq_len(nTabs), function(x){
tabPanel(paste("Tab", x),
column(12,
rHandsontableOutput(paste0("input_table_", x))))
})
do.call(tabsetPanel, myTabs1)
})
### Results ###
results_table<- reactive({
list_of_results_table = list()
list_of_input_table = list()
for (i in c(1:input$num_of_table)){
for (j in c(1:5)) {
list_of_input_table[[i]] <- as.matrix(hot_to_r(input[[paste0("input_table_",i)]]))
list_of_results_table[[i]] <- matrix(as.numeric(NA), ncol = 4, nrow = 5)
list_of_results_table[[i]][,j] <- list_of_input_table[[i]][,j+1][!is.null(list_of_input_table[[i]][,j+1])] / list_of_input_table[[i]][,j]
}}
index = c(1:i)
list_of_results_table[index]
})
observeEvent(input$num_of_table, {
lapply(seq_len(input$num_of_table), function(i) {
output[[paste0('results_table_', i)]] <- renderRHandsontable({
rhandsontable(results_table()[[i]])
})
})
})
output$results <- renderUI({
nTabs = input$num_of_table
myTabs2 = lapply(seq_len(nTabs), function(x){
tabPanel(paste("Tab", x),
column(12,
rHandsontableOutput(paste0("results_table_", x))))
})
do.call(tabsetPanel, myTabs2)
})
}
shinyApp(ui,server)
Please help!!
It seems hot_to_r isn't handling matrix objects correctly in this case.
Please check the following using a data.frame instead:
library(shiny)
library(rhandsontable)
ui <- navbarPage("App",
tabPanel("Input",
numericInput('num_of_table', "Number of sub tabs: ", value = 1, min = 1, max = 10),
uiOutput("input")),
tabPanel("Results",
uiOutput("results"))
)
server <- function(input, output,session) {
### Input ###
input_table <- reactive({
list_of_input_table = list()
for (i in c(1:input$num_of_table)){
mat <- matrix(c(1:25) * i, ncol = 5, nrow = 5)
list_of_input_table[[i]] = as.data.frame(mat)
}
index = c(1:i)
list_of_input_table[index]
})
observeEvent(input$num_of_table, {
lapply(seq_len(input$num_of_table), function(i) {
output[[paste0('input_table_', i)]] <- renderRHandsontable({
rhandsontable(input_table()[[i]])
})
})
})
output$input <- renderUI({
nTabs = input$num_of_table
myTabs1 = lapply(seq_len(nTabs), function(x){
tabPanel(paste("Tab", x),
column(12,
rHandsontableOutput(paste0("input_table_", x))))
})
do.call(tabsetPanel, myTabs1)
})
### Results ###
results_table <- reactive({
list_of_results_table = list()
for (i in c(1:input$num_of_table)){
req(input[[paste0("input_table_", i)]])
list_of_results_table[[i]] <- hot_to_r(input[[paste0("input_table_", i)]])[2:5]/hot_to_r(input[[paste0("input_table_", i)]])[1:4]
}
return(list_of_results_table)
})
observeEvent(input$num_of_table, {
lapply(seq_len(input$num_of_table), function(i) {
output[[paste0('results_table_', i)]] <- renderRHandsontable({
rhandsontable(results_table()[[i]])
})
})
})
output$results <- renderUI({
nTabs = input$num_of_table
myTabs2 = lapply(seq_len(nTabs), function(x){
tabPanel(paste("Tab", x),
column(12,
rHandsontableOutput(paste0("results_table_", x))))
})
do.call(tabsetPanel, myTabs2)
})
}
shinyApp(ui,server)
I filed an issue here.
I have 10 actions button in my shiny app. I'm trying to create a loop but i'm having issues with the reactive values. How could I solve it ?
Here's my code for button 1:
server <- function(input, output, session)
{
value1 <- reactiveVal(0)
observeEvent(input$minus1, {newValue1 <- value1() - 1)
value1(newValue1)})
observeEvent(input$plus1, {newValue1 <- (value1() + 1)
value1(newValue1)})
output$value1 <- renderUI(actionBttn("result1", label = value1()))
}
I tried this, but it doesn't seem to work :
server <- function(input, output, session)
{
for (i in 1:10)
{
paste0("value", i) <- reactiveVal(0)
observeEvent(input$paste0("minus",i), {paste0("newValue", i) <- (paste0("value", i,"()") - 1)
paste0("value", i)(paste0("newValue", i))})
observeEvent(input$paste0("plus",i), {newValue1 <- (paste0("value", i,"()") + 1)
paste0("value", i)(paste0("newValue", i))})
output$paste0("value", i) <- renderUI(actionBttn(paste0("result", i), label = paste0("value", i,"()")))
}
}
I had worked on a similar demo in the past based on:
https://community.rstudio.com/t/one-observer-to-handle-any-number-of-buttons-in-shiny/6569/2
This makes 10 plus and 10 minus buttons, and each button will increase or decrease reactiveValues. I hope this may be helpful.
library(shiny)
library(dplyr)
ui <- fluidPage(
fluidRow(uiOutput("show_table"))
)
server <- function(input, output, session) {
Data <- reactiveValues(
Info = rep(0, 10)
)
observe({
input_btn_p <- paste0("btn_p_", 1:10)
lapply(input_btn_p, function(x){
observeEvent(input[[x]], {
i <- as.numeric(sub("btn_p_", "", x))
Data$Info[i] <- Data$Info[i] + 1
})
})
input_btn_m <- paste0("btn_m_", 1:10)
lapply(input_btn_m, function(x){
observeEvent(input[[x]], {
i <- as.numeric(sub("btn_m_", "", x))
Data$Info[i] <- Data$Info[i] - 1
})
})
})
display_table <- reactive({
data.frame(value = Data$Info) %>%
mutate(button1 = vapply(row_number(),
function(i){
actionButton(inputId = paste0("btn_p_", i), label = "Plus") %>%
as.character()
},
character(1)),
button2 = vapply(row_number(),
function(i){
actionButton(inputId = paste0("btn_m_", i), label = "Minus") %>%
as.character()
},
character(1)))
})
output$show_table <- renderUI({
display_table() %>%
select(value, button1, button2) %>%
knitr::kable(format = "html", escape = FALSE) %>%
HTML()
})
}
shinyApp(ui, server)
I'm trying to generalise Shiny modules so different functions can be passed through, but the expected behaviour of reactivity is not working - could someone point me in the right direction? I have a reprex below that illustrates my problem.
I expect that the dynamic selection of view_id to change values in the renderShiny() function. It works on app load but changing selections do not flow through.
Is it something to do with the environment the module function is created within?
library(shiny)
create_shiny_module_funcs <- function(data_f,
model_f,
outputShiny,
renderShiny){
server_func <- function(input, output, session, view_id, ...){
gadata <- shiny::reactive({
# BUG: this view_id is not reactive but I want it to be
data_f(view_id(), ...)
})
model_output <- shiny::reactive({
shiny::validate(shiny::need(gadata(),
message = "Waiting for data"))
model_f(gadata(), ...)
})
output$ui_out <- renderShiny({
shiny::validate(shiny::need(model_output(),
message = "Waiting for model output"))
message("Rendering model output")
model_output()
}, ...)
return(model_output)
}
ui_func <- function(id, ...){
ns <- shiny::NS(id)
outputShiny(outputId = ns("ui_out"), ...)
}
list(
shiny_module = list(
server = server_func,
ui = ui_func
)
)
}
# create the shiny module
ff <- create_shiny_module_funcs(
data_f = function(view_id) mtcars[, view_id],
model_f = function(x) mean(x),
outputShiny = shiny::textOutput,
renderShiny = function(x) shiny::renderText(paste("Mean is: ", x))
)
## ui.R
ui <- fluidPage(title = "module bug Shiny Demo",
h1("Debugging"),
selectInput("select", label = "Select", choices = c("mpg","cyl","disp")),
textOutput("view_id"),
ff$shiny_module$ui("demo1"),
br()
)
## server.R
server <- function(input, output, session){
view_id <- reactive({
req(input$select)
input$select
})
callModule(ff$shiny_module$server, "demo1", view_id = view_id)
output$view_id <- renderText(paste("Selected: ", input$select))
}
# run the app
shinyApp(ui, server)
The problem was the renderShiny function needs to wrap another function that creates the actual output, so its actually two separate capabilities confused by me as one: renderShiny should take the output of another function that actually creates the thing to render. The below then works:
library(shiny)
module_factory <- function(data_f = function(x) mtcars[, x],
model_f = function(x) mean(x),
output_shiny = shiny::plotOutput,
render_shiny = shiny::renderPlot,
render_shiny_input = function(x) plot(x),
...){
ui <- function(id, ...){
ns <- NS(id)
output_shiny(ns("ui_out"), ...)
}
server <- function(input, output, session, view_id){
gadata <- shiny::reactive({
data_f(view_id(), ...)
})
model <- shiny::reactive({
shiny::validate(shiny::need(gadata(),
message = "Waiting for data"))
model_f(gadata(), ...)
})
output$ui_out <- render_shiny({
shiny::validate(shiny::need(model(),
message = "Waiting for model output"))
render_shiny_input(gadata())
})
return(model)
}
list(
module = list(
ui = ui,
server = server
)
)
}
made_module <- module_factory()
## ui.R
ui <- fluidPage(title = "module bug Shiny Demo",
h1("Debugging"),
selectInput("select", label = "Select", choices = c("mpg","cyl","disp")),
textOutput("view_id"),
made_module$module$ui("factory1"),
br()
)
## server.R
server <- function(input, output, session){
callModule(made_module$module$server, "factory1", view_id = reactive(input$select))
output$view_id <- renderText(paste("Selected: ", input$select))
}
# run the app
shinyApp(ui, server)
I think you want something like this.
library(shiny)
library(plyr)
library(dplyr)
library(DT)
library(data.table)
ui <- pageWithSidebar(
headerPanel = headerPanel('data'),
sidebarPanel = sidebarPanel(fileInput(
'mtcars', h4('Uplaodmtcardata in csv format')
),
uiOutput('tabnamesui')),
mainPanel(uiOutput("tabsets"))
)
server <- function(input, output, session) {
mtcarsFile <- reactive({
input$mtcars
})
xxmtcars <-
reactive({
read.table(
file = mtcarsFile()$datapath,
sep = ',',
header = T,
stringsAsFactors = T
)
})
tabsnames <- reactive({
names(xxmtcars())
})
output$tabnamesui <- renderUI({
req(mtcarsFile())
selectInput(
'tabnamesui',
h5('Tab names'),
choices = as.list(tabsnames()),
multiple = T
# selected = SalesGlobalDataFilter1Val()
)
})
tabnamesinput <- reactive({
input$tabnamesui
})
output$tabsets <- renderUI({
req(mtcarsFile())
tabs <-
reactive({
lapply(tabnamesinput(), function(x)
tabPanel(title = basename(x)
,fluidRow(splitLayout(cellWidths = c("50%", "50%"),
plotOutput(paste0('plot1',x)),
plotOutput(paste0('plot2',x)
))),fluidRow(splitLayout(cellWidths =
c("50%", "50%"),
plotOutput(paste0('plot3',x)),
plotOutput(paste0('plot4',x)
))),
dataTableOutput(paste0('table',x))))
})
do.call(tabsetPanel, c(tabs()))
})
# Save your sub data here
subsetdata<-reactive({
list_of_subdata<-lapply(tabnamesinput(), function(x) {
as.data.table((select(xxmtcars(),x)))
})
names(list_of_subdata)<-tabnamesinput()
return(list_of_subdata)
})
observe(
lapply(tabnamesinput(), function(x) {
output[[paste0('table',x)]] <-
renderDataTable({
subsetdata()[[x]]
})}))
observe(
lapply(tabnamesinput(), function(x) {
for(i in paste0("plot",1:4)){
output[[paste0(i,x)]] <-
renderPlot({subsetdata()[[x]]%>%plot()#CODE REPEATED
})
}
})
)
}
runApp(list(ui = ui, server = server))
Data Source:
https://gist.githubusercontent.com/seankross/a412dfbd88b3db70b74b/raw/5f23f993cd87c283ce766e7ac6b329ee7cc2e1d1/mtcars.csv
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))