Skip to content
This repository has been archived by the owner. It is now read-only.

Commit

Permalink
Browse files Browse the repository at this point in the history
Merge pull request #21 from HendrikSchultheis/oo_clarion 
Clarion object (wilson 2.0)
  • Loading branch information
@HendrikSchultheis
HendrikSchultheis committed Jun 29, 2018
2 parents a2f02b6 + f35ee0a commit 5dc6ab5
Show file tree
Hide file tree
Showing 71 changed files with 2,678 additions and 2,399 deletions.
1 change: 1 addition & 0 deletions .Rbuildignore
View file
@@ -1,3 +1,4 @@
^.*\.Rproj$
^\.Rproj\.user$
^\.buildkite.*
^revdep$
1 change: 0 additions & 1 deletion .buildkite/wilson-env.yml
View file
Expand Up @@ -43,4 +43,3 @@ dependencies:
- r-devtools
- "readline==6.3"
- r-roxygen2
- r-shinybs
14 changes: 6 additions & 8 deletions DESCRIPTION
View file
@@ -1,13 +1,13 @@
Package: wilson
Type: Package
Title: WIlsON Webbased Interactive Omics visualizatioN
Version: 1.0.0
Title: Web-Based Interactive Omics Visualization
Version: 2.0.0
Authors@R: c(
person("Hendrik", "Schultheis", email = "hendrik.schultheis@mpi-bn.mpg.de", role = c("aut", "cre")),
person("Jens", "Preussner", email = "jens.preussner@mpi-bn.mpg.de", role = "aut"),
person("Looso", "Mario", email = "mario.looso@mpi-bn.mpg.de", role = "aut"))
Description: This package provides modules for webbased tools that use plot based strategies to visualize and analyze multi-omics data.
WIlsON utilizes the Rshiny and Plotly frameworks to provide a user friendly dashboard for interactive plotting.
Description: This package provides modules for web-based tools that use plot based strategies to visualize and analyze multi-omics data.
'wilson' utilizes the 'shiny' and 'plotly' frameworks to provide a user friendly dashboard for interactive plotting.
URL: https://github.molgen.mpg.de/loosolab/wilson
BugReports: https://github.molgen.mpg.de/loosolab/wilson/issues
License: MIT + file LICENSE
Expand All @@ -34,19 +34,17 @@ Imports: shiny,
gplots,
reshape,
rintrojs,
webshot,
RJSONIO,
ggrepel (>= 0.6.12),
DESeq2,
rjson,
FactoMineR,
factoextra,
heatmaply (>= 0.14.1),
shinyBS,
shinythemes,
shinycssloaders,
log4r,
openssl,
methods
methods,
R6
RoxygenNote: 6.0.1
biocViews:
3 changes: 1 addition & 2 deletions NAMESPACE
View file
@@ -1,10 +1,9 @@
# Generated by roxygen2: do not edit by hand

