手动更改子表单元格R中的值后更新列总计
我的闪亮应用程序中有一个嵌套的数据表。子表允许用户进入并手动编辑几列中的值。这里的目标是在汇总列的表的末尾有一个手动更改子表单元格R中的值后更新列总计,r,shiny,dt,R,Shiny,Dt,我的闪亮应用程序中有一个嵌套的数据表。子表允许用户进入并手动编辑几列中的值。这里的目标是在汇总列的表的末尾有一个totals行。如果用户进入并更改一个值，则总计行将使用新的列总和更新。例如，如果我是用户，希望将日间的份额（%）更改为20，总计行将更新为105 我能够在常规数据表上创建此功能，但我很难为嵌套子表创建此功能 子表 父表 # Module that renders the table tableMod <- function(input, output, session, ru
totals总计日间的份额（%）
更改为20
，总计
行将更新为105
我能够在常规数据表上创建此功能，但我很难为嵌套子表创建此功能
子表
父表
# Module that renders the table
tableMod <- function(input, output, session, runButton, data){
# this variable will be in sync with your datatable
df <- reactiveVal(data)
output$update_table <- DT::renderDataTable({
runButton()
isolate(
datatable(
df() %>%
bind_rows(
summarise_all(.,
funs(
if (is.numeric(.))
sum(.)
else if (is.factor(.)) "-"
else "Sub Total")
)
),
selection = 'none', editable = TRUE
)
)
})
# Observe the event
observeEvent(input$x1_cell_edit, {
new_df <- df()
row <- input$x1_cell_edit$row
col <- input$x1_cell_edit$col
value <- as.numeric(input$x1_cell_edit$value)
new_df[row, col] <- value
df(new_df)
})
list(updated_df = df)
}
# Module used to display the updated table
tableUI <- function(id) {
ns <- NS(id)
dataTableOutput(ns("update_table"))
}
代码
# Module that renders the table
tableMod <- function(input, output, session, runButton, data){
# this variable will be in sync with your datatable
df <- reactiveVal(data)
output$update_table <- DT::renderDataTable({
runButton()
isolate(
datatable(
df() %>%
bind_rows(
summarise_all(.,
funs(
if (is.numeric(.))
sum(.)
else if (is.factor(.)) "-"
else "Sub Total")
)
),
selection = 'none', editable = TRUE
)
)
})
# Observe the event
observeEvent(input$x1_cell_edit, {
new_df <- df()
row <- input$x1_cell_edit$row
col <- input$x1_cell_edit$col
value <- as.numeric(input$x1_cell_edit$value)
new_df[row, col] <- value
df(new_df)
})
list(updated_df = df)
}
# Module used to display the updated table
tableUI <- function(id) {
ns <- NS(id)
dataTableOutput(ns("update_table"))
}
这是一个带有页脚和footerCallback
选项的解决方案。但它不处理带有“$”的列
df1感谢您提供了另一个很棒的解决方案。我将假设，如果我需要更多的表功能，那么它将需要位于回调
端？比如，如果我想让父项总CPM
更新为子项总CPM
更新？如果我想让父项总CPM
更新为子项总CPM
更新，我需要将其添加到回调
部分
# Module that renders the table
tableMod <- function(input, output, session, runButton, data){
# this variable will be in sync with your datatable
df <- reactiveVal(data)
output$update_table <- DT::renderDataTable({
runButton()
isolate(
datatable(
df() %>%
bind_rows(
summarise_all(.,
funs(
if (is.numeric(.))
sum(.)
else if (is.factor(.)) "-"
else "Sub Total")
)
),
selection = 'none', editable = TRUE
)
)
})
# Observe the event
observeEvent(input$x1_cell_edit, {
new_df <- df()
row <- input$x1_cell_edit$row
col <- input$x1_cell_edit$col
value <- as.numeric(input$x1_cell_edit$value)
new_df[row, col] <- value
df(new_df)
})
list(updated_df = df)
}
# Module used to display the updated table
tableUI <- function(id) {
ns <- NS(id)
dataTableOutput(ns("update_table"))
}
# Bind the market level and mix breakout data together for the final table
market_mix_table <- reactive({
markets <- market_costings_gross_net()
mix_breakout <- daypart_break_out()
# Need to use replicate() on mix_breakout_table for cases when there is an arbitrary number of rows in markets
n <- nrow(markets)
children_list <- replicate(n, mix_breakout, simplify = FALSE)
# Make the dataframe
# This must be met length(children) == nrow(dat)
Dat <- NestedData(
dat = markets,
children = children_list
)
return(Dat)
})
# Render the table
output$daypartTable <- DT::renderDataTable({
# Whether to show row names (set TRUE or FALSE)
rowNames <- FALSE
colIdx <- as.integer(rowNames)
# The data
Dat <- market_mix_table()
# Table
table <- DT::datatable(
callModule(tableMod, "opfun", runButton = reactive(input$opt_run), data = Dat),
callback = callback_js,
rownames = rowNames,
escape = -colIdx-1,
options = list(
columnDefs = list(
list(visible = FALSE, targets = ncol(Dat)-1+colIdx),
list(orderable = FALSE, className = 'details-control', targets = colIdx),
list(className = "dt-center", targets = "_all")
)
)
)
# Some faancy Java magic
path <- getwd()
dep <- htmltools::htmlDependency(
"CellEdit", "1.0.19", path,
script = "dataTables.cellEdit.js", stylesheet = "dataTables.cellEdit.css")
table$dependencies <- c(table$dependencies, list(dep))
return(table)
})
# Testing out the new observeEvent handling
tableUI("opfun"),
actionButton("opt_run", "Run"),
# Display table
DT::dataTableOutput(
width = "100%",
"daypartTable"
)
df1 <- iris[1:3,]
df2 <- data.frame(
Daypart = c("Morning", "Afternoon", "Evening"),
X1 = c(3, 2, 4),
X2 = c(10, 20, 30),
stringsAsFactors = FALSE
)
# function to make the required dataframe
NestedData <- function(dat, children){
stopifnot(length(children) == nrow(dat))
g <- function(d){
if(is.data.frame(d)){
purrr::transpose(d)
}else{
purrr::transpose(NestedData(d[[1]], children = d$children))
}
}
subdats <- lapply(children, g)
oplus <- sapply(subdats, function(x) if(length(x)) "⊕" else "")
cbind(" " = oplus, dat, "_details" = I(subdats), stringsAsFactors = FALSE)
}
# make the required dataframe
# one must have: length(children) == nrow(dat)
Dat <- NestedData(
dat = df1,
children = list(df2, df2, df2)
)
## whether to show row names (set TRUE or FALSE)
rowNames <- FALSE
colIdx <- as.integer(rowNames)
## make the callback
parentRows <- which(Dat[,1] != "")
callback = JS(
"function onUpdate(updatedCell, updatedRow, oldValue) {};",
"table.MakeCellsEditable({",
" onUpdate: onUpdate,",
" inputCss: 'my-input-class',",
" confirmationButton: {",
" confirmCss: 'my-confirm-class',",
" cancelCss: 'my-cancel-class'",
" }",
"});",
sprintf("var parentRows = [%s];", toString(parentRows-1)),
sprintf("var j0 = %d;", colIdx),
"var nrows = table.rows().count();",
"for(var i=0; i < nrows; ++i){",
" if(parentRows.indexOf(i) > -1){",
" table.cell(i,j0).nodes().to$().css({cursor: 'pointer'});",
" }else{",
" table.cell(i,j0).nodes().to$().removeClass('details-control');",
" }",
"}",
"",
"// make the table header of the nested table",
"var format = function(d, childId){",
" if(d != null){",
" var html = ",
" '<table class=\"display compact hover\" ' + ",
" 'style=\"padding-left: 30px;\" id=\"' + childId + '\"><thead><tr>';",
" for(var key in d[d.length-1][0]){",
" html += '<th>' + key + '</th>';",
" }",
" html += '</tr></thead><tfoot><tr>'",
" for(var key in d[d.length-1][0]){",
" html += '<th></th>';",
" }",
" return html + '</tr></tfoot></table>';",
" } else {",
" return '';",
" }",
"};",
"",
"// row callback to style the rows of the child tables",
"var rowCallback = function(row, dat, displayNum, index){",
" if($(row).hasClass('odd')){",
" $(row).css('background-color', 'papayawhip');",
" $(row).hover(function(){",
" $(this).css('background-color', '#E6FF99');",
" }, function() {",
" $(this).css('background-color', 'papayawhip');",
" });",
" } else {",
" $(row).css('background-color', 'lemonchiffon');",
" $(row).hover(function(){",
" $(this).css('background-color', '#DDFF75');",
" }, function() {",
" $(this).css('background-color', 'lemonchiffon');",
" });",
" }",
"};",
"",
"// header callback to style the header of the child tables",
"var headerCallback = function(thead, data, start, end, display){",
" $('th', thead).css({",
" 'border-top': '3px solid indigo',",
" 'color': 'indigo',",
" 'background-color': '#fadadd'",
" });",
"};",
"",
"// footer callback to display the totals",
"var footerCallback = function(tfoot, data, start, end, display){",
" $('th', tfoot).css('background-color', '#fed8b1');",
" var api = this.api();",
" api.columns().eq(0).each(function(index){",
" if(index == 0) return $(api.column(index).footer()).html('Total');",
" var coldata = api.column(index).data();",
" var total = coldata",
" .reduce(function(a, b){return parseFloat(a) + parseFloat(b)}, 0);",
" $(api.column(index).footer()).html(total);",
" })",
"}",
"",
"// make the datatable",
"var format_datatable = function(d, childId){",
" var dataset = [];",
" var n = d.length - 1;",
" for(var i = 0; i < d[n].length; i++){",
" var datarow = $.map(d[n][i], function (value, index) {",
" return [value];",
" });",
" dataset.push(datarow);",
" }",
" var id = 'table#' + childId;",
" if (Object.keys(d[n][0]).indexOf('_details') === -1) {",
" var subtable = $(id).DataTable({",
" 'data': dataset,",
" 'autoWidth': true,",
" 'deferRender': true,",
" 'info': false,",
" 'lengthChange': false,",
" 'ordering': d[n].length > 1,",
" 'order': [],",
" 'paging': false,",
" 'scrollX': false,",
" 'scrollY': false,",
" 'searching': false,",
" 'sortClasses': false,",
" 'rowCallback': rowCallback,",
" 'headerCallback': headerCallback,",
" 'footerCallback': footerCallback,",
" 'columnDefs': [{targets: '_all', className: 'dt-center'}]",
" });",
" } else {",
" var subtable = $(id).DataTable({",
" 'data': dataset,",
" 'autoWidth': true,",
" 'deferRender': true,",
" 'info': false,",
" 'lengthChange': false,",
" 'ordering': d[n].length > 1,",
" 'order': [],",
" 'paging': false,",
" 'scrollX': false,",
" 'scrollY': false,",
" 'searching': false,",
" 'sortClasses': false,",
" 'rowCallback': rowCallback,",
" 'headerCallback': headerCallback,",
" 'footerCallback': footerCallback,",
" 'columnDefs': [",
" {targets: -1, visible: false},",
" {targets: 0, orderable: false, className: 'details-control'},",
" {targets: '_all', className: 'dt-center'}",
" ]",
" }).column(0).nodes().to$().css({cursor: 'pointer'});",
" }",
" subtable.MakeCellsEditable({",
" onUpdate: onUpdate,",
" inputCss: 'my-input-class',",
" confirmationButton: {",
" confirmCss: 'my-confirm-class',",
" cancelCss: 'my-cancel-class'",
" }",
" });",
"};",
"",
"// display the child table on click",
"table.on('click', 'td.details-control', function(){",
" var tbl = $(this).closest('table'),",
" tblId = tbl.attr('id'),",
" td = $(this),",
" row = $(tbl).DataTable().row(td.closest('tr')),",
" rowIdx = row.index();",
" if(row.child.isShown()){",
" row.child.hide();",
" td.html('⊕');",
" } else {",
" var childId = tblId + '-child-' + rowIdx;",
" row.child(format(row.data(), childId)).show();",
" td.html('⊖');",
" format_datatable(row.data(), childId);",
" }",
"});")
## the datatable
dtable <- datatable(
Dat, callback = callback, rownames = rowNames, escape = -colIdx-1,
options = list(
columnDefs = list(
list(visible = FALSE, targets = ncol(Dat)-1+colIdx),
list(orderable = FALSE, className = 'details-control', targets = colIdx),
list(className = "dt-center", targets = "_all")
)
)
)
path <- "~/Work/R/DT" # folder containing the files dataTables.cellEdit.js
# and dataTables.cellEdit.css
dep <- htmltools::htmlDependency(
"CellEdit", "1.0.19", path,
script = "dataTables.cellEdit.js", stylesheet = "dataTables.cellEdit.css")
dtable$dependencies <- c(dtable$dependencies, list(dep))
dtable