Skip to content

Commit 8238f59

Browse files
m7prm7pr
committed
tm_a_kmeans_ui
1 parent 78b95ac commit 8238f59

File tree

3 files changed

+400
-0
lines changed

3 files changed

+400
-0
lines changed

‎NAMESPACE‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,7 @@ S3method(create_sparklines,logical)
1010
S3method(create_sparklines,numeric)
1111
export(add_facet_labels)
1212
export(get_scatterplotmatrix_stats)
13+
export(tm_a_kmeans)
1314
export(tm_a_pca)
1415
export(tm_a_regression)
1516
export(tm_data_table)

‎R/tm_a_kmeans.R‎

Lines changed: 275 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,275 @@
1+
#' `teal` module: Scatterplot and k-means clustering
2+
#'
3+
#' Module for visualizing k-means clustering, including scatterplots and
4+
#' some clustering diagnostics plots. It allows users to identify clusters of similar observations
5+
#' in data, based on continuous variables. Module also displays summary statistics of the goodness
6+
#' of final clustering (within-cluster sum of squares).
7+
#'
8+
#' @note For more examples, please see the vignette "Using k-means clustering" via
9+
#' `vignette("using-kmeans-clustering", package = "teal.modules.general")`.
10+
#'
11+
#' @inheritParams teal::module
12+
#' @inheritParams shared_params
13+
#' @param dat (`data_extract_spec` or `list` of multiple `data_extract_spec`)
14+
#' Variables used for the creation of clusters with filtering and selecting.
15+
#' @param clusters (`integer(1)`) number of clusters.
16+
#' @param algorithm (`character(1)`) name of the clustering algorithm to be used. See more `stats::kmeans`.
17+
#' @param iter.max (`integer(1)`) maximum number of iterations allowed.
18+
#'
19+
#' @templateVar ggnames `r regression_names`
20+
#' @template ggplot2_args_multi
21+
#'
22+
#' @inherit shared_params return
23+
#'
24+
#' @examples
25+
#' # general data example
26+
#' library(teal.widgets)
27+
#'
28+
#' data <- teal_data()
29+
#' data <- within(data, {
30+
#' iris <- iris
31+
#' })
32+
#' datanames(data) <- c("iris")
33+
#'
34+
#' app <- init(
35+
#' data = data,
36+
#' modules = modules(
37+
#' tm_a_kmeans(
38+
#' label = "k-means Clustering",
39+
#' dat = data_extract_spec(
40+
#' dataname = "iris",
41+
#' select = select_spec(
42+
#' label = "Select variables:",
43+
#' choices = variable_choices(
44+
#' data[["iris"]],
45+
#' c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width")
46+
#' ),
47+
#' selected = c("Sepal.Length", "Sepal.Width"),
48+
#' multiple = TRUE,
49+
#' fixed = FALSE
50+
#' )
51+
#' ),
52+
#' ggplot2_args = ggplot2_args(
53+
#' labs = list(subtitle = "Plot generated by k-means Module")
54+
#' )
55+
#' )
56+
#' )
57+
#' )
58+
#' if (interactive()) {
59+
#' shinyApp(app$ui, app$server)
60+
#' }
61+
#'
62+
#' @export
63+
#'
64+
tm_a_kmeans <- function(label = "k-means Clustering",
65+
dat,
66+
clusters = 3,
67+
algorithm = c("Hartigan-Wong", "Lloyd", "Forgy", "MacQueen"),
68+
iter.max = 10,
69+
plot_height = c(600, 200, 2000),
70+
plot_width = NULL,
71+
alpha = c(1, 0, 1),
72+
size = c(2, 1, 8),
73+
ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
74+
ggplot2_args = teal.widgets::ggplot2_args(),
75+
pre_output = NULL,
76+
post_output = NULL) {
77+
message("Initializing tm_a_kmeans")
78+
79+
# Normalize the parameters
80+
if (inherits(dat, "data_extract_spec")) dat <- list(dat)
81+
if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)
82+
83+
# Start of assertions
84+
checkmate::assert_string(label)
85+
checkmate::assert_list(dat, types = "data_extract_spec")
86+
checkmate::assert_numeric(clusters, lower = 1)
87+
88+
algorithm <- match.arg(algorithm)
89+
90+
checkmate::assert_numeric(iter.max, lower = 1)
91+
92+
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
93+
checkmate::assert_numeric(plot_height[1],
94+
lower = plot_height[2],
95+
upper = plot_height[3],
96+
.var.name = "plot_height"
97+
)
98+
99+
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
100+
checkmate::assert_numeric(plot_width[1],
101+
lower = plot_width[2],
102+
upper = plot_width[3],
103+
null.ok = TRUE,
104+
.var.name = "plot_width"
105+
)
106+
107+
if (length(alpha) == 1) {
108+
checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE)
109+
} else {
110+
checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE)
111+
checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")
112+
}
113+
114+
if (length(size) == 1) {
115+
checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE)
116+
} else {
117+
checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE)
118+
checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")
119+
}
120+
121+
ggtheme <- match.arg(ggtheme)
122+
123+
checkmate::assert_list(ggplot2_args, types = "ggplot2_args")
124+
checkmate::assert_subset(names(ggplot2_args), c("default"))
125+
126+
checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
127+
checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
128+
# End of assertions
129+
130+
# Make UI args
131+
args <- as.list(environment())
132+
133+
data_extract_list <- list(dat = dat)
134+
135+
ans <- module(
136+
label = label,
137+
server = srv_a_kmeans,
138+
ui = ui_a_kmeans,
139+
ui_args = args,
140+
server_args = c(
141+
data_extract_list,
142+
list(
143+
plot_height = plot_height,
144+
plot_width = plot_width,
145+
ggplot2_args = ggplot2_args
146+
)
147+
),
148+
datanames = teal.transform::get_extract_datanames(data_extract_list)
149+
)
150+
attr(ans, "teal_bookmarkable") <- FALSE
151+
ans
152+
}
153+
154+
# UI function for the k-means module
155+
ui_a_kmeans <- function(id, ...) {
156+
ns <- NS(id)
157+
args <- list(...)
158+
is_single_dataset_value <- teal.transform::is_single_dataset(args$dat)
159+
160+
tagList(
161+
include_css_files("custom"),
162+
teal.widgets::standard_layout(
163+
output = teal.widgets::white_small_well(
164+
uiOutput(ns("all_plots"))
165+
),
166+
encoding = tags$div(
167+
### Reporter
168+
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
169+
###
170+
tags$label("Encodings", class = "text-primary"),
171+
teal.transform::datanames_input(args["dat"]),
172+
teal.transform::data_extract_ui(
173+
id = ns("dat"),
174+
label = "Data selection",
175+
data_extract_spec = args$dat,
176+
is_single_dataset = is_single_dataset_value
177+
),
178+
teal.widgets::panel_group(
179+
teal.widgets::panel_item(
180+
title = "Display",
181+
collapsed = FALSE,
182+
checkboxGroupInput(
183+
ns("tables_display"),
184+
"Tables display",
185+
choices = c("Cluster centers" = "centers", "Within cluster SS" = "withinss"),
186+
selected = c("centers", "withinss")
187+
)
188+
),
189+
teal.widgets::panel_item(
190+
title = "Setup",
191+
numericInput(
192+
ns("clusters"), "Clusters", value = args$clusters, min = 1, max = 20, step = 1
193+
),
194+
selectInput(
195+
ns("algorithm"), "Algorithm",
196+
choices = c("Hartigan-Wong", "Lloyd", "Forgy", "MacQueen"),
197+
selected = "Hartigan-Wong",
198+
multiple = FALSE
199+
),
200+
numericInput(
201+
ns("iter.max"), "Max Iterations", value = args$iter.max, min = 1, max = 100, step = 1
202+
),
203+
),
204+
teal.widgets::panel_item(
205+
title = "Plot settings",
206+
collapsed = TRUE,
207+
teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
208+
teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE),
209+
selectInput(
210+
inputId = ns("ggtheme"),
211+
label = "Theme (by ggplot):",
212+
choices = ggplot_themes,
213+
selected = args$ggtheme,
214+
multiple = FALSE
215+
)
216+
)
217+
)
218+
),
219+
forms = tagList(
220+
teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
221+
teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
222+
),
223+
pre_output = args$pre_output,
224+
post_output = args$post_output
225+
)
226+
)
227+
}
228+
229+
# Server function for the k-means module
230+
srv_a_kmeans <- function(id, data, reporter, filter_panel_api, dat, plot_height, plot_width, ggplot2_args) {
231+
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
232+
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
233+
checkmate::assert_class(data, "reactive")
234+
checkmate::assert_class(isolate(data()), "teal_data")
235+
moduleServer(id, function(input, output, session) {
236+
237+
output_q <- reactive({
238+
qenv <- teal.code::qenv()
239+
})
240+
241+
teal.widgets::verbatim_popup_srv(
242+
id = "warning",
243+
verbatim_content = reactive(teal.code::get_warnings(output_q())),
244+
title = "Warning",
245+
disabled = reactive(is.null(teal.code::get_warnings(output_q())))
246+
)
247+
248+
teal.widgets::verbatim_popup_srv(
249+
id = "rcode",
250+
verbatim_content = reactive(teal.code::get_code(output_q())),
251+
title = "R Code for k-means"
252+
)
253+
254+
### REPORTER
255+
if (with_reporter) {
256+
card_fun <- function(comment, label) {
257+
card <- teal::report_card_template(
258+
title = "K-means Clustering",
259+
label = label,
260+
with_filter = with_filter,
261+
filter_panel_api = filter_panel_api
262+
)
263+
264+
if (!comment == "") {
265+
card$append_text("Comment", "header3")
266+
card$append_text(comment)
267+
}
268+
card$append_src(teal.code::get_code(output_q()))
269+
card
270+
}
271+
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
272+
}
273+
###
274+
})
275+
}

0 commit comments

Comments
 (0)