From e56286dbd7fa04d64405138e4b87244cef7afe79 Mon Sep 17 00:00:00 2001 From: Nacho Caballero Date: Sun, 18 Aug 2013 16:24:48 -0400 Subject: [PATCH 1/2] added heatmap and moved params --- R/Chart-params.R | 2 - inst/templates/Heatmap/config.yml | 22 +++ inst/templates/Heatmap/template/template.Rmd | 105 ++++++++++++ .../Heatmap/template/template.coffee.Rmd | 153 ++++++++++++++++++ inst/templates/Heatmap/tests/test-Heatmap.R | 77 +++++++++ .../Heatmap/translator/Heatmap-placeholders.R | 39 +++++ inst/templates/Heatmap/translator/Heatmap.R | 147 +++++++++++++++++ inst/templates/Points/translator/Points.R | 3 + 8 files changed, 546 insertions(+), 2 deletions(-) create mode 100644 inst/templates/Heatmap/config.yml create mode 100644 inst/templates/Heatmap/template/template.Rmd create mode 100644 inst/templates/Heatmap/template/template.coffee.Rmd create mode 100644 inst/templates/Heatmap/tests/test-Heatmap.R create mode 100644 inst/templates/Heatmap/translator/Heatmap-placeholders.R create mode 100644 inst/templates/Heatmap/translator/Heatmap.R diff --git a/R/Chart-params.R b/R/Chart-params.R index a0490cb..99298ec 100644 --- a/R/Chart-params.R +++ b/R/Chart-params.R @@ -4,8 +4,6 @@ Chart$methods( get_params = function(){ params$port <<- params$port %or% 8000 - params$width <<- params$width %or% 500 - params$height <<- params$height %or% 500 params$title <<- params$title %or% params$main %or% internal$file$names$template # alias (main) params$padding <<- validate_padding(params$padding) diff --git a/inst/templates/Heatmap/config.yml b/inst/templates/Heatmap/config.yml new file mode 100644 index 0000000..673b222 --- /dev/null +++ b/inst/templates/Heatmap/config.yml @@ -0,0 +1,22 @@ +info: |- + Describe what this template does + +demo: |- + data <- 1:10 + clickme(heatmap, data) + +scripts: + - $shared/d3.v3.2.7.js + - $shared/jquery.v1.8.3.min.js + - $shared/bootstrap-tooltip.v2.3.0.js + - $shared/d3_aux.js + +styles: + - $shared/clickme.css + - $shared/tooltip.css + +require_packages: + +require_server: no + + diff --git a/inst/templates/Heatmap/template/template.Rmd b/inst/templates/Heatmap/template/template.Rmd new file mode 100644 index 0000000..c668566 --- /dev/null +++ b/inst/templates/Heatmap/template/template.Rmd @@ -0,0 +1,105 @@ + + + + + + + {{{ params$title }}} + + {{{ get_assets() }}} + + + + + + + diff --git a/inst/templates/Heatmap/template/template.coffee.Rmd b/inst/templates/Heatmap/template/template.coffee.Rmd new file mode 100644 index 0000000..b82582d --- /dev/null +++ b/inst/templates/Heatmap/template/template.coffee.Rmd @@ -0,0 +1,153 @@ + + + + + + + {{{ params$title }}} + + {{{ get_assets() }}} + + + + + + + diff --git a/inst/templates/Heatmap/tests/test-Heatmap.R b/inst/templates/Heatmap/tests/test-Heatmap.R new file mode 100644 index 0000000..c194675 --- /dev/null +++ b/inst/templates/Heatmap/tests/test-Heatmap.R @@ -0,0 +1,77 @@ +context("Heatmap data") + +test_that("format_heatmap_data", { + params <- list(data = data.frame(x = 1:10, y = 11:20)) + heatmap <- Heatmap$new(params) + formatted_data <- heatmap$format_heatmap_data(params$data, colnames(params$data)) + expect_equal(no_whitespace(to_json(formatted_data)), no_whitespace('[ {"col_values": [ {"row_values": [{"cell_value": 1}, {"cell_value": 11}] }, + {"row_values": [{"cell_value": 2}, {"cell_value": 12}] }, + {"row_values": [{"cell_value": 3}, {"cell_value": 13}] }, + {"row_values": [{"cell_value": 4}, {"cell_value": 14}] }, + {"row_values": [{"cell_value": 5}, {"cell_value": 15}] }, + {"row_values": [{"cell_value": 6}, {"cell_value": 16}] }, + {"row_values": [{"cell_value": 7}, {"cell_value": 17}] }, + {"row_values": [{"cell_value": 8}, {"cell_value": 18}] }, + {"row_values": [{"cell_value": 9}, {"cell_value": 19}] }, + {"row_values": [{"cell_value": 10}, {"cell_value": 20}] }], + "col_names": [ "x", "y" ] } + ]'), info = "neither col_groups nor row_groups") + + col_groups <- factor(c("x","x","y","y"), levels= c("y", "x")) + params <- list(data = data.frame(x1 = 1:3, x2 = 4:6, y1 = 7:9, y2 = 10:12), col_groups = col_groups) + heatmap <- Heatmap$new(params) + formatted_data <- heatmap$format_heatmap_data(params$data, colnames(params$data)) + expect_equal(no_whitespace(to_json(formatted_data)), no_whitespace('[ {"col_values": [ {"row_values": [{"cell_value": 7},{"cell_value": 10}] }, + {"row_values": [{"cell_value": 8},{"cell_value": 11}] }, + {"row_values": [{"cell_value": 9},{"cell_value": 12}] }], + "col_names": ["y1","y2"], + "col_group_name": "y" }, + + {"col_values": [ {"row_values": [{"cell_value": 1},{"cell_value": 4}] }, + {"row_values": [{"cell_value": 2},{"cell_value": 5}] }, + {"row_values": [{"cell_value": 3},{"cell_value": 6}] }], + "col_names": ["x1","x2"], + "col_group_name": "x" } + ]'), info = "only col_groups") + + row_groups <- c("a","a","b","b") + params <- list(data = data.frame(x = 1:4, y = 5:8), row_groups = row_groups) + heatmap <- Heatmap$new(params) + formatted_data <- heatmap$format_heatmap_data(params$data, colnames(params$data)) + expect_equal(no_whitespace(to_json(formatted_data)), no_whitespace('[ {"col_values": [ {"row_values": [{"cell_value": 1},{"cell_value": 5}] }, + {"row_values": [{"cell_value": 2},{"cell_value": 6}] }, + {"row_values": [{"cell_value": 3},{"cell_value": 7}] }, + {"row_values": [{"cell_value": 4},{"cell_value": 8}] }], + "col_names": ["x","y"], + "row_group_names": ["a","a","b","b"]} + ]'), info = "only row_groups") + + row_groups <- c("a","a","b","b") + col_groups <- factor(c("x","x","y","y"), levels= c("y", "x")) + params <- list(data = data.frame(x1 = 1:4, x2 = 5:8, y1 = 9:12, y2 = 13:16), row_groups = row_groups, col_groups = col_groups) + heatmap <- Heatmap$new(params) + formatted_data <- heatmap$format_heatmap_data(params$data, colnames(params$data)) + expect_equal(no_whitespace(to_json(formatted_data)), no_whitespace('[ {"col_values": [ {"row_values": [{"cell_value": 9},{"cell_value": 13}] }, + {"row_values": [{"cell_value": 10},{"cell_value": 14}] }, + {"row_values": [{"cell_value": 11},{"cell_value": 15}] }, + {"row_values": [{"cell_value": 12},{"cell_value": 16}] }], + "col_names": ["y1","y2"], + "col_group_name": "y", + "row_group_names": ["a","a","b","b"]}, + + {"col_values": [ {"row_values": [{"cell_value": 1},{"cell_value": 5}] }, + {"row_values": [{"cell_value": 2},{"cell_value": 6}] }, + {"row_values": [{"cell_value": 3},{"cell_value": 7}] }, + {"row_values": [{"cell_value": 4},{"cell_value": 8}] }], + "col_names": ["x1","x2"], + "col_group_name": "x", + "row_group_names": ["a","a","b","b"]} + ]'), info = "row_groups and col_groups") +}) + + +context("Heatmap sanity") + +test_that("template is generated", { + clickme(heatmap, mat(nrow = 10, ncol = 5)) +}) diff --git a/inst/templates/Heatmap/translator/Heatmap-placeholders.R b/inst/templates/Heatmap/translator/Heatmap-placeholders.R new file mode 100644 index 0000000..3e99f00 --- /dev/null +++ b/inst/templates/Heatmap/translator/Heatmap-placeholders.R @@ -0,0 +1,39 @@ +Heatmap$methods( + + get_d3_color_scale = function(){ + color_range <- as.list(unname(params$palette)) + color_scale <- gettextf("d3.scale.linear() + .domain(%s) + .range(%s) + .interpolate(d3.interpolateLab)", + to_json(params$color_domain), + to_json(color_range)) + + color_scale + }, + + get_tooltip_content = function(){ + + tooltip_names <- colnames(data$unformatted) + tooltip_formats <- get_formats(data$unformatted[, tooltip_names], params$formats) + tooltip_values <- setNames(sapply(tooltip_names, function(name) gettextf("d['%s']", name)), names(tooltip_formats)) + + tooltip_formatted_values <- sapply(1:length(tooltip_values), function(i){ + if (tooltip_formats[i] == "s"){ + tooltip_values[i] + } else { + setNames(gettextf("d3.format('%s')(%s)", tooltip_formats[i], tooltip_values[i]), names(tooltip_values[i])) + } + }) + + rows <- sapply(names(tooltip_formatted_values), function(name) { + gettextf("%s\" + %s + \"", name, tooltip_formatted_values[name]) + }) + rows <- paste(rows, collapse = "") + + tooltip_contents <- gettextf("\"%s
\"", rows) + + tooltip_contents + } + +) \ No newline at end of file diff --git a/inst/templates/Heatmap/translator/Heatmap.R b/inst/templates/Heatmap/translator/Heatmap.R new file mode 100644 index 0000000..9106d7b --- /dev/null +++ b/inst/templates/Heatmap/translator/Heatmap.R @@ -0,0 +1,147 @@ +Heatmap <- setRefClass("Heatmap", + + contains = "Chart", + + methods = list( + + get_params = function(){ + callSuper() + + validate_groups() + + params$row_names <<- params$row_names %or% rownames(params$x) %or% as.character(1:nrow(data$unformatted)) + params$col_names <<- params$col_names %or% colnames(params$x) %or% as.character(1:ncol(data$unformatted)) + + params$cell_width <<- params$cell_width %or% 20 + params$cell_height <<- params$cell_height %or% params$cell_width + + params$palette <<- params$palette %or% c("#278DD6","#fff","#d62728") + + params$color_domain <<- validate_color_domain(params$color_domain) + }, + + get_data = function(){ + data <<- list(unformatted = params$x) + + if (is.matrix(data$unformatted)){ + data$unformatted <<- as.data.frame(data$unformatted, stringsAsFactors = FALSE) + } + + rownames(data$unformatted) <<- params$row_names + colnames(data$unformatted) <<- params$col_names + + # save colnames before adding extra columns (ex. color_groups, order_by) + col_names <- colnames(data$unformatted) + + # TODO: we only create data$unformatted$color_groups when params$color_groups is not null + # if (!is.null(params$color_groups)){ + # data$unformatted <- reorder_data_by_color_groups(data$unformatted, params) + # } + + params$width <<- params$width %or% (params$cell_width * ncol(data$unformatted)) + params$height <<- params$height %or% (params$cell_height * nrow(data$unformatted)) + + data$formatted <<- format_heatmap_data(data$unformatted, col_names) + + data + }, + + get_col_values = function(data, col_names){ + col_values <- unname(apply(data, 1, function(row){ + row_values <- lapply(1:length(row), function(row_index){ + list(cell_value = unname(row[row_index])) + }) + + list(row_values = row_values) + })) + + col_values + }, + + # The heatmap data structure is not as straightforward as the points data structure because + # it has overlapping definitions: col_group[col_values[row_values[cell_values]], col_group_name, col_names, row_group_names] + format_heatmap_data = function(data, col_names) { + if (is.null(params$col_groups)){ + col_values <- get_col_values(data, col_names) + col_group_list <- list( + col_values = col_values, + col_names = col_names + ) + if (!is.null(params$row_groups)){ + col_group_list$row_group_names <- params$row_groups + } + formatted_data <- list(col_group_list) + } else { + if (!is.factor(params$col_groups)){ + params$col_groups <<- factor(params$col_groups) + } + formatted_data <- lapply(levels(params$col_groups), function(col_group){ + col_names <- col_names[which(params$col_groups == col_group)] + data_col_group <- data[, which(params$col_groups == col_group), drop = FALSE] + col_values <- get_col_values(data_col_group, col_names) + col_group_list <- list( + col_values = col_values, + col_names = col_names, + col_group_name = col_group + ) + + if (!is.null(params$row_groups)){ + col_group_list$row_group_names <- params$row_groups + } + + col_group_list + }) + } + + formatted_data + }, + + # Ensure that the domain used with a D3 color scale is only specified when the scale is quantitative + validate_color_domain = function(color_domain){ + if (is.null(color_domain)) { + min <- min(params$x, na.rm = TRUE) + max <- max(params$x, na.rm = TRUE) + + # If the scale crosses zero, make sure it is centered around zero (white) + if (min < 0 && max > 0) { + color_domain <- c(min, 0, max) + if (length(params$palette) != 3){ + params$palette <<- c(params$palette[1], "white", params$palette[2]) + } + } else { + color_domain <- c(min, max) + } + } + + color_domain + }, + + validate_groups = function(){ + if (!is.null(params$row_groups) & length(params$row_groups) > nrow(params$x)){ + stop(gettextf("\n\n\tdata has %d rows, but row_groups contains %d elements:\n%s", + nrow(params$x), + length(params$row_groups), + enumerate(params$row_groups))) + } + + if (!is.null(params$col_groups) & length(params$col_groups) > ncol(params$x)){ + stop(gettextf("\n\n\tdata has %d cols, but col_groups contains %d elements:\n%s", + ncol(params$x), + length(params$col_groups), + enumerate(params$col_groups))) + } + } + + ) +) + +clickme_helper$heatmap <- function(x,...){ + params <- list(x = x, ...) + heatmap <- Heatmap$new(params) + + heatmap$display() +} + + + + diff --git a/inst/templates/Points/translator/Points.R b/inst/templates/Points/translator/Points.R index 7e40994..98fb657 100644 --- a/inst/templates/Points/translator/Points.R +++ b/inst/templates/Points/translator/Points.R @@ -20,6 +20,9 @@ Points <- setRefClass("Points", get_params = function(){ callSuper() + params$width <<- params$width %or% 500 + params$height <<- params$height %or% 500 + params$radius <<- params$radius %or% 5 params$jitter <<- params$jitter %or% 0 params$opacity <<- params$opacity %or% 1 From 0c8469a189d9cd4c72ad398774f4e38baf17a68e Mon Sep 17 00:00:00 2001 From: Nacho Caballero Date: Sun, 18 Aug 2013 16:25:57 -0400 Subject: [PATCH 2/2] fixed palette bug and allowed radius to accept an input vector --- inst/templates/Points/template/template.Rmd | 18 ++++++++++-------- .../Points/template/template.coffee.Rmd | 14 +++++++------- inst/templates/Points/tests/test-Points-data.R | 2 +- .../Points/tests/test-Points-placeholders.R | 9 ++++++--- inst/templates/Points/translator/Points-data.R | 1 + .../Points/translator/Points-placeholders.R | 11 ++++++++--- 6 files changed, 33 insertions(+), 22 deletions(-) diff --git a/inst/templates/Points/template/template.Rmd b/inst/templates/Points/template/template.Rmd index 2bb1c5a..6d4bf27 100644 --- a/inst/templates/Points/template/template.Rmd +++ b/inst/templates/Points/template/template.Rmd @@ -16,14 +16,14 @@