Skip to content

Commit

Permalink
add shinyvalidate to tmg (#498)
Browse files Browse the repository at this point in the history 
closes #420

Signed-off-by: Aleksander Chlebowski <[email protected]>
Signed-off-by: Mahmoud Hallal <[email protected]>
Signed-off-by: Nikolas Burkoff <[email protected]>
Co-authored-by: github-actions <41898282+github-actions[bot]@users.noreply.github.com>
Co-authored-by: Blazewim <[email protected]>
Co-authored-by: 27856297+dependabot-preview[bot]@users.noreply.github.com <27856297+dependabot-preview[bot]@users.noreply.github.com>
Co-authored-by: Aleksander Chlebowski <[email protected]>
Co-authored-by: Aleksander Chlebowski <[email protected]>
Co-authored-by: Nikolas Burkoff <[email protected]>
Co-authored-by: Dawid Kałędkowski <[email protected]>
Co-authored-by: Dawid Kałędkowski <[email protected]>
  • Loading branch information
@mhallal1 @github-actions
@BLAZEWIM @dependabot-preview @chlebowa @gogonzo
9 people authored Jan 11, 2023
1 parent ee6a8b9 commit c106336
Show file tree
Hide file tree
Showing 18 changed files with 828 additions and 534 deletions.
1 change: 1 addition & 0 deletions DESCRIPTION
View file
Original file line number Diff line number Diff line change
Expand Up @@ -32,6 +32,7 @@ Imports:
magrittr,
scales,
shinyjs,
shinyvalidate,
shinyWidgets,
stats,
stringr,
Expand Down
2 changes: 2 additions & 0 deletions NEWS.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,6 +11,7 @@
* Improved UI labels and plot panel title in `tm_g_association`.
* Added inputs `tm_variable_browser` module for text size and plot theme.
* Forced ggplot theme to be always selected in all modules.
* Updated encodings input checks to use `shinyvalidate::InputValidator` instead of `shiny::validate` for better UI experience.

### Bug fixes
* Fixed a bug in `tm_g_scatterplot` when selected x and y facets were the same.
Expand All @@ -20,6 +21,7 @@
### Miscellaneous

* Examples now use `scda.2022` rather than `scda.2021`.
* Replaced deprecated `ggplot2` functions `..count..`, `..density..` and `..prop..`.

# teal.modules.general 0.2.15

Expand Down
197 changes: 121 additions & 76 deletions R/tm_a_pca.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -150,14 +150,7 @@ ui_a_pca <- function(id, ...) {
include_css_files("custom"),
teal.widgets::standard_layout(
output = teal.widgets::white_small_well(
tags$div(
class = "overflow-scroll",
uiOutput(ns("tbl_importance_ui")),
hr(),
uiOutput(ns("tbl_eigenvector_ui")),
hr(),
teal.widgets::plot_with_settings_ui(id = ns("pca_plot"))
)
uiOutput(ns("all_plots"))
),
encoding = div(
### Reporter
Expand Down Expand Up @@ -269,10 +262,63 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
)
}

anl_merged_input <- teal.transform::merge_expression_module(
selector_list <- teal.transform::data_extract_multiple_srv(
data_extract = list(dat = dat, response = response),
datasets = data,
select_validation_rule = list(
dat = ~ if (length(.) < 2L) "Please select more than 1 variable to perform PCA.",
response = shinyvalidate::compose_rules(
shinyvalidate::sv_optional(),
~ if (isTRUE(is.element(., selector_list()$dat()$select)))
"Response must not have been used for PCA."
)
)
)

iv_r <- reactive({
iv <- shinyvalidate::InputValidator$new()
teal.transform::compose_and_enable_validators(iv, selector_list)
})

iv_extra <- shinyvalidate::InputValidator$new()
iv_extra$add_rule("x_axis", function(value) {
if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
if (!shinyvalidate::input_provided(value))
"Need X axis"
}
})
iv_extra$add_rule("y_axis", function(value) {
if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
if (!shinyvalidate::input_provided(value))
"Need Y axis"
}
})
rule_dupl <- function(...) {
if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
if (isTRUE(input$x_axis == input$y_axis))
"Please choose different X and Y axes."
}
}
iv_extra$add_rule("x_axis", rule_dupl)
iv_extra$add_rule("y_axis", rule_dupl)
iv_extra$add_rule("variables", function(value) {
if (identical(input$plot_type, "Circle plot")) {
if (!shinyvalidate::input_provided(value))
"Need Original Coordinates"
}
})
iv_extra$add_rule("pc", function(value) {
if (identical(input$plot_type, "Eigenvector plot")) {
if (!shinyvalidate::input_provided(value))
"Need PC"
}
})
iv_extra$enable()

