Create a dynamic table on shiny app based on shiny widget and row selection of another datatable
Perhaps this will meet your needs. Please note that you may need to modify the formula for elective_se and elective_se2.
server <- function(input, output, session) {
output$costs <- DT::renderDataTable({
dtable <- datatable(
filtercost, selection = "multiple",rownames=FALSE
)
dep <- htmltools::htmlDependency("jqueryui", "1.12.1",
"www/shared/jqueryui",
script = "jquery-ui.min.js",
package = "shiny")
dtable$dependencies <- c(dtable$dependencies, list(dep))
dtable
})
#output$value2 <- renderPrint({ input$somevalue2 })
selectedrow_costsrows <- reactive({
#req(input$costs_rows_selected)
s <- input$costs_rows_selected
data <- as.data.frame(datacost[s,])
names(data) <- NULL
data
if (is.null(input$costs_rows_selected)) {costtable <- NULL
}else {
n <- length(input$costs_rows_selected)
elective_mean<- weighted.mean(as.numeric(data[,2]),as.numeric(data[,1]),na.rm = F)
elective_se <- ifelse(n>1, sqrt(sum((as.numeric(data[,2])-elective_mean)^2)/(n*(n-1))), 0)
elective_CI_l<- elective_mean-1.96*elective_se
elective_CI_h<- elective_mean+1.96*elective_se
Service_type <- c("Elective")
Weighted_mean <- round(c(elective_mean),0)
Weighted_SR <- round(c(elective_se),0)
CI_Lower_95 <- round(c(elective_CI_l),0)
CI_Upeer_95 <- round(c(elective_CI_h),0)
costtable1 <- as.data.frame(rbind(Service_type,Weighted_mean,Weighted_SR,CI_Lower_95,CI_Upeer_95))
elective_mean2<- weighted.mean(as.numeric(data[,4]),as.numeric(data[,3]),na.rm = F)
elective_se2 <- ifelse(n>1, sqrt(sum((as.numeric(data[,4])-elective_mean2)^2)/(n*(n-1))), 0)
elective_CI_l2<- elective_mean2 - 1.96*elective_se2
elective_CI_h2<- elective_mean2 + 1.96*elective_se2
Service_type2 <- c("Non-elective Long Stay")
Weighted_mean2 <- round(c(elective_mean2),0)
Weighted_SR2 <- round(c(elective_se2),0)
CI_Lower_952 <- round(c(elective_CI_l2),0)
CI_Upeer_952 <- round(c(elective_CI_h2),0)
costtable2 <- as.data.frame(rbind(Service_type2,Weighted_mean2,Weighted_SR2,CI_Lower_952,CI_Upeer_952))
colnames(costtable2) <- "V2"
if (is.null(input$somevalue2)) {costtable <- NULL
}else if (length(input$somevalue2)==2){
costtable <- cbind(costtable1,costtable2)
}else{
if (input$somevalue2=="Elective"){
costtable <- costtable1
}else {
costtable <- costtable2
}
}
}
costtable
})
output$selectedrow_costs <- DT::renderDataTable({
df=selectedrow_costsrows()})
}
shinyApp(ui = ui, server = server)
Shiny: Create a dynamic datatable based on a click event on another datatable
Is this what you are looking for?
output$table_02 <- renderDT({
# selected row from tab1
selected_row=input$table_01_rows_selected
# store its node value
node <- unique(df[selected_row, "Nodes"])
# find all the routes that are linked with the stored node value
routes = df[df$Nodes %in% node,]
# show only those observation having the route id that we found in the previous step
datatable(
df[df$Route %in% routes$Route,]
)
})
Create datatable based on cell selection of another datatable in a shiny app
This error is thrown by the rep function since you don't provide a valid times argument. In this case, input$hot3_cells_selected returns a vector representing the row and column indices of the selected cell, respectively. You can access the actual content of the cell using:
DF[input$hot3_cells_selected]
However, you need some additional adjustments to make your code more robust. For example, input$hot3_cells_selected is empty until a cell is selected, which will cause a similar problem with the rep function. Or, your should cover the case where a non-numeric cell is selected (i.e Test1 or Marg1). Below is a possible naïve solution:
# changing only this part of the code will be enough
# inserted DF[input$hot3_cells_selected] when needed below
output$hot5 <-DT::renderDataTable({
# checking whether any cell is selected or not
if(length(input$hot3_cells_selected) > 0) {
# checking whether the selected cell includes a number or not
# note that suppressWarnings is optional
if(!is.na(suppressWarnings(as.numeric(DF[input$hot3_cells_selected])))) {
# you don't need to store the data frame, so removed the assignment
# even if you wanna store it for future reference, use a unique name (not DF)
data.frame(
Sel= rep(TRUE, as.numeric(DF[input$hot3_cells_selected])),
Id= 1:as.numeric(DF[input$hot3_cells_selected]),
Label=paste("Item",as.integer(1:as.numeric(DF[input$hot3_cells_selected]))),
Pf=as.integer(rep.int(0,as.numeric(DF[input$hot3_cells_selected]))),
stringsAsFactors = FALSE
)
}
}
})
Select specific row of a datatable with a shiny widget
library(shiny)
library(DT)
library(shinyWidgets)
dat <- mtcars[1:6,]
callback <- JS(
"Shiny.addCustomMessageHandler(",
" 'selectRow',",
" function(index) {",
" table.row(index - 1).select();",
" }",
");"
)
ui <- fluidPage(
br(),
DTOutput("dtable"),
br(),
fluidRow(
column(
4,
pickerInput(
"rowname",
label = "Choose a row",
choices = setNames(1:nrow(dat), rownames(dat))
)
),
column(
3,
textOutput("selectedRow")
)
)
)
server <- function(input, output, session) {
output[["dtable"]] <- renderDT({
datatable(
dat,
extensions = "Select",
selection = "none",
callback = callback,
options = list(
columnDefs = list(
list(className = "dt-center", targets = "_all")
),
select = list(style = "single")
)
)
}, server = FALSE)
output[["selectedRow"]] <- renderText({
i <- input[["dtable_rows_selected"]]
paste0(
"Selected row: ",
ifelse(is.null(i), "none", i)
)
})
observeEvent(input[["rowname"]], {
session$sendCustomMessage("selectRow", input[["rowname"]])
})
}
shinyApp(ui, server)
Dynamic number of table container in Shiny DT in R
Like this, if I understand the question:
library(htmltools)
dates <- as.Date("2022-06-01") + 0:3
withTags(
tr(
th(rowspan = 2, 'Name'),
lapply(dates, function(d) th(colspan = 2, d))
)
)
# <tr>
# <th rowspan="2">Name</th>
# <th colspan="2">2022-06-01</th>
# <th colspan="2">2022-06-02</th>
# <th colspan="2">2022-06-03</th>
# <th colspan="2">2022-06-04</th>
# </tr>
Select a DT row and then change the value of one cell of this row based on widget selection input and actionButton() in a shiny app
First, we can save the rendered table inside a reactiveValues object along with the row that was selected:
rv <- reactiveValues(df = Input, row_selected = NULL)
Second, every time the edit button get's pressed, the row selected is saved and de data updated using walk2 to loop through all the columns.
observeEvent(input$edit,{
if (!is.null(input$TBL1_rows_selected)) {
cols_to_edit <- c('sectype', 'sectick', 'PurDate', 'selDate', 'aminv')
colnms <- c('Security Type', 'Ticker', 'Purchase Date', 'Sale Date', 'Amount Invested')
"remember the row selected"
rv$row_selected <- input$TBL1_rows_selected
walk2(cols_to_edit, colnms, ~{rv$df[input$TBL1_rows_selected, ..2] <<- input[[..1]]})
}
})
App:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(DT)
library(tidyverse)
Input <- structure(list(`Security Type` = c("Stock", "Stock", "Load Fund"), Ticker = c("XOM", "NFLX", "AMCPX"), `Purchase Date` = structure(c(
16070,
17084, 17084
), class = "Date"), `Sale Date` = structure(c(
18627,
NA, 18545
), class = "Date"), `Amount Invested` = c(
"$10,000",
"$8,000", "$10,000"
)), class = c(
"spec_tbl_df", "tbl_df", "tbl",
"data.frame"
), row.names = c(NA, -3L))
ui = tags$body(class = "skin-blue sidebar-mini control-sidebar-open", dashboardPage(
options = list(sidebarExpandOnHover = TRUE),
header = dashboardHeader(title = "Investment Advisor Monitoring - Insider Trading", titleWidth = 450),
sidebar = dashboardSidebar(
minified = F, collapsed = F,
selectInput(
"sectype", "Security Type",
c(unique(Input$`Security Type`))
),
selectInput(
"sectick", "Ticker",
c(unique(Input$Ticker))
),
dateInput("PurDate", "Purchase Date", value = as.Date("2013-12-31")),
dateInput("selDate", "Sale Date", value = as.Date("2019-01-31")),
selectInput(
"aminv", "Amount Invested",
c(unique(Input$`Amount Invested`))
),
actionButton("edit", "Edit")
),
body = dashboardBody(
h3("Results"),
tabsetPanel(
id = "tabs",
tabPanel(
"InsiderTraining",
dataTableOutput("TBL1")
)
)
),
controlbar = dashboardControlbar(width = 300),
title = "DashboardPage"
))
server = function(input, output) {
# I want to remember the row that was selected
rv <- reactiveValues(df = Input, row_selected = NULL)
observeEvent(input$edit,{
if (!is.null(input$TBL1_rows_selected)) {
cols_to_edit <- c('sectype', 'sectick', 'PurDate', 'selDate', 'aminv')
colnms <- c('Security Type', 'Ticker', 'Purchase Date', 'Sale Date', 'Amount Invested')
"remember the row selected"
rv$row_selected <- input$TBL1_rows_selected
walk2(cols_to_edit, colnms, ~{rv$df[input$TBL1_rows_selected, ..2] <<- input[[..1]]})
}
})
output$TBL1 <- DT::renderDataTable({
DT::datatable(rv$df, selection = list(target = "row", selected = rv$row_selected))
})
}
shinyApp(ui,server)
Choose a datatable row either by clicking, actionButton() or shiny widget
Full app:
library(shinydashboard)
library(shinydashboardPlus)
library(DT)
library(shinyjs)
library(shinyWidgets)
attribute_name <- c("Jack", "Bob", "Jack", "Bob")
category_id <- c(7, 7, 7, 7)
candidate_phrase_lemma <- c("apple", "olive", "banana", "tomato")
d <- data.frame(
attribute_name,
category_id,
candidate_phrase_lemma,
stringsAsFactors = FALSE
)
names <- tapply(d$candidate_phrase_lemma, d$attribute_name, I)
candidate_1 <- c("Jack", "Bob", "Jack", "Bob")
candidate_2 <- c("phone", "camera", "micro", "pc")
similarity <- c(4, 5, 6, 7)
category_id <- c(7, 7, 7, 7)
e <- data.frame(candidate_1, candidate_2, similarity, category_id)
selector <- function(id, values, items = values) {
options <- HTML(paste0(mapply(
function(value, item) {
as.character(tags$option(value = value, selected = "selected", item))
}, values, items
), collapse = ""))
as.character(
tags$select(
id = id, multiple = "multiple", options
)
)
}
dat <- data.frame(
attributes = unique(as.character(d$attribute_name)),
attributes_phrases = vapply(
1:length(names),
function(i) {
selector(paste0("slct", i), names[[i]])
},
character(1)
),
Count = lengths(names),
stringsAsFactors = FALSE
)
nrows <- nrow(dat)
initComplete <- c(
"function(settings) {",
" var table = this.api().table();",
" var nrows = table.rows().count();",
" function selectize(i) {",
" var $slct = $('#slct' + i);",
" $slct.select2({",
" width: '100%',",
" closeOnSelect: false",
" });",
" $slct.on('change', function(e) {",
" table.cell(i-1, 2).data($slct.val().length);",
" });",
" }",
" for(var i = 1; i <= nrows; i++) {",
" selectize(i);",
" }",
"}"
)
callback <- JS(
"Shiny.addCustomMessageHandler(",
" 'selectRow',",
" function(index) {",
" table.row(index - 1).select();",
" }",
");",
"$('#btn-next').prop('disabled', true);",
"var selected_row = null;",
"table.on('select', function( e, dt, type, indexes ) {",
" $('#btn-next').prop('disabled', false);",
" selected_row = indexes[0];",
"});",
"table.on('deselect', function( e, dt, type, indexes ) {",
" $('#btn-next').prop('disabled', true);",
"});",
"var nrows = table.rows().count();",
"$('#btn-next').on('click', function() {",
" var next_row = selected_row + 1 < nrows ? selected_row + 1 : 0;",
" table.row(next_row).select();",
"});"
)
js <- paste0(c(
"Shiny.addCustomMessageHandler(",
" 'addCandidate',",
" function(row_candidate) {",
" var i = row_candidate.row;",
" var candidate = row_candidate.candidate;",
" var $slct = $('#slct' + i);",
" if($slct.find(\"option[value='\" + candidate + \"']\").length === 0) {",
" var newOption = new Option(candidate, candidate, true, true);",
" $slct.append(newOption).trigger('change');",
" }",
" }",
");"
), collapse = "\n")
shinyApp(
ui = dashboardPagePlus(
tags$head(
tags$link(rel = "stylesheet", href = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/css/select2.min.css"),
tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/js/select2.min.js"),
tags$style(HTML(
".select2-selection__choice {background-color: darkblue !important;}"
)),
tags$script(HTML(js))
),
useShinyjs(),
header = dashboardHeaderPlus(),
sidebar = dashboardSidebar(),
body = dashboardBody(
DTOutput("table"),
br(),
fluidRow(
column(
4,
uiOutput("ui-rowselect")
),
column(
2,
actionButton("selectrow", "Select this row")
)
),
br(),
actionButton("btn-next", "Select next row"),
br(), br(),
conditionalPanel(
condition = "input.table_rows_selected.length > 0",
wellPanel(
uiOutput("celltext"),
splitLayout(
actionButton("bc", "Previous candidate"),
actionButton("dec", "Next candidate"),
actionButton("addWord", "Add this candidate", class = "btn-info"),
cellWidths = "auto"
)
)
)
)
),
server = function(input, output, session) {
Text <- reactiveVal()
Data <- reactiveVal()
Candidate <- reactiveVal()
rnum <- reactiveVal()
output[["table"]] <- renderDT({
datatable(
data = dat,
extensions = "Select",
selection = "none",
escape = FALSE,
rownames = FALSE,
callback = callback,
options = list(
pageLength = 5,
columnDefs = list(
list(className = "dt-center", targets = "_all")
),
select = list(style = "single"),
initComplete = JS(initComplete),
preDrawCallback = JS(
"function() { Shiny.unbindAll(this.api().table().node()); }"
),
drawCallback = JS(
"function() { Shiny.bindAll(this.api().table().node()); }"
)
)
)
}, server = FALSE)
output[["ui-rowselect"]] <- renderUI({
selectedRow <- input[["table_rows_selected"]]
choices <- if(is.null(selectedRow)) 1:nrows else (1:nrows)[-selectedRow]
pickerInput(
"rowselect",
label = "Choose a row",
choices = choices
)
})
observeEvent(input[["selectrow"]], {
session$sendCustomMessage("selectRow", input[["rowselect"]])
})
observeEvent(input[["table_rows_selected"]], {
row <- input[["table_rows_selected"]]
dat <- e[e[["candidate_1"]] %in% d[row, 1], ]
Data(dat[order(dat[["similarity"]], decreasing = TRUE), ])
rnum(1)
})
output[["celltext"]] <- renderUI({
HTML(Text())
})
observeEvent(input[["dec"]], {
rnum(rnum() + 1)
})
observeEvent(input[["bc"]], {
rnum(rnum() - 1)
})
observeEvent(list(rnum(), Data()), {
if(rnum() == 1){
disable("bc")
}else{
enable("bc")
}
if(rnum() == nrows){
disable("dec")
}else{
enable("dec")
}
Candidate(Data()[rnum(), 2])
Text(
paste(
"Similarity of <em>", Data()[rnum(), 1], "</em>",
"to candidate <em>", Candidate(), "</em>",
"is <strong>", Data()[rnum(), 3], "</strong>"
)
)
}, ignoreInit = TRUE)
observeEvent(input[["addWord"]], {
session$sendCustomMessage(
"addCandidate",
list(row = input[["table_rows_selected"]], candidate = Candidate())
)
})
}
)
Related Topics
Does the Term "Vectorization" Mean Different Things in Different Contexts
Flip Ordering of Legend Without Altering Ordering in Plot
Generating All Permutations of N Balls in M Bins
Ggplot2: Font Style in Label Expression
R * Not Meaningful for Factors Error
Create Sequential Counter That Restarts on a Condition Within Panel Data Groups
R: How to Use Coord_Cartesian on Facet_Grid with Free-Ranging Axis
Set the Order of a Stacked Bar Chart by the Value of One of the Variables
R: Using a String as an Argument to Mutate Verb in Dplyr
Replicate Each Row of Data.Frame and Specify the Number of Replications for Each Row
Accessing Columns in Data.Table Using a Character Vector of Column Names
Remove Duplicates Based on 2Nd Column Condition
Dplyr Piping Data - Difference Between '.' and '.X'
Error: Vector Memory Exhausted (Limit Reached) R 3.5.0 MACos