var heading_text = "Brand Health Table";
if (!!form.setObjectInspectorTitle)
form.setObjectInspectorTitle(heading_text);
else
form.setHeading(heading_text);
form.group("DATA SOURCE");
var outputLabel = "Output";
var outputPrompt = "Outputs are tables or other Q or R outputs";
if (Q.isOnTheWeb()) {
outputLabel = "Data";
outputPrompt = "Data is tables or other outputs in your Data Sources (bottom-left) or Report tree (top-left)";
}
var tables = form.dropBox({ name: "formTables",
label: outputLabel,
types: ['Table', "RItem:!StandardChart!SignificanceTest:!KMeans:!phraseList:!tidyText:!wordBag"],
required: true,
multi: true }).getValues();
var row_name_controls = [];
var n_tables = tables.length;
for (var i = 1; i < (1 + n_tables); i++)
row_name_controls.push(form.textBox({ label: "Row name " + i,
default_value: "",
prompt: "Enter a row label to override the label that appears on the table",
required: false,
name: "formRowName" + i }));
form.group("FORMAT");
var output = form.comboBox({ label: "Output",
name: "formOutput",
default_value: "Stages",
alternatives: ["Stages", "Conversion", "Stages and Conversion"] }).getValue();
var sort_alternatives = ["First table's order", "Alphabetic"];
var n_rows = output == "Stages" ? n_tables : (output == "Conversion" ? n_tables - 1 : n_tables * 2 - 1);
for (var i = 1; i < (n_rows + 1); i++)
sort_alternatives.push("Row " + i);
form.comboBox({ label: "Sort by",
name: "formSort",
default_value: sort_alternatives[n_tables == 0 ? 0 : 1],
alternatives: sort_alternatives });
var show_as = form.comboBox({ label: "Show as",
name: "formShowAs",
default_value: "Tiles",
alternatives: ["Simple", "Numbers", "Bars", "Tiles"] }).getValue();
if (show_as == "Bars") {
form.colorPicker({ label: "Color",
name: "formBaseColor",
default_value: "#8cc0ff" });
let fixed_width = form.checkBox({ label: "Fixed column width", name: "formFixedWidth",
default_value: false }).getValue();
if (fixed_width)
form.numericUpDown({ label: "Column width (pixels):", name: "formColumnWidth",
default_value: 100, increment: 1, minimum: 1, maximum: 1000 });
}
else if (show_as == "Tiles") {
form.colorPicker({ label: "Gradient start",
name: "formBaseColor",
default_value: "#B1CBEB" });
form.colorPicker({ label: "Gradient end",
name: "formEndColor",
default_value: "#3E7DCC" });
}
# Extracting inputs form the Inputs tab
output <- formOutput
show.as <- formShowAs
base.color <- get0("formBaseColor")
end.color <- get0("formEndColor")
row.names <- c(get0("formRowName1"), get0("formRowName2"), get0("formRowName3"), get0("formRowName4"), get0("formRowName5"), get0("formRowName6"), get0("formRowName7"), get0("formRowName8"), get0("formRowName9"), get0("formRowName10"))
initial.tables <- formTables
sort.by <- formSort
# Row names
table.names <- gsub(".", "", names(formTables), fixed = TRUE)
question.names <- sapply(formTables, function(x)
{
q <- attr(x, "questions")
if (is.null(q))
return("")
if (q[2] == "SUMMARY") q[1] else paste(q[1], "by", q[2])
})
row.names[row.names == ""] <- question.names[row.names == ""]
row.names[row.names == ""] <- table.names[row.names == ""]
while(any(duplicated(row.names)))
row.names[duplicated(row.names)] = paste0(row.names[duplicated(row.names)], "1")
row.names
# Checking that all tables contain only one column
n.columns <- sapply(initial.tables, NCOL)
if (max(n.columns) > 1)
{
StopForUserError("Tables with multiple columns are not supported. Tables with multiple columns are: ",
paste0(names(n.columns[n.columns > 1]), collapse = ", "))
}
# Creating the table
freq <- table(unlist(sapply(initial.tables, verbs:::rowNames)))
brands <- names(freq[freq == length(initial.tables)])
if (length(brands) == 0)
StopForUserError("There are no common row names in these tables; this analysis requires common row names.")
brands <- brands[!brands %in% c("Total", "NET", "Sum", "SUM")]
tables <- list()
for (i in seq_along(initial.tables))
{
t <- initial.tables[[i]]
tables[[i]] <- if (is.matrix(t)) t[brands, ] else t[brands]
}
x = as.data.frame(t(as.data.frame(tables, check.names = FALSE)), check.names = FALSE)
# Setting the row names
n.rows <- nrow(x)
n.row.labels <- length(row.names)
if (n.rows > n.row.labels)
warning("To show more than 10 rows, you will need to modify the row.names line of the source R CODE")
row.i <- 1:min(n.rows, n.row.labels)
rownames(x)[row.i] <- row.names[row.i]
# If required, creating conversion
if (grepl("Conversion", output))
{
if(n.rows == 1)
StopForUserError("Conversion can only be computed with 2 or more input rows.")
conv = x[-1, ] / x[-NROW(x), ] * 100
rownames(conv) = paste0(rownames(x)[-1], "/", rownames(x)[-NROW(x)])
x <- if(output == "Conversion") conv else rbind(x, conv)
}
# Sorting the table
if (sort.by != "Alphabetic")
{
if (sort.by == "First table's order")
{
table.1.names <- names(initial.tables[[1]])
o <- table.1.names[table.1.names %in% colnames(x)]
} else {
x.as.matrix <- as.matrix(x)
i <- as.numeric(strsplit(sort.by, " ")[[1]][2])
o <- order(x.as.matrix[i, ], decreasing = TRUE)
}
x <- x[, o]
}
# Formatting the output
brand.health <- if (show.as == "Simple") x else {
require(formattable)
custom_color_tile <- function (...)
{
formatter("span",
style = function(x) style(display = "block",
padding = "0 4px",
`color` = "white",
`border-radius` = "4px",
`background-color` = csscolor(gradient(as.numeric(x),
...))))
}
fw_color_bar <- function (color, fixed.width = 100, ...)
formatter(.tag = "span", style = function(x)
style(display = "inline-block", direction = "rtl", `border-radius` = "4px",
`padding` = "0px", `background-color` = csscolor(color),
width = paste(fixed.width*proportion(x),"px",sep="")))
n.rows <- nrow(x)
n.columns <- ncol(x)
col.width <- get0("formColumnWidth", ifnotfound = 100)
out <- formattable(x, align = "r", list(
area(col = 1:n.columns) ~ function(x) percent(x / 100, digits = 0),
if (show.as == "Tiles") area(col = 1:n.columns) ~ custom_color_tile(base.color, end.color),
if (show.as == "Bars") ~ fw_color_bar(base.color, col.width)))
if (get0("formFixedWidth", ifnotfound = FALSE))
{
th.font.js.code <- paste0("function(settings, json) {$(this.api().table()",
".header()).css({'font-family' : ",
"'Helvetica Neue,Helvetica,Arial,sans-serif'});}")
out <- DT::formatStyle(as.datatable(out, options = list(
autoWidth = TRUE,
scrollX = FALSE,
dom = "",
ordering = FALSE,
columnDefs = list(list(className = "dt-right",
width = paste0(col.width, "px"),
targets = "_all")),
initComplete = htmlwidgets::JS(th.font.js.code))),
colnames(x), target = "row",
backgroundColor = "#fff",
fontFamily = "Helvetica Neue,Helvetica,Arial,sans-serif")
}
attr(out, "ChartData") <- x
out
}