# ----------------------------------------------------------------------
# Shiny app demonstrating interactive features of the tableFilter widget
# ----------------------------------------------------------------------
library(shiny)
library(htmlwidgets)
library(D3TableFilter)
data(mtcars);
mtcars <- mtcars[, 1:3];
mtcars$candidates <- FALSE;
mtcars$favorite <- FALSE;
myCandidates <- sample(nrow(mtcars), 5);
myFavorite <- sample(myCandidates, 1);
mtcars[myFavorite, "favorite"] <- TRUE;
mtcars[myCandidates, "candidates"] <- TRUE;
edits <- data.frame(Row = c("", ""), Column = (c("", "")), Value = (c("", "")), stringsAsFactors = FALSE);
rownames(edits) <- c("Fail", "Success");
filtering <- data.frame(Rows = c(nrow(mtcars), nrow(mtcars)), Indices = c(paste(1:nrow(mtcars), collapse = ', '), paste(1:nrow(mtcars), collapse = ', ')), stringsAsFactors = FALSE);
rownames(filtering) <- c("Before", "After")
shinyServer(function(input, output, session) {
revals <- reactiveValues();
revals$mtcars <- mtcars;
revals$edits <- edits;
revals$filtering <- filtering;
revals$filters <- NULL;
revals$rowIndex <- 1:nrow(mtcars);
revals$filters <- data.frame(Column = character(), Filter = character(), stringsAsFactors = FALSE);
observe({
if(is.null(input$mtcars_filter)) return(NULL);
revals$rowIndex <- unlist(input$mtcars_filter$validRows);
revals$filtering["After", "Rows"] <- length(revals$rowIndex);
revals$filtering["After", "Indices"] <- paste(revals$rowIndex, collapse = ', ');
filterSettings <-input$mtcars_filter$filterSettings;
tmp <- lapply(filterSettings, function(x) data.frame(Column = x$column, Filter = x$value, stringsAsFactors = FALSE));
revals$filters <- do.call("rbind", tmp);
})
# for a output object "mtcars" D3TableFilter generates an input
# "mtcars_edit"
# this observer does a simple input validation and sends a confirm or reject message after each edit.
observe({
if(is.null(input$mtcars_edit)) return(NULL);
edit <- input$mtcars_edit;
isolate({
# need isolate, otherwise this observer would run twice
# for each edit
id <- edit$id;
row <- as.integer(edit$row);
col <- as.integer(edit$col);
val <- edit$val;
# validate input
if(col == 0) {
# rownames
oldval <- rownames(revals$mtcars)[row];
if(grepl('^\\d', val)) {
rejectEdit(session, tbl = "mtcars", row = row, col = col, id = id, value = oldval);
revals$edits["Fail", "Row"] <- row;
revals$edits["Fail", "Column"] <- col;
revals$edits["Fail", "Value"] <- val;
return(NULL);
}
} else if (col %in% c(1, 2, 3)){
# numeric columns
if(is.na(suppressWarnings(as.numeric(val)))) {
oldval <- revals$mtcars[row, col];
# reset to the old value
# input will turn red briefly, than fade to previous color while
# text returns to previous value
rejectEdit(session, tbl = "mtcars", row = row, col = col, id = id, value = oldval);
revals$edits["Fail", "Row"] <- row;
revals$edits["Fail", "Column"] <- col;
revals$edits["Fail", "Value"] <- val;
return(NULL);
}
} else if (col %in% c(4, 5)) {
; #nothing to validate for logical columns
}
# accept edits
if(col == 0) {
rownames(revals$mtcars)[row] <- val;
} else if (col %in% c(1, 2, 3)) {
revals$mtcars[row, col] <- as.numeric(val);
val = round(as.numeric(val), 1)
} else if (col == 4) {
revals$mtcars[row, col] <- val;
} else if (col == 5) {
# radio buttons. There is no uncheck event
# so we need to set the whole column to FALSE here
revals$mtcars[, "favorite"] <- FALSE;
revals$mtcars[row, col] <- val;
}
# confirm edits
confirmEdit(session, tbl = "mtcars", row = row, col = col, id = id);
revals$edits["Success", "Row"] <- row;
revals$edits["Success", "Column"] <- col;
revals$edits["Success", "Value"] <- val;
})
})
# update summary row. calculate mean/median of displayed row for cols 1:3
observe({
if(input$summaryRow == "mean") {
setFootCellValue(session, tbl = "mtcars", row = 1, col = 0, value = "Mean");
for (col in c(1, 2, 3)) {
value = round(mean(revals$mtcars[revals$rowIndex, col]), 1);
setFootCellValue(session, tbl = "mtcars", row = 1, col = col, value = value);
}
} else {
setFootCellValue(session, tbl = "mtcars", row = 1, col = 0, value = "Median");
for (col in c(1, 2, 3)) {
value = round(median(revals$mtcars[revals$rowIndex, col]), 1);
setFootCellValue(session, tbl = "mtcars", row = 1, col = col, value = value);
}
}
})
output$edits <- renderTable({
if(is.null(revals$edits)) return(invisible());
revals$edits;
});
output$filtering <- renderTable({
if(is.null(revals$filtering)) return(invisible());
revals$filtering;
});
output$filters <- renderTable({
if(nrow(revals$filters) == 0) return(invisible());
revals$filters;
});
output$filteredMtcars <- renderTable({
if(is.null(revals$rowIndex)) return(invisible());
if(is.null(revals$mtcars)) return(invisible());
revals$mtcars[revals$rowIndex, ];
});
output$mtcars <- renderD3tf({
# define table properties. See http://tablefilter.free.fr/doc.php
# for a complete reference
tableProps <- list(
btn_reset = TRUE,
on_keyup = TRUE,
on_keyup_delay = 800,
rows_counter = TRUE,
rows_counter_text = "Rows: ",
themes = list(
name = 'transparent'
),
# alphabetic sorting for the row names column, numeric for all other columns
col_types = c("string", "number", "number", "number", "none", "none"),
col_4 = "none",
col_5 = "none",
# exclude the summary row from filtering
rows_always_visible = list(nrow(mtcars) + 2)
);
# columns are addressed in TableFilter as col_0, col_1, ..., coln
# the "auto" scales recalculate the data range after each edit
# to get the same behaviour with manually defined colour scales
# you can use the "colMin", "colMax", or "colExtent" functions,
# e.g .domain(colExtent("col_1")) or .domain([0, colMax(col_1)])
bgColScales <- list(
col_1 = "auto:white:green"
);
# apply D3.js functions to a column,
# e.g. to turn cell values into scaled SVG graphics
# This example generates an orange circle scaled to the cell value.
# The number is part of the svg graphic, but still allows for sorting and filtering.
cellFunctions <- list(
col_2 = JS('function makeGraph(selection, tbl, col){
// create a scaling function
var domain = colExtent(tbl, col);
var rScale = d3tf.scaleSqrt()
.domain(domain)
.range([8, 14]);
// column has been initialized before, update function
if(tbl + "_" + col + "_init" in window) {
console.log("running update");
// use select here to make circle inherit data from selection
var sel = selection.select("svg")
.select("circle");
sel.transition().duration(500)
.attr("r", function(d) { console.log(d), console.log(d.value) ; return rScale(d.value)});
return(null);
}
// remove text. will be added later within the svg
selection.text(null)
// create svg element
var svg = selection.append("svg")
.attr("width", 28)
.attr("height", 28);
// create a circle with a radius ("r") scaled to the
// value of the cell ("d.value")
var circle = svg.append("g")
.append("circle").attr("class", "circle")
.attr("cx", 14)
.attr("cy", 14)
.style("fill", "orange")
.attr("stroke","none")
.attr("r", domain[0])
.transition().duration(400)
.attr("r", function(d) { return rScale(d.value); });
// place the text within the circle
var text = svg.append("g")
.append("text").attr("class", "text")
.style("fill", "black")
.attr("x", 14)
.attr("y", 14)
.attr("dy", ".35em")
.attr("text-anchor", "middle")
.text(function (d) { return d.value; });
window[tbl + "_" + col + "_init"] = true;
}'),
# This example creates a horizontal bar chart. The text is overlayed onto
# the graphic to enable editing.
col_3 = JS('function makeGraph(selection, tbl, col){
var innerWidth = 117;
var innerHeight = 14;
// create a scaling function
var max = colMax(tbl, col);
var min = colMin(tbl, col);
var wScale = d3tf.scaleLinear()
.domain([0, max])
.range([0, innerWidth]);
// text formatting function
var textformat = d3tf.format(".1f");
// column has been initialized before, update function
if(tbl + "_" + col + "_init" in window) {
// use select here to make circle inherit data from selection
var sel = selection.select("svg")
.select("rect")
.transition().duration(500)
.attr("width", function(d) { return wScale(d.value)});
var txt = selection
.selectAll("text")
.text(function(d) { return textformat(d.value); });
return(null);
}
// can remove padding here, but still cant position text and box independently
selection.style("padding", "5px 5px 5px 5px");
// remove text. will be added back later
selection.text(null);
var svg = selection.append("svg")
.style("position", "absolute")
.attr("width", innerWidth)
.attr("height", innerHeight);
var box = svg.append("rect")
.style("fill", "lightblue")
.attr("stroke","none")
.attr("height", innerHeight)
.attr("width", min)
.transition().duration(500)
.attr("width", function(d) { return wScale(d.value); });
// format number and add text back
var textdiv = selection.append("div");
textdiv.style("position", "relative")
.attr("align", "right");
textdiv.append("text")
.text(function(d) { return textformat(d.value); });
window[tbl + "_" + col + "_init"] = true;
}')
);
# apply D3.js functions to footer columns,
# e.g. to format them or to turn cell values into scaled SVG graphics
footCellFunctions <- list(
col_0 = JS('function makeGraph(selection){
selection.style("font-weight", "bold")
}'),
col_1 = JS('function makeGraph(selection, tbl, col){
// text formatting function
var textformat = d3tf.format(".1f");
selection.style("font-weight", "bold")
.text(function(d) { return textformat(d.value); });
}'),
col_2 = JS('function makeGraph(selection, tbl, col){
// text formatting function
var textformat = d3tf.format(".1f");
selection.style("font-weight", "bold")
.text(function(d) { return textformat(d.value); });
}'),
col_3 = JS('function makeGraph(selection, tbl, col){
// text formatting function
var textformat = d3tf.format(".1f");
// make cell text right aligned
selection.classed("text-right", true)
.style("font-weight", "bold")
.text(function(d) { return textformat(d.value); });
}')
);
initialFilters = list(col_1 = ">20");
colNames = list(Rownames = "Model", mpg = "Miles per gallon", cyl = "Cylinders", disp = "Displacement", candidates = "Candidates", favorite = "My favorite");
# add a summary row. Can be used to set values statically, but also to
# make use of TableFilters "col_operation"
footData <- data.frame(Rownames = "Mean", mpg = mean(mtcars$mpg), cyl = mean(mtcars$cyl), disp = mean(mtcars$disp));
extensions <- list(
list(name = "sort")
);
# the mtcars table output
d3tf(mtcars, tableProps = tableProps,
extensions = extensions,
showRowNames = TRUE,
colNames = colNames,
edit = c("col_1", "col_3"),
checkBoxes = "col_4",
radioButtons = "col_5",
cellFunctions = cellFunctions,
tableStyle = "table table-bordered",
bgColScales = bgColScales,
filterInput = TRUE,
initialFilters = initialFilters,
footData = footData,
footCellFunctions = footCellFunctions,
height = 2000);
})
observe({
if(input$editingCol0) {
enableEdit(session, "mtcars", "col_0");
} else {
disableEdit(session, "mtcars", "col_0");
}
})
observe({
input$dofilter;
isolate({
setFilter(session, tbl = "mtcars", col = "col_0", filterString = input$filterString, doFilter = TRUE);
})
})
observe({
input$clearfilter;
clearFilters(session, tbl = "mtcars", doFilter = TRUE);
})
# server side editing of a cell value
observe({
# Row address is based on the complete, unfiltered and unsorted table
# Column address is one based. In this case showRowNames is TRUE,
# rownames column is col 0, "cylinders" is col 2.
setCellValue(session, tbl = "mtcars", row = 8, col = 2, value = input$cellVal, feedback = TRUE);
})
# server side editing of checkbox
output$candidateUi <- renderUI({
radioButtons("candidate", "Make Datsun candidate", choices = c("yes" = TRUE, "no" = FALSE, selected = mtcars["Datsun 710", "candidate"]))
})
# server side editing of checkbox
observe({
if(is.null(input$candidate)) return(NULL);
# why do I get string values and not logicals here? Shiny bug?
if(input$candidate == "TRUE") {
candidate = TRUE;
} else if (input$candidate == "FALSE") {
candidate = FALSE;
} else {
candidate = input$candidate;
}
setCellValue(session, tbl = "mtcars", row = 3, col = 4, value = candidate, feedback = TRUE);
})
# server side editing of radio button
observe({
input$favorite;
setCellValue(session, tbl = "mtcars", row = 3, col = 5, value = TRUE, feedback = TRUE);
})
## demonstrate selectable rows interface
output$mtcars2 <- renderD3tf({
# define table properties. See http://tablefilter.free.fr/doc.php
# for a complete reference
tableProps <- list(
btn_reset = TRUE,
rows_counter = TRUE,
rows_counter_text = "Rows: ",
on_keyup = TRUE,
on_keyup_delay = 800,
filters_row_index = 1,
# adding a summary row, showing the column means
rows_always_visible = list(nrow(mtcars) + 2),
col_operation = list(
id = list("frow_0_fcol_1_tbl_mtcars2","frow_0_fcol_2_tbl_mtcars2"),
col = list(1,2),
operation = list("mean","mean"),
write_method = list("innerhtml",'innerhtml'),
exclude_row = list(nrow(mtcars) + 2),
decimal_precision = list(1, 1)
)
);
extensions <- list(
list(name = "sort")
);
# add a summary row. Can be used to set values statically, but also to
# make use of TableFilters "col_operation"
footData <- data.frame(Rownames = "Mean", mpg = 0, cyl = 0);
d3tf(mtcars[ , 1:2],
enableTf = TRUE,
tableProps = tableProps,
extensions = extensions,
showRowNames = TRUE,
selectableRows = "multi",
selectableRowsClass = "info",
tableStyle = "table table-bordered table-condensed",
rowStyles = c(rep("", 7), rep("info", 7)),
filterInput = TRUE,
footData = footData,
colsResizable = TRUE,
height = 500);
})
# for a output object "mtcars2" tableFilter generates an input
# "mtcars2_edit".
output$mtcars2Output <- renderTable({
if(is.null(input$mtcars2_select)) return(NULL);
mtcars[input$mtcars2_select, 1:2];
}, rownames = TRUE)
# set class on a row
observe({
setRowClass(session, tbl = "mtcars2", row = 5, class = input$hornetClass);
})
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.