export(Clarion)
export(and)
export(andUI)
export(colorPicker)
export(colorPicker2)
export(colorPicker2UI)
export(colorPickerUI)
export(columnSelector)
export(columnSelectorUI)
Expand Down
136 changes: 66 additions & 70 deletions R/and.R
View file
Expand Up @@ -38,78 +38,78 @@ andUI <- function(id) {
#' @export
and <- function(input, output, session, data, show.elements = NULL, element.grouping = NULL, column.labels = NULL, delimiter = NULL, multiple = TRUE, contains = FALSE, ranged = FALSE, step = 100, reset = NULL) {
# handle reactive data
data.r <- shiny::reactive({
if(shiny::is.reactive(data)){
data_r <- shiny::reactive({
if (shiny::is.reactive(data)) {
data()
}else{
data
}
})

# handle reactive show.elements
show.elements.r <- shiny::reactive({
if(shiny::is.reactive(show.elements)) {
show_elements_r <- shiny::reactive({
if (shiny::is.reactive(show.elements)) {
show.elements <- show.elements()
} else {
show.elements <- show.elements
}
if(is.null(show.elements)) {
show.elements <- names(data.r())
if (is.null(show.elements)) {
show.elements <- names(data_r())
}

return(show.elements)
})

# handle reactive grouping
element.grouping.r <- shiny::reactive({
if(shiny::is.reactive(element.grouping)){
element_grouping_r <- shiny::reactive({
if (shiny::is.reactive(element.grouping)) {
element.grouping()
}else{
} else {
element.grouping
}
})

parameter <- shiny::reactive({
# get column labels
if(is.null(column.labels)){
column.labels <- names(data.r())
}else{
if (is.null(column.labels)) {
column.labels <- names(data_r())
} else {
column.labels <- column.labels
}
# fill multiple if vector is too small
if(shiny::is.reactive(multiple)) {
if (shiny::is.reactive(multiple)) {
multiple <- multiple()
}
if (length(multiple) < ncol(data.r())) {
multiple <- rep(multiple, length.out = ncol(data.r()))
if (length(multiple) < ncol(data_r())) {
multiple <- rep(multiple, length.out = ncol(data_r()))
}
# fill contains if vector is too small
if(shiny::is.reactive(contains)) {
if (shiny::is.reactive(contains)) {
contains <- contains()
}
if (length(contains) < ncol(data.r())) {
contains <- rep(contains, length.out = ncol(data.r()))
if (length(contains) < ncol(data_r())) {
contains <- rep(contains, length.out = ncol(data_r()))
}
# fill ranged if vector is too small
if(shiny::is.reactive(ranged)) {
if (shiny::is.reactive(ranged)) {
ranged <- ranged()
}
if (length(ranged) < ncol(data.r())) {
ranged <- rep(ranged, length.out = ncol(data.r()))
if (length(ranged) < ncol(data_r())) {
ranged <- rep(ranged, length.out = ncol(data_r()))
}
# fill delimiter if vector is too small
if(shiny::is.reactive(delimiter)) {
if (shiny::is.reactive(delimiter)) {
delimiter <- delimiter()
}
if (length(delimiter) < ncol(data.r()) & !is.null(delimiter)) {
delimiter <- rep(delimiter, length.out = ncol(data.r()))
if (length(delimiter) < ncol(data_r()) & !is.null(delimiter)) {
delimiter <- rep(delimiter, length.out = ncol(data_r()))
}
# fill step if vector is too small
if(shiny::is.reactive(step)) {
if (shiny::is.reactive(step)) {
step <- step()
}
if (length(step) < ncol(data.r()) & !is.null(step)) {
step <- rep(step, length.out = ncol(data.r()))
if (length(step) < ncol(data_r()) & !is.null(step)) {
step <- rep(step, length.out = ncol(data_r()))
}

return(list(column.labels = column.labels, multiple = multiple, contains = contains, ranged = ranged, delimiter = delimiter, step = step))
Expand All @@ -122,35 +122,35 @@ and <- function(input, output, session, data, show.elements = NULL, element.grou
progress$set(0, message = "Render orModules:")

# select data based on show.elements
data <- data.r()[, show.elements.r(), with = FALSE]
data <- data_r()[, show_elements_r(), with = FALSE]

step <- ncol(data)

if(!is.null(element.grouping.r())){
if (!is.null(element_grouping_r())) {
# only group shown data
element.grouping <- element.grouping.r()[element.grouping.r()[[1]] %in% show.elements.r()]
element.grouping <- element_grouping_r()[element_grouping_r()[[1]] %in% show_elements_r()]

grouping <- tapply(element.grouping[[1]], element.grouping[[2]], function(x){x})
grouping <- tapply(element.grouping[[1]], element.grouping[[2]], function(x) {x})
# keep grouping order
grouping <- grouping[unique(element.grouping[[2]])]

return <- lapply(1:length(grouping), function(i){
return <- lapply(seq_len(length(grouping)), function(i){
group <- lapply(unlist(grouping[i]), function(x){
progress$inc(step, detail = x)

if(is.numeric(data[[x]])){
if (is.numeric(data[[x]])) {
ui <- orNumericUI(id = session$ns(openssl::sha1(x)))
}else{
} else {
ui <- orTextualUI(id = session$ns(openssl::sha1(x)))
}

if(length(ui) < 4){ # orTextual
if (length(ui) < 4) { # orTextual
shiny::tagList(shiny::fluidRow(
shiny::column(width = 4, ui[1]),
shiny::column(width = 3, ui[2]),
shiny::column(width = 1, offset = 4, ui[3])
))
}else{ # orNumeric
} else { # orNumeric
shiny::tagList(shiny::fluidRow(
shiny::column(width = 4, ui[1]),
shiny::column(width = 1, ui[2]),
Expand All @@ -163,23 +163,23 @@ and <- function(input, output, session, data, show.elements = NULL, element.grou

shiny::tagList(shinydashboard::box(width = 12, collapsible = TRUE, collapsed = TRUE, title = names(grouping[i]), shiny::tagList(group)))
})
}else{
return <- lapply(1:ncol(data), function(x) {
} else {
return <- lapply(seq_len(ncol(data)), function(x) {
progress$inc(step, detail = names(data)[x])
if (is.numeric(data[[x]])) {
ui <- orNumericUI(id = session$ns(openssl::sha1(names(data)[x])))

} else{
} else {
ui <- orTextualUI(id = session$ns(openssl::sha1(names(data)[x])))
}

if(length(ui) < 4){ # orTextual
if (length(ui) < 4) { # orTextual
shiny::tagList(shiny::fluidRow(
shiny::column(width = 4, ui[1]),
shiny::column(width = 3, ui[2]),
shiny::column(width = 1, offset = 4, ui[3])
))
}else{ # orNumeric
} else { # orNumeric
shiny::tagList(shiny::fluidRow(
shiny::column(width = 4, ui[1]),
shiny::column(width = 1, ui[2]),
Expand All @@ -203,41 +203,41 @@ and <- function(input, output, session, data, show.elements = NULL, element.grou
progress <- shiny::Progress$new()
on.exit(progress$close())
progress$set(0, message = "Filtering Module:")
step <- ncol(data.r())
step <- ncol(data_r())

lapply(1:ncol(data.r()), function(x) {
progress$inc(step, detail = names(data.r())[x])
if (is.numeric(data.r()[[x]])) {
lapply(seq_len(ncol(data_r())), function(x) {
progress$inc(step, detail = names(data_r())[x])
if (is.numeric(data_r()[[x]])) {
if (parameter()$ranged[x]) {
shiny::callModule(
module = orNumeric,
id = openssl::sha1(names(data.r())[x]),
choices = data.r()[[x]],
value = c(floor(min(data.r()[[x]], na.rm = TRUE)), ceiling(max(data.r()[[x]], na.rm = TRUE))),
id = openssl::sha1(names(data_r())[x]),
choices = data_r()[[x]],
value = c(floor(min(data_r()[[x]], na.rm = TRUE)), ceiling(max(data_r()[[x]], na.rm = TRUE))),
label = parameter()$column.labels[x],
step = parameter()$step[x],
min. = floor(min(data.r()[[x]], na.rm = TRUE)),
max. = ceiling(max(data.r()[[x]], na.rm = TRUE)),
min. = floor(min(data_r()[[x]], na.rm = TRUE)),
max. = ceiling(max(data_r()[[x]], na.rm = TRUE)),
reset = reset
)
} else{
shiny::callModule(
module = orNumeric,
id = openssl::sha1(names(data.r())[x]),
choices = data.r()[[x]],
value = mean(data.r()[[x]], na.rm = TRUE),
id = openssl::sha1(names(data_r())[x]),
choices = data_r()[[x]],
value = mean(data_r()[[x]], na.rm = TRUE),
label = parameter()$column.labels[x],
step = parameter()$step[x],
min. = floor(min(data.r()[[x]], na.rm = TRUE)),
max. = ceiling(max(data.r()[[x]], na.rm = TRUE)),
min. = floor(min(data_r()[[x]], na.rm = TRUE)),
max. = ceiling(max(data_r()[[x]], na.rm = TRUE)),
reset = reset
)
}
} else{
shiny::callModule(
module = orTextual,
id = openssl::sha1(names(data.r())[x]),
choices = as.character(data.r()[[x]]),
id = openssl::sha1(names(data_r())[x]),
choices = as.character(data_r()[[x]]),
label = parameter()$column.labels[x],
delimiter = parameter()$delimiter[x],
multiple = parameter()$multiple[x],
Expand All @@ -256,35 +256,31 @@ and <- function(input, output, session, data, show.elements = NULL, element.grou

log_message(message = "Applying filter...", level = "INFO", token = session$token)

or.modules <- modules()
or_modules <- modules()

step <- 0.9 / length(or.modules)
step <- 0.9 / length(or_modules)
# OR modules selection
or.selection.bool <- sapply(or.modules, function(x) {
or_selection_bool <- vapply(or_modules, FUN.VALUE = logical(nrow(data_r())), FUN = function(x) {
progress$inc(step, detail = x()$label)
x()$bool
})
or.selection.text <- sapply(or.modules, function(x) {
if(shiny::isTruthy(x()$text)){

or_selection_text <- lapply(or_modules, function(x) {
if (shiny::isTruthy(x()$text)) {
return(paste0(x()$label, ": ", paste(x()$text, collapse = ","), collapse = ""))
}
})

# cast to matrix if sapply returns vector
if(is.vector(or.selection.bool)){
or.selection.bool <- t(as.matrix(or.selection.bool))
}

# selected rows (and selection)
and.selection.bool <- apply(or.selection.bool, 1, all)
and_selection_bool <- apply(or_selection_bool, 1, all)

or.selection.text <- unlist(or.selection.text)
or_selection_text <- unlist(or_selection_text)

progress$set(1)

log_message(message = "Done.", level = "INFO", token = session$token)

return(list(bool = and.selection.bool, text = unlist(or.selection.text)))
return(list(bool = and_selection_bool, text = unlist(or_selection_text)))
})

return(selection)
Expand Down

0 comments on commit 5dc6ab5

Please sign in to comment.