anl_merged_input <- teal.transform::merge_expression_srv(
selector_list = selector_list,
datasets = data,
join_keys = get_join_keys(data),
data_extract = list(dat = dat, response = response)
join_keys = get_join_keys(data)
)

anl_merged_q <- reactive({
Expand All @@ -286,8 +332,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
anl_q_r = anl_merged_q
)

# computation ----
computation <- reactive({
validation <- reactive({
req(merged$anl_q_r())
# inputs
keep_cols <- as.character(merged$anl_input_r()$columns_source$dat)
Expand All @@ -297,21 +342,36 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
scale <- standardization == "center_scale"
ANL <- merged$anl_q_r()[["ANL"]] # nolint

# inputs validation
validate(need(length(keep_cols) > 1, "Please select more than 1 variable to perform PCA."))
teal::validate_has_elements(keep_cols, "Please select columns")
validate(need(
all(vapply(ANL[keep_cols], function(x) is.numeric(x) && all(!is.infinite(x)), logical(1))),
"PCA is only defined for (finite) numeric columns."
))
teal::validate_has_data(ANL, 10)
validate(need(
na_action != "none" | !anyNA(ANL[keep_cols]),
paste(
"There are NAs in the dataset. Please deal with them in preprocessing",
'or select "Drop" in the NA actions inside the encodings panel (left).'
"or select \"Drop\" in the NA actions inside the encodings panel (left)."
)
))
if (scale) {
not_single <- vapply(ANL[keep_cols], function(column) length(unique(column)) != 1, FUN.VALUE = logical(1))

msg <- paste0(
"You have selected `Center & Scale` under `Standardization` in the `Pre-processing` panel, ",
"but one or more of your columns has/have a variance value of zero, indicating all values are identical"
)
validate(need(all(not_single), msg))
}
})

# computation ----
computation <- reactive({
validation()

# inputs
keep_cols <- as.character(merged$anl_input_r()$columns_source$dat)
na_action <- input$na_action
standardization <- input$standardization
center <- standardization %in% c("center", "center_scale") # nolint
scale <- standardization == "center_scale"
ANL <- merged$anl_q_r()[["ANL"]] # nolint

qenv <- teal.code::eval_code(
merged$anl_q_r(),
Expand All @@ -328,16 +388,6 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
)
}

if (scale) {
not_single <- vapply(ANL[keep_cols], function(column) length(unique(column)) != 1, FUN.VALUE = logical(1))

msg <- paste0(
"You have selected `Center & Scale` under `Standardization` in the `Pre-processing` panel, ",
"but one or more of your columns has/have a variance value of zero, indicating all values are identical"
)
validate(need(all(not_single), msg))
}

qenv <- teal.code::eval_code(
qenv,
substitute(
Expand Down Expand Up @@ -366,6 +416,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
# plot args ----
output$plot_settings <- renderUI({
# reactivity triggers
req(iv_r()$is_valid())
req(computation())
qenv <- computation()

Expand Down Expand Up @@ -405,7 +456,6 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
# plot elbow ----
plot_elbow <- function(base_q) {
ggtheme <- input$ggtheme
validate(need(ggtheme, "Please select a theme."))
rotate_xaxis_labels <- input$rotate_xaxis_labels # nolint
font_size <- input$font_size # nolint

Expand All @@ -417,7 +467,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
theme = list(
legend.position = "right",
legend.spacing.y = quote(grid::unit(-5, "pt")),
legend.title = quote(element_text(vjust = 8)),
legend.title = quote(element_text(vjust = 25)),
axis.text.x = substitute(
element_text(angle = angle_value, hjust = hjust_value),
list(angle_value = angle_value, hjust_value = hjust_value)
Expand Down Expand Up @@ -481,19 +531,10 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl

# plot circle ----
plot_circle <- function(base_q) {
validate(
need(input$x_axis, "Need additional plot settings - x axis"),
need(input$y_axis, "Need additional plot settings - y axis"),
need(input$variables, "Need additional plot settings - variables")
)
validate(need(input$x_axis != input$y_axis, "Please choose different X and Y axes."))

x_axis <- input$x_axis # nolint
y_axis <- input$y_axis # nolint
variables <- input$variables # nolint

ggtheme <- input$ggtheme
validate(need(ggtheme, "Please select a theme."))

rotate_xaxis_labels <- input$rotate_xaxis_labels # nolint
font_size <- input$font_size # nolint
Expand Down Expand Up @@ -563,12 +604,6 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl

# plot biplot ----
plot_biplot <- function(base_q) {
validate(
need(input$x_axis, "Need additional plot settings - x axis"),
need(input$y_axis, "Need additional plot settings - y axis")
)
validate(need(isTRUE(input$x_axis != input$y_axis), "Please choose different X and Y axes."))

qenv <- base_q

ANL <- qenv[["ANL"]] # nolint
Expand All @@ -581,7 +616,6 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
pca <- qenv[["pca"]]

ggtheme <- input$ggtheme
validate(need(ggtheme, "Please select a theme."))

rotate_xaxis_labels <- input$rotate_xaxis_labels # nolint
alpha <- input$alpha # nolint
Expand All @@ -602,8 +636,8 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
qenv,
substitute(
expr = {
r <- sqrt(qchisq(0.69, df = 2)) * prod(colMeans(pca_rot ^ 2)) ^ (1 / 4) # styler: off
v_scale <- rowSums(pca$rotation ^ 2) # styler: off
r <- sqrt(qchisq(0.69, df = 2)) * prod(colMeans(pca_rot ^ 2)) ^ (1 / 4) # styler: off
v_scale <- rowSums(pca$rotation ^ 2) # styler: off

rot_vars <- pca$rotation[, c(x_axis, y_axis)] %>%
dplyr::as_tibble(rownames = "label") %>%
Expand Down Expand Up @@ -651,10 +685,6 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
)
dev_labs <- list()
} else {
validate(need(
!resp_col %in% dat_cols,
"Response column must be different from the original variables (that were used for PCA)."
))

rp_keys <- setdiff(
colnames(ANL),
Expand All @@ -676,8 +706,8 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
dev_labs <- list(color = varname_w_label(resp_col, ANL))

scales_biplot <- if (is.character(response) ||
is.factor(response) ||
(is.numeric(response) && length(unique(response)) <= 6)) {
is.factor(response) ||
(is.numeric(response) && length(unique(response)) <= 6)) {
qenv <- teal.code::eval_code(
qenv,
quote(pca_rot$response <- as.factor(response))
Expand Down Expand Up @@ -792,12 +822,8 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl

# plot pc_var ----
plot_pc_var <- function(base_q) {
validate(need(input$pc, "Need additional plot settings - PC"))

pc <- input$pc # nolint

ggtheme <- input$ggtheme
validate(need(ggtheme, "Please select a theme."))

rotate_xaxis_labels <- input$rotate_xaxis_labels # nolint
font_size <- input$font_size # nolint
Expand Down Expand Up @@ -831,9 +857,9 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
quote(ggplot(pca_rot)),
substitute(
geom_bar(aes_string(x = "Variable", y = pc),
stat = "identity",
color = "black",
fill = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]
stat = "identity",
color = "black",
fill = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]
),
env = list(pc = pc)
),
Expand Down Expand Up @@ -876,20 +902,22 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
# plot final ----
output_q <- reactive({
req(computation())
if (input$plot_type == "Elbow plot") {
plot_elbow(computation())
} else if (input$plot_type == "Circle plot") {
plot_circle(computation())
} else if (input$plot_type == "Biplot") {
plot_biplot(computation())
} else if (input$plot_type == "Eigenvector plot") {
plot_pc_var(computation())
} else {
stop("Unknown plot")
}
# teal::validate_inputs_segregated(list("Some inputs require attention" = iv_r(),
# "Plot settings are required" = iv_extra))
teal::validate_inputs(iv_r())
teal::validate_inputs(iv_extra, header = "Plot settings are required")

switch(input$plot_type,
"Elbow plot" = plot_elbow(computation()),
"Circle plot" = plot_circle(computation()),
"Biplot" = plot_biplot(computation()),
"Eigenvector plot" = plot_pc_var(computation()),
stop("Unknown plot"))
})

plot_r <- reactive(output_q()[["g"]])
plot_r <- reactive({
output_q()[["g"]]
})

pws <- teal.widgets::plot_with_settings_srv(
id = "pca_plot",
Expand Down Expand Up @@ -938,6 +966,23 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
)
})

output$all_plots <- renderUI({
# teal::validate_inputs_segregated(list("Some inputs require attention" = iv_r(),
# "Plot settings are required" = iv_extra))
teal::validate_inputs(iv_r())
teal::validate_inputs(iv_extra, header = "Plot settings are required")

validation()
tags$div(
class = "overflow-scroll",
uiOutput(session$ns("tbl_importance_ui")),
hr(),
uiOutput(session$ns("tbl_eigenvector_ui")),
hr(),
teal.widgets::plot_with_settings_ui(id = session$ns("pca_plot"))
)
})

teal.widgets::verbatim_popup_srv(
id = "warning",
verbatim_content = reactive(teal.code::get_warnings(output_q())),
Expand Down
Loading

0 comments on commit c106336

Please sign in to comment.