From 1d3b36a2c9e6e19b95b15601409d6ef99639f9bf Mon Sep 17 00:00:00 2001 From: John Magnotti Date: Tue, 17 Sep 2019 11:49:28 -0500 Subject: [PATCH 01/24] separating multi-electrode power explorer from univariate version. updates for compatibility with new 3d viewer. Beta support for outlier detection. --- NAMESPACE | 1 + R/aaa.R | 27 +- R/common_plotting_functions.R | 152 +++-- R/playing_with_brain_coordinates.R | 68 ++ R/power_explorer_plots.R | 35 +- R/rave_calculators.R | 1 - inst/modules/group_analysis_lme/common.R | 5 - inst/modules/power_explorer/comp.R | 190 ++++-- inst/modules/power_explorer/event_handlers.R | 166 ++++- inst/modules/power_explorer/exports.R | 145 +++-- inst/modules/power_explorer/main.R | 182 ++++-- inst/modules/univariate_power_explorer/comp.R | 294 +++++++++ .../univariate_power_explorer/comp.Rmd | 260 ++++++++ .../univariate_power_explorer/comp.html | 612 ++++++++++++++++++ .../event_handlers.R | 82 +++ .../univariate_power_explorer/exports.R | 243 +++++++ inst/modules/univariate_power_explorer/main.R | 294 +++++++++ inst/tools/funcs.R | 6 +- inst/tools/input_widgets.R | 11 +- inst/tools/output_widgets.R | 85 ++- 20 files changed, 2570 insertions(+), 289 deletions(-) create mode 100644 R/playing_with_brain_coordinates.R create mode 100644 inst/modules/univariate_power_explorer/comp.R create mode 100644 inst/modules/univariate_power_explorer/comp.Rmd create mode 100644 inst/modules/univariate_power_explorer/comp.html create mode 100644 inst/modules/univariate_power_explorer/event_handlers.R create mode 100644 inst/modules/univariate_power_explorer/exports.R create mode 100644 inst/modules/univariate_power_explorer/main.R diff --git a/NAMESPACE b/NAMESPACE index 74d3a7b..961d65f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -19,6 +19,7 @@ import(stringr) importFrom(grDevices,dev.off) importFrom(grDevices,palette) importFrom(grDevices,pdf) +importFrom(magrittr,"%$%") importFrom(magrittr,"%<>%") importFrom(magrittr,"%>%") importFrom(magrittr,extract) diff --git a/R/aaa.R b/R/aaa.R index 2727a6e..e0ad9f7 100644 --- a/R/aaa.R +++ b/R/aaa.R @@ -6,6 +6,7 @@ #' @importFrom magrittr %>% #' @import stringr #' @importFrom magrittr %<>% +#' @importFrom magrittr %$% #' @importFrom magrittr extract2 #' @importFrom magrittr extract #' @import rlang @@ -262,14 +263,16 @@ rave_color_ramp_dark_palette <- colorRampPalette(c('#13547a', 'black', '#ff758c' ..dark_blue_to_red <- rev(c("#67001f", "#b2182b", "#d6604d", "#f4a582", "#fddbc7", "#ffffff", "#d1e5f0", "#92c5de", "#4393c3", "#2166ac", "#053061")) ..light_blue_to_light_red <- c(..dark_blue_to_red[5:1], 'black', ..dark_blue_to_red[11:7]) - +..light_blue_to_gray_to_light_red <- c(..dark_blue_to_red[5:1], '#1E1E1E', ..dark_blue_to_red[11:7]) rave_color_ramp_palette <- colorRampPalette(..dark_blue_to_red, interpolate='linear', space='Lab') rave_heat_map_colors <- rave_color_ramp_palette(1001) rave_color_ramp_dark_palette <- colorRampPalette(..light_blue_to_light_red, interpolate='linear', space='Lab') +rave_color_ramp_gray_palette <- colorRampPalette(..light_blue_to_gray_to_light_red, interpolate='linear', space='Lab') rave_heat_map_dark_colors <- rave_color_ramp_dark_palette(1001) +rave_heat_map_gray_colors <- rave_color_ramp_gray_palette(1001) # put this here for legacy, but we need to exterminate these references crp <- rave_heat_map_colors @@ -282,12 +285,7 @@ rave_axis <- function(side, at, tcl=-0.3, labels=at, las=1, cex.axis=rave_cex.ax # if the color isn't specified, then we are free to set the color to what we want. # let's set it to be black, unless that background color is black, then we'll do white - col %?<-% if(par('bg') == 'black') { - 'white' - } else { - 'black' - } - + col %?<-% get_foreground_color() col.axis %?<-% col ruta_axis( @@ -305,8 +303,6 @@ rave_axis <- function(side, at, tcl=-0.3, labels=at, las=1, cex.axis=rave_cex.ax ) } - - default_plot <- function() { plot_clean(1, 1, type='n', main='No Conditions Specified') } @@ -387,11 +383,14 @@ rave_colors <- list('BASELINE_WINDOW'='gray60', 'ANALYSIS_WINDOW' = 'salmon2', ' 'TRIAL_TYPE_SEPARATOR'='gray40') rave_title <- function(main, cex=rave_cex.main, col, font=1) { - - col %?<-% if(par('bg') == 'black') { - 'white' - } else { - 'black' + if(missing(col)) { + col = if(par('bg') == 'black') { + 'white' + } else if (par('bg') == '#1E1E1E'){ + 'gray70' + } else { + 'black' + } } title(main=list(main, cex=cex, col=col, font=font)) diff --git a/R/common_plotting_functions.R b/R/common_plotting_functions.R index a7901dc..194e48c 100644 --- a/R/common_plotting_functions.R +++ b/R/common_plotting_functions.R @@ -29,7 +29,12 @@ draw_many_heat_maps <- function(hmaps, max_zlim=0, log_scale=FALSE, # this is to add some extra spacing on the LEFT margin to allow, e.g., longer axis titles # we could also set this adaptively based on the max(nchar(...)) for the appropriate labels from hmap[[ii]] condition names if(wide) { - par(mar = c(5.1, 7, 2, 2)) + #NB: B, L, T, R + # trying to be smart about the size of the margin to accomodate the angular text. R doesn't auto adjust :( + max_char_count = max(sapply(hmaps, function(h) ifelse(h$has_trials, max(nchar(h$conditions)), 'a'))) + + par(mar = c(5.1, 5.1 + max(0,(max_char_count - 5)*0.75), + 2, 2)) } # actual data range, as opposed to the max zlim which controls the plottable range @@ -145,8 +150,8 @@ time_series_plot <- function(plot_data, PANEL.FIRST=NULL, PANEL.LAST=NULL) { # group_data is a list # this is a list to allow different N in each group # NB: the reason we use barplot here is that it takes care of the width between groups for us, even though by default we don't actually show the bars -trial_scatter_plot = function(group_data, ylim, bar.cols=NA, bar.borders=NA, cols, ebar.cols='gray30', ebar.lwds=3, jitr_x, - pchs=19, pt.alpha=175, xlab='Group', ylab='Mean % Signal Change', ebar.lend=2, ...) { +trial_scatter_plot = function(group_data, ylim, bar.cols=NA, bar.borders=NA, cols, ebar.cols='gray30', ebar.lwd=3, jitr_x, + pchs=19, pt.alpha=175, xlab='Group', ylab='Mean % Signal Change', ebar.lend=2, show_outliers=TRUE, ...) { nms <- group_data %>% get_list_elements('name') # @@ -156,47 +161,56 @@ trial_scatter_plot = function(group_data, ylim, bar.cols=NA, bar.borders=NA, col # ns <- group_data %>% get_list_elements('N') - yax <- do_if(missing(ylim), { - pretty(get_data_range(group_data), high.u.bias = 100, n=4, min.n=3) - }, ylim) + if(show_outliers) { + yax <- do_if(missing(ylim), { + pretty(get_data_range(group_data), high.u.bias = 100, n=4, min.n=3) + }, ylim) + } else { + yax <- do_if(missing(ylim), { + pretty(sapply(group_data, function(.d) { + range(.d %$% data[is_clean]) + }), high.u.bias = 100, n=4, min.n=3) + }, ylim) + } #there are edge cases where length(mses) != length(names), take care of this with `ind` below bp_names <- paste0(nms, ' (N=' %&% ns %&%')') # this creates space for empty groups -- is this expected behavior? It is good to preserve the color - # mapping, but I'd rather not have the empty, space... so we need to preserve the colors but not the empty space + # mapping, but I'd rather not have the empty space... so we need to preserve the colors but not the empty space ind <- which(unlist(lapply(group_data, '[[', 'has_trials'))) mses <- sapply(ind, function(ii) group_data[[ii]]$mse) + # + axis_col = get_foreground_color() - .col <- if(par('bg')=='black') { - 'white' - } else { - 'black' - } - + # x <- rave_barplot(mses[1,],col='white', ylim=.fast_range(yax), axes=F) + .fg <- par('fg'=axis_col, 'col.lab' = axis_col, col.axis=axis_col) x <- rave_barplot(mses[1,], ylim=.fast_range(yax) %>% stretch(.01), col=bar.cols, border=bar.borders, - names.arg=bp_names[ind], col.axis=.col, axes=F, ...) + names.arg=bp_names[ind], axes=F, ...) + par('fg'=.fg) - # putting this here, but move this out to a PANEL.FIRST + # putting this here, but move this out to a PANEL.FIRST argument axis_label_decorator(group_data) rave_axis(2, at=yax) if(min(yax) < 0) abline(h=0, col='lightgray') - + # grabbing an attribute from the group data if(not_null(attr(group_data, 'stats'))) rave_title(as.title(pretty(attr(group_data, 'stats')))) #emphasize the means lsize <- (1/3)*mean(unique(diff(x))) + # this means there is only 1 group. If there is one group, the barplot seems to get placed at 0.7, with # the usr range being 0.16 - 1.24. if(is.na(lsize)) lsize <- 1/3 - if(missing(jitr_x)) jitr_x <- 0.75*lsize + # jittering is done in main.R now so that it can persist across refreshes + # if(missing(jitr_x)) jitr_x <- 0.75*lsize # if(missing(cols)) cols <- get_color(seq_along(group_data)) if(missing(cols)) cols <- grDevices::palette() @@ -204,12 +218,11 @@ trial_scatter_plot = function(group_data, ylim, bar.cols=NA, bar.borders=NA, col # Ensure all parameters are sufficiently long. This feels extravagant, but needed because we're indexing into these variables # and we don't want to reach beyond the end par_rep <- function(y) rep_len(y, length(group_data)) - cols %<>% par_rep pchs %<>% par_rep - bar.cols %<>% par_rep ebar.cols %<>% par_rep - bar.borders %<>% par_rep + # bar.cols %<>% par_rep + # bar.borders %<>% par_rep # x may not be the same length as group_data because we're skipping empty groups # we still want everything else to be based on group number @@ -217,19 +230,39 @@ trial_scatter_plot = function(group_data, ylim, bar.cols=NA, bar.borders=NA, col for(ii in seq_along(group_data)) { if(group_data[[ii]]$has_trials) { - lines(x[xi] + c(-lsize, lsize), rep(mses[1, xi], 2), lwd=3, lend=ebar.lend, col=ebar.cols[ii]) + lines(group_data[[ii]]$xp + c(-lsize, lsize), rep(mses[1, xi], 2), + lwd=ebar.lwd, lend=ebar.lend, col=ebar.cols[ii]) + + # add_points(x[xi], group_data[[ii]]$data, + # col=getAlphaRGB(cols[ii], pt.alpha), pch=pchs[ii], jitr_x=jitr_x) + - add_points(x[xi], group_data[[ii]]$data, - col=getAlphaRGB(cols[ii], pt.alpha), pch=pchs[ii], jitr_x=jitr_x) + if(show_outliers) { + group_data[[ii]] %$% { + points(x, data, + col=ifelse(is_clean, getAlphaRGB(cols[ii], pt.alpha), 'gray30'), + pch=ifelse(is_clean, pchs[ii], 1)) + } + } else { + group_data[[ii]] %$% { + points(x[is_clean], data[is_clean], + col=getAlphaRGB(cols[ii], pt.alpha), + pch=pchs[ii]) + } + + + } + # cat('How many clean datapoints?' %&% sum(group_data[[ii]]$is_clean) %&% '\n') ebars.y(x[xi], mses[1,xi], mses[2,xi], - lwd=ebar.lwds, col=ebar.cols[ii], code=0, lend=ebar.lend) + lwd=ebar.lwd, col=ebar.cols[ii], code=0, lend=ebar.lend) + xi <- xi+1 } } # in case people need to further decorate - invisible(x) + invisible(group_data) } # the Xmap and Ymap here are functions that allow for transformation of the plot_data $x and $y into @@ -298,6 +331,20 @@ by_trial_heat_map_decorator <- function(plot_data=NULL, results, Xmap=force, Yma } +by_electrode_heat_map_decorator <- function(plot_data=NULL, results, Xmap=force, Ymap=force, ...) { + args <- list( + results=results, Xmap=Xmap, Ymap=Ymap, atype='line', btype='line', + title_options = list(allow_enum=FALSE), + ... + ) + + if(is.null(plot_data)) { + return(do.call(spectrogram_heatmap_decorator, args = args)) + } + + args$plot_data=plot_data + do.call(spectrogram_heatmap_decorator, args = args) +} @@ -326,9 +373,11 @@ make_image <- function(mat, x, y, zlim, col, log='', useRaster=TRUE, clip_to_zli } } - col %?<-% if (par('bg')=='black') { + col %?<-% if(par('bg') == 'black') { rave_heat_map_dark_colors - } else { + } else if(par('bg') == '#1E1E1E') { + rave_heat_map_gray_colors + }else { rave_heat_map_colors } @@ -385,7 +434,6 @@ fix_pdf_name <- function(fname) { return(fname) } - str_rng <- function(rng) sprintf('[%s]', paste0(rng, collapse=':')) rave_color_bar <- function(zlim, actual_lim, clrs, ylab='Mean % Signal Change', @@ -393,14 +441,16 @@ rave_color_bar <- function(zlim, actual_lim, clrs, ylab='Mean % Signal Change', clrs %?<-% if(par('bg') == 'black') { rave_heat_map_dark_colors - } else { + } else if(par('bg') == '#1E1E1E') { + rave_heat_map_gray_colors + }else { rave_heat_map_colors } cbar <- matrix(seq(-zlim, zlim, length=length(clrs))) %>% t par(mar=mar) image(cbar, - col=clrs, axes=F, ylab=ylab, main='', + col=clrs, axes=F, ylab=ylab, main='', col.lab = get_foreground_color(), cex.main=rave_cex.main*.8, cex.lab=rave_cex.lab, cex.axis=rave_cex.axis) # rave_main(str_rng(actual_lim %>% round)) @@ -417,9 +467,10 @@ midpoint <- function(x) { }) } -# this is really only used by the by_trial heat map, but that gets used in multiple modules, so it's here.... +# this is really only used by the by_trial heat map, +# but that gets used in multiple modules, so it's here.... reorder_trials_by_type <- function(bthmd) { - # we want to sort but preserve the order that the conditions were added to the group, but this doesn't do that + # we want to sort but preserve the order that the conditions were added to the group ind <- sapply(bthmd$conditions, function(ttype) which(ttype==bthmd$trials), simplify = FALSE) .xlab <- attr(bthmd$data, 'xlab') @@ -490,7 +541,8 @@ trial_type_boundaries_hm_decorator <- function(map, ...) { } else { yat <- median(y) } - rave_axis(2, tcl=0, lwd=0, at=yat, labels=map$ttypes) + # rather than drawing the labels AT the lines, we should draw them intermediate + rave_axis(2, tcl=0, lwd=0, at=yat+0.5, labels=map$ttypes) }) invisible(map) @@ -575,10 +627,8 @@ axis_label_decorator <- function(plot_data, col) { pd <- pd[[ii]] } - col %?<-% if(par('bg') == 'black') { - 'white' - } else { - 'black' + if(missing(col)) { + col = get_foreground_color() } title(xlab=attr(pd$data, 'xlab'), ylab=attr(pd$data, 'ylab'), @@ -606,13 +656,13 @@ title_decorator <- function(plot_data, results, if(allow_cond) add_if_selected('Condition', { .name <- plot_data[['name']] - if(nchar(.name) > 0) { + if(isTRUE(nchar(.name) > 0)) { .name <- '' %&% .name } title_string = .name }) - # we could write this as a simply m/sapply if the variable names had a clear relationship to one another + # we could write this as a simple m/sapply if the variable names had a clear relationship to one another if(allow_sid) add_if_selected('Subject ID', { conditional_sep(title_string) = results$get_value('subject_code') @@ -620,7 +670,13 @@ title_decorator <- function(plot_data, results, if(allow_enum) add_if_selected('Electrode #', { - conditional_sep(title_string) = 'E' %&% results$get_value('ELECTRODE') + el <- results$get_value('ELECTRODE', ifNotFound = NULL) + if(is.null(el)) { + # using requested_electrodes here rather than ELECTRODE_TEXT because of parsing issues in ELECTRODE_TEXT + el <- rutabaga::deparse_svec(results$get_value('requested_electrodes', ifNotFound = '?'), max_lag=1) + } + # print('EL: ' %&% el) + conditional_sep(title_string) = 'E' %&% el }) if(allow_freq) @@ -727,11 +783,7 @@ window_decorator <- function(window, type=c('line', 'box', 'shaded'), text.y <- par('usr')[4] * .9 - line.col %?<-% if(par('bg') == 'black') { - 'white' - } else { - 'black' - } + line.col %?<-% get_foreground_color() switch(type, line = { @@ -965,8 +1017,6 @@ pretty_num <- function(x, digits = 3, roundup = 5, decimal.mark = '.', ...){ } - - #TODO # have a parameter called "center" that allows all histograms to be centered # enabling easier comparison of the concentraion/dispersion kappa @@ -1015,8 +1065,6 @@ hist.circular <- function(x, ymax, nticks=3, digits=1, breaks=20, col='black', . invisible(x.hist) } - - # # # Colors #' @export get_palette <- function(pname, get_palettes=FALSE, get_palette_names=FALSE) { @@ -1048,6 +1096,7 @@ get_palette <- function(pname, get_palettes=FALSE, get_palette_names=FALSE) { return (pal) } + get_heatmap_palette <- function(pname, get_palettes=FALSE, get_palette_names=FALSE) { # Some of these are from: # https://colorhunt.co/ @@ -1086,11 +1135,6 @@ get_heatmap_palette <- function(pname, get_palettes=FALSE, get_palette_names=FAL return (pal) } - - - - - set_palette <- function(pname) { if(length(pname) == 1) { pname %<>% get_palette diff --git a/R/playing_with_brain_coordinates.R b/R/playing_with_brain_coordinates.R new file mode 100644 index 0000000..352462b --- /dev/null +++ b/R/playing_with_brain_coordinates.R @@ -0,0 +1,68 @@ +# if(FALSE) { +# require(rave) +# subject = Subject$new(project_name = 'congruency', subject_code = 'YAB') +# +# brain = rave_brain2(subject) +# table = load_meta('electrodes', subject_id = subject$id)[, c('Electrode','Coord_x','Coord_y','Coord_z','Label')] +# +# +# trans = read.table(file.path(subject$dirs$suma_dir, 'T1_to_freesurf.txt'), head = F) +# trans = as.matrix(trans) +# brain$scanner_center +# +# # because the center of the (AFNI) T1 is relative the origin of the scanner, we need to translate back to get into +# # FREESURFER RAS space +# new_coord = trans %*% rbind(table$Coord_x, table$Coord_y, table$Coord_z, 1) + c(brain$scanner_center, 0) +# +# +# # store the values back into the electrodes meta table +# table$Coord_x = new_coord[1,] +# table$Coord_y = new_coord[2,] +# table$Coord_z = new_coord[3,] +# +# +# # Set back to brain and calculate nearest nodes +# table$SurfaceElectrode = TRUE +# brain$set_electrodes(table) +# +# brain$plot() +# +# +# new_elec = brain$calculate_template_coordinates(save_to = FALSE) +# new_elec$Radius[59:66] = 0.5 +# +# # save_meta('electrodes', project_name = subject$project_name, subject_code = subject$subject_code, data = new_elec) +# +# +# +# aseg <- threeBrain::read_fs_mgh_mgz('/Volumes/data/UT/YAB/iELVis_localization/YAB/mri/brainmask.mgz') +# dat = aseg$get_data() +# fields::image.plot(dat[,,128]) +# fields::image.plot(dat[,,128]==0) +# unique(as.vector(dat)) +# +# +# anat <- read.table('/Volumes/data/UT/YAB/iELVis_localization/YAB/label/aparc.annot.a2009s.ctab', header=F) +# head(anat) +# tran_elec= new_elec[,2:4] +# +# +# junk = t(as.matrix(anat[,3:5])) +# junk = (brain$Torig %*% rbind(junk, 1))[1:3,] +# +# mapping = t(apply(tran_elec, 1, function(te) { +# dist = colSums((junk - te)^2) +# ii = which.min(dist) +# c(ii, sqrt(dist[ii])) +# })) +# +# l = anat$V2[mapping[,1]] +# +# cbind(new_elec$Label, as.character(l)) +# +# new_elec$Anat = l +# +# brain$set_electrode_values(new_elec) +# +# brain$plot() +# } diff --git a/R/power_explorer_plots.R b/R/power_explorer_plots.R index 900d63e..571c670 100644 --- a/R/power_explorer_plots.R +++ b/R/power_explorer_plots.R @@ -13,12 +13,25 @@ over_time_plot <- function(results, ...) { PANEL.FIRST = time_series_decorator(results = results)) } +get_foreground_color <- function() { + switch(par('bg'), + 'black' = 'white', + 'white' = 'black', + '#1E1E1E' = 'gray70', + 'gray' = '#A5A5A5' + ) +} #works by side effect to change the palette used by the current graphics device set_palette_helper <- function(results, ...) { + .bg <- results$get_value('background_plot_color_hint', 'white') # setting the background color here triggers a cascade of color changes - par('bg'=results$get_value('background_plot_color_hint', 'white')) + if(.bg == 'Gray') { + par('bg'='#1E1E1E') + } else { + par('bg'=.bg) + } pal <- get_palette(results$get_value('color_palette')) @@ -49,7 +62,10 @@ windowed_comparison_plot <- function(results, ...){ set_palette_helper(results) - trial_scatter_plot(group_data = results$get_value('scatter_bar_data')) + trial_scatter_plot( + group_data = results$get_value('scatter_bar_data'), + show_outliers = results$get_value('show_outliers_on_plots') + ) } #' @title Basic Time Frequency Plot @@ -78,6 +94,21 @@ heat_map_plot <- function(results, ...){ ) } + +by_electrode_heat_map <- function(results) { + has_data <- results$get_value('has_data', FALSE) + validate(need(has_data, message="No Condition Specified")) + + set_palette_helper(results) + + by_electrode_heat_map_data <- results$get_value('by_electrode_heat_map_data') + + draw_many_heat_maps(by_electrode_heat_map_data, + max_zlim = results$get_value('max_zlim'), log_scale=FALSE, + PANEL.LAST=by_electrode_heat_map_decorator(results=results)) + +} + # the only difference between this plot and the time x freq heat_map_plot # is the data and the decoration. Use the core heatmap function # to enforce consistent look/feel diff --git a/R/rave_calculators.R b/R/rave_calculators.R index b4f95c9..bc9917b 100644 --- a/R/rave_calculators.R +++ b/R/rave_calculators.R @@ -358,7 +358,6 @@ get_favored_collapsers <- function(swap_var = 'collapse_using_median') { } .fast_se <- function(x) { - C_cov <- get_from_package('C_cov', 'stats', internal = TRUE, check = FALSE) sqrt(.Call(C_cov, x, NULL, 4, FALSE)/length(x)) diff --git a/inst/modules/group_analysis_lme/common.R b/inst/modules/group_analysis_lme/common.R index f2d304e..60bab52 100644 --- a/inst/modules/group_analysis_lme/common.R +++ b/inst/modules/group_analysis_lme/common.R @@ -314,9 +314,6 @@ build_var <- function(nm) { build_val <- function(nm) return ( function() {textInput(ns(nm), 'Val')}) - - - # build the filters using assign just so it's more compact if we end up wanting to have >2 filters f1var_ui <- build_var('f1var_ui') f2var_ui <- build_var('f2var_ui') @@ -325,8 +322,6 @@ f2op_ui <- build_op('f2op_ui') f1val_ui <- build_val('f1val_ui') f2val_ui <- build_val('f2val_ui') - - # sapply(1:10, function(ii) { # for(v in c('var', 'op', 'val')) { # nm <- sprintf('f%s%s_ui', ii, v) diff --git a/inst/modules/power_explorer/comp.R b/inst/modules/power_explorer/comp.R index 5c733fc..92359b5 100644 --- a/inst/modules/power_explorer/comp.R +++ b/inst/modules/power_explorer/comp.R @@ -8,7 +8,6 @@ env = dev_ravebuiltins(T) ## Load subject for debugging env$mount_demo_subject() - # >>>>>>>>>>>> Start ------------- [DO NOT EDIT THIS LINE] --------------------- @@ -37,6 +36,19 @@ define_initialization({ time_points = preload_info$time_points electrodes = preload_info$electrodes epoch_data = module_tools$get_meta('trials') + electrodes_csv = module_tools$get_meta('electrodes') + elec_labels <- unique(electrodes_csv$Label) + + # figure out if there are any outliers to prepopulate the outlier list + outlier_list <- character(0) + efile <- sprintf('%s/power_outliers_%s.csv', subject$dirs$meta_dir, preload_info$epoch_name) + if(file.exists(efile)) { + outlier_data <- read.csv(efile) + if(any(outlier_data$PowerOutlier)) { + outlier_list = epoch_data$Trial[outlier_data$PowerOutlier] + } + } + }) @@ -48,9 +60,9 @@ define_input( definition = customizedUI(inputId = 'input_customized') ) -# define_input_multiple_electrodes(inputId = 'ELECTRODE_TEXT') -define_input_single_electrode(inputId = 'ELECTRODE') -define_input_frequency(inputId = 'FREQUENCY') +define_input_multiple_electrodes(inputId = 'ELECTRODE_TEXT') +# define_input_single_electrode(inputId = 'ELECTRODE') +define_input_frequency(inputId = 'FREQUENCY', initial_value = c(70,150)) define_input_time(inputId = 'ANALYSIS_WINDOW', label='Analysis', initial_value = c(0,1)) define_input_time(inputId = 'BASELINE_WINDOW', label='Baseline', initial_value = c(-1,0)) define_input_condition_groups(inputId = 'GROUPS') @@ -65,26 +77,31 @@ define_input( definition = selectInput('trial_outliers_list', 'Trials to Exclude', choices = NULL, selected = NULL, multiple = TRUE), - init_args = 'choices', + init_args = c('choices', 'selected'), init_expr = { choices = c(epoch_data$Trial) + selected = outlier_list } ) define_input( - definition = actionButton('clear_outliers', 'Trials to Exclude', icon = icon('trash')) + definition = actionButton('clear_outliers', 'Clear Outliers', icon = icon('trash')) ) + define_input( - definition = actionButton('save_new_epoch_file', 'Save Epoch File', icon =icon('file-export')) + definition = actionButton('save_new_epoch_file', + label=HTML("Save Outliers"), + icon =icon('file-export')), + init_args = 'label', + init_expr = { + label = "Save Outliers" + } ) define_input( - definition = selectInput('show_outliers_on_plots', 'Show outliers on plots', - choices=c('Yes', 'No'), selected = 'Yes') + definition = checkboxInput('show_outliers_on_plots', 'Show outliers on plots', value = TRUE) ) - - define_input( definition = numericInput('max_zlim', 'Heatmap Max (0 means data range)', value = 0, min = 0, step = 1) ) @@ -126,6 +143,77 @@ define_input( definition = checkboxInput('draw_decorator_labels', "Label Plot Decorations", value=TRUE) ) + +# +# Analysis Export options +# +{ + define_input( + definition = textInput('analysis_prefix', value = 'power_by_condition', + label = 'Analysis Prefix (no spaces, should match across subjects)') + ) + define_input( + definition = checkboxInput('analysis_mask_export',value = FALSE, + label = 'Export Electrode Mask') + ) + + define_input( + definition = selectInput('analysis_filter_variable', label='Electrode Filter', choices=NULL, selected=NULL) + , init_args = c('choices', 'selected'), + init_expr = { + choices = names(electrodes_csv) + selected = 'Label' + } + ) + + define_input( + definition = selectInput('analysis_filter_elec', label = 'Electrodes to include', + choices=NULL, selected = NULL, multiple = TRUE + ), + init_args = c('choices', 'selected'), + init_expr = { + choices = unique(elec_labels) + selected = unique(elec_labels) + } + ) + + # export based on stats + define_input( + definition = selectInput('analysis_filter_1', label = 'Statistic', + choices=c('none', 'b', 't|F', 'p', 'FDR(p)', 'Bonf(p)'), selected = 'FDR(p)', multiple = FALSE) + ) + define_input( + definition = selectInput('analysis_filter_operator_1', label = '', + choices=c('<', '>', '<=', '>='), selected = '<', multiple = FALSE + ) + ) + define_input( + definition = textInput('analysis_filter_operand_1', label = '', placeholder='e.g., 0.05') + ) + + # stat filter #2 + define_input( + definition = selectInput('analysis_filter_2', label = '', + choices=c('none', 'b', 't|F', 'p', 'FDR(p)', 'Bonf(p)'), selected = 'none', multiple = FALSE) + ) + define_input( + definition = selectInput('analysis_filter_operator_2', label = ' ', + choices=c('<', '>', '<=', '>='), selected = '>', multiple = FALSE) + ) + define_input( + definition = textInput('analysis_filter_operand_2', label = ' ', placeholder='0') + ) + + define_input( + definition = actionButtonStyled('export_data', label='Export Data', icon=shiny::icon('download'), + type = 'primary', width = '50%', style='margin-left: 25%; margin-right:25%') + ) + +} + + +### COLOR PALETTE +{ # define_input( # definition = selectInput(inputId = 'color_palette', label='Color palette', multiple=FALSE, # choices = list('Matlab'=get_palette(get_palette_names = TRUE), @@ -147,9 +235,7 @@ define_input( # selected = cache_input('heatmap_color_palette', val = get_heatmap_palette(get_palette_names = TRUE)[1]) # } # ) - - - + define_input( definition = selectInput(inputId = 'color_palette', label='Color palette', multiple=FALSE, choice=get_palette(get_palette_names = TRUE), @@ -164,7 +250,7 @@ define_input( define_input( definition = selectInput(inputId = 'background_plot_color_hint', label = 'Background color', multiple=FALSE, - choices = c('White', 'Black', 'Gray')) + choices = c('White', 'Black', 'Gray'), selected = 'White') ) define_input( @@ -179,11 +265,29 @@ define_input( definition = customizedUI('graph_export') ) +} + +# +# deterime which varibles only need to trigger a render, not an exectute +render_inputs <- c( + 'sort_trials_by_type', 'draw_decorator_labels', 'PLOT_TITLE', 'plots_to_export', 'show_outliers_on_plots', 'background_plot_color_hint', + 'invert_colors_in_palette', 'reverse_colors_in_palette', 'color_palette', 'max_zlim' +) + +# +# determine which variables only need to be set, not triggering rendering nor executing +manual_inputs <- c( + 'graph_export', 'export_what', 'analysis_filter_variable', 'analysis_filter_elec', + 'analysis_filter_1', 'analysis_filter_2', 'analysis_filter_operator_1', 'analysis_filter_operator_2', + 'analysis_filter_operand_1', 'analysis_filter_operand_2', + 'analysis_prefix', 'analysis_mask_export', 'export_data' +) + # Define layouts if exists input_layout = list( '[#cccccc]Electrodes' = list( - c('ELECTRODE'), + c('ELECTRODE_TEXT'), c('combine_method')#, #c('reference_type', 'reference_group') ), @@ -207,9 +311,9 @@ input_layout = list( c('log_scale', 'sort_trials_by_type', 'collapse_using_median') ), '[-]Trial Outliers' = list( - 'trial_outliers_list', 'show_outliers_on_plots', - c('clear_outliers', 'save_new_epoch_file') + 'trial_outliers_list', + 'clear_outliers', 'save_new_epoch_file' ), #[#aaaaaa] '[-]Export Plots' = list( @@ -218,6 +322,12 @@ input_layout = list( c('graph_export') ), '[-]Export Data/Results' = list( + 'analysis_prefix', + 'analysis_mask_export', + 'analysis_filter_variable', 'analysis_filter_elec', + c('analysis_filter_1', 'analysis_filter_operator_1', 'analysis_filter_operand_1'), + c('analysis_filter_2', 'analysis_filter_operator_2', 'analysis_filter_operand_2'), + 'export_data' ) ) @@ -226,36 +336,46 @@ input_layout = list( # Define Outputs define_output( definition = plotOutput(outputId = 'heat_map_plot'), - title = 'Heat Map (Collapse trial)', + title = 'Activity over time by frequency', width = 12, order = 1 ) define_output( - definition = plotOutput('by_trial_heat_map', click = shiny::NS('power_explorer')('by_trial_heat_map_click')), - title = 'Activity over time by trial (Collapse freq)', + definition = plotOutput('by_trial_heat_map'), + # click = clickOpts(shiny::NS('power_explorer')('by_trial_heat_map_click'), clip = FALSE)), + title = 'Activity over time by trial', width = 12, order = 2 ) +define_output( + definition = plotOutput('by_electrode_heat_map'), + title = 'Activity over time by electrode', + width = 12, + order = 2.5 +) + define_output( definition = plotOutput('over_time_plot'), - title = 'Collapse freq+trial', - width = 8, + title = 'Activty over time by condition', + width = 7, order = 3 ) define_output( - definition = plotOutput(outputId = 'windowed_comparison_plot'), - title = 'Collapse freq+time', - width = 4, + definition = plotOutput('windowed_comparison_plot', + click = clickOpts(shiny::NS('power_explorer')('windowed_by_trial_click'), clip = FALSE), + dblclick = clickOpts(shiny::NS('power_explorer')('windowed_by_trial_dbl_click'), clip = FALSE)), + title = 'Activity by trial and condition', + width = 3, order = 4 ) define_output( definition = customizedUI('click_output'), - title = 'Click Information', - width=12, order=2.5 + title = 'Last Click', + width=2, order=4.1 ) @@ -265,19 +385,13 @@ define_output( # width = 12, # order = 5 # ) - +# define_output_3d_viewer( outputId = 'power_3d', - title = '3D Viewer for Power', - surfaces = 'pial', - multiple_subject = F, + message = 'Click here to reload viewer', + title = 'Statistical results by electrode', height = '70vh', - order = 1e3, - width = 12, - additional_ui = tagList( - selectInput(ns('viewer_3d_type'), 'Which statistics', choices = c('b', 't', 'p'))#, - #p(ns('blah')) - ) + order = 1e4 ) diff --git a/inst/modules/power_explorer/event_handlers.R b/inst/modules/power_explorer/event_handlers.R index ac664a1..79ddd7e 100644 --- a/inst/modules/power_explorer/event_handlers.R +++ b/inst/modules/power_explorer/event_handlers.R @@ -1,57 +1,163 @@ -observeEvent(input$power_3d__mouse_event, { - mouse_event = input$power_3d__mouse_event$event - object = input$power_3d__mouse_event$object - - print(input$power_3d__mouse_event) - - # This is dirty, i think we can provide function to get which electrode chosen - if(mouse_event$action == 'dblclick' && isTRUE( object$is_electrode )){ - # Get object chosen, is it an electrode? - # Use isTRUE() to validate since object$is_electrode could be NULL - e = stringr::str_match(object$name, '^Electrode ([0-9]+)')[2] - e = as.integer(e) + +observeEvent(input$power_3d_mouse_dblclicked, { + # mouse_event = input$power_3d__mouse_dblclicked$event + # object = input$power_3d__mouse_dblclicked$object + + .data <- input$power_3d_mouse_dblclicked + + print(input$power_3d_mouse_dblclicked) + + if(isTRUE(.data$is_electrode)) { + e <- .data$electrode_number if(e %in% preload_info$electrodes){ - updateTextInput(session, 'ELECTRODE', value = e) + updateTextInput(session, 'ELECTRODE_TEXT', value = e) showNotification(p('Switched to electrode ', e), type = 'message', id = ns('power_3d_widget__mouse')) }else{ showNotification(p('Electrode ', e, ' is not loaded.'), type = 'warning', id = ns('power_3d_widget__mouse')) } } + + # # This is dirty, i think we can provide function to get which electrode chosen + # if(mouse_event$action == 'dblclick' && isTRUE( object$is_electrode )){ + # # Get object chosen, is it an electrode? + # # Use isTRUE() to validate since object$is_electrode could be NULL + # e = stringr::str_match(object$name, '^Electrode ([0-9]+)')[2] + # e = as.character(e) + # if(e %in% preload_info$electrodes){ + # updateTextInput(session, 'ELECTRODE_TEXT', value = e) + # showNotification(p('Switched to electrode ', e), type = 'message', id = ns('power_3d_widget__mouse')) + # }else{ + # showNotification(p('Electrode ', e, ' is not loaded.'), type = 'warning', id = ns('power_3d_widget__mouse')) + # } + # } +}) + +observeEvent(input$trial_outliers_list, { + enable_save_button() }) +observeEvent(input$analysis_filter_variable, { + electrodes_csv %?<-% NULL + + if(is.data.frame(electrodes_csv)) { + col_name <- input$analysis_filter_variable + + updateSelectInput(session, 'analysis_filter_elec', + selected=unique(electrodes_csv[[col_name]]), + choices = unique(electrodes_csv[[col_name]])) + } + +}) + + +observeEvent(input$clear_outliers, { + updateSelectInput(session, 'trial_outliers_list', selected=character(0)) + enable_save_button() +}) + +# save the outlier information to the current epoch file +observeEvent(input$save_new_epoch_file, { + showNotification(p('Saving outlier data to epoch file: ', preload_info$epoch_name), type = 'message', id = ns('snef')) + + efile <- sprintf('%s/power_outliers_%s.csv', subject$dirs$meta_dir, preload_info$epoch_name) + + epoch_data <- module_tools$get_meta('trials') + epoch_data$PowerOutlier <- FALSE + epoch_data$PowerOutlier[epoch_data$Trial %in% trial_outliers_list] <- TRUE + + write.csv(epoch_data, file=efile, row.names = FALSE) + + disable_save_button() +}) + +enable_save_button <- function() { + # Check if current options match the original trial outlier list + updateActionButton(session, 'save_new_epoch_file', label=HTML("Save Outliers")) +} + +disable_save_button <- function() { + updateActionButton(session, 'save_new_epoch_file', label=HTML("Save Outliers")) +} + + input = getDefaultReactiveInput() output = getDefaultReactiveOutput() session = getDefaultReactiveDomain() local_data = reactiveValues( - click_location = NULL + instruction_string = "Click on Activity by trial and condition plot for details." %&% + "", + by_trial_heat_map_click_location = NULL, + windowed_by_trial_click_location = NULL, + click_info = NULL ) -# by_trial_heat_map_click <- function() { -# print('click') -# } -observeEvent(input$by_trial_heat_map_click, { - local_data$click_location = input$by_trial_heat_map_click +update_click_information <- function() { + .loc <- local_data$windowed_by_trial_click_location + + # first we determine which group is being clicked, then we drill down + # to determine the nearest point -- this should be faster than just looking + # through all the points across all the groups, n'est-ce pas? + .gi <- which.min(abs(.loc$x - sapply(scatter_bar_data, `[[`, 'xp'))) + + # scaling the x-component distance as that should be the more discriminable of the two components? + wX <- 10 + #TODO consider a minimum closeness value here? + .ind <- which.min(abs(wX*(scatter_bar_data[[.gi]]$x - .loc$x)) + + abs(scatter_bar_data[[.gi]]$data - .loc$y)) + + .trial <- scatter_bar_data[[.gi]]$Trial_num[.ind] + .val <- round(scatter_bar_data[[.gi]]$data[.ind], + digits = abs(min(0, -1+floor(log10(max(abs(scatter_bar_data[[.gi]]$data))))))) + + .type <- scatter_bar_data[[.gi]]$trials[.ind] + + + local_data$click_info <- list('trial' = .trial, 'value' = .val, 'trial_type' = .type) +} + +update_trial_outlier_list <- function() { + last_click <- local_data$click_info + + if(!is.null(last_click)) { + .tol <- input$trial_outliers_list + if(any(last_click$trial == .tol)) { + .tol <- .tol[.tol != last_click$trial] + } else { + .tol <- c(.tol, last_click$trial) + } + + updateSelectInput(session, 'trial_outliers_list', selected = .tol) + } +} + +observeEvent(input$windowed_by_trial_click, { + local_data$windowed_by_trial_click_location = input$windowed_by_trial_click + update_click_information() }) -output$trial_heatmap_click <- renderUI({ - loc <- local_data$click_location +observeEvent(input$windowed_by_trial_dbl_click, { + local_data$windowed_by_trial_click_location = input$windowed_by_trial_dbl_click + update_click_information() + update_trial_outlier_list() +}) - print(loc) - - HTML( - 'Clicked: ' %&% loc$x %&% ', ' %&% loc$y +output$trial_click <- renderUI({ + .click <- local_data$click_info + + HTML("
Nearest Trial: " %&% .click$trial %&% '
Value: ' %&% .click$value %&% + '
Trial Type: ' %&% .click$trial_type %&% + "

—
" %&% local_data$instruction_string %&% '

' ) }) click_output = function() { - logger('click out...') - # put analysis information in here - if(!is.null(local_data$click_location)) { - return(htmlOutput(ns('trial_heatmap_click'))) + if(!is.null(local_data$windowed_by_trial_click_location)) { + return(htmlOutput(ns('trial_click'))) } - return('no trials clicked yet') + + return(HTML("

" %&% local_data$instruction_string %&% '

')) } diff --git a/inst/modules/power_explorer/exports.R b/inst/modules/power_explorer/exports.R index 2ec19b3..2338da3 100644 --- a/inst/modules/power_explorer/exports.R +++ b/inst/modules/power_explorer/exports.R @@ -3,14 +3,14 @@ output = getDefaultReactiveOutput() power_3d_fun = function(brain){ showNotification(p('Generating 3d viewer...')) - + + # brain = rave::rave_brain2(subject = subject); + # brain$load_surfaces(subject = subject, surfaces = c('pial', 'white', 'smoothwm')) + dat = rave::cache(key = list( list(BASELINE_WINDOW, preload_info) ), val = get_summary()) - - - # for each electrode, we want to test the different conditions .FUN <- if(length(levels(dat$condition)) > 1) { @@ -30,16 +30,36 @@ power_3d_fun = function(brain){ get_t(x$power) %>% set_names(c('b', 't', 'p')) } } + + # names(dat) = c('Subject', 'Electrode', 'trial', + # 'condition', 'power') - values = sapply(unique(dat$elec), function(e){ + values = lapply(unique(dat$elec), function(e){ sub = dat[dat$elec == e, ] re = .FUN(sub) - v = re[input$viewer_3d_type] - brain$set_electrode_value(subject, e, v) - return(v) - }) - - brain$view(value_range = c(-1,1) * max(abs(values))) + # v = re[input$viewer_3d_type] + # brain$set_electrode_value(subject, e, v) + return(re) + }) %>% rbind_list + + values = as.data.frame(values) + values$Subject = as.factor(subject$subject_code) + values$Electrode = unique(dat$elec) + + + # b t p Subject Electrode Time + # 1 120.36184 13.83425 7.733204e-22 sub_large 14 0 + # 2 45.21445 8.11932 1.004675e-11 sub_large 15 0 + + brain$set_electrode_values(values) + + brain$plot(symmetric = 0, palettes = list( + b = rave_heat_map_colors, + p = c('red', 'red', 'grey') + ), side_shift = c(-265, 0)) + + # brain$view(value_range = c(-1,1) * max(abs(values)), + # color_ramp = rave_heat_map_colors, side_shift = c(-265, 0)) } # Export functions @@ -97,7 +117,7 @@ get_summary <- function() { } export_stats = function(conn=NA, lbl='stat_out', dir, ...){ - out_dir <- dir #module_tools$get_subject_dirs()$module_data_dir %&% '/condition_explorer/' + out_dir <- dir #module_tools$get_subject_dirs()$module_data_dir %&% '/power_explorer/' if(!dir.exists(out_dir)) { dir.create(out_dir, recursive = TRUE) @@ -131,13 +151,12 @@ graph_export = function(){ # export_graphs(conn = '~/Desktop/hmp_e.pdf') # }) - output$btn_graph_download <- downloadHandler( filename = function(...) { paste0('power_explorer_export', format(Sys.time(), "%b_%d_%Y_%H_%M_%S"), '.zip') }, - content = function(conn){ + content = function(conn) { tmp_dir = tempdir() # map the human names to the function names @@ -153,10 +172,12 @@ output$btn_graph_download <- downloadHandler( tmp_files <- prefix %&% str_replace_all(names(fnames), ' ', '_') %&% '.pdf' - mapply(export_graphs, file.path(tmp_dir, tmp_files), fnames) + # to speed this up, we'll open all the files and write an electrodes contents into each, then iterate + # mapply( + export_graphs(conns=file.path(tmp_dir, tmp_files), plot_functions=fnames) wd = getwd() - on.exit({setwd(wd)}) + on.exit({setwd(wd)}, add = TRUE) setwd(tmp_dir) @@ -164,50 +185,49 @@ output$btn_graph_download <- downloadHandler( } ) -export_graphs <- function(conn=NA, - which_plot=c('heat_map_plot','by_trial_heat_map','over_time_plot', 'windowed_comparison_plot'), ...) { +export_graphs <- function(conns=NA, plot_functions, ...) { - which_plot <- match.arg(which_plot) + # which_plot <- match.arg(which_plot) args = isolate(reactiveValuesToList(input)) electrodes_loaded = preload_info$electrodes - # check to see if we should loop over all electrodes or just the current electrode + # check to see if we should loop over all electrodes or just the currently selected electrode(s) if(export_what == 'Current Selection') { - electrodes_loaded <- ELECTRODE + electrodes_loaded <- requested_electrodes } - progress = rave::progress('Rendering graphs for: ' %&% str_replace_all(which_plot, '_', ' '), - max = length(electrodes_loaded) + 1) + progress = rave::progress('Rendering graphs...', + max = length(electrodes_loaded) + 2) on.exit({progress$close()}, add=TRUE) progress$inc(message = 'Initializing') - .export_graph = function(){ module = rave::get_module('ravebuiltins', 'power_explorer', local = TRUE) - formal_names = names(formals(module)) + # args = sapply(formal_names, get) args = args[formal_names] names(args) = formal_names - - # having issues here with the size of the plots being too large for the font sizes - # we can't (easily) change the cex being used by the plots. So maybe we can - # just change the size of the output PDF. people can the resize - - # based on the number of groups we should scale the plots - ngroups = 0 - for(ii in seq_along(args$GROUPS)) { - if(length(args$GROUPS[[ii]]$group_conditions)>1) { - ngroups = ngroups+1 - } + + # so we want to open all the PDFs initially + # based on the number of groups we should scale the plots + ngroups = 0 + for(ii in seq_along(args$GROUPS)) { + if(length(args$GROUPS[[ii]]$group_conditions)>1) { + ngroups = ngroups+1 } - + } + # having issues here with the size of the plots being too large for the font sizes + # we can't (easily) change the cex being used by the plots. So maybe we can + # just change the size of the output PDF. people can then resize but keep the relative sizes correct + #TODO get the names of the open devices, iterate only on the newly opened graphcsi devices + fin = mapply(function(conn, pf) { w_scale = h_scale = 1 - if(which_plot == 'windowed_comparison_plot') { + if(pf == 'windowed_comparison_plot') { w_scale = ngroups / 2.25 } - if(which_plot %in% c('by_trial_heat_map', 'heat_map_plot')) { + if(pf %in% c('by_trial_heat_map', 'heat_map_plot')) { w_scale = ngroups*1.25 h_scale = ngroups*1.05 } @@ -216,24 +236,45 @@ export_graphs <- function(conn=NA, .h <- round(6.03*h_scale,1) pdf(conn, width = .w, height = .h, useDingbats = FALSE) + }, conns, plot_functions) + + + on.exit({ + replicate(length(conns), dev.off()) + }, add = TRUE) + + plot_for_el <- function(etext) { - on.exit(dev.off()) + if(length(etext) > 1) { + etext %<>% deparse_svec + } - for(e in electrodes_loaded){ - progress$inc(message = sprintf('Electrode %s', e)) - args[['ELECTRODE']] = e - result = do.call(module, args) - result[[which_plot]]() + progress$inc(message = sprintf('Rendering graphs for %s', etext)) + args[['ELECTRODE_TEXT']] = etext + result = do.call(module, args) + for(g in plot_functions) { + dev.set() + result[[g]]() } } - .export_graph() - - # showNotification(p('Export graph finished.')) + # first write into the graphs the aggregate functions + plot_for_el(electrodes_loaded) - #TODO check the variable export_per_electrode to see if we need to loop over electrodes and export - # or if we want use just the current_electrodes and combine them - - #TODO need to scale all the fonts etc so things aren't too large for export + # now for the individual electrodes + lapply(electrodes_loaded, plot_for_el) + # progress$close() + showNotification(p('Exports finished!')) + } + + + + + +# Export data options + + + + diff --git a/inst/modules/power_explorer/main.R b/inst/modules/power_explorer/main.R index 3e21b56..aba11c2 100644 --- a/inst/modules/power_explorer/main.R +++ b/inst/modules/power_explorer/main.R @@ -2,24 +2,31 @@ # Initialize inputs # rm(list = ls(all.names=T)); rstudioapi::restartSession() +require(ravebuiltins) ravebuiltins:::dev_ravebuiltins(T) -mount_demo_subject() - +mount_demo_subject(force_reload_subject = T) init_module(module_id = 'power_explorer', debug = TRUE) - +# attachDefaultDataRepository() if(FALSE) { GROUPS = list(list(group_name='A', group_conditions=c('known_a', 'last_a', 'drive_a', 'meant_a')), list(group_name='B', group_conditions=c('known_v', 'last_v', 'drive_v', 'meant_v'))) + FREQUENCY = c(75,150) + ELECTRODE_TEXT = '14-15' } # >>>>>>>>>>>> Start ------------- [DO NOT EDIT THIS LINE] --------------------- -# requested_electrodes = rutabaga::parse_svec(ELECTRODE_TEXT, sep = ':-') -# requested_electrodes %<>% get_by(`%in%`, electrodes) +# +# cache <- function(key,val, ...) { +# return (val) +# } + +requested_electrodes = rutabaga::parse_svec(ELECTRODE_TEXT, sep=',|;', connect = ':-') +requested_electrodes %<>% get_by(`%in%`, electrodes) # this will be NA if the only requested electrodes are not available # electrode <- requested_electrodes[1] -# assertthat::assert_that(length(requested_electrodes) >= 1 && - # all(not_NA(requested_electrodes)), msg = 'No electrode selected') +assertthat::assert_that(length(requested_electrodes) >= 1 && + all(not_NA(requested_electrodes)), msg = 'No electrode selected') # grab the subject code so it can be used later subject_code = subject$subject_code @@ -36,22 +43,35 @@ group_data = lapply(seq_along(GROUPS), function(idx) { has_trials = length(Trial_num) > 0, conditions = unlist(g$group_conditions) ) - }) has_trials <- vapply(group_data, function(g){g$has_trials}, FALSE) any_trials <- any(has_trials) +# for performance -- check if the previous baseline exists in the cache. If so, +# grab it, if not, then recaclulate, but remove the previous one to save on space +# Could put another value in the cache -- last_baseline_key or something, so we +# can check that directly +# cache('hi', val={Sys.sleep(2); 4}, replace=F) +# getDefaultCacheEnvironment()[[digest::digest('hi')]] + # Subset data bl_power <- cache( - key = list(subject$id, ELECTRODE, BASELINE_WINDOW, preload_info$time_points, combine_method, + key = list(subject$id, requested_electrodes, BASELINE_WINDOW, + preload_info$time_points, combine_method, any_trials, preload_info$epoch_name, preload_info$reference_name), - val = baseline(power$subset(Electrode = Electrode == ELECTRODE), + val = baseline(power$subset(Electrode = Electrode %in% requested_electrodes), from=BASELINE_WINDOW[1], to= BASELINE_WINDOW[2], hybrid = FALSE, mem_optimize = FALSE) ) +jitter_seed <- cache( + key = 'jitter_seed', + val = sample(1:100, 1) +) + # Prepare plot datasets -scatter_bar_data <- line_plot_data <- by_trial_heat_map_data <- heat_map_data <- group_data +scatter_bar_data <- line_plot_data <- by_electrode_heat_map_data <- + by_trial_heat_map_data <- heat_map_data <- group_data flat_data <- data.frame() # set transform method @@ -60,11 +80,10 @@ flat_data <- data.frame() # for transforms, the idea is to apply at each trial for each frequency # then when things get it will already be done - #relies on .transform as defined above if(combine_method != 'none') { transformed_power <- cache( - key = list(combine_method, subject$id, ELECTRODE, BASELINE_WINDOW, preload_info$time_points, + key = list(combine_method, subject$id, ELECTRODE_TEXT, BASELINE_WINDOW, preload_info$time_points, any_trials, preload_info$epoch_name, preload_info$reference_name), val = { @@ -85,41 +104,51 @@ if(combine_method != 'none') { bl_power$set_data(transformed_power) } - # Collapse data ## Leave it here in case you want to change it later # (make it user specific) collapse_method = 'mean' -# This module is no longer across electrodes, so if we are transforming, # we likely want to do it at the trial level, not on the back end before combining across electrodes + +# to help with caching, we need to only recalculate here if the GROUPs have changed. +# get_data_for_condition <- function(ii) { +# +# } + for(ii in which(has_trials)){ - .power_all = bl_power$subset(Trial = Trial %in% group_data[[ii]]$Trial_num, data_only = FALSE, drop=FALSE) - .power_freq = .power_all$subset(Frequency=Frequency %within% FREQUENCY, data_only = FALSE, drop=FALSE) +.time_stamp <- proc.time() + ### 17ms + .power_all = bl_power$subset(Trial = Trial %in% group_data[[ii]]$Trial_num) + .power_all_clean <- .power_all$subset(Trial=! (Trial %in% trial_outliers_list)) + .power_freq = .power_all$subset(Frequency=Frequency %within% FREQUENCY) + .power_freq_clean = .power_freq$subset(Trial=! (Trial %in% trial_outliers_list)) N = dim(.power_all)[1L] + Nclean <- dim(.power_all_clean)[1L] + trials <- epoch_data %>% subset((.)$Trial %in% group_data[[ii]]$Trial_num) %>% extract2('Condition') + tnums <- epoch_data %>% subset((.)$Trial %in% group_data[[ii]]$Trial_num) %>% extract2('Trial') - - trials = epoch_data %>% subset((.)$Trial %in% group_data[[ii]]$Trial_num) %>% extract2('Condition') - - # utils functions + # This copies over some information from group_data that is needed by particular plots + # as well as populating data/range wrap_data = function(value){ list( data = value, range = .fast_range(value), N = N, trials = trials, - name = group_data[[ii]]$group_name - ) + Trial_num = group_data[[ii]]$Trial_num, + is_clean = !(tnums %in% trial_outliers_list), + name = group_data[[ii]]$name, + has_trials = group_data[[ii]]$has_trials, + conditions = group_data[[ii]]$conditions + ) } # 1 Time x Frequency - .power_all_clean <- .power_all$subset(Trial=! (Trial %in% trial_outliers_list)) - Nclean <- dim(.power_all_clean)[1L] - heat_map_data[[ii]] <- append(heat_map_data[[ii]], - wrap_data(.power_all_clean$collapse(keep = c(3,2), method = collapse_method))) + heat_map_data[[ii]] <- wrap_data(.power_all_clean$collapse(keep = c(3,2), method = collapse_method)) attr(heat_map_data[[ii]]$data, 'xlab') <- 'Time (s)' attr(heat_map_data[[ii]]$data, 'ylab') <- 'Frequency' @@ -136,10 +165,8 @@ for(ii in which(has_trials)){ heat_map_data[[ii]]$N <- Nclean # 2 Time x Trial (.power_freq) - # by trial data. Set drop to FALSE b/c we want to keep the electrode dim even if #e ==1 - by_trial_heat_map_data[[ii]] <- append( by_trial_heat_map_data[[ii]], wrap_data( - .power_freq$collapse(keep = c(3,1), method = collapse_method) - )) + # by trial data. + by_trial_heat_map_data[[ii]] <- wrap_data(.power_freq$collapse(keep = c(3,1), method = collapse_method)) # the x value for the bthmd is time by_trial_heat_map_data[[ii]]$x <- .power_freq$dimnames$Time @@ -152,32 +179,71 @@ for(ii in which(has_trials)){ attr(by_trial_heat_map_data[[ii]]$data, 'zlab') <- ifelse(combine_method=='none', 'Mean % Signal Change', 'Mean ' %&% combine_method %&% ' %SC') + # 2.5 by electrode over time + by_electrode_heat_map_data[[ii]] <- wrap_data(.power_freq$collapse(keep = c(3,4), method = collapse_method)) + + # the x value for the bthmd is time + by_electrode_heat_map_data[[ii]]$x <- .power_freq$dimnames$Time + + #the y value for the bthmd is Trial + by_electrode_heat_map_data[[ii]]$y <- .power_freq$dimnames$Electrode + + attr(by_electrode_heat_map_data[[ii]]$data, 'xlab') <- 'Time (s)' + attr(by_electrode_heat_map_data[[ii]]$data, 'ylab') <- 'Electrode' + attr(by_electrode_heat_map_data[[ii]]$data, 'zlab') <- ifelse(combine_method=='none', 'Mean % Signal Change', + 'Mean ' %&% combine_method %&% ' %SC') + # 3 Time only # coll freq and trial for line plot w/ ebar. Because we're doing error bars, we have to know whether we have 1 vs. >1 electrodes # if(length(requested_electrodes) == 1){ # Single electrode, mean and mse for each time points - line_plot_data[[ii]] = append(line_plot_data[[ii]], wrap_data(t( - apply( - .power_freq$collapse(keep = c(1,3), method = 'mean'), - 2, .fast_mse) - ))) + line_plot_data[[ii]] = wrap_data(t( + apply(.power_freq_clean$collapse(keep = 3:4, method = 'mean'), 1, .fast_mse) + )) attr(line_plot_data[[ii]]$data, 'xlab') <- 'Time (s)' attr(line_plot_data[[ii]]$data, 'ylab') <- ifelse(combine_method=='none', 'Mean % Signal Change', 'Mean ' %&% combine_method %&% ' %SC') - # scatter bar data - scatter_bar_data[[ii]] = append(scatter_bar_data[[ii]], wrap_data( - rowMeans(.power_freq$subset( - Time = (Time %within% ANALYSIS_WINDOW), - data_only = TRUE - )) - )) + # N for the line plot is the number of electrodes + line_plot_data[[ii]]$N <- dim(.power_freq_clean)[4L] + + # scatter bar data -- here we want all of the data because we are going to highlight (or not) the outliers -- same for by-trial heatmap + # if(show_outliers_on_plots) { + scatter_bar_data[[ii]] <- wrap_data( + rowMeans(.power_freq$subset(Time = (Time %within% ANALYSIS_WINDOW),data_only = TRUE)) + ) + # } else { + # scatter_bar_data[[ii]] = append(scatter_bar_data[[ii]], wrap_data( + # rowMeans(.power_freq_clean$subset( + # Time = (Time %within% ANALYSIS_WINDOW), + # data_only = TRUE + # )) + # )) + # } + # the N should reflect only those clean points, as the (summary) stats are based on the clean data only + scatter_bar_data[[ii]]$N <- Nclean + + # Although this seems to be the wrong place to do this, not sure where else we can do it + # to enable point identification later, we need to know the x-location of each point. So the jittering + # needs to be done here. + .xp <- barplot(which(has_trials),plot=FALSE) + .r <- if(sum(has_trials)>1) { + mean(unique(diff(.xp)))*0.25 + } else { + 0.75*(1/3) + } + scatter_bar_data[[ii]]$xp <- .xp[ii] + set.seed(jitter_seed) + scatter_bar_data[[ii]]$x <- .xp[ii] + runif(length(scatter_bar_data[[ii]]$data), -.r, .r) attr(scatter_bar_data[[ii]]$data, 'xlab') <- 'Group' attr(scatter_bar_data[[ii]]$data, 'ylab') <- ifelse(combine_method=='none', 'Mean % Signal Change', 'Mean ' %&% combine_method %&% ' %SC') + line_plot_data[[ii]]$data[is.na(line_plot_data[[ii]]$data[,2]),2] <- 0 + + # we want to make a special range for the line plot data that takes into account mean +/- SE line_plot_data[[ii]]$range <- .fast_range(plus_minus(line_plot_data[[ii]]$data[,1], line_plot_data[[ii]]$data[,2])) @@ -185,10 +251,14 @@ for(ii in which(has_trials)){ # also add in the x variable for the time series line_plot_data[[ii]]$x <- .power_freq$dimnames$Time - # for the scatter_bar_data we also need to get m_se within condition - scatter_bar_data[[ii]]$mse <- .fast_mse(scatter_bar_data[[ii]]$data) + # for the scatter_bar_data we also need to get m_se within condition w/o the outliers + scatter_bar_data[[ii]]$mse <- .fast_mse(scatter_bar_data[[ii]]$data[scatter_bar_data[[ii]]$is_clean]) - flat_data %<>% rbind(data.frame('group'=ii, 'y' = scatter_bar_data[[ii]]$data)) + flat_data %<>% rbind(data.frame('group'=ii, + 'y' = with(scatter_bar_data[[ii]], data[is_clean]))) + + print('loop ' %&% ii) + print(proc.time() - .time_stamp) } # .power_freq[,, preload_info$time_points %within% ANALYSIS_WINDOW, ]$data @@ -226,23 +296,27 @@ attr(scatter_bar_data, 'stats') <- result_for_suma # <<<<<<<<<<<< End ----------------- [DO NOT EDIT THIS LINE] ------------------- # Debug +# rm(list = ls(all.names=T)); rstudioapi::restartSession() require(ravebuiltins) - +ravebuiltins:::dev_ravebuiltins(T) +mount_demo_subject() module = ravebuiltins:::debug_module('power_explorer') -result = module(GROUPS = list(list(group_name='A', group_conditions=c('known_a', 'last_a', 'drive_a', 'meant_a')), - # putting in an empty group to test our coping mechanisms - list(group_name='YY', group_conditions=c()), - list(group_name='', group_conditions=c('known_v', 'last_v', 'drive_v', 'meant_v'))), - FREQUENCY = c(75,150), max_zlim = 0, +result = module(ELECTRODE_TEXT = '1-20', + # GROUPS = list(list(group_name='A', group_conditions=c('known_a', 'last_a', 'drive_a', 'meant_a')), + # # putting in an empty group to test our coping mechanisms + # list(group_name='YY', group_conditions=c()), + # list(group_name='ZZ', group_conditions=c('known_v', 'last_v', 'drive_v', 'meant_v'))), + background_plot_color_hint='white', BASELINE_WINDOW = c(-1,-.1), + FREQUENCY = c(75,150), max_zlim = 0, show_outliers_on_plots = TRUE, sort_trials_by_type = T, combine_method = 'none') results = result$results # attachDefaultDataRepository() +result$windowed_comparison_plot() result$heat_map_plot() result$by_trial_heat_map() result$over_time_plot() -result$windowed_comparison_plot() ravebuiltins::dev_ravebuiltins(expose_functions = TRUE) view_layout('power_explorer', sidebar_width = 3, launch.browser = T) @@ -265,5 +339,5 @@ res = module() # Step 4: launch modules in RAVE (production) # Cmd+Shift+B m = rave::detect_modules('ravebuiltins') -rave::init_app(m) +rave::start_rave() diff --git a/inst/modules/univariate_power_explorer/comp.R b/inst/modules/univariate_power_explorer/comp.R new file mode 100644 index 0000000..d082b56 --- /dev/null +++ b/inst/modules/univariate_power_explorer/comp.R @@ -0,0 +1,294 @@ +# File defining module inputs, outputs + +# ----------------------------------- Debug ------------------------------------ +require(ravebuiltins) + +env = dev_ravebuiltins(T) + +## Load subject for debugging +env$mount_demo_subject() + + +# >>>>>>>>>>>> Start ------------- [DO NOT EDIT THIS LINE] --------------------- + + +# ---------------------- Initializing Global variables ----------------------- +load_scripts( + 'inst/modules/power_explorer/exports.R', + 'inst/modules/power_explorer/event_handlers.R', + asis = TRUE +) + +define_initialization({ + ## + ## Make sure power (referenced) exists + ## with the following line, RAVE will pop up a dialogue if + ## power is not loaded and ask users to load data + ## + rave_checks('power referenced') + + ## + ## Get referenced power (Wavelet power) + ## + power = module_tools$get_power(referenced = TRUE) + + ## Shared variables + frequencies = preload_info$frequencies + time_points = preload_info$time_points + electrodes = preload_info$electrodes + epoch_data = module_tools$get_meta('trials') +}) + + +# --------------------------------- Inputs ----------------------------------- +# Define inputs + +# Select from multiple choices, +define_input( + definition = customizedUI(inputId = 'input_customized') +) + +# define_input_multiple_electrodes(inputId = 'ELECTRODE_TEXT') +define_input_single_electrode(inputId = 'ELECTRODE') +define_input_frequency(inputId = 'FREQUENCY') +define_input_time(inputId = 'ANALYSIS_WINDOW', label='Analysis', initial_value = c(0,1)) +define_input_time(inputId = 'BASELINE_WINDOW', label='Baseline', initial_value = c(-1,0)) +define_input_condition_groups(inputId = 'GROUPS') + +define_input( + definition = selectInput('combine_method', 'Electrode Transforms', + choices = c('none', 'amplitude', 'z-score', 'max-scale', '0-1 scale', 'rank'), + multiple = F, selected = 'none') +) + +define_input( + definition = selectInput('trial_outliers_list', 'Trials to Exclude', + choices = NULL, + selected = NULL, multiple = TRUE), + init_args = 'choices', + init_expr = { + choices = c(epoch_data$Trial) + } +) + +define_input( + definition = actionButton('clear_outliers', 'Trials to Exclude', icon = icon('trash')) +) +define_input( + definition = actionButton('save_new_epoch_file', 'Save Epoch File', icon =icon('file-export')) +) + +define_input( + definition = selectInput('show_outliers_on_plots', 'Show outliers on plots', + choices=c('Yes', 'No'), selected = 'Yes') +) + + + +define_input( + definition = numericInput('max_zlim', 'Heatmap Max (0 means data range)', value = 0, min = 0, step = 1) +) + +define_input( + definition = checkboxInput('log_scale', 'Log Freq (NI)') +) + +define_input( + definition = checkboxInput('sort_trials_by_type', 'Sort Trials') +) + +define_input( + definition = checkboxInput('collapse_using_median', 'Collapse w/ Median (NI)') +) + + +# let people decide how much information to include in the plots. It's up to the individual plot to actually make +# use of this information, probably through shared decorators +define_input( + definition = selectInput(inputId = 'PLOT_TITLE', label = 'Plot Decorations', multiple=TRUE, + choices =c('Subject ID', 'Electrode #', 'Condition', 'Frequency Range', 'Sample Size', 'Baseline Window', 'Analysis Window'), + selected=c('Subject ID', 'Electrode #', 'Condition', 'Frequency Range', 'Sample Size', 'Baseline Window', 'Analysis Window')) +) + +define_input( + definition = selectInput(inputId = 'plots_to_export', label='Plots to Export', multiple=TRUE, + choices = c('Spectrogram', 'By Trial Power', 'Over Time Plot', 'Windowed Average'), + selected = c('Spectrogram', 'By Trial Power', 'Over Time Plot', 'Windowed Average')) +) + +define_input( + definition = selectInput(inputId = 'export_what', + label='Which electrodes should be exported?', multiple=FALSE, + choices = c('All Loaded', 'Current Selection')) +) + +define_input( + definition = checkboxInput('draw_decorator_labels', "Label Plot Decorations", value=TRUE) +) + +# define_input( +# definition = selectInput(inputId = 'color_palette', label='Color palette', multiple=FALSE, +# choices = list('Matlab'=get_palette(get_palette_names = TRUE), +# 'RAVE'=c('redish', 'bluish'), +# 'RColorBrewer'=c('redish', 'bluish'),), +# selected = get_palette(get_palette_names = TRUE)[1]) +# ) + + + +# define_input( +# definition = selectInput(inputId = 'heatmap_color_palette', label='Heatmap Colors', multiple=FALSE, +# choice=get_heatmap_palette(get_palette_names = TRUE), +# selected = get_heatmap_palette(get_palette_names = TRUE)[1]), +# +# # cache the color palette across data reloads. needs init_args and init_expr +# init_args = c('selected'), +# init_expr = { +# selected = cache_input('heatmap_color_palette', val = get_heatmap_palette(get_palette_names = TRUE)[1]) +# } +# ) + + + +define_input( + definition = selectInput(inputId = 'color_palette', label='Color palette', multiple=FALSE, + choice=get_palette(get_palette_names = TRUE), + selected = get_palette(get_palette_names = TRUE)[1]), + + # cache the color palette across data reloads. needs init_args and init_expr + init_args = c('selected'), + init_expr = { + selected = cache_input('color_palette', val = get_palette(get_palette_names = TRUE)[1]) + } +) + +define_input( + definition = selectInput(inputId = 'background_plot_color_hint', label = 'Background color', multiple=FALSE, + choices = c('White', 'Black', 'Gray')) +) + +define_input( + definition = checkboxInput('invert_colors_in_palette', "Inverse Palette Colors", value=FALSE) +) + +define_input( + definition = checkboxInput('reverse_colors_in_palette', "Reverse Palette Order", value=FALSE) +) + +define_input( + definition = customizedUI('graph_export') +) + + +# Define layouts if exists +input_layout = list( + '[#cccccc]Electrodes' = list( + c('ELECTRODE'), + c('combine_method')#, + #c('reference_type', 'reference_group') + ), + #[#99ccff] + 'Trial Selector' = list( + 'GROUPS' + ), + 'Analysis Settings' = list( + 'FREQUENCY', + 'BASELINE_WINDOW', + 'ANALYSIS_WINDOW' + ), + '[-]Plot Options' = list( + c('PLOT_TITLE'), + 'draw_decorator_labels', + c('color_palette', 'background_plot_color_hint', + 'invert_colors_in_palette', 'reverse_colors_in_palette'), + c('max_zlim'), + # 'heatmap_color_palette', + #FIXME collapse_using_median should be in Analysis Settings??? + c('log_scale', 'sort_trials_by_type', 'collapse_using_median') + ), + '[-]Trial Outliers' = list( + 'trial_outliers_list', + 'show_outliers_on_plots', + c('clear_outliers', 'save_new_epoch_file') + ), + #[#aaaaaa] + '[-]Export Plots' = list( + c('plots_to_export'), + c('export_what'), + c('graph_export') + ), + '[-]Export Data/Results' = list( + ) +) + +# End of input +# ---------------------------------- Outputs ---------------------------------- +# Define Outputs +define_output( + definition = plotOutput(outputId = 'heat_map_plot'), + title = 'Heat Map (Collapse trial)', + width = 12, + order = 1 +) + +define_output( + definition = plotOutput('by_trial_heat_map'), + # click = clickOpts(shiny::NS('power_explorer')('by_trial_heat_map_click'), clip = FALSE)), + title = 'Activity over time by trial (Collapse freq)', + width = 12, + order = 2 +) + +define_output( + definition = plotOutput('over_time_plot'), + title = 'Collapse freq+trial', + width = 8, + order = 3 +) + +define_output( + definition = plotOutput('windowed_comparison_plot', + click = clickOpts(shiny::NS('power_explorer')('windowed_by_trial_click'), clip = FALSE)), + title = 'Collapse freq+time', + width = 4, + order = 4 +) + +define_output( + definition = customizedUI('click_output'), + title = 'Click Information', + width=12, order=2.5 +) + + +# define_output( +# definition = customizedUI('viewer_3d'), +# title = '3D Viewer', +# width = 12, +# order = 5 +# ) + +define_output_3d_viewer( + outputId = 'power_3d', + title = '3D Viewer for Power', + surfaces = 'pial', + multiple_subject = F, + height = '70vh', + order = 1e3, + width = 12, + additional_ui = tagList( + selectInput(ns('viewer_3d_type'), 'Which statistics', choices = c('b', 't', 'p'))#, + #p(ns('blah')) + ) +) + + +# <<<<<<<<<<<< End ----------------- [DO NOT EDIT THIS LINE] ------------------- + + + + +# -------------------------------- View layout --------------------------------- +quos = env$parse_components(module_id = 'power_explorer') + +view_layout('power_explorer', launch.browser = T, sidebar_width = 3) diff --git a/inst/modules/univariate_power_explorer/comp.Rmd b/inst/modules/univariate_power_explorer/comp.Rmd new file mode 100644 index 0000000..403cbb0 --- /dev/null +++ b/inst/modules/univariate_power_explorer/comp.Rmd @@ -0,0 +1,260 @@ +--- +title: "Module Input Output" +author: "Zhengjia Wang" +date: "2/7/2019" +output: html_document +runtime: shiny +--- + + + +```{r setup, include=FALSE, message=FALSE, echo=FALSE} +knitr::opts_chunk$set(echo = TRUE) +``` + + +```{r debug, message=FALSE, echo=FALSE, warning=FALSE} +junk = capture.output({..env = ravebuiltins::dev_ravebuiltins()}) +..env$cat2 = function(...){} +## Load subject for debugging +# ..env$mount_demo_subject() +..env$view_layout('power_explorer') +``` + + +This R Markdown document is made interactive using Shiny. Unlike the more traditional workflow of creating static reports, you can now create documents that allow your readers to change the assumptions underlying your analysis and see the results immediately. + +To learn more, see [Interactive Documents](http://rmarkdown.rstudio.com/authoring_shiny.html). + +## Inputs and Outputs + +You can embed Shiny inputs and outputs in your document. Outputs are automatically updated whenever inputs change. This demonstrates how a standard R plot can be made interactive by wrapping it in the Shiny `renderPlot` function. The `selectInput` and `sliderInput` functions create the input widgets used to drive the plot. + +```{r module_inputs, eval=FALSE} +# ---------------------- Initializing Global variables ----------------------- +load_scripts( + 'inst/modules/power_explorer/3d_viewer.R' +) + +define_initialization({ + ## + ## Make sure power (referenced) exists + ## with the following line, RAVE will pop up a dialogue if + ## power is not loaded and ask users to load data + ## + rave_checks('power referenced') + + ## + ## Get referenced power (Wavelet power) + ## + power = module_tools$get_power(referenced = TRUE) + + ## Shared variables + frequencies = preload_info$frequencies + time_points = preload_info$time_points + electrodes = preload_info$electrodes + epoch_data = module_tools$get_meta('trials') +}) + + + + +# --------------------------------- Inputs ----------------------------------- +# Define inputs + +# Select from multiple choices, +define_input( + definition = textInput('electrode_text', 'Electrodes', value = "", placeholder = '1-5,8,11-20'), + init_args = c('label', 'value'), + init_expr = { + last_input = cache_input('electrode_text', val = as.character(electrodes[1])) + e = rutabaga::parse_svec(last_input) + e = e[e %in% electrodes] + if(!length(e)){ + e = electrodes[1] + } + value = rutabaga::deparse_svec(e) + label = 'Electrodes (' %&% deparse_selections(electrodes) %&% ')' + } +) + +define_input( + definition = customizedUI(inputId = 'input_customized') +) + +define_input( + definition = sliderInput('FREQUENCY', 'Frequency', min = 1, max = 200, value = c(1,200), step = 1, round = 1), + init_args = c('min', 'max', 'value'), + init_expr = { + min = floor(min(frequencies)) + max = ceiling(max(frequencies)) + value = cache_input('FREQUENCY', c(min, max)) + } +) + +define_input( + definition = sliderInput('TIME_RANGE', 'Analysis', min = 0, max = 1, value = c(0,1), step = 0.01, round = -2), + init_args = c('min', 'max', 'value'), + init_expr = { + min = min(time_points) + max = max(time_points) + value = cache_input('TIME_RANGE', c(0, max(time_points))) + } +) + +define_input( + definition = sliderInput('BASELINE', 'Baseline', min = 0, max = 1, value = c(0,1), step = 0.01, round = -2), + init_args = c('min', 'max', 'value'), + init_expr = { + min = min(time_points) + max = max(time_points) + value = cache_input('BASELINE', c(min(time_points), 0)) + } +) + +define_input( + definition = selectInput('combine_method', 'Electrode Transforms', + choices = c('none', 'z-score', 'max-scale', '0-1 scale', 'rank'), + multiple = F, selected = 'none') +) + + +define_input( + definition = selectInput('reference_type', 'Transform Reference', + choices = c('Trial', 'Trial type', 'Active trial types', 'All trials'), + selected='Trial') +) + +define_input( + definition = selectInput('reference_group', 'Reference Group', + choices = c('Per Electrode', 'All Electrodes'), selected = 'Per Electrode') +) + +define_input( + definition = numericInput('max_zlim', 'Maximum Plot Value', value = 0, min = 0, step = 1) +) +define_input( + definition = checkboxInput('log_scale', 'Log Freq') +) +define_input( + definition = checkboxInput('sort_trials_by_type', 'Sort Trials') +) + + + +define_input( + definition = compoundInput( + inputId = 'GROUPS', prefix= 'Group', inital_ncomp = 1, components = { + textInput('GROUP_NAME', 'Name', value = '', placeholder = 'Name') + selectInput('GROUP', ' ', choices = '', multiple = TRUE) + }), + init_args = c('initialize', 'value'), + init_expr = { + trials = preload_info$condition + initialize = list( + GROUP = list( + choices = unique(trials) + ) + ) + value = cache_input('GROUPS', list( + list( + GROUP = list(trials), + GROUP_NAME = 'All Conditions' + ) + )) + } +) + + +# Define layouts if exists +input_layout = list( + '[#cccccc]Electrodes' = list( + c('electrode_text'), + c('combine_method'), + c('reference_type', 'reference_group') + ), + '[#99ccff]Trial Selector' = list( + 'GROUPS' + ), + 'Analysis Settings' = list( + 'FREQUENCY', + 'BASELINE', + 'TIME_RANGE' + ), + '[-][#33aaff]Export Options' = list(), + '[-]Plotting' = list( + c('log_scale', 'sort_trials_by_type', 'collapse_using_median'), + c('max_zlim') + ) +) + +``` + +```{r module outputs, eval=FALSE} +# Define Outputs +define_output( + definition = plotOutput(outputId = 'heat_map_plot'), + title = 'Heat Map (Collapse trial)', + width = 12, + order = 1 +) + +define_output( + definition = plotOutput('by_trial_heat_map'), + title = 'Activity over time by trial (Collapse freq)', + width = 12, + order = 2 +) + +define_output( + definition = plotOutput('over_time_plot'), + title = 'Collapse freq+trial', + width = 8, + order = 4 +) + +define_output( + definition = plotOutput(outputId = 'windowed_comparison_plot'), + title = 'Collapse time+freq', + width = 4, + order = 3 +) + +define_output( + definition = customizedUI('viewer_3d'), + title = '3D Viewer', + width = 12, + order = 5 +) + + +# output_layout = list( +# # 'Tabset One' = list( +# # 'Multiple Output' = 'heat_map_plot' +# # ) +# 'Multiple Output' = 'heat_map_plot' +# ) +``` + +## Embedded Application + +It's also possible to embed an entire Shiny application within an R Markdown document using the `shinyAppDir` function. This example embeds a Shiny application located in another directory: + + +Note the use of the `height` parameter to determine how much vertical space the embedded application should occupy. + +You can also use the `shinyApp` function to define an application inline rather then in an external directory. + +In all of R code chunks above the `echo = FALSE` attribute is used. This is to prevent the R code within the chunk from rendering in the document alongside the Shiny components. + + + diff --git a/inst/modules/univariate_power_explorer/comp.html b/inst/modules/univariate_power_explorer/comp.html new file mode 100644 index 0000000..a82473f --- /dev/null +++ b/inst/modules/univariate_power_explorer/comp.html @@ -0,0 +1,612 @@ + + + + + + + + + + + + + + +Module Input Output + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+ + + + + + + + + + + + + + +
## [ INFO ]: 
+## Active modules: 
+##  - 3D Viewer(viewer_3d)
+##  - Electrode Reference(reference)
+##  - Condition Explorer(condition_explorer)
+##  - Inter-Trial Phase Coherence(itpc_phase)
+##  - Onset Detection(onset_detection)
+## According to [/Users/beauchamplab/rave_modules/modules.csv]
+## [ INFO ]: RAVE - (Code: Fir) is loaded!
+## [ INFO ]: Module File:           /Users/beauchamplab/rave_modules/modules.csv
+## [ INFO ]: Data Repository:       /Volumes/data/rave_data/ent_data
+## [ INFO ]: Raw-data Repository:   /Volumes/data/rave_data/raw
+## [ INFO ]: Type 'rave_options(launch_gui = T)' or '?rave_options' for details
+
## Loading subject. Please wait...[ DEBUG ]: Preparing subject [demo/sub_large]
+## [ DEBUG ]: # of electrodes to be loaded: 2
+## [ DEBUG ]: Data type(s): 
+## [ DEBUG ]: Epoch name: Auditory
+## [ DEBUG ]: From: -1 sec - to: 2 sec.
+## [ DEBUG ]: Frequencies:  Hz - to:  Hz.
+## [ DEBUG ]: Electrode - 14
+## [ DEBUG ]: Electrode - 15
+## [ DEBUG ]: Loaded.
+## [ DEBUG ]: Parsing spec file
+## [ DEBUG ]: Loading surface volume
+## [ DEBUG ]: Loading pials
+## [ DEBUG ]: Loading left pial
+## [ DEBUG ]: Loading right pial
+## [ DEBUG ]: Loading Subject
+## [ DEBUG ]: Loaded Subject: demo/sub_large
+## [ INFO ]: Environment for subject [demo/sub_large] has been created! Here are some variables that can be used directly: 
+## - data_check
+## - preload_info
+## - module_tools
+## - subject
+## [ INFO ]: Check ?rave_prepare for details.
+

This R Markdown document is made interactive using Shiny. Unlike the more traditional workflow of creating static reports, you can now create documents that allow your readers to change the assumptions underlying your analysis and see the results immediately.

+

To learn more, see Interactive Documents.

+
+

Inputs and Outputs

+

You can embed Shiny inputs and outputs in your document. Outputs are automatically updated whenever inputs change. This demonstrates how a standard R plot can be made interactive by wrapping it in the Shiny renderPlot function. The selectInput and sliderInput functions create the input widgets used to drive the plot.

+
#  ----------------------  Initializing Global variables -----------------------
+load_scripts(
+  'inst/modules/power_explorer/3d_viewer.R'
+)
+
## Loading source -  inst/modules/power_explorer/3d_viewer.R
+
sess = getDefaultReactiveDomain()
+
+define_initialization({
+  ##
+  ## Make sure power (referenced) exists
+  ## with the following line, RAVE will pop up a dialogue if 
+  ## power is not loaded and ask users to load data
+  ## 
+  rave_checks('power referenced')
+  
+  ##
+  ## Get referenced power (Wavelet power)
+  ## 
+  power = module_tools$get_power(referenced = TRUE)
+  
+  ## Shared variables
+  frequencies = preload_info$frequencies
+  time_points = preload_info$time_points
+  electrodes = preload_info$electrodes
+  epoch_data = module_tools$get_meta('trials')
+})
+
## The following data will be checked:  power referenced[ DEBUG ]: Step 1 (of 1) electrode 14 (power)
+## [ DEBUG ]: Step 1 (of 1) electrode 15 (power)
+
#  ---------------------------------  Inputs -----------------------------------
+# Define inputs
+
+# Select from multiple choices, 
+define_input(
+  definition = textInput('electrode_text', 'Electrodes', value = "", placeholder = '1-5,8,11-20'),
+  init_args = c('label', 'value'),
+  init_expr = {
+    last_input = cache_input('electrode_text', val = as.character(electrodes[1]))
+    e = rutabaga::parse_svec(last_input)
+    e = e[e %in% electrodes]
+    if(!length(e)){
+      e = electrodes[1]
+    }
+    value = rutabaga::deparse_svec(e)
+    label = 'Electrodes (' %&% deparse_selections(electrodes) %&% ')'
+  }
+)
+
## Input Definition -   shiny::textInput(inputId = ns("electrode_text"), label = "Electrodes", 
+##       value = "", placeholder = "1-5,8,11-20")Package/Environment -  shinyUpdating Input Parameter(s) -   label - "Electrodes (14-15)"  value - "14"Input Value -    electrode_text = "14"
+
define_input(
+  definition = customizedUI(inputId = 'input_customized')
+)
+
## Input Definition -   rave::customizedUI(inputId = ns("input_customized"))Package/Environment -   raveInput Value -   input_customized = NULL
+
define_input(
+  definition = sliderInput('FREQUENCY', 'Frequency', min = 1, max = 200, value = c(1,200), step = 1, round = 1),
+  init_args = c('min', 'max', 'value'),
+  init_expr = {
+    min = floor(min(frequencies))
+    max = ceiling(max(frequencies))
+    value = cache_input('FREQUENCY', c(min, max))
+  }
+)
+
## Input Definition -   shiny::sliderInput(inputId = ns("FREQUENCY"), label = "Frequency", 
+##       min = 1, max = 200, value = c(1, 200), step = 1, round = 1)Package/Environment -   shinyUpdating Input Parameter(s) -   min - 2  max - 198  value - c(2, 198)Input Value -     FREQUENCY = c(2, 198)
+
define_input(
+  definition = sliderInput('TIME_RANGE', 'Analysis', min = 0, max = 1, value = c(0,1), step = 0.01, round = -2),
+  init_args = c('min', 'max', 'value'),
+  init_expr = {
+    min = min(time_points)
+    max = max(time_points)
+    value = cache_input('TIME_RANGE', c(0, max(time_points)))
+  }
+)
+
## Input Definition -   shiny::sliderInput(inputId = ns("TIME_RANGE"), label = "Analysis", 
+##       min = 0, max = 1, value = c(0, 1), step = 0.01, round = -2)Package/Environment -   shinyUpdating Input Parameter(s) -   min - -1  max - 2  value - c(0, 2)Input Value -    TIME_RANGE = c(0, 2)
+
define_input(
+  definition = sliderInput('BASELINE', 'Baseline', min = 0, max = 1, value = c(0,1), step = 0.01, round = -2),
+  init_args = c('min', 'max', 'value'),
+  init_expr = {
+    min = min(time_points)
+    max = max(time_points)
+    value = cache_input('BASELINE', c(min(time_points), 0))
+  }
+)
+
## Input Definition -   shiny::sliderInput(inputId = ns("BASELINE"), label = "Baseline", 
+##       min = 0, max = 1, value = c(0, 1), step = 0.01, round = -2)Package/Environment -   shinyUpdating Input Parameter(s) -   min - -1  max - 2  value - c(-1, 0)Input Value -   BASELINE = c(-1, 0)
+
define_input(
+  definition = selectInput('combine_method', 'Electrode Transforms',
+                           choices = c('none', 'z-score', 'max-scale', '0-1 scale', 'rank'), 
+                           multiple = F, selected = 'none')
+)
+
## Input Definition -   shiny::selectInput(inputId = ns("combine_method"), label = "Electrode Transforms", 
+##       choices = c("none", "z-score", "max-scale", "0-1 scale", 
+##           "rank"), selected = "none", multiple = F)Package/Environment -     shinyInput Value -  combine_method = "none"
+
define_input(
+  definition = selectInput('reference_type', 'Transform Reference',
+                           choices = c('Trial', 'Trial type', 'Active trial types', 'All trials'), 
+                           selected='Trial')
+)
+
## Input Definition -   shiny::selectInput(inputId = ns("reference_type"), label = "Transform Reference", 
+##       choices = c("Trial", "Trial type", "Active trial types", 
+##           "All trials"), selected = "Trial")Package/Environment -    shinyInput Value -  reference_type = "Trial"
+
define_input(
+  definition = selectInput('reference_group', 'Reference Group',
+                           choices = c('Per Electrode', 'All Electrodes'), selected = 'Per Electrode')
+)
+
## Input Definition -   shiny::selectInput(inputId = ns("reference_group"), label = "Reference Group", 
+##       choices = c("Per Electrode", "All Electrodes"), selected = "Per Electrode")Package/Environment -   shinyInput Value -  reference_group = "Per Electrode"
+
define_input(
+  definition = numericInput('max_zlim', 'Maximum Plot Value', value = 0, min = 0, step = 1)
+)
+
## Input Definition -   shiny::numericInput(inputId = ns("max_zlim"), label = "Maximum Plot Value", 
+##       value = 0, min = 0, step = 1)Package/Environment -     shinyInput Value -  max_zlim = 0
+
define_input(
+  definition = checkboxInput('log_scale', 'Log Freq')
+)
+
## Input Definition -   shiny::checkboxInput(inputId = ns("log_scale"), label = "Log Freq")Package/Environment -    shinyInput Value -  log_scale = NULL
+
define_input(
+  definition = checkboxInput('sort_trials_by_type', 'Sort Trials')
+)
+
## Input Definition -   shiny::checkboxInput(inputId = ns("sort_trials_by_type"), label = "Sort Trials")Package/Environment -   shinyInput Value -  sort_trials_by_type = NULL
+
define_input(
+  definition = compoundInput(
+    inputId = 'GROUPS', prefix= 'Group', inital_ncomp = 1, components = {
+      textInput('GROUP_NAME', 'Name', value = '', placeholder = 'Name')
+      selectInput('GROUP', ' ', choices = '', multiple = TRUE)
+    }),
+  init_args = c('initialize', 'value'),
+  init_expr = {
+    trials = preload_info$condition
+    initialize = list(
+      GROUP = list(
+        choices = unique(trials)
+      )
+    )
+    value = cache_input('GROUPS', list(
+      list(
+        GROUP = list(trials),
+        GROUP_NAME = 'All Conditions'
+      )
+    ))
+  }
+)
+
## Input Definition -   rave::compoundInput(inputId = ns("GROUPS"), components = {
+##       textInput("GROUP_NAME", "Name", value = "", placeholder = "Name")
+##       selectInput("GROUP", " ", choices = "", multiple = TRUE)
+##   }, inital_ncomp = 1, prefix = "Group")Package/Environment -    raveUpdating Input Parameter(s) -   initialize - list(GROUP = list(choices = c("AknownVmeant", "AmeantVdrive", 
+##   "meant_v", "drive_v", "known_a", "known_av", "AdriveVlast", "AlastVknown", 
+##   "meant_a", "drive_av", "drive_a", "last_a", "meant_av", "press_AV", 
+##   "last_av", "known_v", "last_v")))  value - list(list(GROUP = list(c("AknownVmeant", "AmeantVdrive", "meant_v", 
+##   "drive_v", "known_a", "known_av", "AdriveVlast", "AlastVknown", 
+##   "meant_a", "drive_av", "drive_a", "last_a", "meant_av", "press_AV", 
+##   "last_av", "known_v", "last_v")), GROUP_NAME = "All Conditions"))Input Value -     GROUPS = list(list(GROUP = list(c("AknownVmeant", "AmeantVdrive", "meant_v", 
+##   "drive_v", "known_a", "known_av", "AdriveVlast", "AlastVknown", 
+##   "meant_a", "drive_av", "drive_a", "last_a", "meant_av", "press_AV", 
+##   "last_av", "known_v", "last_v")), GROUP_NAME = "All Conditions"))
+
# Define layouts if exists
+input_layout = list(
+  '[#cccccc]Electrodes' = list(
+    c('electrode_text'),
+    c('combine_method'),
+    c('reference_type', 'reference_group')
+  ),
+  '[#99ccff]Trial Selector' = list(
+    'GROUPS'
+  ),
+  'Analysis Settings' = list(
+    'FREQUENCY',
+    'BASELINE',
+    'TIME_RANGE'
+  ),
+  '[-][#33aaff]Export Options' = list(),
+  '[-]Plotting' = list(
+    c('log_scale', 'sort_trials_by_type', 'collapse_using_median'),
+    c('max_zlim')
+  )
+)
+
# Define Outputs
+define_output(
+  definition = plotOutput(outputId = 'heat_map_plot'),
+  title = 'Heat Map (Collapse trial)',
+  width = 12,
+  order = 1
+)
+
## Title -      Heat Map (Collapse trial)Definition -       shiny::plotOutput(outputId = ns("heat_map_plot"))Package/Environment -  shinyWidth -        12 (100.0% of output panel width)Order -        1Output function ` heat_map_plot ` found in package  ravebuiltins .
+
define_output(
+  definition = plotOutput('by_trial_heat_map'),
+  title = 'Activity over time by trial (Collapse freq)',
+  width = 12,
+  order = 2
+)
+
## Title -      Activity over time by trial (Collapse freq)Definition -         shiny::plotOutput(outputId = ns("by_trial_heat_map"))Package/Environment -  shinyWidth -        12 (100.0% of output panel width)Order -        2Output function ` by_trial_heat_map ` found in package  ravebuiltins .
+
define_output(
+  definition = plotOutput('over_time_plot'),
+  title = 'Collapse freq+trial',
+  width = 8,
+  order = 4
+)
+
## Title -      Collapse freq+trialDefinition -         shiny::plotOutput(outputId = ns("over_time_plot"))Package/Environment -     shinyWidth -        8 (66.7% of output panel width)Order -      4Output function ` over_time_plot ` found in package  ravebuiltins .
+
define_output(
+  definition = plotOutput(outputId = 'windowed_comparison_plot'),
+  title = 'Collapse time+freq',
+  width = 4,
+  order = 3
+)
+
## Title -      Collapse time+freqDefinition -      shiny::plotOutput(outputId = ns("windowed_comparison_plot"))Package/Environment -   shinyWidth -        4 (33.3% of output panel width)Order -      3Output function ` windowed_comparison_plot ` found in package  ravebuiltins .
+
define_output(
+  definition = customizedUI('viewer_3d'),
+  title = '3D Viewer',
+  width = 12,
+  order = 5
+)
+
## Title -      3D ViewerDefinition -       rave::customizedUI(inputId = ns("viewer_3d"))Package/Environment -  raveWidth -         12 (100.0% of output panel width)Order -        5Cannot find output function ` viewer_3d ` in package  ravebuiltins !
+
# output_layout = list(
+#   # 'Tabset One' = list(
+#   #   'Multiple Output' = 'heat_map_plot'
+#   # )
+#   'Multiple Output' = 'heat_map_plot'
+# )
+
+
+

Embedded Application

+

It’s also possible to embed an entire Shiny application within an R Markdown document using the shinyAppDir function. This example embeds a Shiny application located in another directory:

+

Note the use of the height parameter to determine how much vertical space the embedded application should occupy.

+

You can also use the shinyApp function to define an application inline rather then in an external directory.

+

In all of R code chunks above the echo = FALSE attribute is used. This is to prevent the R code within the chunk from rendering in the document alongside the Shiny components.

+
+ + + + +
+ + + + + + + + diff --git a/inst/modules/univariate_power_explorer/event_handlers.R b/inst/modules/univariate_power_explorer/event_handlers.R new file mode 100644 index 0000000..f5cbce6 --- /dev/null +++ b/inst/modules/univariate_power_explorer/event_handlers.R @@ -0,0 +1,82 @@ +observeEvent(input$power_3d__mouse_event, { + mouse_event = input$power_3d__mouse_event$event + object = input$power_3d__mouse_event$object + + print(input$power_3d__mouse_event) + + # This is dirty, i think we can provide function to get which electrode chosen + if(mouse_event$action == 'dblclick' && isTRUE( object$is_electrode )){ + # Get object chosen, is it an electrode? + # Use isTRUE() to validate since object$is_electrode could be NULL + e = stringr::str_match(object$name, '^Electrode ([0-9]+)')[2] + e = as.integer(e) + if(e %in% preload_info$electrodes){ + updateTextInput(session, 'ELECTRODE', value = e) + showNotification(p('Switched to electrode ', e), type = 'message', id = ns('power_3d_widget__mouse')) + }else{ + showNotification(p('Electrode ', e, ' is not loaded.'), type = 'warning', id = ns('power_3d_widget__mouse')) + } + } +}) + + +input = getDefaultReactiveInput() +output = getDefaultReactiveOutput() +session = getDefaultReactiveDomain() + +local_data = reactiveValues( + by_trial_heat_map_click_location = NULL, + windowed_by_trial_click_location = NULL, + click_info = NULL +) + +# observeEvent(input$by_trial_heat_map_click, { +# local_data$by_trial_heat_map_click_location = input$by_trial_heat_map_click +# }) + + +observeEvent(input$windowed_by_trial_click, { + local_data$windowed_by_trial_click_location = input$windowed_by_trial_click + .loc <- local_data$windowed_by_trial_click_location + + # first we determine which group is being clicked, then we drill down + # to determine the nearest point -- this should be faster than just looking + # through all the points across all the groups, n'est-ce pas? + .gi <- which.min(abs(.loc$x - sapply(scatter_bar_data, `[[`, 'xp'))) + .ind <- which.min(abs(scatter_bar_data[[.gi]]$x - .loc$x) + + abs(scatter_bar_data[[.gi]]$data - .loc$y)) + + .trial <- scatter_bar_data[[.gi]]$Trial_num[.ind] + .val <- round(scatter_bar_data[[.gi]]$data[.ind], + digits = abs(min(0, -1+floor(log10(max(abs(scatter_bar_data[[.gi]]$data))))))) + + .tol <- input$trial_outliers_list + # print(.tol) + if(any(.trial == .tol)) { + .tol <- .tol[.tol != .trial] + } else { + .tol <- c(.tol, .trial) + } + + updateSelectInput(session, 'trial_outliers_list', selected = .tol) + local_data$click_info <- list('trial' = .trial, 'value' = .val) +}) + +output$trial_outlier_click <- renderUI({ + # loc <- local_data$by_trial_heat_map_click_location + .click <- local_data$click_info + + HTML( + 'Nearest Trial: ' %&% .click$trial %&% '
Value: ' %&% .click$value + ) +}) + +click_output = function() { + # logger('click out...') + # put analysis information in here + if(!is.null(local_data$windowed_by_trial_click_location)) { + return(htmlOutput(ns('trial_outlier_click'))) + } + return('no trials clicked yet') +} + diff --git a/inst/modules/univariate_power_explorer/exports.R b/inst/modules/univariate_power_explorer/exports.R new file mode 100644 index 0000000..b02631f --- /dev/null +++ b/inst/modules/univariate_power_explorer/exports.R @@ -0,0 +1,243 @@ +input <- getDefaultReactiveInput() +output = getDefaultReactiveOutput() + +power_3d_fun = function(brain){ + showNotification(p('Generating 3d viewer...')) + + # brain = rave::rave_brain2(); + brain$load_surfaces(subject = subject, surfaces = c('pial', 'white', 'smoothwm')) + + dat = rave::cache(key = list( + list(BASELINE_WINDOW, preload_info) + ), val = get_summary()) + + + + + # for each electrode, we want to test the different conditions + .FUN <- if(length(levels(dat$condition)) > 1) { + + if (length(levels(dat$condition)) == 2) { + function(x) { + res = get_t(power ~ condition, data=x) + res = c(res[1] - res[2], res[3], res[4]) + res %>% set_names(c('b', 't', 'p')) + } + } else { + function(x) { + get_f(power ~ condition, data=x) + } + } + } else { + function(x) { + get_t(x$power) %>% set_names(c('b', 't', 'p')) + } + } + + values = sapply(unique(dat$elec), function(e){ + sub = dat[dat$elec == e, ] + re = .FUN(sub) + v = re[input$viewer_3d_type] + brain$set_electrode_value(subject, e, v) + return(v) + }) + + brain$view(value_range = c(-1,1) * max(abs(values)), + color_ramp = rave_heat_map_colors) +} + +# Export functions +get_summary <- function() { + # here we just want an estimate of the power at each trial for each electrode + # get the labels for each trial + + ..g_index <- 1 + GROUPS = lapply(GROUPS, function(g){ + g$Trial_num = epoch_data$Trial[epoch_data$Condition %in% unlist(g$group_conditions)] + + if(g$group_name == '') { + g$group_name <- LETTERS[..g_index] + ..g_index <<- ..g_index + 1 + } + + return(g) + }) + rm(..g_index) + + tnum_by_condition <- sapply(GROUPS, function(g) { + list(g$Trial_num) + }) %>% set_names(sapply(GROUPS, '[[', 'group_name')) + + all_trials <- unlist(tnum_by_condition) + # .bl_power <- cache( + # key = list(subject$id, preload_info$electrodes, BASELINE_WINDOW, preload_info), + # val = baseline(power, BASELINE_WINDOW[1], BASELINE_WINDOW[2], hybrid = FALSE, mem_optimize = FALSE) + # ) + + .bl_power <- baseline(power, BASELINE_WINDOW[1], BASELINE_WINDOW[2], hybrid = FALSE, mem_optimize = FALSE) + + # subset out the trials, frequencies, and time rane + .power <- .bl_power$subset(Frequency = Frequency %within% FREQUENCY, + Time = Time %within% ANALYSIS_WINDOW, + Trial = Trial %in% all_trials, data_only = FALSE) + + stimulus <- epoch_data$Condition[as.numeric(.power$dimnames$Trial)] + + condition <- .power$dimnames$Trial %>% as.numeric %>% sapply(function(tnum) { + #ensure only one group is ever selected? or we could throw an error on length > 1 + sapply(tnum_by_condition, `%in%`, x=tnum) %>% which %>% extract(1) + }) %>% names + + # rutabaga over Freq and Time + # by_elec <- rutabaga::collapse(.power$data, keep=c(1,4)) / prod(.power$dim[2:3]) + by_elec <- .power$collapse(keep = c(1,4), method = 'mean') + + data.frame('subject_id' = subject$id, + 'elec' = rep(preload_info$electrodes, each=length(condition)), + 'trial' = rep(seq_along(condition), times=length(preload_info$electrodes)), + 'condition' = rep(condition, length(preload_info$electrodes)), + 'power' = c(by_elec) + ) +} + +export_stats = function(conn=NA, lbl='stat_out', dir, ...){ + out_dir <- dir #module_tools$get_subject_dirs()$module_data_dir %&% '/condition_explorer/' + + if(!dir.exists(out_dir)) { + dir.create(out_dir, recursive = TRUE) + } + + if(is.na(conn)) { + fout <- out_dir %&% lbl %&% '.RDS' + } else { + fout <- conn #out_dir %&% conn + } + + + # run through all the active electrodes and get the data + # out_data <- lapply_async(electrodes, process_for_stats) + + out_data <- get_summary() + + saveRDS(out_data, file = fout) + + invisible(out_data) +} + +graph_export = function(){ + tagList( + # actionLink(ns('btn_graph_export'), 'Export Graphs'), + downloadLink(ns('btn_graph_download'), 'Download Graphs') + ) +} + +# observeEvent(input$btn_graph_export, { +# export_graphs(conn = '~/Desktop/hmp_e.pdf') +# }) + + +output$btn_graph_download <- downloadHandler( + filename = function(...) { + paste0('power_explorer_export', + format(Sys.time(), "%b_%d_%Y_%H_%M_%S"), '.zip') + }, + content = function(conn){ + tmp_dir = tempdir() + + # map the human names to the function names + function_map <- list('Spectrogram' = 'heat_map_plot', + 'By Trial Power' = 'by_trial_heat_map', + 'Over Time Plot' = 'over_time_plot', + 'Windowed Average' = 'windowed_comparison_plot') + + to_export <- function_map[plots_to_export] + prefix <- sprintf('%s_%s_%s_', subject$subject_code, subject$project_name, format(Sys.time(), "%b_%d_%Y_%H_%M_%S")) + + fnames <- function_map[plots_to_export] + + tmp_files <- prefix %&% str_replace_all(names(fnames), ' ', '_') %&% '.pdf' + + mapply(export_graphs, file.path(tmp_dir, tmp_files), fnames) + + wd = getwd() + on.exit({setwd(wd)}) + + setwd(tmp_dir) + + zip(conn, files = tmp_files, flags='-r2X') + } +) + +export_graphs <- function(conn=NA, + which_plot=c('heat_map_plot','by_trial_heat_map','over_time_plot', 'windowed_comparison_plot'), ...) { + + which_plot <- match.arg(which_plot) + + args = isolate(reactiveValuesToList(input)) + + electrodes_loaded = preload_info$electrodes + # check to see if we should loop over all electrodes or just the current electrode + if(export_what == 'Current Selection') { + electrodes_loaded <- ELECTRODE + } + + progress = rave::progress('Rendering graphs for: ' %&% str_replace_all(which_plot, '_', ' '), + max = length(electrodes_loaded) + 1) + + on.exit({progress$close()}, add=TRUE) + progress$inc(message = 'Initializing') + + .export_graph = function(){ + module = rave::get_module('ravebuiltins', 'power_explorer', local = TRUE) + + formal_names = names(formals(module)) + args = args[formal_names] + names(args) = formal_names + + # having issues here with the size of the plots being too large for the font sizes + # we can't (easily) change the cex being used by the plots. So maybe we can + # just change the size of the output PDF. people can the resize + + # based on the number of groups we should scale the plots + ngroups = 0 + for(ii in seq_along(args$GROUPS)) { + if(length(args$GROUPS[[ii]]$group_conditions)>1) { + ngroups = ngroups+1 + } + } + + w_scale = h_scale = 1 + if(which_plot == 'windowed_comparison_plot') { + w_scale = ngroups / 2.25 + } + + if(which_plot %in% c('by_trial_heat_map', 'heat_map_plot')) { + w_scale = ngroups*1.25 + h_scale = ngroups*1.05 + } + + .w <- round(9.75*w_scale,1) + .h <- round(6.03*h_scale,1) + + pdf(conn, width = .w, height = .h, useDingbats = FALSE) + + on.exit(dev.off()) + + for(e in electrodes_loaded){ + progress$inc(message = sprintf('Electrode %s', e)) + args[['ELECTRODE']] = e + result = do.call(module, args) + result[[which_plot]]() + } + } + + .export_graph() + + # showNotification(p('Export graph finished.')) + + #TODO check the variable export_per_electrode to see if we need to loop over electrodes and export + # or if we want use just the current_electrodes and combine them + + #TODO need to scale all the fonts etc so things aren't too large for export + +} diff --git a/inst/modules/univariate_power_explorer/main.R b/inst/modules/univariate_power_explorer/main.R new file mode 100644 index 0000000..0d15e9f --- /dev/null +++ b/inst/modules/univariate_power_explorer/main.R @@ -0,0 +1,294 @@ +# Main algorithm - rave_executes + +# Initialize inputs +# rm(list = ls(all.names=T)); rstudioapi::restartSession() +ravebuiltins:::dev_ravebuiltins(T) +mount_demo_subject() + +init_module(module_id = 'power_explorer', debug = TRUE) + +if(FALSE) { + GROUPS = list(list(group_name='A', group_conditions=c('known_a', 'last_a', 'drive_a', 'meant_a')), + list(group_name='B', group_conditions=c('known_v', 'last_v', 'drive_v', 'meant_v'))) +} + +# >>>>>>>>>>>> Start ------------- [DO NOT EDIT THIS LINE] --------------------- +# requested_electrodes = rutabaga::parse_svec(ELECTRODE_TEXT, sep = ':-') +# requested_electrodes %<>% get_by(`%in%`, electrodes) + +# this will be NA if the only requested electrodes are not available +# electrode <- requested_electrodes[1] +# assertthat::assert_that(length(requested_electrodes) >= 1 && + # all(not_NA(requested_electrodes)), msg = 'No electrode selected') + +# grab the subject code so it can be used later +subject_code = subject$subject_code + +# Clean group input data +group_data = lapply(seq_along(GROUPS), function(idx) { + g = GROUPS[[idx]] + + Trial_num = epoch_data$Trial[epoch_data$Condition %in% unlist(g$group_conditions)] + list( + name = g$group_name, + Trial_num = Trial_num, + group_index = idx, + has_trials = length(Trial_num) > 0, + conditions = unlist(g$group_conditions) + ) + +}) +has_trials <- vapply(group_data, function(g){g$has_trials}, FALSE) +any_trials <- any(has_trials) + +# Subset data +bl_power <- cache( + key = list(subject$id, ELECTRODE, BASELINE_WINDOW, preload_info$time_points, combine_method, + any_trials, preload_info$epoch_name, preload_info$reference_name), + val = baseline(power$subset(Electrode = Electrode == ELECTRODE), + from=BASELINE_WINDOW[1], to= BASELINE_WINDOW[2], + hybrid = FALSE, mem_optimize = FALSE) +) + +# Prepare plot datasets +scatter_bar_data <- line_plot_data <- by_trial_heat_map_data <- heat_map_data <- group_data +flat_data <- data.frame() + +# set transform method +.transform <- electrode_transform(combine_method) + +# for transforms, the idea is to apply at each trial for each frequency +# then when things get it will already be done + + +#relies on .transform as defined above +if(combine_method != 'none') { + transformed_power <- cache( + key = list(combine_method, subject$id, ELECTRODE, BASELINE_WINDOW, preload_info$time_points, + any_trials, preload_info$epoch_name, preload_info$reference_name), + + val = { + transformed_power <- bl_power$get_data() + + # we should be able to apply the sqrt transform directly to the eniter tensor + if(combine_method == 'amplitude') { + transformed_power %<>% .transform + } else { + for(ti in seq_len(dim(transformed_power)[1L])) { + transformed_power[ti,,,1] <- t(apply(transformed_power[ti,,,1], 1, .transform)) + } + } + + transformed_power + } + ) + bl_power$set_data(transformed_power) +} + + +# Collapse data + +## Leave it here in case you want to change it later +# (make it user specific) +collapse_method = 'mean' + +# This module is no longer across electrodes, so if we are transforming, +# we likely want to do it at the trial level, not on the back end before combining across electrodes +for(ii in which(has_trials)){ + .power_all = bl_power$subset(Trial = Trial %in% group_data[[ii]]$Trial_num) + .power_freq = .power_all$subset(Frequency=Frequency %within% FREQUENCY) + .power_all_clean <- .power_all$subset(Trial=! (Trial %in% trial_outliers_list)) + .power_freq_clean = .power_freq$subset(Trial=! (Trial %in% trial_outliers_list)) + + N = dim(.power_all)[1L] + Nclean <- dim(.power_all_clean)[1L] + + trials <- epoch_data %>% subset((.)$Trial %in% group_data[[ii]]$Trial_num) %>% extract2('Condition') + tnums <- epoch_data %>% subset((.)$Trial %in% group_data[[ii]]$Trial_num) %>% extract2('Trial') + # tnums %in% trial_outliers_list + # utils functions + wrap_data = function(value){ + list( + data = value, + range = .fast_range(value), + N = N, + trials = trials, + is_clean = !(tnums %in% trial_outliers_list), + name = group_data[[ii]]$group_name + ) + } + + # 1 Time x Frequency + heat_map_data[[ii]] <- append(heat_map_data[[ii]], + wrap_data(.power_all_clean$collapse(keep = c(3,2), method = collapse_method))) + + attr(heat_map_data[[ii]]$data, 'xlab') <- 'Time (s)' + attr(heat_map_data[[ii]]$data, 'ylab') <- 'Frequency' + attr(heat_map_data[[ii]]$data, 'zlab') <- ifelse(combine_method=='none', 'Mean % Signal Change', + 'Mean ' %&% combine_method %&% ' %SC') + + # the x value for the hmd is time + heat_map_data[[ii]]$x <- .power_all$dimnames$Time + + #the y value for the hmd is frequency + heat_map_data[[ii]]$y <- .power_all$dimnames$Frequency + + # hmd is using the clean data + heat_map_data[[ii]]$N <- Nclean + + # 2 Time x Trial (.power_freq) + # by trial data. + by_trial_heat_map_data[[ii]] <- append( by_trial_heat_map_data[[ii]], wrap_data( + .power_freq$collapse(keep = c(3,1), method = collapse_method) + )) + + # the x value for the bthmd is time + by_trial_heat_map_data[[ii]]$x <- .power_freq$dimnames$Time + + #the y value for the bthmd is Trial + by_trial_heat_map_data[[ii]]$y <- seq_along(.power_freq$dimnames$Trial) + + attr(by_trial_heat_map_data[[ii]]$data, 'xlab') <- 'Time (s)' + attr(by_trial_heat_map_data[[ii]]$data, 'ylab') <- 'Trial' + attr(by_trial_heat_map_data[[ii]]$data, 'zlab') <- ifelse(combine_method=='none', 'Mean % Signal Change', + 'Mean ' %&% combine_method %&% ' %SC') + + # 3 Time only + # coll freq and trial for line plot w/ ebar. Because we're doing error bars, we have to know whether we have 1 vs. >1 electrodes + # if(length(requested_electrodes) == 1){ + # Single electrode, mean and mse for each time points + line_plot_data[[ii]] = append(line_plot_data[[ii]], wrap_data(t( + apply( + .power_freq_clean$collapse(keep = c(1,3), method = 'mean'), + 2, .fast_mse) + ))) + + attr(line_plot_data[[ii]]$data, 'xlab') <- 'Time (s)' + attr(line_plot_data[[ii]]$data, 'ylab') <- ifelse(combine_method=='none', 'Mean % Signal Change', + 'Mean ' %&% combine_method %&% ' %SC') + line_plot_data[[ii]]$N <- Nclean + + # scatter bar data -- here we want all of the data because we are going to highlight (or not) the outliers -- same for by-trial heatmap + if(show_outliers_on_plots) { + scatter_bar_data[[ii]] = append(scatter_bar_data[[ii]], wrap_data( + rowMeans(.power_freq$subset( + Time = (Time %within% ANALYSIS_WINDOW), + data_only = TRUE + )) + )) + } else { + scatter_bar_data[[ii]] = append(scatter_bar_data[[ii]], wrap_data( + rowMeans(.power_freq_clean$subset( + Time = (Time %within% ANALYSIS_WINDOW), + data_only = TRUE + )) + )) + } + scatter_bar_data[[ii]]$N <- Nclean + + # to enable point identification later, we need to know the x-location of each point. So the jittering + # needs to be done here. + # Although this seems to be the wrong place to do this, not sure where else we can do it + .xp <- barplot(which(has_trials),plot=FALSE) + .r <- if(sum(has_trials)>1) { + mean(unique(diff(.xp)))*0.25 + } else { + 0.75*(1/3) + } + scatter_bar_data[[ii]]$xp <- .xp[ii] + scatter_bar_data[[ii]]$x <- .xp[ii] + runif(length(scatter_bar_data[[ii]]$data), -.r, .r) + + attr(scatter_bar_data[[ii]]$data, 'xlab') <- 'Group' + attr(scatter_bar_data[[ii]]$data, 'ylab') <- ifelse(combine_method=='none', 'Mean % Signal Change', + 'Mean ' %&% combine_method %&% ' %SC') + + # we want to make a special range for the line plot data that takes into account mean +/- SE + line_plot_data[[ii]]$range <- .fast_range(plus_minus(line_plot_data[[ii]]$data[,1], + line_plot_data[[ii]]$data[,2])) + + # also add in the x variable for the time series + line_plot_data[[ii]]$x <- .power_freq$dimnames$Time + + # for the scatter_bar_data we also need to get m_se within condition w/o the outliers + scatter_bar_data[[ii]]$mse <- .fast_mse(scatter_bar_data[[ii]]$data[scatter_bar_data[[ii]]$is_clean]) + + flat_data %<>% rbind(data.frame('group'=ii, + 'y' = scatter_bar_data[[ii]] %$% {data[is_clean]})) +} + +# .power_freq[,, preload_info$time_points %within% ANALYSIS_WINDOW, ]$data + +# for baseline you want to have only the baseline times +flat_data$group %<>% factor + +# this can be used elsewhere +has_data = sum(has_trials) + +# calculate some statistics + +# calculate the statistics here so that we can add them to the niml_out +# if there are > 1 groups in the data, then do linear model, otherwise one-sample t-test +if(length(unique(flat_data$group)) > 1) { + # we need to check if they have supplied all identical data sets + # easy way is to check that the trials are the same? + g1_trials <- unlist(GROUPS[[which(has_trials)[1]]]$group_conditions) + if(all( + sapply(which(has_trials)[-1], + function(ii) { + setequal(unlist(GROUPS[[ii]]$group_conditions),g1_trials) + }) + )) { + result_for_suma <- get_t(flat_data$y[flat_data$group==flat_data$group[1]]) + } else { + result_for_suma <- get_f(y ~ group, flat_data) + } +} else { + result_for_suma <- flat_data$y %>% get_t +} + +attr(scatter_bar_data, 'stats') <- result_for_suma + +# <<<<<<<<<<<< End ----------------- [DO NOT EDIT THIS LINE] ------------------- + +# Debug +require(ravebuiltins) + +module = ravebuiltins:::debug_module('power_explorer') + +result = module(GROUPS = list(list(group_name='A', group_conditions=c('known_a', 'last_a', 'drive_a', 'meant_a')), + # putting in an empty group to test our coping mechanisms + list(group_name='YY', group_conditions=c()), + list(group_name='', group_conditions=c('known_v', 'last_v', 'drive_v', 'meant_v'))), + FREQUENCY = c(75,150), max_zlim = 0, + sort_trials_by_type = T, combine_method = 'none') +results = result$results +# attachDefaultDataRepository() + +result$heat_map_plot() +result$by_trial_heat_map() +result$over_time_plot() +result$windowed_comparison_plot() + +ravebuiltins::dev_ravebuiltins(expose_functions = TRUE) +view_layout('power_explorer', sidebar_width = 3, launch.browser = T) + +m = to_module(module_id) +init_app(m) + +mount_demo_subject() + +env = reload_this_package(expose = FALSE, clear_env = TRUE) + +# Step 2: make sure rave data is attached +attachDefaultDataRepository() + +# Step 3: try to run from local session +module = rave::get_module(package = 'ravebuiltins', module_id = 'power_explorer', local = T) + +res = module() + +# Step 4: launch modules in RAVE (production) +# Cmd+Shift+B +m = rave::detect_modules('ravebuiltins') +rave::init_app(m) + diff --git a/inst/tools/funcs.R b/inst/tools/funcs.R index 256d519..9354e1b 100644 --- a/inst/tools/funcs.R +++ b/inst/tools/funcs.R @@ -170,10 +170,8 @@ rave_checks <- function(...){ -get_brain = function(surfaces = 'pial', multiple_subject = FALSE){ +get_brain = function(surfaces = 'pial'){ subject = get('subject', envir = rave::getDefaultDataRepository()) - brain = rave::rave_brain2(surfaces = surfaces, multiple_subject = multiple_subject) - brain$load_electrodes(subject) - brain$load_surfaces(subject) + brain = rave::rave_brain2(subject, surfaces = surfaces) brain } diff --git a/inst/tools/input_widgets.R b/inst/tools/input_widgets.R index c010350..99e1403 100644 --- a/inst/tools/input_widgets.R +++ b/inst/tools/input_widgets.R @@ -20,7 +20,6 @@ define_input_multiple_electrodes <- function(inputId, label = 'Electrodes'){ }) parent_frame = parent.frame() - rave::eval_dirty(quo, env = parent_frame) } @@ -73,8 +72,16 @@ define_input_frequency <- function(inputId, label = 'Frequency', is_range = TRUE }else{ initial_value %?<-% min } + value = cache_input(!!inputId, initial_value) - value = ..get_nearest(value, preload_info$frequencies) + if(length(value) == 1) { + # the problem here is that it doesn't work for ranges... + value = ..get_nearest_val(value, preload_info$frequencies) + } else { + v1 <- ..get_nearest_val(value[1], preload_info$frequencies) + v2 <- ..get_nearest_val(value[2], preload_info$frequencies) + value = c(v1,v2) + } } ) }) diff --git a/inst/tools/output_widgets.R b/inst/tools/output_widgets.R index 857347f..9c4daff 100644 --- a/inst/tools/output_widgets.R +++ b/inst/tools/output_widgets.R @@ -4,6 +4,8 @@ define_output_3d_viewer <- function( height = '500px', width = 12, order = 0, additional_ui = NULL ){ + + # Generate reactives output_call = paste0(outputId, '_widget') output_btn = paste0(outputId, '_btn') @@ -11,7 +13,6 @@ define_output_3d_viewer <- function( additional_ui = substitute(additional_ui) - quo = rlang::quo({ assign(!!output_call, function(){ clicked = shiny::isolate(input[[!!output_btn]]) @@ -32,43 +33,65 @@ define_output_3d_viewer <- function( }, envir = environment()) local({ `%?<-%` <- rave::`%?<-%` + ns %?<-% function(x) {x} + input = getDefaultReactiveInput() output = getDefaultReactiveOutput() session = getDefaultReactiveDomain() local_data %?<-% reactiveValues() + ...local_env %?<-% new.env(parent = emptyenv()) output[[!!outputId]] <- threeBrain::renderBrain({ - brain = rave::rave_brain2(surfaces = !!surfaces, multiple_subject = !!multiple_subject) - brain$load_electrodes(subject) - brain$load_surfaces(subject) - - re = brain - # Render function - if(input[[!!output_btn]] > 0){ - f = get0(!!output_fun, envir = ..runtime_env, ifnotfound = function(...){ - rutabaga::cat2('3D Viewer', !!outputId, 'cannot find function', !!output_fun, level = 'INFO') - }) - - tryCatch({ - re = f(brain) - }, error = function(e){ - rave::logger(e, level = 'ERROR') + render_func = function(){ + threeBrain::renderBrain({ + brain = rave::rave_brain2(subject = subject, surfaces = !!surfaces) + + shiny::validate( + shiny::need(!is.null(brain), message = 'Cannot find surface/volume files') + ) + + re = brain + # Render function + if(input[[!!output_btn]] > 0){ + f = get0(!!output_fun, envir = ..runtime_env, ifnotfound = function(...){ + rutabaga::cat2('3D Viewer', !!outputId, 'cannot find function', !!output_fun, level = 'INFO') + }) + + tryCatch({ + re = f(brain) + }, error = function(e){ + rave::logger(e, level = 'ERROR') + }) + + } + + if('htmlwidget' %in% class(re)){ + # User called $view() with additional params, directly call the widget + ...local_env$widget = re + re + }else if('rave-brain' %in% class(re)){ + # User just returned brain object + ...local_env$widget = re$plot() + re$plot(side_shift = c(-265, 0)) + }else{ + # User returned nothing + ...local_env$widget = brain$plot() + brain$plot(side_shift = c(-265, 0)) + } + + }) - - } - - if('htmlwidget' %in% class(re)){ - # User called $view() with additional params, directly call the widget - re - }else if('rave_three_brain' %in% class(re)){ - # User just returned brain object - re$view() - }else{ - # User returned nothing - brain$view() } + # Register render function + output[[!!outputId]] <- render_func() + # Register cross-session function so that other sessions can register the same output widget + session$userData$cross_session_funcs %?<-% list() + # ns must be defined, but in get_module(..., local=T) will raise error + # because we are not in shiny environment + ns %?<-% function(x){x} + session$userData$cross_session_funcs[[ns(!!outputId)]] = render_func }) }) }) @@ -82,7 +105,7 @@ define_output_3d_viewer <- function( order = !!order ) - load_scripts(rlang::quo({!!quo})) + load_scripts(rlang::quo(!!quo)) }) eval(rlang::quo_squash(df), envir = parent.frame()) # evaluate @@ -91,10 +114,6 @@ define_output_3d_viewer <- function( } - - - - # define_output_3d_viewer <- function( # outputId, title, surfaces = 'pial', multiple_subject = F, # message = 'Click here to Generate 3D viewer', From 87e85c69ce69b34e9e71522c7b4c8eab032b309c Mon Sep 17 00:00:00 2001 From: dipterix Date: Tue, 17 Sep 2019 13:17:05 -0500 Subject: [PATCH 02/24] Rewrote 3D viewer --- DESCRIPTION | 32 +- inst/modules/overview_viewer_3d/UI.R | 28 -- inst/modules/overview_viewer_3d/comp.R | 148 ++++---- inst/modules/overview_viewer_3d/import.R | 176 ---------- inst/modules/overview_viewer_3d/io.R | 243 -------------- inst/modules/overview_viewer_3d/main.R | 170 ++++++---- inst/modules/overview_viewer_3d/outputs.R | 205 +++++++++++ .../overview_viewer_3d/reactive_inputs.R | 270 --------------- inst/modules/overview_viewer_3d/reactives.R | 317 ++++++------------ inst/modules/overview_viewer_3d/utils.R | 256 -------------- inst/tools/input_widgets.R | 139 ++++++++ 11 files changed, 642 insertions(+), 1342 deletions(-) delete mode 100644 inst/modules/overview_viewer_3d/UI.R delete mode 100644 inst/modules/overview_viewer_3d/import.R delete mode 100644 inst/modules/overview_viewer_3d/io.R create mode 100644 inst/modules/overview_viewer_3d/outputs.R delete mode 100644 inst/modules/overview_viewer_3d/reactive_inputs.R delete mode 100644 inst/modules/overview_viewer_3d/utils.R diff --git a/DESCRIPTION b/DESCRIPTION index dcb17f8..cfe0faa 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,37 +1,35 @@ # Generated by roxygen2: do not edit by hand Package: ravebuiltins Type: Package -Title: What the Package Does (Title Case) -Version: 0.1.0 -Description: More about what it does (maybe more than one line) - Use four spaces when indenting paragraphs within the Description. +Title: Builtin Modules for `RAVE` +Version: 0.1.1 +Description: Provides builtin modules for `RAVE` License: MIT + file LICENSE Encoding: UTF-8 LazyData: true RoxygenNote: 6.1.1 -Authors@R: - person(given = "Zhengjia", - family = "Wang", - role = "cre", - email = "dipterix.wang@gmail.com") +Authors@R: c( + person(given = "Zhengjia", family = "Wang", role = "cre", email = "zhengjia.wang@rice.edu"), + person(given = "John", family = "Magnotti", role = "aut", email = "jmagnotti@bcm.edu") + ) Imports: + methods, + stats, shiny (>= 1.2.0), rlang (>= 0.3.0), stringr (>= 1.3.1), - magrittr, - circular, - lmerTest, - methods, + threeBrain (>= 0.1.3), + future (>= 0.14.0), + magrittr (>= 1.5), + circular (>= 0.4-93), + lmerTest (>= 3.1-0), rave, rutabaga, - future, - abind, - stats + abind Suggests: devtools, yaml (>= 2.2.0), rstudioapi (>= 0.9.0) Remotes: github::dipterix/rutabaga, - github::dipterix/threeBrain, github::beauchamplab/rave diff --git a/inst/modules/overview_viewer_3d/UI.R b/inst/modules/overview_viewer_3d/UI.R deleted file mode 100644 index 0e55e5e..0000000 --- a/inst/modules/overview_viewer_3d/UI.R +++ /dev/null @@ -1,28 +0,0 @@ -.module_path = 'Viewer3D' -.module_id = 'viewer_3d' -.preserved = c('Voltage, Referenced', 'Power, Referenced', 'Phase, Raw') - - -# -# rave_inputs( -# customizedUI('data_picker'), -# customizedUI('data_controls_name'), -# customizedUI('data_controls_import'), -# customizedUI('data_controls_details'), -# customizedUI('data_controls_misc'), -# .input_panels = list( -# 'Dataset' = list( -# 'data_controls_name', -# 'data_controls_import' -# ), -# 'Controls' = list( -# 'data_controls_details', -# 'data_controls_misc' -# ), -# '[-] Data Import' = list( -# 'data_picker' -# ) -# ) -# ) - - diff --git a/inst/modules/overview_viewer_3d/comp.R b/inst/modules/overview_viewer_3d/comp.R index 85aaac5..aecddbb 100644 --- a/inst/modules/overview_viewer_3d/comp.R +++ b/inst/modules/overview_viewer_3d/comp.R @@ -25,118 +25,132 @@ module_id <- 'overview_viewer_3d' # >>>>>>>>>>>> Start ------------- [DO NOT EDIT THIS LINE] --------------------- +load_scripts(rlang::quo({ DEBUG = FALSE }), + 'inst/modules/overview_viewer_3d/reactives.R', + 'inst/modules/overview_viewer_3d/outputs.R', + asis = TRUE) -# ---------------------- Initializing Global variables ----------------------- -load_scripts( - get_path('inst/modules/overview_viewer_3d/reactive_inputs.R'), - get_path('inst/modules/overview_viewer_3d/io.R'), - rlang::quo({ - - - # observe({ - # if(length(local_data$gen_3d)){ - # local_data$update_viewer_btn - # isolate(update_data()) - # print(local_data$gen_3d) - # local_data[['__update']] = Sys.time() - # } - # - # }) - - }) - -) define_initialization({ project_name = subject$project_name - current_subject = subject$subject_code - all_subjects = rave::get_subjects(project_name) - + current_subject_code = subject$subject_code + all_subject_code = rave::get_subjects( project_name ) + project_dir = normalizePath(file.path(subject$dirs$rave_dir, '../../')) }) -# --------------------------------- Inputs ----------------------------------- -# Define inputs -define_input( - definition = selectInput( - inputId = 'SURFACE_TYPES', label = 'Surface Type(s)', - choices = c('pial', 'white', 'smoothwm'), - multiple = TRUE, selected = 'pial'), - init_args = 'selected', - init_expr = { - selected = 'pial' - } -) +# --------------------------------- Inputs ----------------------------------- define_input( - definition = selectInput(inputId = 'SUBJECTS', label = 'Subject(s)', choices = '', multiple = TRUE), + definition = shiny::selectInput( + inputId = 'subject_codes', label = 'Subject', choices = '', + selected = character(0), multiple = TRUE), init_args = c('choices', 'selected'), init_expr = { - choices = all_subjects - selected = current_subject + choices = all_subject_code + selected = cache_input('subject_codes', current_subject_code) } ) define_input( - definition = checkboxInput(inputId = 'load_n27', label = 'Force to load N27 brain.', value = FALSE) -) - -define_input( - definition = customizedUI('subject_checks') -) - -define_input( - definition = rave::actionButtonStyled('gen_3d', label = 'Generate 3D viewer', type = 'success') + definition = shiny::selectInput( + inputId = 'surface_types', label = 'Additional Surface Types', + choices = c('white', 'smoothwm', 'inf_200', 'pial-outer-smoothed', 'sphere', 'inflated'), + selected = character(0), multiple = TRUE), + init_args = c('selected'), + init_expr = { + selected = cache_input('surface_types', character(0)) + } ) +define_input(definition = shiny::checkboxInput(inputId = 'use_template', label = 'Use Template Brain', value = FALSE)) +define_input(definition = rave::actionButtonStyled(inputId = 'viewer_result_btn2', type = 'success', 'Update Viewer', width = '100%')) +# Add csv file define_input( - definition = fileInput('DATA_FILE', label = 'Data File', multiple = FALSE) + definition = shiny::fileInput('csv_file', label = 'Upload a csv Data File', accept = 'text/csv', multiple = TRUE) ) +define_input(definition = customizedUI('file_check', width = '100%')) define_input( - definition = customizedUI('data_checks') + definition = shiny::selectInput('data_files', label = 'Data Files', choices = NULL, selected = character(0), multiple = TRUE), + init_args = c('choices', 'selected'), + init_expr = { + # Find all csvs + choices = find_csv( project_dir, NULL ) + local_env$csv_files = choices + selected = cache_input('data_files', character(0)) + } ) -define_input( - definition = actionButtonStyled('viewer_update_btn', 'Update Viewer', type = 'info') -) -define_input( - definition = customizedUI('viewer_inputs3') -) +define_input_3d_viewer_generator('viewer_result', label = 'Open viewer in a new tab', reactive = 'local_data') + + input_layout = list( - 'Surfaces' = list( - c('SURFACE_TYPES', 'SUBJECTS'), - 'load_n27', - 'subject_checks', - 'gen_3d' + 'Subject & Surfaces' = list( + c('subject_codes'), + c('surface_types'), + c('use_template'), + 'viewer_result_btn2' ), - 'Data' = list( - 'DATA_FILE', - 'data_checks', - 'viewer_update_btn' + 'Data Source' = list( + c('data_files'), + c('csv_file'), + c('file_check') ), - 'Share' = list('viewer_inputs3') + 'Misc' = list( + c('viewer_result', 'viewer_result_ui') + ) ) +manual_inputs = c('subject_codes', 'surface_types', 'use_template', 'csv_file', 'viewer_result_download') + # End of input # ---------------------------------- Outputs ---------------------------------- -# Define Outputs +#' Define Outputs +# define_output_3d_viewer(outputId = 'viewer_result', title = 'Embedded Viewer', +# order = 1, width = 12, hide_btn = TRUE, height = '82vh') define_output( - definition = customizedUI('viewer_wrapper'), + definition = rave::customizedUI('viewer_result_out_ui'), title = 'Viewer', width = 12L, order = 1 ) +define_output( + definition = rave::customizedUI('electrode_details'), + title = 'Details', + width = 4L, + order = 3 +) + +define_output( + definition = rave::customizedUI('electrode_table_ui'), #DT::dataTableOutput('electrode_table'), + title = 'Combined Data File', + width = 8, + order = 2 +) + +# output_layout = list( +# width = 12L, +# 'Outputs' =list( +# 'Data Table' = list( +# 'electrode_details', 'viewer_result_out_ui' +# ), +# '3D Viewer' = list( +# 'electrode_table' +# ) +# ) +# ) + # <<<<<<<<<<<< End ----------------- [DO NOT EDIT THIS LINE] ------------------- diff --git a/inst/modules/overview_viewer_3d/import.R b/inst/modules/overview_viewer_3d/import.R deleted file mode 100644 index 9d98902..0000000 --- a/inst/modules/overview_viewer_3d/import.R +++ /dev/null @@ -1,176 +0,0 @@ -# In charge of 'Data Import' section - - -data_controls_import = function(){ - # react to input$mask_name - local_data$mask_loaded - mask_name = input$mask_name - nms = ls(env$masks) - if(!length(mask_name)){ - mask_name = '_Blank' - } - if(mask_name %in% nms){ - mask = env$masks[[mask_name]] - if(check_mask_format(mask)){ - # generate summary info - tags$ul( - tags$li('Name: ', mask$name), - tags$li('# of variables/time points: ', length(mask$header)), - tags$li('Type: ', mask$type), - tags$li('# of electrodes: ', length(mask$electrodes)), - tags$li('Valid electrodes: ', deparse_selections((mask$electrodes)[mask$valid])) - ) -> - ui - local_data$refresh_controller = Sys.time() - return(ui) - } - - if(mask_name %in% .preserved || is.null(mask)){ - return( - actionButton(ns('do_get_data'), 'Load Data') - ) - } - } -} - -observeEvent(input$do_get_data, { - mask_name = input$mask_name - m = str_trim(unlist(str_split(str_to_lower(mask_name), ','))) - di = list( - 'power' = 'power', - 'voltage' = 'volt', - 'phase' = 'phase' - ) - - showNotification(p('loading'), type = 'message', id = ns(.module_id)) - - trials = module_tools$get_meta('trials') - - mask = get_data(di[[m[1]]], referenced = (m[2] == 'referenced'), frequencies = preload_info$frequencies, trial_num = trials$Trial) - - env$masks[[mask_name]] = mask - showNotification(p('Done!'), type = 'message', id = ns(.module_id), duration = 2) - - local_data$mask_loaded = Sys.time() -}) - -data_picker = function(){ - # name size type datapath - # local_sparse_function.md 2419 text/markdown ... - tagList( - shiny::fileInput( - inputId = ns('file'), - label = 'Upload a file', - multiple = F, - placeholder = '' - ), - shiny::textInput(ns('data_name'), 'Data Name'), - hr(), - div( - div( - style = 'max-width:80px; float:right', - actionLink(ns('import'), 'Import') - ) - ) - ) -} - - -observeEvent(input$file, { - infile = input$file - # check file - if(!is.null(infile)){ - tryCatch({ - name = stringr::str_remove_all(infile$name, '(\\..*$)|[\\W_]') - header = unlist(read.csv(infile$datapath, header = F, row.names = 1, stringsAsFactors = F, nrows = 1)) - body = read.csv(infile$datapath, header = F, row.names = 1, stringsAsFactors = F, skip = 1) - names(header) = NULL - - electrodes = as.integer(row.names(body)) - - sel = electrodes %in% subject$filter_all_electrodes(electrodes) - body = body[sel, ] - electrodes = electrodes[sel] - - if(is.numeric(header)){ - # This is animation and header is keyframes - type = 'animation' - # keyframe always starts from 0 - header = header - min(header) - }else{ - # This is static and header is variable name - type = 'static' - } - - - # env$masks[[name]] - local_data$to_be_imported = list( - name = name, - header = header, - body = body, - type = type, - electrodes = electrodes, - valid = electrodes %in% subject$valid_electrodes, - loaded = electrodes %in% preload_info$electrodes, - cached = FALSE - ) - - updateTextInput(session, 'data_name', value = name) - - # save mask - # module_tools$save_subject_data(data = env$masks, name = 'file_list', path = .module_path) - # local_data$mask_name = name - }, error = function(e){ - print(e) - }) - - } -}) - - - - -observeEvent(input$data_name, { - old = input$data_name - new = stringr::str_remove_all(old, '[\\W_]') - new = stringr::str_sub(new, end = 20) - if(new != old){ - updateTextInput(session, 'data_name', value = new) - } -}) - - -observeEvent(input$import, { - name = input$data_name - name = stringr::str_sub(stringr::str_remove_all(name, '[\\W_]'), end = 20) - current_mask = local_data$to_be_imported - if(is.blank(name)){ - showNotification(p('Name cannot be blank!'), id = ns(.module_id), type = 'error') - }else if(!is.list(current_mask) || is.null(current_mask$cached) || !is.character(current_mask$name)){ - showNotification(p('Invalid mask file! Have you imported any file yet?'), id = ns(.module_id), type = 'error') - }else if(current_mask$cached){ - showNotification(p(sprintf( - 'This mask has already been imported by [%s]', current_mask$name - )), id = ns(.module_id), type = 'message') - updateTextInput(session, 'data_name', value = current_mask$name) - }else{ - # valid mask, import - current_mask$name = name - current_mask$cached = TRUE - env$masks[[name]] = current_mask - local_data$to_be_imported = current_mask - tmp_env = new.env(parent = baseenv()) - tmp_env = rave:::copy_env(env$masks, tmp_env) - tmp_env[['Voltage Referenced']] = NULL - module_tools$save_subject_data( - data = tmp_env, - name = 'file_list', - path = .module_path - ) - local_data$mask_name = name - local_data$refresh_controller = Sys.time() - showNotification(p(sprintf( - 'Import succeed! [%s]', name - )), id = ns(.module_id), type = 'message') - } -}) diff --git a/inst/modules/overview_viewer_3d/io.R b/inst/modules/overview_viewer_3d/io.R deleted file mode 100644 index def97f8..0000000 --- a/inst/modules/overview_viewer_3d/io.R +++ /dev/null @@ -1,243 +0,0 @@ -read_data = function(file){ - tryCatch({ - - dat = read.csv(file, stringsAsFactors = FALSE) - - stopifnot(ncol(dat) >= 4) - - ii = which(names(dat) == 'ProjectName') - - if(ii > 1){ - dat = dat[, -(seq_len(ii-1))] - } - - # columns: ProjectName SubjectCode Electrode ...(values) - cols = names(dat) - stopifnot( - cols[1] == 'ProjectName' && - cols[2] == 'SubjectCode' && - cols[3] == 'Electrode' - ) - - s = read.csv(file, header = F, nrows = 1)[, -(1:3)] - s = unlist(s) - names(s) = NULL - attr(dat, 'col_vars') = s - dat - - }, error = function(e){ - FALSE - }) -} - - -check_subject = function(project_name, subject_code, surface_types){ - data_dir = rave_options('data_dir') - subject_id = paste0(project_name, '/', subject_code) - pretty_id = stringr::str_remove_all(paste0(project_name, subject_code), '[^a-zA-Z0-9]') - viewer_dir = file.path(data_dir, project_name, subject_code, 'rave', 'viewer') - suma_dir = file.path(data_dir, project_name, subject_code, 'rave', 'suma') - - # Check surface_cache - fs = paste0(pretty_id, '_%sh_', surface_types, '.json') - fs = as.vector(sapply(fs, function(f){sprintf(f, c('l','r'))})) - surface_cache = all(file.exists(file.path(viewer_dir, fs))) - - # Check surface_raw (141 asc) - fs = paste0('std.141.%sh.', surface_types, '.asc') - fs = as.vector(sapply(fs, function(f){sprintf(f, c('l','r'))})) - surface_raw = all(file.exists(file.path(suma_dir, fs))) - - # Check transform_cache - transform_cache = file.exists(file.path(suma_dir, 'T1_to_freesurf.txt')) - - # check transform_raw - transform_raw = file.exists(file.path(suma_dir, 'fs_SurfVol_Alnd_Exp+orig.HEAD')) - - # check mapping_cache - tbl = load_meta('electrodes', project_name, subject_code) - cols = c('VertexNumber', 'Subcortical', 'SurfaceType', 'Hemisphere') - mapping_cache = all(cols %in% names(tbl)) && any(tbl$VertexNumber >= 0) - - return( - c(surface_cache || !surface_raw, surface_raw, transform_cache || !transform_raw, transform_raw, mapping_cache) - ) -} - - -data_checks = function(){ - has_data_file = local_data$has_data_file - valid_data = local_data$valid_data - contains_data = local_data$contains_data - - if(!has_data_file){ - return() - } - - if(!valid_data){ - - tbl = data.frame( - ProjectName = project_name, - SubjectCode = c(rep(SUBJECTS[1], 3), '...'), - Electrode = c('1','2','...', ''), - ValueName1 = c('10.2', '2.4', '...', ''), - stringsAsFactors = F - ) - - s = paste0(utils::capture.output({print(tbl)}), collapse = '\n') - - - return(tagList( - hr(), - p( - 'Data file is invalid. It Must be a .csv file, with at least 4 columns and the first three column names need to be ', - strong( - 'ProjectName, SubjectCode, Electrode' - ), " (case sensiitive). For example:" - ), - pre(s) - )) - } - - if(!contains_data){ - ss = input$SUBJECTS - if(!length(ss)){ - return(tagList( - hr(), - p('No subject is to be loaded?') - )) - } - return(tagList( - hr(), - p('Cannot find any data that maches your selections. Either ', - strong('ProjectName'), ' has no ', sprintf('"%s"', project_name), ', or ', - strong('SubjectCode'), ' contains no ', paste(sprintf('"%s"', ss), collapse = ', ')) - )) - } - - # Data is valid, show data parameters - vars = attr(local_data$dat, 'col_vars') - if(is.numeric(vars)){ - ts_data = TRUE - }else{ - ts_data = FALSE - } - - return(tagList( - hr(), - checkboxInput(ns('ts_data'), 'Time Series Data', value = ts_data), - checkboxInput(ns('sym'), 'Symmetric Range', value = get_input('sym', TRUE)), - div( - class = 'rave-grid-inputs', - div( - style = 'flex-basis: 50%', - uiOutput(ns('data_variable')) - ), - div( - style = 'flex-basis: 25%', - numericInput(ns('value_range1'), 'Plot Range: From', value = 0) - ), - div( - style = 'flex-basis: 25%', - numericInput(ns('value_range2'), '- To', value = 0) - ) - # TODO: add color picker or even have descrete color scheme - ) - - )) -} - -observeEvent(input$sym, { - if(isTRUE(input$sym)){ - v1 = input$value_range1; - v2 = input$value_range2 - if(length(v1) && !is.na(v1)){ - updateNumericInput(session, 'value_range1', value = -abs(v1)) - updateNumericInput(session, 'value_range2', value = abs(v1)) - }else if(length(v2) && !is.na(v2)){ - updateNumericInput(session, 'value_range1', value = -abs(v2)) - updateNumericInput(session, 'value_range2', value = abs(v2)) - } - } -}) - -observeEvent(input$value_range1, { - v1 = input$value_range1; - v2 = input$value_range2 - sym = input$sym - if(isTRUE(sym) && length(v1) && !is.na(v1)){ - if(!length(v2) || is.na(v2)){ - updateNumericInput(session, 'value_range1', value = -abs(v1)) - updateNumericInput(session, 'value_range2', value = abs(v1)) - - }else if(v1 + v2 != 0){ - updateNumericInput(session, 'value_range1', value = -abs(v1)) - updateNumericInput(session, 'value_range2', value = abs(v1)) - } - - } -}) - -observeEvent(input$value_range2, { - v2 = input$value_range1 - v1 = input$value_range2 - sym = input$sym - if(isTRUE(sym) && length(v1) && !is.na(v1)){ - if(!length(v2) || is.na(v2)){ - updateNumericInput(session, 'value_range1', value = -abs(v1)) - updateNumericInput(session, 'value_range2', value = abs(v1)) - - }else if(v1 + v2 != 0){ - updateNumericInput(session, 'value_range1', value = -abs(v1)) - updateNumericInput(session, 'value_range2', value = abs(v1)) - } - - } -}) - -output$data_value_range <- renderUI({ - - - if(sym){ - div( - style = 'flex-basis: 50%', - numericInput(ns('value_range_up'), 'Plot Range', value = v_up, min = 0) - ) - }else{ - div( - style = 'flex-basis: 50%', - numericInput(ns('value_range_up'), 'Plot Range', value = v_up, min = 0) - ) - } - -}) - - - -output$data_variable <- renderUI({ - vars = attr(local_data$dat, 'col_vars') - ts_data = input$ts_data - - if(ts_data){ - vars = as.numeric(vars) - max = max(vars) - min = min(vars) - var_ui = sliderInput(ns('time'), label = 'Time Range', max = max, min = min, - value = get_input('time', c(min, max))) - }else{ - vars = as.character(vars) - var_ui = selectInput(ns('var'), 'Variable to Visualize', choices = vars, - selected = get_input('var', NULL)) - } - - var_ui -}) - - - - - - - - - diff --git a/inst/modules/overview_viewer_3d/main.R b/inst/modules/overview_viewer_3d/main.R index af1e4f3..1680f5f 100644 --- a/inst/modules/overview_viewer_3d/main.R +++ b/inst/modules/overview_viewer_3d/main.R @@ -8,84 +8,120 @@ mount_demo_subject() init_module(module_id = 'overview_viewer_3d', debug = TRUE) # >>>>>>>>>>>> Start ------------- [DO NOT EDIT THIS LINE] --------------------- -######' @auto=TRUE -# Check all the data -mis_terms = c('Surface cache', 'Surface files', 'Transform matrix', 'Surface volume file', 'Mapping to template') +# Step 1. collect variables needed +subject_codes = unique(c(subject$subject_code, subject_codes)) +project_name = subject$project_name +local_data$current_subjecct = subject$subject_code +local_data$current_project = project_name +project_dir = normalizePath(file.path(subject$dirs$rave_dir, '../../')) + +# Step 2. Read all csv files and combine them +local_env$tables = list() +selected_paths = lapply(data_files, function(p){ + path = normalizePath(file.path(project_dir, '_project_data', '3dviewer', p), mustWork = FALSE) + if(!file.exists(path)){ return() } + + # Read in path + tryCatch({ + dat = read.csv( path , stringsAsFactors = FALSE ) + nms = names(dat) + if( !nrow(dat) ){ return() } + + # 1. Electrode + if( !'Electrode' %in% nms ){ return() } + + # 2. Subject + if( !'Subject' %in% nms ){ + # try to guess subject code from p + subcode = unlist(stringr::str_split(p, '[\\\\/_]'))[[1]] + if( !subcode %in% subject_codes ){ return() } + dat$Subject = subcode + } + + # 3. project + if( 'Project' %in% nms ){ + dat = dat[dat$Project %in% subject$project_name, ] + } + dat$Project = subject$project_name + + # 4. Time + if( 'Time' %in% nms ){ + dat$Time = as.numeric(dat$Time) + dat = dat[!is.na(dat$Time), ] + }else{ + dat$Time = 0 + } + + local_env$tables[[ path ]] = dat + return(path) + }, error = function(e){ + NULL + }) +}) + +selected_paths = unlist( selected_paths ) +# Find table names +table_headers = lapply(selected_paths, function(path){ names(local_env$tables[[ path ]]) }) +table_headers = unique( unlist( table_headers ) ) +table_headers = c('Project', 'Subject', 'Electrode', 'Time', + table_headers[!table_headers %in% c('Project', 'Subject', 'Electrode', 'Time')]) + +elec_value_table = structure(lapply(table_headers, function(x){NULL}), + names = table_headers, class = 'data.frame') + +# This can't be a file path +local_env$tables[['#$..^']] = elec_value_table +combined_table = do.call('rbind', lapply(c('#$..^', selected_paths), function(path){ + re = local_env$tables[[ path ]] + if( !is.data.frame(re) || !nrow(re)){ return( NULL ) } # this cannot happen but just in case + for( nm in table_headers[!table_headers %in% names(re)] ){ + re[[nm]] = NA + } + re +})) -has_subject = length(SUBJECTS) > 0 -multiple_subject = load_n27 || length(SUBJECTS) > 1 +print(names(local_env$tables)) -has_surface = length(SURFACE_TYPES) > 0 +# Step 3. generate combined csv tables +combined_table = combined_table[, table_headers] -local_data$has_subject = has_subject -local_data$has_surface = has_surface -######' -checks = sapply(SUBJECTS, function(s){ - res = check_subject(project_name, s, SURFACE_TYPES) - - missing_files = paste(mis_terms[c(2,4)][!res[c(2,4)]], collapse = ', ') - if(missing_files != ''){ - missing_files = tags$li(strong(s), missing_files) - }else{ - missing_files = NULL - } - if(multiple_subject){ - missing_cache = paste(mis_terms[c(1,3,5)][!res[c(1,3,5)]], collapse = ', ') - }else{ - missing_cache = paste(mis_terms[c(1,3)][!res[c(1,3)]], collapse = ', ') - } - if(missing_cache != ''){ - missing_cache = tags$li(strong(s), missing_cache) - }else{ - missing_cache = NULL - } - - list( - subject_code = s, - result = res, - missing_files = missing_files, - missing_cache = missing_cache - ) -}, USE.NAMES = T, simplify = F) - -miss_f = any(vapply(checks, function(x){ !is.null(x$missing_files) }, FUN.VALUE = FALSE)) -miss_c = any(vapply(checks, function(x){ !is.null(x$missing_cache) }, FUN.VALUE = FALSE)) - -local_data$file_checks = checks -local_data$miss_f = miss_f -local_data$miss_c = miss_c - -######' - -# load data -has_data_file = FALSE -valid_data = FALSE -contains_data = FALSE -dat = NULL - -if(length(DATA_FILE) && length(DATA_FILE$datapath)){ - has_data_file = TRUE - dat = read_data(DATA_FILE$datapath) - if(is.data.frame(dat)){ - dat = dat[dat$ProjectName == project_name & dat$SubjectCode %in% SUBJECTS, ] - valid_data = TRUE - if(nrow(dat)){ - contains_data = TRUE - } +# Step 4. collect freesurfer data +progress = rave::progress('Importing from FreeSurfer files', max = length(subject_codes) + 1) +on.exit({ progress$close() }) + +progress$inc('Initializing...') +brain = lapply(subject_codes, function(subject_code){ + progress$inc(sprintf('Import %s (might take a while)', subject_code)) + check_result = rave:::check_subjects2(project_name = project_name, + subject_code = subject_code, quiet = TRUE) + if( check_result$check$rave_dir ){ + sub = rave::Subject$new(project_name = project_name, subject_code = subject_code, strict = FALSE) + return(rave::rave_brain2(sub, surfaces = surface_types)) } + return(NULL) +}) + +# Step 5. if template, use it +brain = rave::dropNulls(brain) +if( isTRUE(use_template) || length(brain) > 1 ){ + brain = threeBrain::merge_brain(.list = brain) +}else if(length(brain)){ + brain = brain[[1]] } -local_data$dat = dat -local_data$has_data_file = has_data_file -local_data$valid_data = valid_data -local_data$contains_data = contains_data +if( 'R6' %in% class(brain) && is.data.frame(combined_table) && nrow(combined_table) ){ + brain$set_electrode_values(combined_table) +} -######' -local_data$force_update = Sys.time() +# Step 6. refresh UI +local_data$viewer_result = Sys.time() +# shiny::validate( +# shiny::need(length(brain), message = 'Cannot find any Brain object') +# ) # <<<<<<<<<<<< End ----------------- [DO NOT EDIT THIS LINE] ------------------- diff --git a/inst/modules/overview_viewer_3d/outputs.R b/inst/modules/overview_viewer_3d/outputs.R new file mode 100644 index 0000000..320dfaa --- /dev/null +++ b/inst/modules/overview_viewer_3d/outputs.R @@ -0,0 +1,205 @@ +# outputs + +electrode_table_ui <- function(){ + # shiny::validate( + # shiny::need(exists('combined_table') && is.data.frame(combined_table), + # message = 'No table imported.') + # ) + local_data$viewer_result + + if( !(exists('combined_table') && is.data.frame(combined_table)) ){ + return(div( + class = "shiny-output-error shiny-output-error-shiny.silent.error shiny-output-error-validation", + 'No table imported' + )) + } + + div( + style='min-height: 520px;', + checkboxInput(ns('table_show_all'), 'Show all', value = cache_input('table_show_all', val = FALSE)), + DT::dataTableOutput(ns('electrode_table')) + ) +} + +output$electrode_table <- DT::renderDataTable({ + local_data$viewer_result + shiny::validate( + shiny::need(exists('combined_table') && is.data.frame(combined_table), + message = 'No table imported.') + ) + + tbl = combined_table + click_info = input$viewer_result_out_mouse_dblclicked + if( !isTRUE(input$table_show_all) && is.list(click_info) && isTRUE(click_info$is_electrode)){ + sub = click_info$subject + elec = click_info$electrode_number + + tbl = combined_table[combined_table$Electrode %in% elec & combined_table$Subject %in% sub, ] + } + + DT::datatable(tbl, options = list( + scrollX = TRUE, + lengthMenu = c(10, 25, 100) + )) +}) + + + + +viewer_result_fun <- function(...){ + + # Assume brain is given + shiny::validate( + shiny::need(length(brain), message = 'Cannot find any Brain object') + ) + + client_size = get_client_size() + side_width = ceiling((client_size$available_size[[2]] - 300) / 3) + + brain$plot(side_width = min(side_width, 300), debug = DEBUG) +} + +viewer_result_out_ui <- function(){ + client_size = get_client_size() + client_height = client_size$available_size[[2]] - 200 + client_height = sprintf('%.0fpx', client_height) + htmltools::div( + style = 'margin:-10px;', + threeBrain::threejsBrainOutput(ns('viewer_result_out'), width = '100%', height = client_height) + ) +} + +electrode_details <- function(){ + # listen to dblclick information + + click_info = input$viewer_result_out_mouse_dblclicked + + if( !isTRUE(click_info$is_electrode) ){ + return(div( + class = "shiny-output-error shiny-output-error-shiny.silent.error shiny-output-error-validation", + 'Please double click an electrode' + )) + } + + local_data$click_info = click_info + # This is a electrode, display the information + keyframes = click_info$object$keyframes + varnames = names(keyframes) + varnames = varnames[!varnames %in% c( + '[Hightlight]', '[Subject]', '[No Color]', 'X', 'Project', 'Subject' + )] + if( !length(varnames) ){ + return(div( + class = "shiny-output-error shiny-output-error-shiny.silent.error shiny-output-error-validation", + 'No value found' + )) + } + + current_clip = shiny::isolate( local_data$detail_type ) + if( !length(current_clip) || !current_clip %in% varnames ){ + current_clip = varnames[1] + } + + re = get_electrode_info(brain = brain, subject_code = click_info$subject, + electrode = click_info$electrode_number, keyframe = '') + + re = tagList( + selectInput(ns('detail_type'), sprintf('Variable - %s (%s)', re$name, re$group), choices = varnames, selected = current_clip), + shiny::uiOutput(ns('detail_ui')) + ) +} + + +output$detail_ui <- renderUI({ + dtype = local_data$detail_type + click_info = local_data$click_info + + re = get_electrode_info(brain = brain, subject_code = click_info$subject, + electrode = click_info$electrode_number, keyframe = dtype) + + div( + style = 'margin:0 -10px -10px -10px;', + shiny::plotOutput(ns('detail_plot'), height = '460px') + ) +}) + +get_electrode_info <- function(brain, subject_code, electrode, keyframe){ + is_multiple = !is.null(brain$template_subject) + if( is_multiple ){ + brain = brain$objects[[ subject_code ]] + } + if(is.null(brain)){ return() } + el = brain$electrodes$objects[[electrode]] + if( is.null(el) ){ return(NULL) } + + row = subject$electrodes[subject$electrodes$Electrode == electrode, ] + + kf = el$keyframes[[ keyframe ]] + + re = list( + name = el$name, + group = row$Group + ) + + if( !is.null(kf) ){ + re$is_continuous = kf$is_continuous + re$time_range = kf$time_range + re$value_names = kf$value_names + re$value_range = kf$value_range + } + re +} + +output$detail_plot <- renderPlot({ + dtype = local_data$detail_type + click_info = local_data$click_info + if( length(dtype) != 1 || !is.list(click_info) ){ + return() + } + assign('click_info', click_info, envir = globalenv()) + + keyframes = click_info$object$keyframes + plot_data = keyframes[[ dtype ]] + + if( is.null(plot_data) ){ + return() + } + + + time = unlist(plot_data$time) + value = unlist(plot_data$value) + + if(plot_data$data_type != 'continuous'){ + info = get_electrode_info(brain = brain, subject_code = click_info$subject, electrode = click_info$electrode_number, keyframe = dtype) + + if( !is.factor(info$value_names) ){ + level = levels(as.factor(info$value_names)) + }else{ + level = levels(info$value_names) + } + + value = factor(value, levels = level) + rutabaga::plot_clean(time, as.numeric(value), xlab = 'Time', ylab = dtype, + main = click_info$name) + points(time, value, type = 'p', pch = 16) + rutabaga::ruta_axis(1, pretty(time)) + rutabaga::ruta_axis(2, value) + }else{ + if( length(value) > 20){ + tp = 'b' + }else{ + tp = 'l' + } + rutabaga::plot_clean(time, value, xlab = 'Time', ylab = dtype, + main = click_info$name) + points(time, value, type = tp, pch = 16) + rutabaga::ruta_axis(1, pretty(time)) + rutabaga::ruta_axis(2, pretty(value)) + } + +}) + + +observeEvent(input$detail_type, { + local_data$detail_type = input$detail_type +}) diff --git a/inst/modules/overview_viewer_3d/reactive_inputs.R b/inst/modules/overview_viewer_3d/reactive_inputs.R deleted file mode 100644 index 3f9ff3d..0000000 --- a/inst/modules/overview_viewer_3d/reactive_inputs.R +++ /dev/null @@ -1,270 +0,0 @@ -input = getDefaultReactiveInput() -output = getDefaultReactiveOutput() -session = getDefaultReactiveDomain() -local_data %?<-% reactiveValues() - -get_input = function(key, default = NULL){ - v = isolate(local_data[[key]]) - if(!length(v)) v = default - return(v) -} - -observe({ - # move "EVERYTHING" from input to local_data - input_inst = reactiveValuesToList(input) - for(nm in names(input_inst)){ - local_data[[nm]] = input_inst[[nm]] - } -}, priority = 998L) - -subject_checks <- function(){ - local_data$force_update - - miss_f = local_data$miss_f - miss_c = local_data$miss_c - checks = local_data$file_checks - has_surface = local_data$has_surface - has_subject = local_data$has_subject - - if(!length(has_subject) || !has_subject){ - return(p( - strong('Please select at least one subject!') - )) - } - if(!has_surface){ - return(p( - strong('Please select at least one surface type!') - )) - } - - ui1 = NULL - if(miss_f){ - ui1 = p( - strong('The following subject(s) have missing files:'), - tags$ul( - tagList( - lapply(checks, '[[', 'missing_files') - ) - ) - ) - } - ui2 = NULL - if(miss_c){ - ui2 = p( - strong('The following subject(s) have missing cache/calculation:'), - tags$ul( - tagList( - lapply(checks, '[[', 'missing_cache') - ) - ) - ) - } - - if(miss_f){ - btn = tags$small('You can still generate 3D viewer with missing files. However, the viewer might not be complete.') - }else if(miss_c){ - btn = tags$small("Don't worry, RAVE will calculate them for you") - }else{ - btn = tags$small("You are good to go!") - } - - tagList( - ui1, ui2, p(btn) - ) - -} - - - - -# assign values load mesh -# observeEvent(list(input$viewer_update_btn, input$gen_3d), { -# re = update_data() -# if(is.list(re)){ -# re$brain$view(value_range = re$value_range, time_range = re$time_range) -# }else{ -# NULL -# } -# }) - - - - - -viewer_wrapper = function(){ - threeBrain::threejsBrainOutput(ns('viewer'), height = '85vh') -} - - -output$viewer <- threeBrain::renderBrain({ - - input$viewer_update_btn - input$gen_3d - - tryCatch({ - re = isolate(update_data()) - local_data$last_brain = re$brain - - re$brain$view(value_range = re$value_range, time_range = re$time_range) - # local_env$brain$view( value_range = value_range, time_range = time_range ) - - - }, error = function(e){ - msg = 'Please click button "generate 3D viewer" to start' - cond = structure(list(message = msg), - class = c("shiny.silent.error", "validation", "error", "condition")) - local_data$last_brain = re$brain - stop(cond) - }) - - - -}) - - - - - -update_data = function(){ - # multiple_subject SUBJECTS SURFACE_TYPES - has_subject = local_data$has_subject - has_surface = local_data$has_surface - - if(!length(has_subject) || !has_subject || !has_surface){ - return() - } - checks = local_data$file_checks - - prog = rave::progress('Generating 3D Viewer', max = 3) - - if(multiple_subject){ - - prog$inc('Check mappings') - lapply(checks, function(x){ - # list( - # subject_code = s, - # result = res, - # missing_files = missing_files, - # missing_cache = missing_cache - # ) - if( !x$result[5] ){ - # need to create cache for the subject (map to template brain) - subject_id = paste0(project_name, '/', x$subject_code) - brain = rave_brain2(surfaces = SURFACE_TYPES, multiple_subject = F) - try({ - brain$calculate_template_brain_location(subject = subject_id) - }) - - } - }) - - prog$inc('Check/Download N27 brain') - brain = rave_brain2(multiple_subject = multiple_subject, surfaces = SURFACE_TYPES) - }else{ - prog$inc('Importing') - brain = rave_brain2(multiple_subject = multiple_subject, surfaces = SURFACE_TYPES) - } - - ts_data = local_data$ts_data - dat = local_data$dat - vars = attr(dat, 'col_vars') - - - if(is.null(ts_data)){ - time_range = NULL - col_sel = NULL - }else if (ts_data){ - time_range = get_input('time', NULL) - vars = as.numeric(vars) - col_sel = rutabaga::is_within(vars, time_range) - }else{ - var = get_input('var', NULL) - var = as.character(vars) - time_range = NULL - col_sel = vars == var - } - - value_range = c( - get_input('value_range1', NULL), - get_input('value_range2', NULL) - ) - if(length(value_range) != 2 || any(is.na(value_range)) || value_range[1] >= value_range[2]){ - value_range = NULL - } - - - for(sub in SUBJECTS){ - try({ - subj = Subject$new(project_name = project_name, subject_code = sub, strict = F) - brain$load_electrodes(subject = subj) - brain$load_surfaces(subject = subj) - - # try to load subject data - idx = which(col_sel) + 3 - subset = dat[dat$SubjectCode == sub, ] - if(nrow(subset)){ - for(ii in seq_len(nrow(subset))){ - row = subset[ii, ] - - if(ts_data){ - value = as.numeric(row[, -(1:3)]) - time = vars - }else{ - value = as.numeric(row[, idx]) - time = seq_along(value) - } - - brain$set_electrode_value(subj, electrode = row$Electrode, value = value, time = time) - } - } - - }, silent = T) - } - - - prog$close() - - return(list( - brain = brain, - value_range = value_range, - time_range = time_range - )) - -} - - - -viewer_inputs3 = function(){ - if(is.null(local_data$last_brain)){ - return(p( - 'No valid brain widget found!' - )) - } - tagList( - textInput(ns('export_title'), 'Widget Title', value = get_input('export_title', '3D Viewer')), - downloadLink(ns('export_btn'), 'Download Viewer') - ) -} - - -output$export_btn <- downloadHandler( - filename = 'viewer.zip', - content = function(file){ - tryCatch({ - showNotification(p('Generating in progress. This may take a while... '), duration = NULL, id = ns('viewer_export_noti'), type = 'message') - brain = isolate(local_data$last_brain) - title = isolate(input$export_title) - tmp_dir = file.path(tempdir(), paste(sample(c(letters, 0:9), 17), collapse = '')) - re = brain$save_brain(directory = tmp_dir, title = title, as_zip = T) - file.copy(re$zipfile, file) - unlink(tmp_dir, recursive = TRUE, force = TRUE) - }, error = function(e){ - cat2(e, level = 'WARNING') - }, finally = { - try({ - removeNotification(id = ns('viewer_export_noti')) - }) - - }) - } -) diff --git a/inst/modules/overview_viewer_3d/reactives.R b/inst/modules/overview_viewer_3d/reactives.R index 5508c0f..ac81814 100644 --- a/inst/modules/overview_viewer_3d/reactives.R +++ b/inst/modules/overview_viewer_3d/reactives.R @@ -1,237 +1,118 @@ -session = getDefaultReactiveDomain() +local_env = new.env(parent = emptyenv()) input = getDefaultReactiveInput() -output = getDefaultReactiveOutput() -local_data = reactiveValues( - mask_name = NULL, - to_be_imported = NULL -) -env = new.env() -env$masks = new.env(parent = baseenv()) -.module_path = 'Viewer3D' -.module_id = 'viewer_3d' -bgcolor = '#ffffff' -mouse_control = 'trackball' - - +session = getDefaultReactiveDomain() +local_data = reactiveValues() +local_env$tables = list() -data_controls_name = function(){ - local_data$refresh_controller - name = local_data$mask_name - if(!length(name) == 1 || !name %in% names(as.list(env$masks))){ - name = NULL - } - local_data$refresh_control_pane = Sys.time() - selectInput(ns('mask_name'), 'Select a Dataset for Visualization', choices = c('_Blank', names(as.list(env$masks))), selected = name) -} -data_controls_misc = function(){ - tagList( - checkboxInput(ns('col_sym'), 'Symmetric Color', value = T), - downloadLink(ns('export'), 'Download 3D Viewer') - ) +find_csv <- function( project_dir, scodes ){ + scodes = '_project_data/3dviewer' #c('_project_data/3dviewer', scodes) + # find all csv files within project folder + res = lapply( scodes, function(scode){ + root_dir = file.path(project_dir, scode) + fs = list.files(root_dir, pattern = '\\.[cC][sS][vV]$', all.files = TRUE, recursive = TRUE) + fs + }) + + unlist(res) } -output$export <- downloadHandler( - filename = function(){ - 'rave_3d_viewer.html' - }, - content = function(con){ - showNotification(p('Generating... This will take a while'), type = 'message', duration = NULL, id = ns(.module_id)) - htmlwidgets::saveWidget(viewer(), con) - showNotification(p('Done!'), type = 'message', id = ns(.module_id), duration = 5) - } -) - -data_controls_details = function(){ - local_data$refresh_control_pane - name = local_data$mask_name - name %?<-% '_Blank' - ui = NULL - if(name %in% .preserved){ - # mask = env$masks[[name]] - # local_data$controller_data = mask - return(get_ui(name)) - } - if(name %in% names(as.list(env$masks))){ - mask = env$masks[[name]] - local_data$controller_data = mask - if(!is.null(mask)){ - switch( - mask$type, - 'static' = { - ui = tagList( - selectInput(ns('main_var'), 'Display Colours', choices = mask$header), - selectInput(ns('thred_var'), 'Threshold', choices = mask$header), - sliderInput(ns('thred_rg'), 'Range', min = 0, max = 1, value = c(0,1), round = -2L), - selectInput(ns('info_var'), 'Click Info', choices = mask$header, multiple = T, selected = mask$header) - ) - }, - 'animation' = { - ui = tagList() - } - ) - } - } - ui -} - -observe({ - local_data$mask_name = input$mask_name - local_data$col_sym = input$col_sym - local_data$main_var = input$main_var - local_data$thred_var = input$thred_var - local_data$thred_rg = input$thred_rg - local_data$info_var = input$info_var +observeEvent(local_data$current_project, { + local_env$tables = list() }) -observe({ - try({ - mask = local_data$controller_data - if(is.null(mask) || is.null(mask$body)){ - return() - } - thred_var = local_data$thred_var - col = mask$header == thred_var - val = mask$body[, col] - val = as.numeric(val) - val = val[!is.na(val)] - if(length(val)){ - val = range(val, na.rm = T) +# observeEvent(input$viewer_result_btn2, { +# local_data$viewer_result_btn = input$viewer_result_btn2 +# }) - if(val[1] < val[2]){ - val[1] = floor(val[1] * 100) / 100 - val[2] = ceiling(val[2] * 100) / 100 - updateSliderInput(session, 'thred_rg', label = sprintf('Range (%s)', thred_var), min = val[1], max = val[2], value = val, step = 0.001) - } - } - }, silent = T) +observeEvent(local_data$data_files_needUpdate, { + s = local_env$data_files_more + sfs = unique(c(s, shiny::isolate(input$data_files))) + fs = unique(c(sfs, local_env$csv_files)) + local_env$data_files_more = NULL + updateSelectInput(session, 'data_files', choices = fs, selected = sfs) }) -viewer = function(){ - try({ - local_data$controller_data - name = isolate(local_data$mask_name) - name %?<-% '_Blank' - if(name %in% names(as.list(env$masks))){ - mask = local_data$controller_data - }else{ - mask = NULL - } - mask %?<-% list( - electrodes = NULL, - values = NULL - ) - mask$type %?<-% '_blank' - - col_sym = local_data$col_sym - col_sym %?<-% T - - marker = apply(subject$electrodes, 1, function(x){ - as.character(p( - tags$small(sprintf( - '%s, %s', x['Group'], x['Type'] - )) - )) - }) - - switch (mask$type, - '_blank' = { - return( - module_tools$plot_3d_electrodes( - tbl = subject$electrodes, - # marker = marker, - # fps = 1, - # loop = F, - control_gui = T - # background_colors = c(bgcolor, '#000000'), - # control = mouse_control - ) - ) - - }, - 'static' = { - main_var = local_data$main_var - thred_var = local_data$thred_var - # thred_rg = local_data$thred_rg - thred_rg %?<-% c(-Inf, Inf) - info_var = local_data$info_var - body = mask$body[order(mask$electrodes), ] - mask$electrodes = sort(mask$electrodes) - - # thred value - values = as.numeric(body[, mask$header == main_var]) - t_vals = as.numeric(body[, mask$header == thred_var]) - sel = !is.na(t_vals) & t_vals %within% thred_rg & (mask$electrodes %in% subject$filter_all_electrodes(mask$electrodes)) - - body = mask$body[sel, ] - values = values[sel] - electrodes = mask$electrodes[sel] - if(length(info_var)){ - # marker should be shown even the electrode is filtered out - sapply(info_var, function(v){ - mk = unlist(mask$body[, mask$header == v]) - if(is.numeric(mk)){ - # mk = sprintf('%.4f', mk) - mk = prettyNum(mk, digits=4, format="fg") - } - sapply(mk, function(x){ - as.character( - tags$li(tags$label(v), ' ', x) - ) - }) - }) -> - tmp - apply(tmp, 1, function(x){ - as.character( - div( - tags$ul(HTML(x)) - ) - ) -> - s - str_remove_all(s, '\\n') - }) -> - tmp - in_mask = subject$electrodes$Electrode %in% mask$electrodes - marker[in_mask] = str_c( - marker[in_mask], - tmp - ) - }else{ - marker = NULL - } - return( - module_tools$plot_3d_electrodes( - electrodes = electrodes, - values = values,key_frame = 0, - marker = marker, - control_gui = T - ) - ) - - }, - 'animation' = { - return( - module_tools$plot_3d_electrodes( - electrodes = mask$electrodes, - key_frame = mask$header, - values = t(mask$body), - control_gui = T - ) - ) +observeEvent(input$show_example, { + s = shiny::isolate(local_data$show_example) + s = !isTRUE(s) + local_data$show_example = s +}) - } +file_check <- function(){ + + show_example = get_val(local_data$show_example, default = FALSE) + + if( show_example ){ + tbl = data.frame( + Project = subject$project_name, + Subject = subject$subject_code, + Electrode = c('1','1','2','3', '...'), + Time = c('0','0.2','0','1', '...'), + Value1 = c(sprintf('%.2f', rnorm(4)), '...'), + Value2 = c(letters[1:4], '...') ) - }, silent = T) - - - + xtbl = knitr::kable( + tbl, format = 'html', digits = 2, table.attr = "class='table-striped', style='width:100%'", + caption = 'An example of csv file. "Subject" and "Electrode" are mandatory. Column names are case sensitive.' + ) + + tagList( + actionLink(ns('show_example'), label = 'Hide example'), + hr(), + div( + style = 'overflow-x: scroll;', + htmltools::HTML(xtbl) + ) + ) + }else{ + actionLink(ns('show_example'), label = 'Show example') + } + } - - - +observeEvent(input$csv_file, { + print(input$csv_file) + files = input$csv_file + # Read in csv file + lapply(seq_len(nrow(files)), function(ii){ + file_info = files[ii, ] + + notif = p('Cannot read ', htmltools::strong(file_info$name), '. Invalid csv table file.') + + tryCatch({ + dat = read.csv(file_info$datapath, stringsAsFactors = FALSE) + if(!all( c('Electrode', 'Subject') %in% names(dat) )){ + notif = p('Table ', htmltools::strong(file_info$name), ' MUST has columns ', htmltools::strong('"Subject"'), '(character) and ', htmltools::strong('"Electrode"'), '(integer), case sensitive.') + stop() + } + + dest_dir = file.path(subject$dirs$rave_dir, '../../_project_data/3dviewer/') + dir.create(dest_dir, showWarnings = FALSE, recursive = TRUE) + + fname = file_info$name + save_path = file.path(dest_dir, file_info$name) + if( file.exists(save_path) ){ + fname = stringr::str_to_lower(file_info$name) + fname = stringr::str_replace(fname, '\\.csv$', strftime(Sys.time(), '[%y%m%d-%H%M%S].csv')) + save_path = file.path(dest_dir, fname) + } + + utils::write.csv(dat, file = save_path, row.names = FALSE) + + # s = file.path('_project_data', '3dviewer', save_path) + # Force update selected data files + local_env$data_files_more = fname + + local_data$data_files_needUpdate = Sys.time() + }, error = function(e){ + showNotification(notif, type = 'error') + }) + }) + +}) diff --git a/inst/modules/overview_viewer_3d/utils.R b/inst/modules/overview_viewer_3d/utils.R deleted file mode 100644 index d60182e..0000000 --- a/inst/modules/overview_viewer_3d/utils.R +++ /dev/null @@ -1,256 +0,0 @@ -get_ui = function(name){ - mask = env$masks[[name]] - - switch (name, - 'Power, Referenced' = { - freqs = preload_info$frequencies - time = preload_info$time_points - tagList( - selectInput( - ns('power_trials'), - 'Condition', - choices = preload_info$condition, - selected = - cache_input('power_trials', preload_info$condition), - multiple = T - ), - sliderInput( - ns('power_freq'), - 'Frequency', - min = min(freqs), - max = max(freqs), - value = cache_input('power_freq', range(freqs)) - ), - sliderInput( - ns('power_bs'), - 'Baseline', - min = min(time), - max = max(time), - value = cache_input('power_bs', c(-1,0)), - step = 0.01 - ), - actionButton(ns('gen_3d'), 'Generate 3D Animation') - ) - }, - 'Voltage, Referenced' = { - freqs = preload_info$frequencies - time = preload_info$time_points - tagList( - selectInput( - ns('volt_trials'), - 'Condition', - choices = preload_info$condition, - selected = - cache_input('volt_trials', preload_info$condition), - multiple = T - ), - actionButton(ns('gen_3d'), 'Generate 3D Animation') - ) - }, - 'Phase, Raw' = { - freqs = preload_info$frequencies - time = preload_info$time_points - tagList( - selectInput( - ns('phase_trials'), - 'Condition', - choices = preload_info$condition, - selected = - cache_input('phase_trials', preload_info$condition), - multiple = T - ), - selectInput(ns('phase_freq'), 'Frequency', choices = freqs, selected = cache_input('phase_freq', min(freqs))), - actionButton(ns('gen_3d'), 'Generate 3D Animation') - ) - } - ) -} - -observeEvent(input$gen_3d, { - name = local_data$mask_name - mask = env$masks[[name]] - tbl = module_tools$get_meta('trials') - switch ( - name, - 'Voltage, Referenced' = { - cond = input$volt_trials - trial_ind = tbl$Trial[tbl$Condition %in% cond] - if(!length(trial_ind)){ - showNotification(p('Condition cannot be blank'), type = 'error') - return() - }else{ - cache_input('volt_trials', cond, read_only = F) - } - - dat = module_tools$get_voltage(force = T, referenced = T) - dat = dat$subset(Trial = Trial %in% trial_ind, drop = F, data_only = T) - dat = rutabaga::collapse(dat, c(3,2)) / dim(dat)[1] - - mask$body = dat - }, - 'Power, Referenced' = { - cond = input$power_trials - freqs = input$power_freq - bs = input$power_bs - - - trial_ind = tbl$Trial[tbl$Condition %in% cond] - # step 0 check - if(!length(trial_ind)){ - showNotification(p('Condition cannot be blank'), type = 'error') - return() - }else{ - cache_input('power_trials', cond, read_only = F) - } - if(length(bs) != 2 || bs[1] == bs[2]){ - showNotification(p('Baseline is invalid'), type = 'error') - return() - }else{ - cache_input('power_bs', bs, read_only = F) - } - if(sum(preload_info$frequencies %within% freqs)){ - cache_input('power_freq', freqs, read_only = F) - }else{ - showNotification(p('No frequency is found'), type = 'error') - return() - } - progress = progress(title = 'Generating 3D Viewer', max = 4, session = session) - on.exit({progress$close()}, add = T, after = FALSE) - # Step 1, baseline - progress$inc('Calculating Baseline') - - bl = cache(list(bs, preload_info), module_tools$baseline(module_tools$get_power(), from = bs[1], to = bs[2])) - - - progress$inc('Subset...') - mask$electrodes = bl$dimnames$Electrode - bl = bl$subset(Trial = Trial %in% trial_ind, Frequency = Frequency %within% freqs, drop = F, data_only = T) - - progress$inc('Collapse...') - mask$body = apply(bl, c(4,3), median) - # mask$body = rutabaga::collapse(bl, keep = c(4, 3)) / prod(dim(bl)[1:2]) - - - - }, - 'Phase, Raw' = { - cond = input$phase_trials - freq = as.numeric(input$phase_freq) - - tbl = module_tools$get_meta('trials') - trial_ind = tbl$Trial[tbl$Condition %in% cond] - # step 0 check - if(!length(trial_ind)){ - showNotification(p('Condition cannot be blank'), type = 'error') - return() - }else{ - cache_input('phase_trials', cond, read_only = F) - } - - progress = progress(title = 'Generating 3D Viewer', max = 4, session = session) - on.exit({progress$close()}, add = T, after = FALSE) - progress$inc('Loading Phase') - dat = module_tools$get_phase(referenced = F) - - progress$inc('Subset') - dat = dat$subset(Trial = Trial %in% trial_ind, Frequency = Frequency == freq, data_only = T, drop = F) - # foreach timepoints, intercoherent coef - progress$inc('Inter-trial Coherence...') - dat = exp(1i * dat) - # Collapse mean TODO implement rutabaga::collapse to support complex - dat = apply(dat, c(4,3), mean) - dat = Mod(dat) - mask$body = dat - progress$inc('Rendering...') - } - ) - - local_data$controller_data = mask - env$masks[[name]] = mask -}) - - -get_data = function(dt, referenced = T, frequencies, trial_num, ...){ - trials = module_tools$get_meta('trials') - sel = trials$Trial %in% trial_num - - freqs = module_tools$get_meta('frequencies') - fsel = freqs$Frequency %within% frequencies - re = NULL - switch( - dt, - 'phase' = { - dat = module_tools$get_phase(force = T, referenced = referenced) - srate = subject$sample_rate - electrodes = dat$dimnames$Electrode - valid = electrodes %in% subject$valid_electrodes - name = sprintf('Phase, %s', ifelse(referenced, 'Referenced', 'Raw')) - re = list( - name = name, - header = seq_along(preload_info$time_points) / srate, - body = NULL, - type = 'animation', - electrodes = electrodes, - loaded = rep(T, length(electrodes)), - valid = valid, - cached = TRUE - ) - }, - 'volt' = { - dat = module_tools$get_voltage(force = T, referenced = referenced) - srate = subject$preprocess_info('srate') - electrodes = dat$dimnames$Electrode - valid = electrodes %in% subject$valid_electrodes - name = sprintf('Voltage, %s', ifelse(referenced, 'Referenced', 'Raw')) - re = list( - name = name, - header = seq_len(dat$dim[2]) / srate, - body = NULL, - type = 'animation', - electrodes = electrodes, - loaded = rep(T, length(electrodes)), - valid = valid, - cached = TRUE - ) - }, - - 'power' = { - dat = module_tools$get_power(force = T, referenced = referenced) - srate = subject$sample_rate - electrodes = dat$dimnames$Electrode - valid = electrodes %in% subject$valid_electrodes - name = sprintf('Power, %s', ifelse(referenced, 'Referenced', 'Raw')) - re = list( - name = name, - header = seq_len(dat$dim[3]) / srate, - body = NULL, - type = 'animation', - electrodes = electrodes, - loaded = rep(T, length(electrodes)), - valid = valid, - cached = TRUE - ) - } - ) - return(re) -} - - - -check_mask_format = function(mask){ - if(!is.list(mask)){ - return(FALSE) - } - hdiff = setdiff(c("name","header","body","type","electrodes","valid","loaded","cached"), names(mask)) - if(length(hdiff)){ - return(FALSE) - } - # if(!mask$name %in% .preserved && length(mask$header) != ncol(mask$body)){ - # return(FALSE) - # } - if(!mask$type %in% c('static', 'animation', 'null')){ - return(FALSE) - } - return(T) -} - diff --git a/inst/tools/input_widgets.R b/inst/tools/input_widgets.R index 9ca1d00..e17918f 100644 --- a/inst/tools/input_widgets.R +++ b/inst/tools/input_widgets.R @@ -1,3 +1,142 @@ +define_input_3d_viewer_generator <- function( + inputId, label = 'Open viewer in a new tab', button_types = c('primary', 'default'), + download_label = 'Download', download_btn = TRUE, + download_filename = 'rave_viewer.zip', + reactive = 'input' +){ + input_ui = paste0(inputId, '_ui') + input_fun = paste0(inputId, '_fun') + input_download = paste0(inputId, '_download') + outputId = paste0(inputId, '_out') + quo = rlang::quo({ + define_input( definition = actionButtonStyled( + inputId = !!inputId, label = !!label, width = '100%', type = !!button_types[[1]] + ) ) + define_input( definition = rave::customizedUI(!!input_ui) ) + # This is actually an output + load_scripts(rlang::quo({ + + assign(!!input_ui, function(){ + btn_class = c(!!button_types, '')[2] + + if( btn_class != '' ){ + btn_class = paste0('btn-', btn_class) + } + if( !!download_btn ){ + shiny::downloadButton(outputId = ns(!!input_download), label = !!download_label, + style='width:100%', class = btn_class) + }else{ + shiny::downloadLink(outputId = ns(!!input_download), label = !!download_label, + style='width:100%') + } + + }) + + local({ + input %?<-% getDefaultReactiveInput() + if( !!reactive == 'input' ){ + react = input + }else{ + react = get0(!!reactive, ifnotfound = shiny::reactiveValues()) + } + ...widget_env = new.env(parent = emptyenv()) + + # Generate 3D viewer render function + ...fun = function(){ + re = NULL + f = get0(!!input_fun, envir = ..runtime_env, ifnotfound = function(...){ + rutabaga::cat2('3D Viewer', !!outputId, 'cannot find function', !!input_fun, level = 'INFO') + }) + tryCatch({ + re = f() + }, error = function(e){ + rave::logger(e, level = 'ERROR') + }) + re + } + + render_func = function(){ + threeBrain::renderBrain({ + re = NULL + # Render function + if(length( react[[!!inputId]] )){ + re = ...fun() + } + + if('R6' %in% class(re)){ + re = re$plot() + } + ...widget_env$widget = re + re + }) + } + + output %?<-% getDefaultReactiveOutput() + + output[[!!input_download]] = shiny::downloadHandler( + filename = !!download_filename, content = function(con){ + if( !length(...widget_env$widget) ){ + re = ...fun() + }else{ + re = ...widget_env$widget + } + showNotification(p('Generating 3D viewer. Please wait...'), duration = NULL, + type = 'default', id = '...save_brain_widget') + tmp_dir = tempdir() + finfo = threeBrain::save_brain(re, directory = tmp_dir, + title = 'RAVE Viewer', as_zip = TRUE) + on.exit({ unlink( finfo$zipfile ) }) + + showNotification(p('Done!'), type = 'message', id = '...save_brain_widget') + + file.copy(finfo$zipfile, to = con, overwrite = TRUE, recursive = FALSE) + } + ) + + + # Register render function + + # 1. main viewer (if exists) + output[[!!outputId]] <- render_func() + + # 2. side viewers + # Register cross-session function so that other sessions can register the same output widget + session$userData$cross_session_funcs %?<-% list() + # ns must be defined, but in get_module(..., local=T) will raise error + # because we are not in shiny environment + ns %?<-% function(x){x} + session$userData$cross_session_funcs[[ns(!!outputId)]] = render_func + + + observeEvent(input[[!!inputId]], { + + rave_id = session$userData$rave_id + if(is.null(rave_id)){ rave_id = '' } + token = session$userData$token + if(is.null(token)){ token = '' } + globalId = ns(!!outputId) + + query_str = list( + type = '3dviewer', + globalId = htmltools::urlEncodePath(globalId), + sessionId = htmltools::urlEncodePath(rave_id), + token = token + ) + url = paste(sprintf('%s=%s', names(query_str), as.vector(query_str)), collapse = '&') + + shinyjs::runjs(sprintf('window.open("/?%s");', url)) + }) + }) + + })) + }) + + parent_frame = parent.frame() + + rave::eval_dirty(quo, env = parent_frame) +} + + define_input_multiple_electrodes <- function(inputId, label = 'Electrodes'){ quo = rlang::quo({ define_input( From 19f9efce50eb7c9554fa28b6c6fe32359274cc0d Mon Sep 17 00:00:00 2001 From: dipterix Date: Tue, 17 Sep 2019 15:02:04 -0500 Subject: [PATCH 03/24] Fixed 3D viewer in reference module --- inst/modules/channel_reference/comp.R | 5 ++- .../modules/channel_reference/reactive_main.R | 36 ++++++++++++------- 2 files changed, 28 insertions(+), 13 deletions(-) diff --git a/inst/modules/channel_reference/comp.R b/inst/modules/channel_reference/comp.R index 0c28353..c1a2b1d 100644 --- a/inst/modules/channel_reference/comp.R +++ b/inst/modules/channel_reference/comp.R @@ -18,7 +18,8 @@ module_id <- 'channel_reference' # ---------------------- Initializing Global variables ----------------------- load_scripts( get_path('inst/modules/channel_reference/reactive_main.R'), - get_path('inst/modules/channel_reference/common.R') + get_path('inst/modules/channel_reference/common.R'), + asis = TRUE ) define_initialization({ @@ -48,6 +49,8 @@ define_initialization({ } check_load_volt() + brain = rave::rave_brain2(subject) + # Load current brain }) diff --git a/inst/modules/channel_reference/reactive_main.R b/inst/modules/channel_reference/reactive_main.R index bf162fe..4c1de0c 100644 --- a/inst/modules/channel_reference/reactive_main.R +++ b/inst/modules/channel_reference/reactive_main.R @@ -118,32 +118,44 @@ output[['elec_loc']] <- threeBrain::renderBrain({ Group = tbl$Group[sel] Type = tbl$Type[sel] Reference = tbl$Reference[sel] - sprintf('

Reference - %s (%s)
Reference to - %s

', Group, Type, Reference) + sprintf('Group - %s (%s)Reference to - %s', Group, Type, Reference) }) -> marker - values = rep(-1, length(electrodes)) + lev = factor(c('Current Group', 'Bad Electrode')) + values = rep(lev[1], length(electrodes)) bad_electrodes = rave:::parse_selections(input[[('ref_bad')]]) - values[electrodes %in% bad_electrodes] = 1 + values[electrodes %in% bad_electrodes] = lev[2] - brain = rave_brain2(surfaces = 'pial', multiple_subject = F) - brain$load_electrodes(subject) + # brain = rave_brain2(surfaces = 'pial', multiple_subject = F) + # brain$load_electrodes(subject) - if(local_data$load_mesh){ - brain$load_surfaces(subject) - } + # make a table + tbl = data.frame( + Electrode = electrodes, + Type = values, + Note = marker + ) + brain$set_electrode_values( tbl ) - for(ii in seq_along(electrodes)){ - brain$set_electrode_value(subject = subject, electrode = electrodes[[ii]], value = values[[ii]], time = 0, message = marker[[ii]]) + if( isTRUE(local_data$load_mesh) ){ + brain$plot(volumes = FALSE, surfaces = TRUE, side_canvas = FALSE, control_panel = FALSE, palettes = list( + 'Type' = c('red', 'navy') + )) + }else{ + # Maybe load N27 brain if not exists + brain$plot(volumes = FALSE, surfaces = FALSE, side_canvas = FALSE, control_panel = FALSE, palettes = list( + 'Type' = c('red', 'navy') + )) } - brain$view(value_range = c(-1,1), control_panel = F) + # brain$view(value_range = c(-1,1), control_panel = F) }) observeEvent(input$load_mesh, { - load_mesh = isolate(!local_data$load_mesh) + load_mesh = isolate(!isTRUE(local_data$load_mesh)) local_data$load_mesh = load_mesh updateActionButton(session, 'load_mesh', label = ifelse(load_mesh, 'Hide Mesh', 'Show Mesh')) }) From a461a09d9efe53581bde0bc7ebb24be13f530f02 Mon Sep 17 00:00:00 2001 From: dipterix Date: Tue, 17 Sep 2019 15:36:02 -0500 Subject: [PATCH 04/24] a minor fix --- inst/modules/overview_viewer_3d/outputs.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/modules/overview_viewer_3d/outputs.R b/inst/modules/overview_viewer_3d/outputs.R index 320dfaa..bb0f384 100644 --- a/inst/modules/overview_viewer_3d/outputs.R +++ b/inst/modules/overview_viewer_3d/outputs.R @@ -185,7 +185,7 @@ output$detail_plot <- renderPlot({ rutabaga::ruta_axis(1, pretty(time)) rutabaga::ruta_axis(2, value) }else{ - if( length(value) > 20){ + if( length(value) <= 20){ tp = 'b' }else{ tp = 'l' From c7bf7764233620385ca2e2d68116e666dcf4d52d Mon Sep 17 00:00:00 2001 From: dipterix Date: Tue, 17 Sep 2019 16:04:21 -0500 Subject: [PATCH 05/24] Fixed check and docs --- DESCRIPTION | 7 ++++--- NAMESPACE | 3 +++ R/aaa.R | 30 ++++++++++++++++++++++++++++++ R/common_plotting_functions.R | 30 ++++++++++++++++++++---------- man/draw_many_heat_maps.Rd | 2 ++ man/easy_layout.Rd | 3 +-- man/get_palette.Rd | 18 ++++++++++++++++++ man/make_image.Rd | 8 ++++++-- 8 files changed, 84 insertions(+), 17 deletions(-) create mode 100644 man/get_palette.Rd diff --git a/DESCRIPTION b/DESCRIPTION index cfe0faa..4808ff7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -3,14 +3,15 @@ Package: ravebuiltins Type: Package Title: Builtin Modules for `RAVE` Version: 0.1.1 -Description: Provides builtin modules for `RAVE` +Description: This package provides builtin modules for `RAVE`. It aims at analyze + and visualize `iEEG` data from different perspectives. License: MIT + file LICENSE Encoding: UTF-8 LazyData: true RoxygenNote: 6.1.1 Authors@R: c( - person(given = "Zhengjia", family = "Wang", role = "cre", email = "zhengjia.wang@rice.edu"), - person(given = "John", family = "Magnotti", role = "aut", email = "jmagnotti@bcm.edu") + person(given = "Zhengjia", family = "Wang", role = c("cre", "aut"), email = "zhengjia.wang@rice.edu"), + person(given = "John", family = "Magnotti", role = "aut", email = "magnotti@bcm.edu") ) Imports: methods, diff --git a/NAMESPACE b/NAMESPACE index 961d65f..d45839c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -16,9 +16,12 @@ import(rlang) import(rutabaga) import(shiny) import(stringr) +importFrom(grDevices,col2rgb) +importFrom(grDevices,colorRampPalette) importFrom(grDevices,dev.off) importFrom(grDevices,palette) importFrom(grDevices,pdf) +importFrom(grDevices,rgb) importFrom(magrittr,"%$%") importFrom(magrittr,"%<>%") importFrom(magrittr,"%>%") diff --git a/R/aaa.R b/R/aaa.R index e0ad9f7..b31673b 100644 --- a/R/aaa.R +++ b/R/aaa.R @@ -18,6 +18,9 @@ #' @importFrom grDevices dev.off #' @importFrom grDevices pdf #' @importFrom grDevices palette +#' @importFrom grDevices col2rgb +#' @importFrom grDevices colorRampPalette +#' @importFrom grDevices rgb #' #' @import graphics #' @@ -26,6 +29,33 @@ #' @importFrom stats pt #' @importFrom stats quantile #' +NULL + +# Add global variables to pass check +..async_quo = NULL +..async_var = NULL +.palettes = NULL +BASELINE = NULL +FREQUENCY = NULL +Frequency = NULL +TIME_RANGE = NULL +Time = NULL +draw_time_baseline = NULL +is_clean = NULL +label.col = NULL +x = NULL +xax = NULL +xlab = NULL +y = NULL +yax = NULL +ylab = NULL +data = NULL + + + + + + cat2 <- function(..., end = '\n', level = 'DEBUG', print_level = FALSE, pal = list( 'DEBUG' = 'grey60', diff --git a/R/common_plotting_functions.R b/R/common_plotting_functions.R index 194e48c..d304820 100644 --- a/R/common_plotting_functions.R +++ b/R/common_plotting_functions.R @@ -12,6 +12,7 @@ #' so if you draw within the plotting region it will overwrite the heatmap. To fix this requires editing draw_img(...) to allow for a function to be called after creation but before rendering. #' Don't depend on this call order, use PANEL.LAST if you want to draw things on top of the heatmap #' @param PANEL.LAST a function that is called after the rendering of each heat map. It is not called after the rendering of the color bar. +#' @param axes vector of logicals, whether to draw axis #' @description Easy way to make a bunch of heatmaps with consistent look/feel and get a colorbar. #' By default it is setup for time/freq, but by swapping labels and decorators you can do anything. #' @seealso layout_heat_maps @@ -351,12 +352,14 @@ by_electrode_heat_map_decorator <- function(plot_data=NULL, results, Xmap=force, #' @author John Magnotti #' @title RAVE custom image plotter -#' @param zmat z-matrix +#' @param mat z-matrix #' @param x,y z and y axis -#' @param xlab, ylab label for x and y +#' @param col vector of colors, color palette #' @param zlim value to trim zmat #' @param log which axis will be in log scale #' @param useRaster,... passed to image() +#' @param clip_to_zlim whether to clip mat +#' @param add logical, whether to overlay current plot to an existing image #' @description The idea here is to to separate the plotting of the heatmap from all the accoutrements that are done in the decorators. #' We are just plotting image(mat) Rather Than t(mat) as you might expect. The Rave_calculators know this so we can save a few transposes along the way. make_image <- function(mat, x, y, zlim, col, log='', useRaster=TRUE, clip_to_zlim=TRUE, add=TRUE) { @@ -403,7 +406,8 @@ layout_heat_maps <- function(k, ratio=4) { ##RUTABAGA median_ticks <- function(k, .floor=1) c(.floor, ceiling(k/2), k) -`conditional_sep<-` <- function(str, value = '', sep=' ') { +`conditional_sep<-` <- function(str, value = '') { + sep=' ' if(isTRUE(nchar(str) > 0)) { str = paste0(str, sep) } @@ -946,13 +950,16 @@ tf_hm_decorator <- function(hmap, results, ...) easy_layout <- function(K, nrows = 1, legend, legend_size = lcm(3), legend_side = 4, s_margin = par('mar'), b_margin = par('oma'), - l_margin = local({ - mar = s_margin; - mar[legend_side] = 0; - mar[(legend_side + 2) %% 4] = 0.5; - mar - })){ + l_margin){ #TODO RUTABAGA + if(missing( l_margin )){ + l_margin = local({ + mar = s_margin; + mar[legend_side] = 0; + mar[(legend_side + 2) %% 4] = 0.5; + mar + }) + } # calculate nrow and ncols ncols = ceiling(K / nrows) @@ -1065,7 +1072,10 @@ hist.circular <- function(x, ymax, nticks=3, digits=1, breaks=20, col='black', . invisible(x.hist) } -# # # Colors +#' Function to get builtin color palettes +#' @param pname palette name +#' @param get_palette_names whether to get palette names +#' @param get_palettes ignored #' @export get_palette <- function(pname, get_palettes=FALSE, get_palette_names=FALSE) { # Some of these are from: diff --git a/man/draw_many_heat_maps.Rd b/man/draw_many_heat_maps.Rd index e6cd5a2..58a3c64 100644 --- a/man/draw_many_heat_maps.Rd +++ b/man/draw_many_heat_maps.Rd @@ -27,6 +27,8 @@ so if you draw within the plotting region it will overwrite the heatmap. To fix Don't depend on this call order, use PANEL.LAST if you want to draw things on top of the heatmap} \item{PANEL.LAST}{a function that is called after the rendering of each heat map. It is not called after the rendering of the color bar.} + +\item{axes}{vector of logicals, whether to draw axis} } \description{ Easy way to make a bunch of heatmaps with consistent look/feel and get a colorbar. diff --git a/man/easy_layout.Rd b/man/easy_layout.Rd index 6550fa6..eaaa70f 100644 --- a/man/easy_layout.Rd +++ b/man/easy_layout.Rd @@ -6,8 +6,7 @@ \usage{ easy_layout(K, nrows = 1, legend, legend_size = lcm(3), legend_side = 4, s_margin = par("mar"), b_margin = par("oma"), - l_margin = local({ mar = s_margin mar[legend_side] = 0 - mar[(legend_side + 2)\%\%4] = 0.5 mar })) + l_margin) } \arguments{ \item{K}{number of plots to be made} diff --git a/man/get_palette.Rd b/man/get_palette.Rd new file mode 100644 index 0000000..8079dbb --- /dev/null +++ b/man/get_palette.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/common_plotting_functions.R +\name{get_palette} +\alias{get_palette} +\title{Function to get builtin color palettes} +\usage{ +get_palette(pname, get_palettes = FALSE, get_palette_names = FALSE) +} +\arguments{ +\item{pname}{palette name} + +\item{get_palettes}{ignored} + +\item{get_palette_names}{whether to get palette names} +} +\description{ +Function to get builtin color palettes +} diff --git a/man/make_image.Rd b/man/make_image.Rd index b2e6b4f..e5ab67b 100644 --- a/man/make_image.Rd +++ b/man/make_image.Rd @@ -8,17 +8,21 @@ make_image(mat, x, y, zlim, col, log = "", useRaster = TRUE, clip_to_zlim = TRUE, add = TRUE) } \arguments{ +\item{mat}{z-matrix} + \item{x, y}{z and y axis} \item{zlim}{value to trim zmat} +\item{col}{vector of colors, color palette} + \item{log}{which axis will be in log scale} \item{useRaster, ...}{passed to image()} -\item{zmat}{z-matrix} +\item{clip_to_zlim}{whether to clip mat} -\item{xlab, }{ylab label for x and y} +\item{add}{logical, whether to overlay current plot to an existing image} } \description{ The idea here is to to separate the plotting of the heatmap from all the accoutrements that are done in the decorators. From 98f0b6c33191332dfcdbde0025bdb834ef998404 Mon Sep 17 00:00:00 2001 From: John Magnotti Date: Thu, 3 Oct 2019 13:24:50 -0500 Subject: [PATCH 06/24] updated data export UI --- NAMESPACE | 2 + R/common_plotting_functions.R | 38 +++- R/power_explorer_plots.R | 186 ++++++++++++++++ inst/modules/power_explorer/comp.R | 215 +++++++++++++------ inst/modules/power_explorer/event_handlers.R | 90 ++++++-- inst/modules/power_explorer/exports.R | 14 +- inst/modules/power_explorer/main.R | 90 ++++++-- man/across_electrodes_beta_histogram.Rd | 16 ++ man/across_electrodes_f_histogram.Rd | 16 ++ man/draw_many_heat_maps.Rd | 3 +- 10 files changed, 553 insertions(+), 117 deletions(-) create mode 100644 man/across_electrodes_beta_histogram.Rd create mode 100644 man/across_electrodes_f_histogram.Rd diff --git a/NAMESPACE b/NAMESPACE index d45839c..0d97833 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,7 @@ # Generated by roxygen2: do not edit by hand +export(across_electrodes_beta_histogram) +export(across_electrodes_f_histogram) export(by_condition_welch) export(by_trial_erp_map) export(dev_ravebuiltins) diff --git a/R/common_plotting_functions.R b/R/common_plotting_functions.R index d304820..f19ac99 100644 --- a/R/common_plotting_functions.R +++ b/R/common_plotting_functions.R @@ -19,7 +19,7 @@ #' @seealso draw_img draw_many_heat_maps <- function(hmaps, max_zlim=0, log_scale=FALSE, show_color_bar=TRUE, useRaster=TRUE, wide=FALSE, - PANEL.FIRST=NULL, PANEL.LAST=NULL, axes=c(TRUE, TRUE), ...) { + PANEL.FIRST=NULL, PANEL.LAST=NULL, axes=c(TRUE, TRUE), xrange=NULL, ...) { k <- sum(hmaps %>% get_list_elements('has_trials')) orig.pars <- layout_heat_maps(k) @@ -32,7 +32,7 @@ draw_many_heat_maps <- function(hmaps, max_zlim=0, log_scale=FALSE, if(wide) { #NB: B, L, T, R # trying to be smart about the size of the margin to accomodate the angular text. R doesn't auto adjust :( - max_char_count = max(sapply(hmaps, function(h) ifelse(h$has_trials, max(nchar(h$conditions)), 'a'))) + max_char_count = max(sapply(hmaps, function(h) ifelse(h$has_trials, max(nchar(h$conditions)), 1))) par(mar = c(5.1, 5.1 + max(0,(max_char_count - 5)*0.75), 2, 2)) @@ -50,9 +50,18 @@ draw_many_heat_maps <- function(hmaps, max_zlim=0, log_scale=FALSE, } else { '' } - lapply(hmaps, function(map){ if(map$has_trials){ + + # check the plottable range, to make sure we're only plotting what the user has requested + xrange %?<-% range(map$x) + + if (! all(map$x %within% xrange) ) { + ind <- map$x %within% xrange + map$x <- map$x[ind] + map$data <- map$data[ind,,drop=FALSE] + } + # we are linearizing the x and y spaces so that we can use the fast raster x <- seq_along(map$x) y <- seq_along(map$y) @@ -115,9 +124,20 @@ draw_many_heat_maps <- function(hmaps, max_zlim=0, log_scale=FALSE, } # show power over time with MSE by condition -time_series_plot <- function(plot_data, PANEL.FIRST=NULL, PANEL.LAST=NULL) { +time_series_plot <- function(plot_data, PANEL.FIRST=NULL, PANEL.LAST=NULL, xrange=NULL) { + + # check the plottable range, to make sure we're only plotting what the user has requested + xrange %?<-% get_data_range(plot_data, 'x') - xlim <- pretty(get_list_elements(plot_data, 'x') %>% unlist) + for(ii in seq_along(plot_data)) { + if (! all(plot_data[[ii]]$x %within% xrange) ) { + ind <- plot_data[[ii]]$x %within% xrange + plot_data[[ii]]$x <- plot_data[[ii]]$x[ind] + plot_data[[ii]]$data <- plot_data[[ii]]$data[ind,,drop=FALSE] + } + } + + xlim <- pretty(xrange)#get_list_elements(plot_data, 'x') %>% unlist) ylim <- pretty(get_data_range(plot_data) %>% unlist, min.n=2, n=4) plot_clean(xlim, ylim) @@ -640,6 +660,12 @@ axis_label_decorator <- function(plot_data, col) { } +round_to_nearest <- function(x, val=10) { + val*round(x/val) +} + + + # by default we use PLOT_TITLE variable in results to see what to put in the title string # callers can override this behavior by specifically dis-allowing certain options # currently you can't force something to be TRUE if a user doesn't allow it, but we can think about @@ -842,7 +868,7 @@ window_decorator <- function(window, type=c('line', 'box', 'shaded'), # # x = sort(rnorm(10)) # ..get_nearest(pretty(x), x) -# RUTABAGA +# move to RUTABAGA ..get_nearest_i <- function(from,to) { sapply(from, function(.x) which.min(abs(.x-to))) } diff --git a/R/power_explorer_plots.R b/R/power_explorer_plots.R index 571c670..ad08020 100644 --- a/R/power_explorer_plots.R +++ b/R/power_explorer_plots.R @@ -10,9 +10,192 @@ over_time_plot <- function(results, ...) { set_palette_helper(results) time_series_plot(plot_data = results$get_value('line_plot_data'), + xrange = results$get_value('plot_time_range'), PANEL.FIRST = time_series_decorator(results = results)) } + +#' @title Histogram of F-tests per electrode +#' @param results results returned by module +#' @param ... other parameters passed to module output +#' @export +across_electrodes_f_histogram <- function(results, ...) { + has_data <- results$get_value('has_data', FALSE) + + validate(need(has_data, message="No Condition Specified")) + set_palette_helper(results) + + omnibus_results <- results$get_value('omnibus_results') + ts <- omnibus_results[2,] + + hist(ts, xlab='', ylab='', col='gray50', main='', border=get_foreground_color(), + las=1, cex.axis=rave_cex.axis, axes=F) + rave_axis(1, at=axTicks(1)) + rave_axis(2, at=axTicks(2) %>% round %>% unique) + rave_axis_labels(xlab='T-test for mean response', ylab='# of Electrodes') + + cut <- as.numeric(results$get_value('tval_operand')) + if(!is_null(cut)) { + abline(v=cut, lwd=2, col='orangered') + } +} + +#' @title Histogram of per-condition means, per electrode +#' @param results results returned by module +#' @param ... other parameters passed to module output +#' @export +across_electrodes_beta_histogram <- function(results, ...) { + has_data <- results$get_value('has_data', FALSE) + validate(need(has_data, message="No Condition Specified")) + + set_palette_helper(results) + + omnibus_results <- results$get_value('omnibus_results') + ms <- omnibus_results[1,] + + hist(ms, main='', col='gray50', border=get_foreground_color(), + las=1, axes=F, xlab='', ylab='') + rave_axis(1, at=axTicks(1)) + rave_axis(2, at=axTicks(2) %>% round %>% unique) + rave_axis_labels(xlab='Mean Response', ylab='# of Electrodes') + + cut <- as.numeric(results$get_value('mean_operand')) + if(!is_null(cut)) { + abline(v=cut, lwd=2, col='orangered') + } +} + + +rave_axis_labels <- function(xlab=NULL, ylab=NULL, col=NULL, cex.lab=rave_cex.lab, ...) { + col %?<-% get_foreground_color() + + title(xlab=xlab, ylab=ylab, cex.lab=cex.lab, col.lab=col, ...) +} + + +# several functions will need to use this +determine_passing_electrodes <- function(results, ...) { + res <- results$get_value('omnibus_results') + v <- c('mean', 'pval', 'tval') + filters <- sapply(v %&% '_filter', function(e) results$get_value(e)) + operators <- sapply(v %&% '_operator', function(e) results$get_value(e)) + operands <- sapply(v %&% '_operand', function(e) results$get_value(e)) + + pass_the_test <- rep(TRUE, length(results$get_value('electrodes'))) + + pval_filters <- c('p', 'FDR(p)', 'Bonf(p)') + pval_funcs <- list('p' = c, + 'FDR(p)' = function(p) p.adjust(p, method='fdr'), + 'Bonf(p)' = function(p) p.adjust(p, method='bonferroni')) + + # operands[1] = '50' + + for(ii in seq_along(filters)) { + # first check if there is a valid operand + if(all(operands[ii] != "", not_NA(as.numeric(operands[ii]))) ) { + # convert the operator to its corresponding method + OP <- getMethod(operators[ii]) + # default to p-value + val = res[3,] + if(filters[ii] %in% pval_filters) { + val = pval_funcs[[filters[ii]]](val) + } else if (filters[ii] == 't') { + val = res[2,] + } else if (filters[ii] == 'b0') { + val = res[1,] + } + pass_the_test = pass_the_test & OP(val,as.numeric(operands[ii])) + } + } + + # now we do the check on the anatomical filters + emeta <- results$get_value('electrodes_csv') + + afilt <- sapply('analysis_filter_variable' %&% c('', '_2'), function(e) results$get_value(e)) + aval <- lapply('analysis_filter_elec' %&% c('', '_2'), function(e) results$get_value(e)) + + # print(results$get_value('analysis_filter_elec')) + + for(ii in seq_along(afilt)) { + if(afilt[ii] != 'none') { + key <- as.character(afilt[ii]) + val <- unlist(aval[[ii]]) + el_vals <- paste0(emeta[[key]]) + + ### there is weirdness here with the NA label + if(any(is.na(val))) val %<>% paste0 + + pass_the_test = pass_the_test & (el_vals %in% val) + } + } + + # update the local_data variable -- can this be done? + # local_data$electrodes_passing_the_test <- as.numeric(names(pass_the_test)) + # no. instead let's put this value in a textInput?? + + if(shiny_is_running()){ + updateTextInput(getDefaultReactiveDomain(), 'current_active_set', value=deparse_svec( + as.numeric(names(which(pass_the_test))) + )) + } + return(pass_the_test) +} + +shiny_is_running <- function() { + cls <- class(getDefaultReactiveDomain()) + any(cls %in% c('ShinySession', 'session_proxy')) +} + +across_electrodes_corrected_pvalue <- function(results, ...) { + has_data <- results$get_value('has_data', FALSE) + validate(need(has_data, message="No Condition Specified")) + set_palette_helper(results) + + omnibus_results <- results$get_value('omnibus_results') + ps <- omnibus_results[3,] + + filt <- results$get_value('pval_filter') + pval_funcs <- list('p' = c, + 'FDR(p)' = function(p) p.adjust(p, method='fdr'), + 'Bonf(p)' = function(p) p.adjust(p, method='bonferroni')) + + ps <- pval_funcs[[filt]](ps) + nl10 <- function(p) -log10(p) + # we want to determine the cut point based on the currently selected filters + # we need to check all the filters, in case they have multiple filters + passing_els <- determine_passing_electrodes(results) + # print(names(passing_els)) + + .col <- get_foreground_color() + cut <- as.numeric(results$get_value('pval_operand')) + + plot_clean(1:ncol(omnibus_results), + ylim=pretty(nl10(c(ps, ifelse(is.null(cut), 0.01, cut))))) + + if(!is.null(cut)) { + segments(x0=0, x1=ncol(omnibus_results), y0=nl10(cut), lty=2, col='orangered') + rave_axis(4, at=nl10(cut), label=results$get_value('pval_operand'), + tcl=0, cex.axis = 1, lwd=0, mgpy=c(-3, -1, -0)) + } + + # get_foreground_color() + + points(nl10(ps), pch=16, col=ifelse(passing_els, 'gray10', 'gray70')) + + title(xlab='Electrode #', ylab=results$get_value('pval_filter'), + col.lab = .col, cex.lab=rave_cex.lab, main = '') + rave_axis(1, at=seq_along(omnibus_results[2,]), labels=colnames(omnibus_results)) + + axt <- axTicks(2) + # rave_axis(2, at=axTicks(2), labels=lapply(lbl, expression) %>% unlist) + # not sure how to vectorize an expression involving bquote :( + rave_axis(2, at=axt, labels = F, tcl=0) + for(ii in seq_along(axt)) { + rave_axis(2, at=axt[ii], label=bquote(10**-.(axt[ii])), cex.axis = rave_cex.axis*.9) + } + print(omnibus_results[3,]) +} + get_foreground_color <- function() { switch(par('bg'), 'black' = 'white', @@ -90,6 +273,7 @@ heat_map_plot <- function(results, ...){ draw_many_heat_maps(hmaps = results$get_value('heat_map_data'), log_scale = results$get_value('log_scale'), max_zlim = results$get_value('max_zlim'), + xrange = results$get_value('plot_time_range'), PANEL.LAST = spectrogram_heatmap_decorator(results=results) ) } @@ -105,6 +289,7 @@ by_electrode_heat_map <- function(results) { draw_many_heat_maps(by_electrode_heat_map_data, max_zlim = results$get_value('max_zlim'), log_scale=FALSE, + xrange = results$get_value('plot_time_range'), PANEL.LAST=by_electrode_heat_map_decorator(results=results)) } @@ -142,6 +327,7 @@ by_trial_heat_map <- function(results) { max_zlim = results$get_value('max_zlim'), log_scale=FALSE, wide = sort_trials_by_type, PANEL.LAST=decorator, + xrange = results$get_value('plot_time_range'), # we always want the x axis, but we only want the y axis if we are NOT sorting by type axes=c(TRUE, !sort_trials_by_type)) } diff --git a/inst/modules/power_explorer/comp.R b/inst/modules/power_explorer/comp.R index 92359b5..1fb0f82 100644 --- a/inst/modules/power_explorer/comp.R +++ b/inst/modules/power_explorer/comp.R @@ -36,7 +36,9 @@ define_initialization({ time_points = preload_info$time_points electrodes = preload_info$electrodes epoch_data = module_tools$get_meta('trials') - electrodes_csv = module_tools$get_meta('electrodes') + # here we're limiting the meta data to the electrodes that are currently loaded + # we can't export unloaded electrodes + electrodes_csv = module_tools$get_meta('electrodes') %>% subset((.)$Electrode %in% electrodes) elec_labels <- unique(electrodes_csv$Label) # figure out if there are any outliers to prepopulate the outlier list @@ -95,28 +97,22 @@ define_input( init_args = 'label', init_expr = { label = "Save Outliers" - } -) + }) define_input( - definition = checkboxInput('show_outliers_on_plots', 'Show outliers on plots', value = TRUE) -) + definition = checkboxInput('show_outliers_on_plots', 'Show outliers on plots', value = TRUE)) define_input( - definition = numericInput('max_zlim', 'Heatmap Max (0 means data range)', value = 0, min = 0, step = 1) -) + definition = numericInput('max_zlim', 'Heatmap Max (0 means data range)', value = 0, min = 0, step = 1)) define_input( - definition = checkboxInput('log_scale', 'Log Freq (NI)') -) + definition = checkboxInput('log_scale', 'Log Freq (NI)')) define_input( - definition = checkboxInput('sort_trials_by_type', 'Sort Trials') -) + definition = checkboxInput('sort_trials_by_type', 'Sort Trials')) define_input( - definition = checkboxInput('collapse_using_median', 'Collapse w/ Median (NI)') -) + definition = checkboxInput('collapse_using_median', 'Collapse w/ Median (NI)')) # let people decide how much information to include in the plots. It's up to the individual plot to actually make @@ -127,21 +123,20 @@ define_input( selected=c('Subject ID', 'Electrode #', 'Condition', 'Frequency Range', 'Sample Size', 'Baseline Window', 'Analysis Window')) ) +define_input_time('plot_time_range', label='Plot Time Range', initial_value = c(-1e5,1e5)) + define_input( - definition = selectInput(inputId = 'plots_to_export', label='Plots to Export', multiple=TRUE, + definition = selectInput(inputId = 'plots_to_export', label='Plots to download', multiple=TRUE, choices = c('Spectrogram', 'By Trial Power', 'Over Time Plot', 'Windowed Average'), - selected = c('Spectrogram', 'By Trial Power', 'Over Time Plot', 'Windowed Average')) -) + selected = c('Spectrogram', 'By Trial Power', 'Over Time Plot', 'Windowed Average'))) define_input( definition = selectInput(inputId = 'export_what', - label='Which electrodes should be exported?', multiple=FALSE, - choices = c('All Loaded', 'Current Selection')) -) + label='Which electrodes should be included?', multiple=FALSE, + choices = c('All Loaded', 'Current Selection'))) define_input( - definition = checkboxInput('draw_decorator_labels', "Label Plot Decorations", value=TRUE) -) + definition = checkboxInput('draw_decorator_labels', "Label Plot Decorations", value=TRUE)) # @@ -150,24 +145,46 @@ define_input( { define_input( definition = textInput('analysis_prefix', value = 'power_by_condition', - label = 'Analysis Prefix (no spaces, should match across subjects)') - ) + label = HTML('
Export filename (no spaces)'))) define_input( definition = checkboxInput('analysis_mask_export',value = FALSE, - label = 'Export Electrode Mask') - ) + label = 'Export Electrode Mask')) + + define_input( + definition = checkboxInput('filter_3d_viewer', "Filter 3D Viewer Results (requires viewer reload)", value=FALSE)) + + define_input( + definition = selectInput('trial_type_filter', label=HTML('
Trials to include in export file'), choices=NULL, selected=NULL, multiple =TRUE), + init_args = c('choices', 'selected'), + init_expr = { + choices = unique(preload_info$condition) + selected = unique(preload_info$condition) + }) + + define_input( + definition = actionButtonStyled(inputId = 'synch_with_trial_selector', + label='Synch with trial selector', icon = shiny::icon('refresh'))) define_input( - definition = selectInput('analysis_filter_variable', label='Electrode Filter', choices=NULL, selected=NULL) + definition = selectInput('analysis_filter_variable', label='Anatomical Filter 1', choices=NULL, selected=NULL) + , init_args = c('choices', 'selected'), + init_expr = { + choices = c('none', names(electrodes_csv)) + selected = ifelse('FreeSurferLabel' %in% names(electrodes_csv), 'FreeSurferLabel', 'Label') + }) + + define_input( + definition = selectInput('analysis_filter_variable_2', label='Anatomical Filter 2', choices=NULL, selected=NULL) , init_args = c('choices', 'selected'), init_expr = { - choices = names(electrodes_csv) - selected = 'Label' + choices = c('none', names(electrodes_csv)) + selected = ifelse('Hemisphere' %in% names(electrodes_csv), 'Hemisphere', 'none') } ) + define_input( - definition = selectInput('analysis_filter_elec', label = 'Electrodes to include', + definition = selectInput('analysis_filter_elec', label = 'Values to include', choices=NULL, selected = NULL, multiple = TRUE ), init_args = c('choices', 'selected'), @@ -176,38 +193,60 @@ define_input( selected = unique(elec_labels) } ) + define_input( + definition = selectInput('analysis_filter_elec_2', label = 'Values to include', + choices=NULL, selected = NULL, multiple = TRUE)) # export based on stats + + # filter 1: p-value filter define_input( - definition = selectInput('analysis_filter_1', label = 'Statistic', - choices=c('none', 'b', 't|F', 'p', 'FDR(p)', 'Bonf(p)'), selected = 'FDR(p)', multiple = FALSE) - ) + definition = selectInput('pval_filter', label = HTML('Functional Filters
p-value'), + choices=c('p', 'FDR(p)', 'Bonf(p)'), + selected = 'FDR(p)', multiple = FALSE)) define_input( - definition = selectInput('analysis_filter_operator_1', label = '', - choices=c('<', '>', '<=', '>='), selected = '<', multiple = FALSE - ) - ) + definition = selectInput('pval_operator', label = '', + choices=c('<', '>', '<=', '>='), selected = '<', multiple = FALSE)) define_input( - definition = textInput('analysis_filter_operand_1', label = '', placeholder='e.g., 0.05') - ) + definition = textInput('pval_operand', label = '', value = 0.01)) - # stat filter #2 + # stat filter for t-value define_input( - definition = selectInput('analysis_filter_2', label = '', - choices=c('none', 'b', 't|F', 'p', 'FDR(p)', 'Bonf(p)'), selected = 'none', multiple = FALSE) - ) + definition = selectInput('tval_filter', label = 't-value', + choices=c('t', '|t|'), selected = 't', multiple = FALSE)) define_input( - definition = selectInput('analysis_filter_operator_2', label = ' ', - choices=c('<', '>', '<=', '>='), selected = '>', multiple = FALSE) - ) + definition = selectInput('tval_operator', label = ' ', + choices=c('<', '>', '<=', '>='), selected = '>', multiple = FALSE)) define_input( - definition = textInput('analysis_filter_operand_2', label = ' ', placeholder='0') - ) + definition = textInput('tval_operand', label= ' ')) + # stat filter for mean + # this filter should be dynamic based on the contents of the statistical output define_input( - definition = actionButtonStyled('export_data', label='Export Data', icon=shiny::icon('download'), - type = 'primary', width = '50%', style='margin-left: 25%; margin-right:25%') - ) + definition = selectInput('mean_filter', label = 'mean response', + choices=c('b0', 'abs(b0)'), selected = 'b0', multiple = FALSE)) + define_input( + definition = selectInput('mean_operator', label = ' ', + choices=c('<', '>', '<=', '>='), selected = '>', multiple = FALSE)) + define_input( + definition = textInput('mean_operand', label= ' ')) + + define_input( + definition = actionButtonStyled('export_data', label='Export data for group analysis', icon=shiny::icon('download'), + type = 'primary')) + + define_input( + definition = actionButtonStyled('select_good_electrodes',label='Visualize Active Electrodes', + icon=shiny::icon('magic'), type = 'default')) + + define_input( + definition = textInput('current_active_set', label='Electrodes passing all functional and anatomical filters (read-only)', value='')) + + + # define_input( + # definition = actionButtonStyled('export_plots_and_data', label='Export Plots and Data', icon=shiny::icon('download'), + # type = 'primary', width = '50%', style='margin-left: 25%; margin-right:25%') + # ) } @@ -271,62 +310,73 @@ define_input( # deterime which varibles only need to trigger a render, not an exectute render_inputs <- c( 'sort_trials_by_type', 'draw_decorator_labels', 'PLOT_TITLE', 'plots_to_export', 'show_outliers_on_plots', 'background_plot_color_hint', - 'invert_colors_in_palette', 'reverse_colors_in_palette', 'color_palette', 'max_zlim' + 'invert_colors_in_palette', 'reverse_colors_in_palette', 'color_palette', 'max_zlim','plot_time_range', + 'tval_filter', 'pval_filter', 'mean_filter', + 'tval_operator', 'pval_operator', 'mean_operator', + 'tval_operand', 'pval_operand', 'mean_operand', 'analysis_filter_elec_2', 'analysis_filter_elec', + 'analysis_filter_variable', 'analysis_filter_variable_2' ) # # determine which variables only need to be set, not triggering rendering nor executing manual_inputs <- c( - 'graph_export', 'export_what', 'analysis_filter_variable', 'analysis_filter_elec', - 'analysis_filter_1', 'analysis_filter_2', 'analysis_filter_operator_1', 'analysis_filter_operator_2', - 'analysis_filter_operand_1', 'analysis_filter_operand_2', - 'analysis_prefix', 'analysis_mask_export', 'export_data' + 'graph_export', 'filter_3d_viewer', 'trial_type_filter', 'synch_with_trial_selector', + 'export_what', 'analysis_prefix', 'analysis_mask_export', 'export_data', 'current_active_set' ) - # Define layouts if exists input_layout = list( - '[#cccccc]Electrodes' = list( - c('ELECTRODE_TEXT'), - c('combine_method')#, + #'[#cccccc] + 'Select electrodes for analysis' = list( + c('ELECTRODE_TEXT') + #, c('combine_method'), #c('reference_type', 'reference_group') ), #[#99ccff] - 'Trial Selector' = list( + 'Select trials for analysis' = list( 'GROUPS' ), - 'Analysis Settings' = list( + 'Set analysis options' = list( 'FREQUENCY', 'BASELINE_WINDOW', 'ANALYSIS_WINDOW' ), - '[-]Plot Options' = list( + '[-]Set plot options' = list( + 'plot_time_range', c('PLOT_TITLE'), 'draw_decorator_labels', c('color_palette', 'background_plot_color_hint', 'invert_colors_in_palette', 'reverse_colors_in_palette'), c('max_zlim'), # 'heatmap_color_palette', + c('sort_trials_by_type') #FIXME collapse_using_median should be in Analysis Settings??? - c('log_scale', 'sort_trials_by_type', 'collapse_using_median') + # c('log_scale', , 'collapse_using_median') ), - '[-]Trial Outliers' = list( + '[-]Manage trial outliers' = list( 'show_outliers_on_plots', 'trial_outliers_list', 'clear_outliers', 'save_new_epoch_file' ), #[#aaaaaa] - '[-]Export Plots' = list( + '[-]Download plots and underlying data' = list( c('plots_to_export'), c('export_what'), + # 'export_plots_and_data'# c('graph_export') ), - '[-]Export Data/Results' = list( + # 'filter_3d_viewer', + # 'analysis_mask_export', + '[-]Export data from all electrodes for group analysis' = list( + c('pval_filter', 'pval_operator', 'pval_operand'), + c('tval_filter', 'tval_operator', 'tval_operand'), + c('mean_filter', 'mean_operator', 'mean_operand'), + c('analysis_filter_variable', 'analysis_filter_elec'), + c('analysis_filter_variable_2', 'analysis_filter_elec_2'), + 'current_active_set', + 'select_good_electrodes', + 'trial_type_filter', 'synch_with_trial_selector', 'analysis_prefix', - 'analysis_mask_export', - 'analysis_filter_variable', 'analysis_filter_elec', - c('analysis_filter_1', 'analysis_filter_operator_1', 'analysis_filter_operand_1'), - c('analysis_filter_2', 'analysis_filter_operator_2', 'analysis_filter_operand_2'), 'export_data' ) ) @@ -367,7 +417,7 @@ define_output( definition = plotOutput('windowed_comparison_plot', click = clickOpts(shiny::NS('power_explorer')('windowed_by_trial_click'), clip = FALSE), dblclick = clickOpts(shiny::NS('power_explorer')('windowed_by_trial_dbl_click'), clip = FALSE)), - title = 'Activity by trial and condition', + title = 'By-trial windowed response (across electrodes)', width = 3, order = 4 ) @@ -378,6 +428,29 @@ define_output( width=2, order=4.1 ) +define_output( + definition = plotOutput('across_electrodes_f_histogram'), + title = 't-value across all loaded electrodes', + width = 4, + order = 5.1 +) + +define_output( + definition = plotOutput('across_electrodes_beta_histogram'), + title = 'mean response across all loaded electrodes', + width = 4, + order = 5.2 +) + +define_output( + definition = plotOutput('across_electrodes_corrected_pvalue'), + title = 'p-value across all loaded electrodes', + width = 4, + order = 5 +) + + + # define_output( # definition = customizedUI('viewer_3d'), diff --git a/inst/modules/power_explorer/event_handlers.R b/inst/modules/power_explorer/event_handlers.R index 79ddd7e..f0e1a83 100644 --- a/inst/modules/power_explorer/event_handlers.R +++ b/inst/modules/power_explorer/event_handlers.R @@ -1,3 +1,14 @@ +input = getDefaultReactiveInput() +output = getDefaultReactiveOutput() +session = getDefaultReactiveDomain() + +local_data = reactiveValues( + instruction_string = "Click on Activity by trial and condition plot for details." %&% + "
  • Single-click for trial information
  • Double-click for outlier (de)selection
", + by_trial_heat_map_click_location = NULL, + windowed_by_trial_click_location = NULL, + click_info = NULL +) observeEvent(input$power_3d_mouse_dblclicked, { # mouse_event = input$power_3d__mouse_dblclicked$event @@ -37,20 +48,61 @@ observeEvent(input$trial_outliers_list, { }) +observeEvent(input$synch_with_trial_selector, { + GROUPS %?<-% NULL + + if(!is.null(GROUPS)) { + # the lapply and then unlist handles the case + # of empty group(s) + updateSelectInput(session, 'trial_type_filter', + selected = unique(lapply(GROUPS, `[[`, 'group_conditions') %>% unlist) + ) + } +}) + observeEvent(input$analysis_filter_variable, { electrodes_csv %?<-% NULL if(is.data.frame(electrodes_csv)) { col_name <- input$analysis_filter_variable - - updateSelectInput(session, 'analysis_filter_elec', - selected=unique(electrodes_csv[[col_name]]), - choices = unique(electrodes_csv[[col_name]])) + if(col_name == 'none') { + updateSelectInput(session, 'analysis_filter_elec', + selected=character(0), + choices = character(0)) + } else { + updateSelectInput(session, 'analysis_filter_elec', + selected=unique(electrodes_csv[[col_name]]), + choices = unique(electrodes_csv[[col_name]])) + } } +}) +observeEvent(input$analysis_filter_variable_2, { + electrodes_csv %?<-% NULL + + if(is.data.frame(electrodes_csv)) { + col_name <- input$analysis_filter_variable_2 + + if(col_name == 'none') { + updateSelectInput(session, 'analysis_filter_elec_2', + selected=character(0), + choices = character(0)) + } else { + updateSelectInput(session, 'analysis_filter_elec_2', + selected=unique(electrodes_csv[[col_name]]), + choices = unique(electrodes_csv[[col_name]])) + } + + } }) +observeEvent(input$select_good_electrodes, { + if(!is.null(input$current_active_set)) { + updateTextInput(session, 'ELECTRODE_TEXT', value = parse_svec(input$current_active_set)) + } +}) + observeEvent(input$clear_outliers, { updateSelectInput(session, 'trial_outliers_list', selected=character(0)) enable_save_button() @@ -81,19 +133,6 @@ disable_save_button <- function() { } -input = getDefaultReactiveInput() -output = getDefaultReactiveOutput() -session = getDefaultReactiveDomain() - -local_data = reactiveValues( - instruction_string = "Click on Activity by trial and condition plot for details." %&% - "
  • Single-click for trial information
  • Double-click for outlier (de)selection
", - by_trial_heat_map_click_location = NULL, - windowed_by_trial_click_location = NULL, - click_info = NULL -) - - update_click_information <- function() { .loc <- local_data$windowed_by_trial_click_location @@ -146,8 +185,18 @@ observeEvent(input$windowed_by_trial_dbl_click, { output$trial_click <- renderUI({ .click <- local_data$click_info - - HTML("
Nearest Trial: " %&% .click$trial %&% '
Value: ' %&% .click$value %&% + # div( + # style='margin-left: 5px; min-height: 400px', + # 'Nearest Trial: ', .click$trial, br(), + # 'Value: ', .click$value, br(), + # 'Trial Type: ', .click$trial_type, + # p( + # style='margin-top:20px', + # HTML('—'), br(), + # local_data$instruction_string + # ) + # ) + HTML("
Nearest Trial: " %&% .click$trial %&% '
Value: ' %&% .click$value %&% '
Trial Type: ' %&% .click$trial_type %&% "

—
" %&% local_data$instruction_string %&% '

' ) @@ -158,6 +207,7 @@ click_output = function() { return(htmlOutput(ns('trial_click'))) } - return(HTML("

" %&% local_data$instruction_string %&% '

')) + return(HTML("
" %&% + "

" %&% local_data$instruction_string %&% '

')) } diff --git a/inst/modules/power_explorer/exports.R b/inst/modules/power_explorer/exports.R index 2338da3..1143f5a 100644 --- a/inst/modules/power_explorer/exports.R +++ b/inst/modules/power_explorer/exports.R @@ -13,7 +13,6 @@ power_3d_fun = function(brain){ # for each electrode, we want to test the different conditions .FUN <- if(length(levels(dat$condition)) > 1) { - if (length(levels(dat$condition)) == 2) { function(x) { res = get_t(power ~ condition, data=x) @@ -140,10 +139,21 @@ export_stats = function(conn=NA, lbl='stat_out', dir, ...){ invisible(out_data) } + +## modified from downloadButton +fix_font_color_button <- function (outputId, label = "Download", class = NULL, ...) { + aTag <- tags$a(id = outputId, class = paste("btn shiny-download-link", + class), href = "", target = "_blank", download = NA, + icon("download"), label, ...) +} + graph_export = function(){ tagList( # actionLink(ns('btn_graph_export'), 'Export Graphs'), - downloadLink(ns('btn_graph_download'), 'Download Graphs') + fix_font_color_button(ns('btn_graph_download'), 'Download graphs and their data', icon=shiny::icon('download'), + class = 'btn-primary text-white') + # actionLink(ns('btn_graph_export'), 'Export Graphs'), + ) } diff --git a/inst/modules/power_explorer/main.R b/inst/modules/power_explorer/main.R index aba11c2..4aa488c 100644 --- a/inst/modules/power_explorer/main.R +++ b/inst/modules/power_explorer/main.R @@ -4,14 +4,16 @@ # rm(list = ls(all.names=T)); rstudioapi::restartSession() require(ravebuiltins) ravebuiltins:::dev_ravebuiltins(T) -mount_demo_subject(force_reload_subject = T) +mount_demo_subject(force_reload_subject = T, + subject_code = 'YAB',project_name = 'congruency', electrodes=13:20, epoch='YABa') + init_module(module_id = 'power_explorer', debug = TRUE) # attachDefaultDataRepository() if(FALSE) { GROUPS = list(list(group_name='A', group_conditions=c('known_a', 'last_a', 'drive_a', 'meant_a')), list(group_name='B', group_conditions=c('known_v', 'last_v', 'drive_v', 'meant_v'))) FREQUENCY = c(75,150) - ELECTRODE_TEXT = '14-15' + ELECTRODE_TEXT = '14-19' } # >>>>>>>>>>>> Start ------------- [DO NOT EDIT THIS LINE] --------------------- @@ -232,10 +234,12 @@ for(ii in which(has_trials)){ mean(unique(diff(.xp)))*0.25 } else { 0.75*(1/3) - } - scatter_bar_data[[ii]]$xp <- .xp[ii] + } + + xpi <- which(ii == which(has_trials)) + scatter_bar_data[[ii]]$xp <- .xp[xpi] set.seed(jitter_seed) - scatter_bar_data[[ii]]$x <- .xp[ii] + runif(length(scatter_bar_data[[ii]]$data), -.r, .r) + scatter_bar_data[[ii]]$x <- .xp[xpi] + runif(length(scatter_bar_data[[ii]]$data), -.r, .r) attr(scatter_bar_data[[ii]]$data, 'xlab') <- 'Group' attr(scatter_bar_data[[ii]]$data, 'ylab') <- ifelse(combine_method=='none', 'Mean % Signal Change', @@ -271,6 +275,41 @@ has_data = sum(has_trials) # calculate some statistics +# because we're eventually going to be doing second-level stats, we're not too worried about +# gratuitous NHST + +# the first thing we want is an omnibus F statistic. Because the data are baseline corrected, we're here +# just comparing with zero. That is, a no-intercept model. + +# we need the omnibus result per-electrode, do for all electrodes, not just selected + +all_trial_types <- GROUPS %>% lapply(`[[`, 'group_conditions') %>% unlist %>% unique + +get_data_per_electrode <- function() { + bl <- baseline(power$subset(Trial=Trial %in% epoch_data$Trial[epoch_data$Condition %in% all_trial_types], + Frequency=Frequency %within% FREQUENCY, + Time=Time %within% range(BASELINE_WINDOW, ANALYSIS_WINDOW) ), + from=BASELINE_WINDOW[1], to= BASELINE_WINDOW[2], + hybrid = FALSE, mem_optimize = FALSE) + bl.analysis <- bl$subset(Time=Time %within% ANALYSIS_WINDOW) + pow <- bl$collapse(keep = c(1,4)) + m = colMeans(pow) + t = m / .fast_column_se(pow) + p = 2*pt(abs(t), df = nrow(pow)-1, lower=F) + + res <- rbind(m,t,p) + colnames(res) <- dimnames(power)$Electrode + + return(res) +} + +omnibus_results <- cache( + key = list(subject$id, BASELINE_WINDOW, FREQUENCY,all_trial_types, + ANALYSIS_WINDOW, combine_method, preload_info$epoch_name, + preload_info$reference_name, trial_outliers_list), + val = get_data_per_electrode() +) + # calculate the statistics here so that we can add them to the niml_out # if there are > 1 groups in the data, then do linear model, otherwise one-sample t-test if(length(unique(flat_data$group)) > 1) { @@ -299,30 +338,47 @@ attr(scatter_bar_data, 'stats') <- result_for_suma # rm(list = ls(all.names=T)); rstudioapi::restartSession() require(ravebuiltins) ravebuiltins:::dev_ravebuiltins(T) -mount_demo_subject() +mount_demo_subject(force_reload_subject = T) module = ravebuiltins:::debug_module('power_explorer') -result = module(ELECTRODE_TEXT = '1-20', - # GROUPS = list(list(group_name='A', group_conditions=c('known_a', 'last_a', 'drive_a', 'meant_a')), - # # putting in an empty group to test our coping mechanisms - # list(group_name='YY', group_conditions=c()), - # list(group_name='ZZ', group_conditions=c('known_v', 'last_v', 'drive_v', 'meant_v'))), - background_plot_color_hint='white', BASELINE_WINDOW = c(-1,-.1), - FREQUENCY = c(75,150), max_zlim = 0, show_outliers_on_plots = TRUE, +result = module(ELECTRODE_TEXT = '14', + GROUPS = list(list(group_name='A', group_conditions=c('known_a', 'last_a', 'drive_a', 'meant_a')), + # putting in an empty group to test our coping mechanisms + list(group_name='YY', group_conditions=c()), + list(group_name='ZZ', group_conditions=c('known_v', 'last_v', 'drive_v', 'meant_v'))), + background_plot_color_hint='white', BASELINE_WINDOW = c(-1,-.1), plot_time_range = c(-1,1.5), + FREQUENCY = c(70,150), max_zlim = 0, show_outliers_on_plots = TRUE, sort_trials_by_type = T, combine_method = 'none') results = result$results +# results$get_value('omnibus_results') +result$across_electrodes_corrected_pvalue() + # attachDefaultDataRepository() +# get_summary() -result$windowed_comparison_plot() result$heat_map_plot() +result$windowed_comparison_plot() result$by_trial_heat_map() result$over_time_plot() +result$by_electrode_heat_map() ravebuiltins::dev_ravebuiltins(expose_functions = TRUE) -view_layout('power_explorer', sidebar_width = 3, launch.browser = T) -m = to_module(module_id) -init_app(m) + +# dev layout has red theme +dev_layout <- function(module_id, sidebar_width = 5, launch.browser = rstudio_viewer){ + # Always reload the package to the newest status and preview + env = reload_this_package() + + m = env$to_module(module_id = module_id, sidebar_width = sidebar_width) + rave::init_app(m, launch.browser = launch.browser, disable_sidebar = T, simplify_header = T, theme='red') +} + +# view_layout('power_explorer', sidebar_width = 3, launch.browser = T) +dev_layout('power_explorer', sidebar_width = 3, launch.browser = T) + +# m = to_module(module_id) +# init_app(m) mount_demo_subject() diff --git a/man/across_electrodes_beta_histogram.Rd b/man/across_electrodes_beta_histogram.Rd new file mode 100644 index 0000000..9285488 --- /dev/null +++ b/man/across_electrodes_beta_histogram.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/power_explorer_plots.R +\name{across_electrodes_beta_histogram} +\alias{across_electrodes_beta_histogram} +\title{Histogram of per-condition means, per electrode} +\usage{ +across_electrodes_beta_histogram(results, ...) +} +\arguments{ +\item{results}{results returned by module} + +\item{...}{other parameters passed to module output} +} +\description{ +Histogram of per-condition means, per electrode +} diff --git a/man/across_electrodes_f_histogram.Rd b/man/across_electrodes_f_histogram.Rd new file mode 100644 index 0000000..d6af833 --- /dev/null +++ b/man/across_electrodes_f_histogram.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/power_explorer_plots.R +\name{across_electrodes_f_histogram} +\alias{across_electrodes_f_histogram} +\title{Histogram of F-tests per electrode} +\usage{ +across_electrodes_f_histogram(results, ...) +} +\arguments{ +\item{results}{results returned by module} + +\item{...}{other parameters passed to module output} +} +\description{ +Histogram of F-tests per electrode +} diff --git a/man/draw_many_heat_maps.Rd b/man/draw_many_heat_maps.Rd index 58a3c64..8852083 100644 --- a/man/draw_many_heat_maps.Rd +++ b/man/draw_many_heat_maps.Rd @@ -6,7 +6,8 @@ \usage{ draw_many_heat_maps(hmaps, max_zlim = 0, log_scale = FALSE, show_color_bar = TRUE, useRaster = TRUE, wide = FALSE, - PANEL.FIRST = NULL, PANEL.LAST = NULL, axes = c(TRUE, TRUE), ...) + PANEL.FIRST = NULL, PANEL.LAST = NULL, axes = c(TRUE, TRUE), + xrange = NULL, ...) } \arguments{ \item{hmaps}{data to draw heatmaps} From 2f01f6963a626926832c08ebbf1e5c10395a7383 Mon Sep 17 00:00:00 2001 From: John Magnotti Date: Tue, 8 Oct 2019 15:38:49 -0500 Subject: [PATCH 07/24] more changes to handle data exporting. there is an infinite update if you change the electrode category selector too frequently. don't do this... --- R/common_plotting_functions.R | 10 +- inst/modules/power_explorer/comp.R | 82 ++++++-- inst/modules/power_explorer/event_handlers.R | 78 +++++++- inst/modules/power_explorer/exports.R | 15 ++ inst/modules/power_explorer/main.R | 186 +++++++++--------- .../univariate_power_explorer/exports.R | 5 - inst/tools/input_widgets.R | 12 +- 7 files changed, 265 insertions(+), 123 deletions(-) diff --git a/R/common_plotting_functions.R b/R/common_plotting_functions.R index f19ac99..d1dc177 100644 --- a/R/common_plotting_functions.R +++ b/R/common_plotting_functions.R @@ -301,15 +301,15 @@ spectrogram_heatmap_decorator <- function(plot_data, results, Xmap=force, Ymap=f windows <- list( 'Baseline'=list( - window = Xmap(results$get_value('BASELINE_WINDOW')), + window = Xmap(plot_data$baseline_window),#results$get_value('BASELINE_WINDOW')), type=btype ), 'Analysis'=list( window = if(atype=='box') { - list(x=Xmap(results$get_value('ANALYSIS_WINDOW')), - y=Ymap(results$get_value('FREQUENCY'))) + list(x=Xmap(plot_data$analysis_window),#results$get_value('ANALYSIS_WINDOW')), + y=Ymap(plot_data$frequency_window))#results$get_value('FREQUENCY'))) } else { - Xmap(results$get_value('ANALYSIS_WINDOW')) + Xmap(plot_data$analysis_window)#results$get_value('ANALYSIS_WINDOW')) }, type=atype ) @@ -774,7 +774,7 @@ time_series_decorator <- function(plot_data, results, ...) { } # this decorator takes care of checking if has_data==TRUE and only shows labels for which there is data -# I guess this could be an option to include N==0 labels... +# I guess there could be an option to include N==0 labels... legend_decorator <- function(plot_data, include=c('name', 'N'), location='topleft') { valid.names <- c('name', 'N') diff --git a/inst/modules/power_explorer/comp.R b/inst/modules/power_explorer/comp.R index 1fb0f82..a1e5039 100644 --- a/inst/modules/power_explorer/comp.R +++ b/inst/modules/power_explorer/comp.R @@ -39,8 +39,17 @@ define_initialization({ # here we're limiting the meta data to the electrodes that are currently loaded # we can't export unloaded electrodes electrodes_csv = module_tools$get_meta('electrodes') %>% subset((.)$Electrode %in% electrodes) + + elec_filter <- 'Label' elec_labels <- unique(electrodes_csv$Label) + # if there is a FreeSurferLabel column let's go with that, otherwise we'll fall back to the Label column + column <- which(names(electrodes_csv) %>% tolower %>% equals('freesurferlabel')) + if(length(column) > 0) { + elec_filter <- names(electrodes_csv)[column] + elec_labels <- unique(electrodes_csv[[column]]) + } + # figure out if there are any outliers to prepopulate the outlier list outlier_list <- character(0) efile <- sprintf('%s/power_outliers_%s.csv', subject$dirs$meta_dir, preload_info$epoch_name) @@ -62,8 +71,33 @@ define_input( definition = customizedUI(inputId = 'input_customized') ) -define_input_multiple_electrodes(inputId = 'ELECTRODE_TEXT') +# , label='Download copy of electrode meta data') +# ) + + +define_input_multiple_electrodes(inputId = 'ELECTRODE_TEXT', label = 'Select electrodes by number') # define_input_single_electrode(inputId = 'ELECTRODE') + +# we also want to be able to select electrodes categorically +define_input( + definition = selectInput('electrode_category_selector', label='Select electrodes by category', choices=NULL, selected=NULL) + , init_args = c('choices', 'selected'), + init_expr = { + choices = names(electrodes_csv) + selected = elec_filter + }) +define_input( + definition = selectInput('electrode_category_selector_choices', label = 'Electrodes to display', + choices=NULL, selected = NULL, multiple = TRUE + ), + init_args = c('choices', 'selected'), + init_expr = { + choices = unique(elec_labels) + selected = unique(elec_labels) + } +) + + define_input_frequency(inputId = 'FREQUENCY', initial_value = c(70,150)) define_input_time(inputId = 'ANALYSIS_WINDOW', label='Analysis', initial_value = c(0,1)) define_input_time(inputId = 'BASELINE_WINDOW', label='Baseline', initial_value = c(-1,0)) @@ -170,7 +204,7 @@ define_input( , init_args = c('choices', 'selected'), init_expr = { choices = c('none', names(electrodes_csv)) - selected = ifelse('FreeSurferLabel' %in% names(electrodes_csv), 'FreeSurferLabel', 'Label') + selected = elec_filter }) define_input( @@ -181,7 +215,6 @@ define_input( selected = ifelse('Hemisphere' %in% names(electrodes_csv), 'Hemisphere', 'none') } ) - define_input( definition = selectInput('analysis_filter_elec', label = 'Values to include', @@ -306,6 +339,14 @@ define_input( } + + +define_input( + definition = customizedUI('download_electrodes_csv') +) + + + # # deterime which varibles only need to trigger a render, not an exectute render_inputs <- c( @@ -317,30 +358,45 @@ render_inputs <- c( 'analysis_filter_variable', 'analysis_filter_variable_2' ) +define_input( + definition = checkboxInput('auto_calculate', label = 'Automatically recalculate analysis', value = FALSE) +) + +define_input( + definition = actionButtonStyled('do_calculate_btn', 'Recalculate analysis for all selected electrodes', width = '100%', type = 'primary') +) + # # determine which variables only need to be set, not triggering rendering nor executing manual_inputs <- c( - 'graph_export', 'filter_3d_viewer', 'trial_type_filter', 'synch_with_trial_selector', + 'graph_export', 'filter_3d_viewer', 'trial_type_filter', 'synch_with_trial_selector', 'download_electrodes_csv', 'export_what', 'analysis_prefix', 'analysis_mask_export', 'export_data', 'current_active_set' ) # Define layouts if exists input_layout = list( #'[#cccccc] - 'Select electrodes for analysis' = list( - c('ELECTRODE_TEXT') + 'Configure analysis settings' = list( + c('electrode_category_selector', 'electrode_category_selector_choices'), + 'ELECTRODE_TEXT', + 'download_electrodes_csv', #, c('combine_method'), - #c('reference_type', 'reference_group') + #c('reference_type', 'reference_group'), + 'FREQUENCY', + 'BASELINE_WINDOW', + 'ANALYSIS_WINDOW', + 'do_calculate_btn', 'auto_calculate' ), #[#99ccff] - 'Select trials for analysis' = list( + 'Compare trial types' = list( 'GROUPS' ), - 'Set analysis options' = list( - 'FREQUENCY', - 'BASELINE_WINDOW', - 'ANALYSIS_WINDOW' - ), + # 'Set analysis options' = list( + # 'FREQUENCY', + # 'BASELINE_WINDOW', + # 'ANALYSIS_WINDOW', + # 'do_calculate_btn', 'auto_calculate' + # ), '[-]Set plot options' = list( 'plot_time_range', c('PLOT_TITLE'), diff --git a/inst/modules/power_explorer/event_handlers.R b/inst/modules/power_explorer/event_handlers.R index f0e1a83..b2124f7 100644 --- a/inst/modules/power_explorer/event_handlers.R +++ b/inst/modules/power_explorer/event_handlers.R @@ -7,7 +7,8 @@ local_data = reactiveValues( "
  • Single-click for trial information
  • Double-click for outlier (de)selection
", by_trial_heat_map_click_location = NULL, windowed_by_trial_click_location = NULL, - click_info = NULL + click_info = NULL, + calculate_flag = 0 ) observeEvent(input$power_3d_mouse_dblclicked, { @@ -60,6 +61,73 @@ observeEvent(input$synch_with_trial_selector, { } }) + +observeEvent(input$ELECTRODE_TEXT, { + # be careful here so we don't trigger loops! + electrodes_csv %?<-% NULL + if(is.data.frame(electrodes_csv)) { + + # check if the electrode text matches the current electrode values + current_etext_els <- as.numeric(parse_svec(input$ELECTRODE_TEXT) ) %>% sort + all_vals <- electrodes_csv[[input$electrode_category_selector]] + vals <- input$electrode_category_selector_choices + current_category_els <- as.numeric(electrodes_csv$Electrode[vals == all_vals]) %>% sort + + if(!all(current_etext_els == current_category_els)) { + .selected <- unique(all_vals[as.numeric(electrodes_csv$Electrode) %in% + current_etext_els]) + + updateSelectInput(session, 'electrode_category_selector_choices', + selected = .selected) + } else { + # no change + } + + + } +}) + + +observeEvent(input$electrode_category_selector, { + # be careful here so we don't trigger loops! + + electrodes_csv %?<-% NULL + + if(is.data.frame(electrodes_csv)) { + col_name <- input$electrode_category_selector + vals <- electrodes_csv[[col_name]] + + # to get the selected choices, we need to match with what ELECTRODE_TEXT currently provides + .selected <- unique(vals[as.numeric(electrodes_csv$Electrode) %in% + as.numeric(parse_svec(input$ELECTRODE_TEXT))]) + + updateSelectInput(session, 'electrode_category_selector_choices', + selected = .selected, + choices = unique(vals)) + } +}) + +observeEvent(input$electrode_category_selector_choices, { + # be careful here so we don't trigger loops! + + + electrodes_csv %?<-% NULL + if(is.data.frame(electrodes_csv)) { + current_els <- as.numeric(parse_svec(input$ELECTRODE_TEXT) ) %>% sort + all_vals <- electrodes_csv[[input$electrode_category_selector]] + vals <- input$electrode_category_selector_choices + new_els <- as.numeric(electrodes_csv$Electrode[all_vals %in% vals]) %>% sort + + if(!all(new_els == current_els)) { + updateTextInput(session, 'ELECTRODE_TEXT', + value = deparse_svec(new_els)) + } else { + # no change + } + } +}) + + observeEvent(input$analysis_filter_variable, { electrodes_csv %?<-% NULL @@ -96,10 +164,16 @@ observeEvent(input$analysis_filter_variable_2, { } }) - observeEvent(input$select_good_electrodes, { if(!is.null(input$current_active_set)) { updateTextInput(session, 'ELECTRODE_TEXT', value = parse_svec(input$current_active_set)) + + if(! input$auto_calculate) { + print('a calc is off, auto click') + shinyjs::click('do_calculate_btn') + } else { + print('a calc is on, no click') + } } }) diff --git a/inst/modules/power_explorer/exports.R b/inst/modules/power_explorer/exports.R index 1143f5a..a1b4200 100644 --- a/inst/modules/power_explorer/exports.R +++ b/inst/modules/power_explorer/exports.R @@ -157,6 +157,21 @@ graph_export = function(){ ) } +download_electrodes_csv <- function() { + tagList(downloadLink(ns('btn_electrodes_meta_download'), 'Download copy of meta data for all electrodes'), + tags$p(' ', style='margin-bottom:20px')) +} + +output$btn_electrodes_meta_download <- downloadHandler( + filename=function(...) { + paste0('electrodes_meta_data_copy_', + format(Sys.time(), "%b_%d_%Y_%H_%M_%S"), '.csv') + }, + content = function(conn) { + write.csv(module_tools$get_meta('electrodes'), file=conn) + } +) + # observeEvent(input$btn_graph_export, { # export_graphs(conn = '~/Desktop/hmp_e.pdf') # }) diff --git a/inst/modules/power_explorer/main.R b/inst/modules/power_explorer/main.R index 4aa488c..27305cf 100644 --- a/inst/modules/power_explorer/main.R +++ b/inst/modules/power_explorer/main.R @@ -22,6 +22,20 @@ if(FALSE) { # return (val) # } +# these are only needed when shiny is running (e.g., module debug mode) +if(shiny_is_running()) { + calc_flag = shiny::isolate(local_data$calculate_flag) + + if( !auto_calculate && calc_flag >= do_calculate_btn ){ + # Not auto calculation + session$sendCustomMessage(type = 'rave_enable_button', message = list( element_id = ns('do_calculate_btn') )) + local_data$calculate_flag = do_calculate_btn + return() + }else{ + session$sendCustomMessage(type = 'rave_disable_button', message = list( element_id = ns('do_calculate_btn') )) + local_data$calculate_flag = do_calculate_btn + } +} requested_electrodes = rutabaga::parse_svec(ELECTRODE_TEXT, sep=',|;', connect = ':-') requested_electrodes %<>% get_by(`%in%`, electrodes) @@ -81,7 +95,6 @@ flat_data <- data.frame() # for transforms, the idea is to apply at each trial for each frequency # then when things get it will already be done - #relies on .transform as defined above if(combine_method != 'none') { transformed_power <- cache( @@ -111,7 +124,6 @@ if(combine_method != 'none') { ## Leave it here in case you want to change it later # (make it user specific) collapse_method = 'mean' - # we likely want to do it at the trial level, not on the back end before combining across electrodes # to help with caching, we need to only recalculate here if the GROUPs have changed. @@ -120,7 +132,8 @@ collapse_method = 'mean' # } for(ii in which(has_trials)){ -.time_stamp <- proc.time() + .time_stamp <- proc.time() + ### 17ms .power_all = bl_power$subset(Trial = Trial %in% group_data[[ii]]$Trial_num) .power_all_clean <- .power_all$subset(Trial=! (Trial %in% trial_outliers_list)) @@ -130,102 +143,99 @@ for(ii in which(has_trials)){ N = dim(.power_all)[1L] Nclean <- dim(.power_all_clean)[1L] - trials <- epoch_data %>% subset((.)$Trial %in% group_data[[ii]]$Trial_num) %>% extract2('Condition') - tnums <- epoch_data %>% subset((.)$Trial %in% group_data[[ii]]$Trial_num) %>% extract2('Trial') + epoch_data_subset <- epoch_data %>% subset((.)$Trial %in% group_data[[ii]]$Trial_num) # This copies over some information from group_data that is needed by particular plots # as well as populating data/range - wrap_data = function(value){ - list( + wrap_data = function(value, ...){ + ll = list( data = value, range = .fast_range(value), N = N, - trials = trials, + trials = epoch_data_subset$Condition, Trial_num = group_data[[ii]]$Trial_num, - is_clean = !(tnums %in% trial_outliers_list), + is_clean = !(epoch_data_subset$Trial %in% trial_outliers_list), name = group_data[[ii]]$name, has_trials = group_data[[ii]]$has_trials, - conditions = group_data[[ii]]$conditions + conditions = group_data[[ii]]$conditions, + baseline_window = BASELINE_WINDOW, + analysis_window = ANALYSIS_WINDOW, + frequency_window = FREQUENCY ) + + vals = list(...) + + for (k in c('ylab', 'zlab')) { + if (isTRUE(vals[[k]] == 'auto')) { + vals[[k]] = ifelse(combine_method == 'none', + 'Mean % Signal Change', + 'Mean ' %&% combine_method %&% ' %SC') + } + } + + for(k in names(vals)) { + # check for attribute labels + if (k %in% c('xlab', 'ylab', 'zlab')) { + attr(ll$data, k) = vals[[k]] + } + # all other values just add into the data list + else { + ll[[k]] = vals[[k]] + } + } + + return (ll) } - # 1 Time x Frequency - heat_map_data[[ii]] <- wrap_data(.power_all_clean$collapse(keep = c(3,2), method = collapse_method)) - - attr(heat_map_data[[ii]]$data, 'xlab') <- 'Time (s)' - attr(heat_map_data[[ii]]$data, 'ylab') <- 'Frequency' - attr(heat_map_data[[ii]]$data, 'zlab') <- ifelse(combine_method=='none', 'Mean % Signal Change', - 'Mean ' %&% combine_method %&% ' %SC') - - # the x value for the hmd is time - heat_map_data[[ii]]$x <- .power_all$dimnames$Time - - #the y value for the hmd is frequency - heat_map_data[[ii]]$y <- .power_all$dimnames$Frequency - - # hmd is using the clean data - heat_map_data[[ii]]$N <- Nclean - - # 2 Time x Trial (.power_freq) - # by trial data. - by_trial_heat_map_data[[ii]] <- wrap_data(.power_freq$collapse(keep = c(3,1), method = collapse_method)) - - # the x value for the bthmd is time - by_trial_heat_map_data[[ii]]$x <- .power_freq$dimnames$Time - - #the y value for the bthmd is Trial - by_trial_heat_map_data[[ii]]$y <- seq_along(.power_freq$dimnames$Trial) + # 1. power @ frequency over time + heat_map_data[[ii]] <- wrap_data( + .power_all_clean$collapse(keep = c(3,2), method = collapse_method), + xlab='Time (s)', ylab='Frequency', zlab='auto', + x = .power_all$dimnames$Time, + y = .power_all$dimnames$Frequency, + # hmd is using the clean data + N = Nclean + ) - attr(by_trial_heat_map_data[[ii]]$data, 'xlab') <- 'Time (s)' - attr(by_trial_heat_map_data[[ii]]$data, 'ylab') <- 'Trial' - attr(by_trial_heat_map_data[[ii]]$data, 'zlab') <- ifelse(combine_method=='none', 'Mean % Signal Change', - 'Mean ' %&% combine_method %&% ' %SC') + # 2. power @ trial over time + by_trial_heat_map_data[[ii]] <- wrap_data( + .power_freq$collapse(keep = c(3,1), method = collapse_method), + x = .power_freq$dimnames$Time, + y = seq_along(.power_freq$dimnames$Trial), + xlab='Time (s)', ylab='Trial', zlab='auto' + ) # 2.5 by electrode over time - by_electrode_heat_map_data[[ii]] <- wrap_data(.power_freq$collapse(keep = c(3,4), method = collapse_method)) - - # the x value for the bthmd is time - by_electrode_heat_map_data[[ii]]$x <- .power_freq$dimnames$Time - - #the y value for the bthmd is Trial - by_electrode_heat_map_data[[ii]]$y <- .power_freq$dimnames$Electrode - - attr(by_electrode_heat_map_data[[ii]]$data, 'xlab') <- 'Time (s)' - attr(by_electrode_heat_map_data[[ii]]$data, 'ylab') <- 'Electrode' - attr(by_electrode_heat_map_data[[ii]]$data, 'zlab') <- ifelse(combine_method=='none', 'Mean % Signal Change', - 'Mean ' %&% combine_method %&% ' %SC') + by_electrode_heat_map_data[[ii]] <- wrap_data( + .power_freq$collapse(keep = c(3,4), method = collapse_method), + x=.power_freq$dimnames$Time, + y=.power_freq$dimnames$Electrode, + xlab='Time (s)', ylab='Electrode', zlab='auto' + ) - # 3 Time only + # 3. Time only # coll freq and trial for line plot w/ ebar. Because we're doing error bars, we have to know whether we have 1 vs. >1 electrodes - # if(length(requested_electrodes) == 1){ # Single electrode, mean and mse for each time points line_plot_data[[ii]] = wrap_data(t( - apply(.power_freq_clean$collapse(keep = 3:4, method = 'mean'), 1, .fast_mse) - )) + apply(.power_freq_clean$collapse(keep = 3:4, method = 'mean'), 1, .fast_mse)), + xlab='Time (s)', ylab='auto', N=dim(.power_freq_clean)[4L], x=.power_freq_clean$dimnames$Time + ) + + # set NA (divide by zero) error bars to 0 + line_plot_data[[ii]]$data[is.na(line_plot_data[[ii]]$data[,2]),2] <- 0 - attr(line_plot_data[[ii]]$data, 'xlab') <- 'Time (s)' - attr(line_plot_data[[ii]]$data, 'ylab') <- ifelse(combine_method=='none', 'Mean % Signal Change', - 'Mean ' %&% combine_method %&% ' %SC') - # N for the line plot is the number of electrodes - line_plot_data[[ii]]$N <- dim(.power_freq_clean)[4L] + # we want to make a special range for the line plot data that takes into account mean +/- SE + line_plot_data[[ii]]$range <- .fast_range(plus_minus(line_plot_data[[ii]]$data[,1], + line_plot_data[[ii]]$data[,2])) # scatter bar data -- here we want all of the data because we are going to highlight (or not) the outliers -- same for by-trial heatmap # if(show_outliers_on_plots) { scatter_bar_data[[ii]] <- wrap_data( - rowMeans(.power_freq$subset(Time = (Time %within% ANALYSIS_WINDOW),data_only = TRUE)) - ) - # } else { - # scatter_bar_data[[ii]] = append(scatter_bar_data[[ii]], wrap_data( - # rowMeans(.power_freq_clean$subset( - # Time = (Time %within% ANALYSIS_WINDOW), - # data_only = TRUE - # )) - # )) - # } - # the N should reflect only those clean points, as the (summary) stats are based on the clean data only - scatter_bar_data[[ii]]$N <- Nclean - + rowMeans(.power_freq$subset(Time = (Time %within% ANALYSIS_WINDOW),data_only = TRUE)), + N=Nclean, xlab='Group', ylab='auto', x=.power_freq$dimnames$Time + ) + # Although this seems to be the wrong place to do this, not sure where else we can do it # to enable point identification later, we need to know the x-location of each point. So the jittering # needs to be done here. @@ -240,20 +250,7 @@ for(ii in which(has_trials)){ scatter_bar_data[[ii]]$xp <- .xp[xpi] set.seed(jitter_seed) scatter_bar_data[[ii]]$x <- .xp[xpi] + runif(length(scatter_bar_data[[ii]]$data), -.r, .r) - - attr(scatter_bar_data[[ii]]$data, 'xlab') <- 'Group' - attr(scatter_bar_data[[ii]]$data, 'ylab') <- ifelse(combine_method=='none', 'Mean % Signal Change', - 'Mean ' %&% combine_method %&% ' %SC') - - line_plot_data[[ii]]$data[is.na(line_plot_data[[ii]]$data[,2]),2] <- 0 - - - # we want to make a special range for the line plot data that takes into account mean +/- SE - line_plot_data[[ii]]$range <- .fast_range(plus_minus(line_plot_data[[ii]]$data[,1], - line_plot_data[[ii]]$data[,2])) - - # also add in the x variable for the time series - line_plot_data[[ii]]$x <- .power_freq$dimnames$Time + # for the scatter_bar_data we also need to get m_se within condition w/o the outliers scatter_bar_data[[ii]]$mse <- .fast_mse(scatter_bar_data[[ii]]$data[scatter_bar_data[[ii]]$is_clean]) @@ -261,11 +258,10 @@ for(ii in which(has_trials)){ flat_data %<>% rbind(data.frame('group'=ii, 'y' = with(scatter_bar_data[[ii]], data[is_clean]))) - print('loop ' %&% ii) - print(proc.time() - .time_stamp) + # print('loop ' %&% ii) + # print(proc.time() - .time_stamp) } -# .power_freq[,, preload_info$time_points %within% ANALYSIS_WINDOW, ]$data # for baseline you want to have only the baseline times flat_data$group %<>% factor @@ -273,7 +269,7 @@ flat_data$group %<>% factor # this can be used elsewhere has_data = sum(has_trials) -# calculate some statistics +# calculate some statistics across electrodes # because we're eventually going to be doing second-level stats, we're not too worried about # gratuitous NHST @@ -294,6 +290,7 @@ get_data_per_electrode <- function() { bl.analysis <- bl$subset(Time=Time %within% ANALYSIS_WINDOW) pow <- bl$collapse(keep = c(1,4)) m = colMeans(pow) + t = m / .fast_column_se(pow) p = 2*pt(abs(t), df = nrow(pow)-1, lower=F) @@ -310,7 +307,7 @@ omnibus_results <- cache( val = get_data_per_electrode() ) -# calculate the statistics here so that we can add them to the niml_out +# calculate the statistics here so that we can add them to plot output -- eventually this goes away? # if there are > 1 groups in the data, then do linear model, otherwise one-sample t-test if(length(unique(flat_data$group)) > 1) { # we need to check if they have supplied all identical data sets @@ -327,11 +324,12 @@ if(length(unique(flat_data$group)) > 1) { result_for_suma <- get_f(y ~ group, flat_data) } } else { - result_for_suma <- flat_data$y %>% get_t + result_for_suma <- get_t(flat_data$y) } attr(scatter_bar_data, 'stats') <- result_for_suma + # <<<<<<<<<<<< End ----------------- [DO NOT EDIT THIS LINE] ------------------- # Debug diff --git a/inst/modules/univariate_power_explorer/exports.R b/inst/modules/univariate_power_explorer/exports.R index b02631f..f566340 100644 --- a/inst/modules/univariate_power_explorer/exports.R +++ b/inst/modules/univariate_power_explorer/exports.R @@ -131,11 +131,6 @@ graph_export = function(){ ) } -# observeEvent(input$btn_graph_export, { -# export_graphs(conn = '~/Desktop/hmp_e.pdf') -# }) - - output$btn_graph_download <- downloadHandler( filename = function(...) { paste0('power_explorer_export', diff --git a/inst/tools/input_widgets.R b/inst/tools/input_widgets.R index 2b0e4aa..aed901e 100644 --- a/inst/tools/input_widgets.R +++ b/inst/tools/input_widgets.R @@ -146,14 +146,14 @@ define_input_multiple_electrodes <- function(inputId, label = 'Electrodes'){ electrodes = preload_info$electrodes - last_input = cache_input(!!inputId, val = as.character(electrodes[1])) + last_input = cache_input(!!inputId, val = as.character(electrodes)) e = rave::parse_selections(last_input) e = e[e %in% electrodes] if(!length(e)){ e = electrodes[1] } value = rave::deparse_selections(e) - label = 'Electrodes (' %&% rave::deparse_selections(electrodes) %&% ')' + label = paste0(!!label, ' (currently loaded: ', rave::deparse_selections(electrodes), ')') } ) }) @@ -303,12 +303,16 @@ define_input_condition_groups <- function(inputId, label = 'Group', initial_grou choices = cond ) ) - value = cache_input(!!inputId, list( + default_val = list( list( group_name = 'All Conditions', group_conditions = list(cond) ) - )) + ) + value = cache_input(!!inputId, default_val) + if( !length(value) || !length(value[[1]]$group_conditions) || !any(value[[1]]$group_conditions %in% cond)){ + value = default_val + } } ) }) From ab85029325edfcc92a894997bcff18585e19d834 Mon Sep 17 00:00:00 2001 From: dipterix Date: Wed, 9 Oct 2019 13:50:39 -0500 Subject: [PATCH 08/24] enabled power explorer data export to group analysis --- R/power_explorer_plots.R | 11 +- inst/modules/power_explorer/comp.R | 20 +++- inst/modules/power_explorer/event_handlers.R | 120 ++++++++++++------- inst/modules/power_explorer/exports.R | 115 ++++++++++++++++++ inst/modules/power_explorer/main.R | 28 ++++- 5 files changed, 242 insertions(+), 52 deletions(-) diff --git a/R/power_explorer_plots.R b/R/power_explorer_plots.R index ad08020..6306389 100644 --- a/R/power_explorer_plots.R +++ b/R/power_explorer_plots.R @@ -108,9 +108,9 @@ determine_passing_electrodes <- function(results, ...) { } } + # now we do the check on the anatomical filters emeta <- results$get_value('electrodes_csv') - afilt <- sapply('analysis_filter_variable' %&% c('', '_2'), function(e) results$get_value(e)) aval <- lapply('analysis_filter_elec' %&% c('', '_2'), function(e) results$get_value(e)) @@ -134,9 +134,11 @@ determine_passing_electrodes <- function(results, ...) { # no. instead let's put this value in a textInput?? if(shiny_is_running()){ - updateTextInput(getDefaultReactiveDomain(), 'current_active_set', value=deparse_svec( - as.numeric(names(which(pass_the_test))) - )) + # updateTextInput(getDefaultReactiveDomain(), 'current_active_set', value=deparse_svec( + # as.numeric(names(which(pass_the_test))) + # )) + updateTextInput(getDefaultReactiveDomain(), 'current_active_set', + value=deparse_svec(emeta$Electrode[pass_the_test])) } return(pass_the_test) } @@ -164,7 +166,6 @@ across_electrodes_corrected_pvalue <- function(results, ...) { # we want to determine the cut point based on the currently selected filters # we need to check all the filters, in case they have multiple filters passing_els <- determine_passing_electrodes(results) - # print(names(passing_els)) .col <- get_foreground_color() cut <- as.numeric(results$get_value('pval_operand')) diff --git a/inst/modules/power_explorer/comp.R b/inst/modules/power_explorer/comp.R index a1e5039..d851e9c 100644 --- a/inst/modules/power_explorer/comp.R +++ b/inst/modules/power_explorer/comp.R @@ -184,6 +184,7 @@ define_input( definition = checkboxInput('analysis_mask_export',value = FALSE, label = 'Export Electrode Mask')) + define_input_time(inputId = 'export_time_window', label='Export time window', initial_value = c(0,1)) define_input( definition = checkboxInput('filter_3d_viewer', "Filter 3D Viewer Results (requires viewer reload)", value=FALSE)) @@ -204,7 +205,7 @@ define_input( , init_args = c('choices', 'selected'), init_expr = { choices = c('none', names(electrodes_csv)) - selected = elec_filter + selected = 'none' }) define_input( @@ -265,8 +266,14 @@ define_input( definition = textInput('mean_operand', label= ' ')) define_input( - definition = actionButtonStyled('export_data', label='Export data for group analysis', icon=shiny::icon('download'), - type = 'primary')) + definition = customizedUI('export_data_ui') + ) + define_input( + definition = checkboxInput('export_also_download', 'Also download data', value = FALSE) + ) + # define_input( + # definition = actionButtonStyled('export_data', label='Export data for group analysis', icon=shiny::icon('download'), + # type = 'primary')) define_input( definition = actionButtonStyled('select_good_electrodes',label='Visualize Active Electrodes', @@ -370,7 +377,7 @@ define_input( # determine which variables only need to be set, not triggering rendering nor executing manual_inputs <- c( 'graph_export', 'filter_3d_viewer', 'trial_type_filter', 'synch_with_trial_selector', 'download_electrodes_csv', - 'export_what', 'analysis_prefix', 'analysis_mask_export', 'export_data', 'current_active_set' + 'export_what', 'analysis_prefix', 'analysis_mask_export', 'export_data', 'current_active_set', 'export_also_download', 'export_time_window' ) # Define layouts if exists @@ -432,8 +439,11 @@ input_layout = list( 'current_active_set', 'select_good_electrodes', 'trial_type_filter', 'synch_with_trial_selector', + 'export_time_window', 'analysis_prefix', - 'export_data' + # 'export_data' + 'export_data_ui', + 'export_also_download' ) ) diff --git a/inst/modules/power_explorer/event_handlers.R b/inst/modules/power_explorer/event_handlers.R index b2124f7..e9b7573 100644 --- a/inst/modules/power_explorer/event_handlers.R +++ b/inst/modules/power_explorer/event_handlers.R @@ -17,7 +17,7 @@ observeEvent(input$power_3d_mouse_dblclicked, { .data <- input$power_3d_mouse_dblclicked - print(input$power_3d_mouse_dblclicked) + # print(input$power_3d_mouse_dblclicked) if(isTRUE(.data$is_electrode)) { e <- .data$electrode_number @@ -62,30 +62,67 @@ observeEvent(input$synch_with_trial_selector, { }) -observeEvent(input$ELECTRODE_TEXT, { - # be careful here so we don't trigger loops! - electrodes_csv %?<-% NULL - if(is.data.frame(electrodes_csv)) { - - # check if the electrode text matches the current electrode values - current_etext_els <- as.numeric(parse_svec(input$ELECTRODE_TEXT) ) %>% sort - all_vals <- electrodes_csv[[input$electrode_category_selector]] - vals <- input$electrode_category_selector_choices - current_category_els <- as.numeric(electrodes_csv$Electrode[vals == all_vals]) %>% sort - - if(!all(current_etext_els == current_category_els)) { - .selected <- unique(all_vals[as.numeric(electrodes_csv$Electrode) %in% - current_etext_els]) +rave::sync_shiny_inputs( + input = input, session = session, inputIds = c( + 'ELECTRODE_TEXT', 'electrode_category_selector_choices' + ), uniform = list( + # ELECTRODE_TEXT to electrodes + function(ELECTRODE_TEXT){ + return(parse_svec(ELECTRODE_TEXT, sort = TRUE)) + }, + # electrode_category_selector_choices to electrodes + function(electrode_category_selector_choices){ + electrodes_csv %?<-% NULL + if(!is.data.frame(electrodes_csv)) { return(NULL) } + current_els <- parse_svec(input$ELECTRODE_TEXT, sort = TRUE) + all_vals <- electrodes_csv[[input$electrode_category_selector]] + vals <- electrode_category_selector_choices + new_els <- as.numeric(electrodes_csv$Electrode[all_vals %in% vals]) %>% sort + return(new_els) + } + ), updates = list( + # update ELECTRODE_TEXT + function(els){ + if(!is.null(els)) {updateTextInput(session, 'ELECTRODE_TEXT', value = deparse_svec(els))} + }, + # update electrode_category_selector_choices + function(els){ + electrodes_csv %?<-% NULL + if(!is.data.frame(electrodes_csv)) { return(NULL) } + + all_vals <- electrodes_csv[[input$electrode_category_selector]] + selected <- unique(all_vals[as.numeric(electrodes_csv$Electrode) %in% els]) updateSelectInput(session, 'electrode_category_selector_choices', - selected = .selected) - } else { - # no change + selected = selected) } - - - } -}) + ) +) + +# observeEvent(input$ELECTRODE_TEXT, { +# # be careful here so we don't trigger loops! +# electrodes_csv %?<-% NULL +# if(is.data.frame(electrodes_csv)) { +# +# # check if the electrode text matches the current electrode values +# current_etext_els <- as.numeric(parse_svec(input$ELECTRODE_TEXT) ) %>% sort +# all_vals <- electrodes_csv[[input$electrode_category_selector]] +# vals <- input$electrode_category_selector_choices +# current_category_els <- as.numeric(electrodes_csv$Electrode[vals == all_vals]) %>% sort +# +# if(!all(current_etext_els == current_category_els)) { +# .selected <- unique(all_vals[as.numeric(electrodes_csv$Electrode) %in% +# current_etext_els]) +# +# updateSelectInput(session, 'electrode_category_selector_choices', +# selected = .selected) +# } else { +# # no change +# } +# +# +# } +# }) observeEvent(input$electrode_category_selector, { @@ -107,25 +144,26 @@ observeEvent(input$electrode_category_selector, { } }) -observeEvent(input$electrode_category_selector_choices, { - # be careful here so we don't trigger loops! - - - electrodes_csv %?<-% NULL - if(is.data.frame(electrodes_csv)) { - current_els <- as.numeric(parse_svec(input$ELECTRODE_TEXT) ) %>% sort - all_vals <- electrodes_csv[[input$electrode_category_selector]] - vals <- input$electrode_category_selector_choices - new_els <- as.numeric(electrodes_csv$Electrode[all_vals %in% vals]) %>% sort - - if(!all(new_els == current_els)) { - updateTextInput(session, 'ELECTRODE_TEXT', - value = deparse_svec(new_els)) - } else { - # no change - } - } -}) +# observeEvent(input$electrode_category_selector_choices, { +# # be careful here so we don't trigger loops! +# +# +# electrodes_csv %?<-% NULL +# if(is.data.frame(electrodes_csv)) { +# current_els <- as.numeric(parse_svec(input$ELECTRODE_TEXT) ) %>% sort +# all_vals <- electrodes_csv[[input$electrode_category_selector]] +# vals <- input$electrode_category_selector_choices +# new_els <- as.numeric(electrodes_csv$Electrode[all_vals %in% vals]) %>% sort +# +# if(!all(new_els == current_els)) { +# updateTextInput(session, 'ELECTRODE_TEXT', +# value = deparse_svec(new_els)) +# } else { +# # no change +# } +# } +# }) + observeEvent(input$analysis_filter_variable, { diff --git a/inst/modules/power_explorer/exports.R b/inst/modules/power_explorer/exports.R index a1b4200..3806f89 100644 --- a/inst/modules/power_explorer/exports.R +++ b/inst/modules/power_explorer/exports.R @@ -301,5 +301,120 @@ export_graphs <- function(conns=NA, plot_functions, ...) { # Export data options +export_data_ui <- function(){ + download = isTRUE(input$export_also_download) + if( download ){ + tags$a(id = ns('export_data_and_download'), class = 'btn btn-primary shiny-download-link', + href = '', target='_blank', download='', + shiny::icon('download'), 'Export data for group analysis') + }else{ + actionButtonStyled(ns('export_data_only'), + label = 'Export data for group analysis', + icon=shiny::icon('save'), + type = 'primary') + } +} + +output$export_data_and_download <- downloadHandler( + filename = function(){ + analysis_prefix = stringr::str_replace_all(analysis_prefix, '[^\\w]+', '_') + paste0(analysis_prefix, '.csv.gz') + }, + content = function(con){ + res_path = export_data_function() + R.utils::gzip(res_path, destname = con) + } +) +observeEvent(input$export_data_only, { + export_data_function() + showNotification(p('Done saving'), duration = 3, type = 'message') +}) +# export data for group analysis +export_data_function <- function(){ + + project_name = subject$project_name + subject_code = subject$subject_code + + # et electrodes to be exported + electrodes = parse_selections(current_active_set) + electrodes = electrodes[electrodes %in% preload_info$electrodes] + + progress = progress('Exporting baselined data...', max = 3 + length(electrodes)) + on.exit({ progress$close() }) + progress$inc('Collecting data') + + # Get trial conditions + conditions = trial_type_filter + conditions = conditions[conditions %in% preload_info$condition] + trials = module_tools$get_meta('trials') + trial_number = trials$Trial[trials$Condition %in% conditions] + + # Get timepoints,frequency range + time_points = preload_info$time_points + time_points = time_points[time_points %within% export_time_window] + freq_range = preload_info$frequencies + freq_range = freq_range[freq_range %within% FREQUENCY] + + # get baseline + baseline_range = BASELINE_WINDOW + + # Do some checks + + # Check 1: if no electrode is chosen + # Check 2: if no condition is chosen + # Check 3: if no time is chosen + # Check 4: if no frequency is found + check_fails = !c(length(electrodes), length(trial_number), length(time_points), length(time_points)) + err_msg = c('None of the electrodes to be exported is loaded', 'No trial found matching selected condition', + 'Time range is too narrow for any data points to be found', 'Frequency range is too narrow for any data points to be found') + if(any(check_fails)){ + err_msg = err_msg[check_fails] + showNotification(p('The following error(s) found:',br(),tags$ul(tagList( + lapply(err_msg, tags$li) + ))), type = 'error', id = ns('export_csv')) + return() + } + + # Baseline + progress$inc('Generating results... (might take a while)') + + # Memory-friendly baseline but might be more time consuming + power = module_tools$get_power(referenced = TRUE) + + # condition list + cond_list = list(); cond_list[trials$Trial] = trials$Condition + + # Use async lapply to speed up the calculation as it's really per electrode analysis + res = rave::lapply_async(electrodes, function(e){ + bl = baseline(power$subset(Trial = Trial %in% trial_number, + Time = Time %within% time_points, + Frequency = Frequency %within% freq_range, + Electrode = Electrode %in% e), + from = baseline_range[1], to = baseline_range[2], hybrid = FALSE, mem_optimize = FALSE) + flat = bl$collapse(keep = c(1,3)) + dimnames(flat) = dimnames(bl)[c(1,3)] + flat = reshape2::melt(flat, value.name = 'Power') # trial time, value + flat$Condition = unlist(cond_list[flat$Trial]) + flat$Electrode = e + flat + }, .call_back = function(ii){ + progress$inc(sprintf('Electrode %d', electrodes[[ii]])) + # specify all variables in .globals, in this way we can avoid the whole memory mappings + }, .globals = c('power', 'trial_number', 'time_points', 'freq_range', 'e', 'baseline_range', 'cond_list')) + res = do.call('rbind', res) + res$Project = project_name + res$Subject = subject_code + # Write out results + progress$inc('Writing out on server, preparing...') + # write to server _project_data/power_explorer/file + analysis_prefix = stringr::str_replace_all(analysis_prefix, '[^\\w]+', '_') + now = strftime(Sys.time(), '-%Y%m%d-%H%M%S') + + fname = paste0(analysis_prefix, now, '.csv') + dirname = file.path(subject$dirs$subject_dir, '..', '_project_data', 'power_explorer') + dir.create(dirname, showWarnings = FALSE, recursive = TRUE) + data.table::fwrite(res, file.path(dirname, fname), append = FALSE) + return(normalizePath(file.path(dirname, fname))) +} diff --git a/inst/modules/power_explorer/main.R b/inst/modules/power_explorer/main.R index 27305cf..214a56a 100644 --- a/inst/modules/power_explorer/main.R +++ b/inst/modules/power_explorer/main.R @@ -299,12 +299,38 @@ get_data_per_electrode <- function() { return(res) } +get_data_per_electrode_alt <- function(){ + trial_numbers = epoch_data$Trial[epoch_data$Condition %in% all_trial_types] + + # Do not baseline them all, otherwise memory will explode + res = rave::lapply_async(electrodes, function(e){ + # Subset on electrode is memory optimized, and is fast + bl = power$subset(Electrode = Electrode == e) + bl = baseline(bl$subset(Trial=Trial %in% trial_numbers, + Frequency=Frequency %within% FREQUENCY, + Time=Time %within% range(BASELINE_WINDOW, ANALYSIS_WINDOW) ), + from=BASELINE_WINDOW[1], to= BASELINE_WINDOW[2], + hybrid = FALSE, mem_optimize = FALSE) + bl.analysis <- bl$subset(Time=Time %within% ANALYSIS_WINDOW) + pow <- bl$collapse(keep = c(1,4)) + m = colMeans(pow) + + t = m / .fast_column_se(pow) + p = 2*pt(abs(t), df = nrow(pow)-1, lower=F) + + res <- rbind(m,t,p) + colnames(res) <- e + res + }, .globals = c('electrodes', 'e', 'trial_numbers', 'FREQUENCY', 'ANALYSIS_WINDOW', 'BASELINE_WINDOW', + '.fast_column_se'), .gc = FALSE) + do.call('cbind', res) +} omnibus_results <- cache( key = list(subject$id, BASELINE_WINDOW, FREQUENCY,all_trial_types, ANALYSIS_WINDOW, combine_method, preload_info$epoch_name, preload_info$reference_name, trial_outliers_list), - val = get_data_per_electrode() + val = get_data_per_electrode_alt() ) # calculate the statistics here so that we can add them to plot output -- eventually this goes away? From 7706f38bf73709135a90e62992845ca960429fc5 Mon Sep 17 00:00:00 2001 From: John Magnotti Date: Wed, 9 Oct 2019 15:03:17 -0500 Subject: [PATCH 09/24] switch to .csv from .gz --- inst/modules/power_explorer/exports.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/inst/modules/power_explorer/exports.R b/inst/modules/power_explorer/exports.R index 3806f89..9786fe6 100644 --- a/inst/modules/power_explorer/exports.R +++ b/inst/modules/power_explorer/exports.R @@ -318,11 +318,12 @@ export_data_ui <- function(){ output$export_data_and_download <- downloadHandler( filename = function(){ analysis_prefix = stringr::str_replace_all(analysis_prefix, '[^\\w]+', '_') - paste0(analysis_prefix, '.csv.gz') + paste0(analysis_prefix, '.csv') }, content = function(con){ res_path = export_data_function() - R.utils::gzip(res_path, destname = con) + # R.utils::gzip(res_path, destname = con) + file.copy(res_path, to=con) } ) observeEvent(input$export_data_only, { From 85ae9a5722f3fe7c88008462815fab1a5ac5117e Mon Sep 17 00:00:00 2001 From: dipterix Date: Thu, 10 Oct 2019 18:19:41 -0500 Subject: [PATCH 10/24] Added two utils: col2hex can easily make color for html htmltable_confmat writes down analysis results (like lm) to html table --- R/utils.R | 138 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 138 insertions(+) diff --git a/R/utils.R b/R/utils.R index 30efa3b..4aec6ef 100644 --- a/R/utils.R +++ b/R/utils.R @@ -13,3 +13,141 @@ package_installed <- function (pkg) { system.file("", package = pkg) != "" } + +col2hex <- function(col, alpha = NULL, prefix = '#'){ + col = grDevices::col2rgb(col, alpha = FALSE) / 255 + col = grDevices::rgb(red = col[1,], green = col[2,], blue = col[3,], alpha = alpha) + stringr::str_replace(col, '^[^0-9A-F]*', prefix) +} + +htmltable_coefmat <- function( + x, caption = NULL, digits = max(3L, getOption("digits") - 2L), + signif.stars = getOption("show.signif.stars"), + signif.legend = signif.stars, + dig.tst = max(1L, min(5L, digits - 1L)), + k = 3, + cs.ind = 1:k, tst.ind = k + 1, + zap.ind = integer(), + nc = ncol(x), + P.values = NULL, + has.Pvalue = nc >= 4L && length(cn <- colnames(x)) && + substr(cn[nc], 1L, 3L) %in% c("Pr(", "p-v"), + eps.Pvalue = .Machine$double.eps, + na.print = "NA", quote = FALSE, right = TRUE, ... +){ + if (is.null(d <- dim(x)) || length(d) != 2L) + stop("'x' must be coefficient matrix/data frame") + nc <- d[2L] + if (is.null(P.values)) { + scp <- getOption("show.coef.Pvalues") + if (!is.logical(scp) || is.na(scp)) { + warning("option \"show.coef.Pvalues\" is invalid: assuming TRUE") + scp <- TRUE + } + P.values <- has.Pvalue && scp + } else if (P.values && !has.Pvalue) { + stop("'P.values' is TRUE, but 'has.Pvalue' is not") + } + + if (has.Pvalue && !P.values) { + d <- dim(xm <- data.matrix(x[, -nc, drop = FALSE])) + nc <- nc - 1 + has.Pvalue <- FALSE + } else { + xm <- data.matrix(x) + } + k <- nc - has.Pvalue - ifelse (missing(tst.ind), 1, length(tst.ind)) + if (!missing(cs.ind) && length(cs.ind) > k) { + stop("wrong k / cs.ind") + } + Cf <- array("", dim = d, dimnames = dimnames(xm)) + ok <- !(ina <- is.na(xm)) + for (i in zap.ind) xm[, i] <- zapsmall(xm[, i], digits) + if (length(cs.ind)) { + acs <- abs(coef.se <- xm[, cs.ind, drop = FALSE]) + if (any(ia <- is.finite(acs))) { + digmin <- 1 + if (length(acs <- acs[ia & acs != 0])) + floor(log10(range(acs[acs != 0], finite = TRUE))) + else 0 + Cf[, cs.ind] <- format(round(coef.se, max(1L, digits - + digmin)), digits = digits) + } + } + if (length(tst.ind)) + Cf[, tst.ind] <- format(round(xm[, tst.ind], digits = dig.tst), + digits = digits) + if (any(r.ind <- !((1L:nc) %in% c(cs.ind, tst.ind, if (has.Pvalue) nc)))) + for (i in which(r.ind)) Cf[, i] <- format(xm[, i], digits = digits) + ok[, tst.ind] <- FALSE + okP <- if (has.Pvalue) ok[, -nc] else ok + x1 <- Cf[okP] + dec <- getOption("OutDec") + if (dec != ".") x1 <- chartr(dec, ".", x1) + x0 <- (xm[okP] == 0) != (as.numeric(x1) == 0) + if (length(not.both.0 <- which(x0 & !is.na(x0)))) { + Cf[okP][not.both.0] <- format(xm[okP][not.both.0], digits = max(1L, + digits - 1L)) + } + if (any(ina)) Cf[ina] <- na.print + if (P.values) { + if (!is.logical(signif.stars) || is.na(signif.stars)) { + warning("option \"show.signif.stars\" is invalid: assuming TRUE") + signif.stars <- TRUE + } + if (any(okP <- ok[, nc])) { + pv <- as.vector(xm[, nc]) + Cf[okP, nc] <- format.pval(pv[okP], digits = dig.tst, + eps = eps.Pvalue) + signif.stars <- signif.stars && any(pv[okP] < 0.1) + if (signif.stars) { + Signif <- symnum(pv, corr = FALSE, na = FALSE, + cutpoints = c(0, 0.001, 0.01, 0.05, 0.1, 1), + symbols = c("***", "**", "*", ".", " ")) + Cf <- cbind(Cf, format(Signif)) + } + } else signif.stars <- FALSE + } else signif.stars <- FALSE + + # Make Cf a table + # print.default(Cf, quote = quote, right = right, na.print = na.print, ...) + re = list() + tags = htmltools::tags + rnames = rownames(Cf) + + if(length(caption) != 1){ + caption = NULL + } + sleg = '' + if (signif.stars && signif.legend) { + if ((w <- getOption("width")) < nchar(sleg <- attr(Signif, "legend"))){ + sleg <- strwrap(sleg, width = w - 2, prefix = " ") + } + # cat("---\nSignif. codes: ", sleg, sep = "", fill = w + 4 + max(nchar(sleg, "bytes") - nchar(sleg))) + re$signif = sleg + sleg = tagList( + br(), + sprintf(' - Signif. codes: %s', sleg) + ) + } + + re$table = tags$div( + class = 'table-responsive', + tags$table( + class = 'table table-striped table-sm', + tags$caption(caption, ' ', tags$small(sleg)), + tags$thead( + tags$tr( + lapply(c('', colnames(Cf)), tags$th) + ) + ), + tags$tbody( + lapply(seq_len(nrow(Cf)), function(ii){ + v = c(rnames[ii], Cf[ii,]); names(v) = NULL + tags$tr(lapply(v, tags$td)) + }) + ) + ) + ) + + re +} From 1de2742ac62b23c45719ed69b6aa2957095e0161 Mon Sep 17 00:00:00 2001 From: dipterix Date: Thu, 10 Oct 2019 18:23:57 -0500 Subject: [PATCH 11/24] Allow multiple initializations --- inst/tools/comps.R | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/inst/tools/comps.R b/inst/tools/comps.R index a2f4190..1d60846 100644 --- a/inst/tools/comps.R +++ b/inst/tools/comps.R @@ -163,8 +163,11 @@ get_comp_env <- function(module_id){ init_env = new.env(parent = emptyenv()) init_env[['init']] = FALSE define_initialization = function(definition){ + if(isFALSE(init_env[['init']])){ + init_env[['init']] = list() + } definition = substitute(definition) - init_env[['init']] = definition + init_env[['init']][[length(init_env[['init']]) + 1]] = definition } scripts = new.env(parent = emptyenv()) load_scripts = function(..., asis = FALSE){ @@ -228,7 +231,13 @@ parse_components <- function(module_id){ init_expr = envs$init_env$init inits = lapply(inputs, '[[', 'initialization') names(inits) = names(inputs) - rave_update_quo = rlang::quo(rave_updates({eval(!!init_expr)}, !!!inits)) + + init_anon_quos = lapply(init_expr, function(expr){rlang::quo(eval(!!expr))}) + + rlang::quo(rave_updates({!!!init_anon_quos})) + + rave_update_quo = rlang::quo(rave_updates({!!!init_anon_quos}, !!!inits)) + # rave_update_quo = rlang::quo(rave_updates({eval(!!init_expr)}, !!!inits)) # outputs output_layout = tmp_env[['output_layout']] @@ -361,7 +370,10 @@ init_module <- function(module_id, debug = FALSE, force_local=FALSE){ # initialize global variables init_expr = envs$init_env$init - base::eval(init_expr, envir = param_env) + lapply(init_expr, function(expr){ + base::eval(expr, envir = param_env) + }) + # Initialize inputs inputs = as.list(envs$input_env) From 1d3a0c9466e5a0ba4b0e74977774a1d4d91999ab Mon Sep 17 00:00:00 2001 From: dipterix Date: Thu, 10 Oct 2019 18:25:22 -0500 Subject: [PATCH 12/24] New LME module --- inst/modules/group_analysis_lme/common.R | 462 ++---------------- inst/modules/group_analysis_lme/comp.R | 132 ++++- .../group_analysis_lme/input_analysis.R | 30 ++ .../group_analysis_lme/input_filters.R | 1 + inst/modules/group_analysis_lme/outputs.R | 106 ++++ inst/modules/group_analysis_lme/reactives.R | 422 ++++++++++++++++ inst/tools/input_widgets.R | 458 +++++++++++++++++ 7 files changed, 1170 insertions(+), 441 deletions(-) create mode 100644 inst/modules/group_analysis_lme/input_analysis.R create mode 100644 inst/modules/group_analysis_lme/input_filters.R create mode 100644 inst/modules/group_analysis_lme/outputs.R create mode 100644 inst/modules/group_analysis_lme/reactives.R diff --git a/inst/modules/group_analysis_lme/common.R b/inst/modules/group_analysis_lme/common.R index 60bab52..9c12593 100644 --- a/inst/modules/group_analysis_lme/common.R +++ b/inst/modules/group_analysis_lme/common.R @@ -1,18 +1,4 @@ -input = getDefaultReactiveInput() -output = getDefaultReactiveOutput() -session = getDefaultReactiveDomain() -local_data = reactiveValues( - potential_analysis = list(), - analysis_name = NULL, - sample_table = NULL, - var_dependent = NULL, - var_fixed_effects = NULL, - lmer_results = NULL, - full_table=NULL, - filter_count = 0, - filters = list() -) matrix_to_table <- function(mat, row_label=' ') { @@ -41,9 +27,13 @@ matrix_to_table <- function(mat, row_label=' ') { } -output$lme_output <- renderUI({ - - .lmer <- isolate(local_data$lmer_results) +lme_out = function() { + # put analysis information in here + if(is.null(local_data$lmer_results)){ + return(htmltools::div(style='color:#a1a1a1; text-align:center; ', 'No model calculated yet')) + } + + lmer_results = local_data$lmer_results # flat_data <- isolate(local_data$full_table) # # # ranef @@ -54,410 +44,42 @@ output$lme_output <- renderUI({ # # plot(fitted(.lmer) + resid(.lmer), fitted(.lmer), asp=1) # - + + smry = summary(lmer_results) + + tbl_html = htmltable_coefmat(smry$coefficients, caption = 'LME Summary Table') # put a description row - txt <- '

LME Call: ' %&% format(formula(.lmer)) %&% '
' %&% - (summary(.lmer)$methTitle %>% str_replace_all('\n', '
')) %&% '

' - - # fancy up the variable printing a bit, put the str_rep in parentheses so we don't mess up the description lines above - # we also want to give people a hint about the reference level - # ref_tt <- levels(flat_data$)[1] - # ref_tp <- levels(flat_data$time_period)[1] - # intercept <- sprintf('Intercept=%s:%s', ref_tt, ref_tp) - txt <- txt %&% ( - (summary(.lmer)$coefficients %>% matrix_to_table(row_label='Coef')) #%>% - # str_replace_all('trial_type', 'Trial=') %>% - # str_replace_all('time_period', 'Time=') %>% - # str_replace_all('(Intercept)', intercept) - ) - - HTML( - # '' - txt) -}) - -var_sel = function(){ - if(local_data$filter_count > 0){ - minus_btn = actionButton(ns('filter_minus'), shiny::icon('minus')) - - vars = names(local_data$sample_table) - vars %?<-% '' - - # restore filters if previous entered - filters = isolate(local_data$filters) - filter = list() # default list - - filter_uis = lapply( - seq_len(local_data$filter_count), - function(ii){ - if(length(filters) >= ii){ - # Make sure if you hit "+", the last loop won't crash - # in that case, filter will be the list() in parent environment - filter = filters[[ii]] - } - tagList( - tagList( - tags$label('Filter ' %&% ii, style = ifelse(ii == 1, '', 'margin-top: 15px;')), - div( - # To make a box to wrap group inputs - class = 'rave-grid-inputs', - div( - style = 'flex-basis: 50%;', - selectInput(ns('filter_var_' %&% ii), 'Variable', choices = vars, selected = get_val(filter, 'var', default = NULL)) - ), - div( - style = 'flex-basis: 50%;', - selectInput(ns('filter_op_' %&% ii), 'Operator', choices = c('=', '!=', '>', '>=', '<', '<=', 'in', 'not in', 'between'), selected = get_val(filter, 'op', default = '=')) - ), - div( - style = 'flex-basis: 100%;', - textInput(ns('filter_val_' %&% ii), 'Value', value = get_val(filter, 'val', default = NULL)) - ) - ) - - ) - ) + htmltools::p( + smry$methTitle, sprintf(' (%s)', smry$objClass), br(), + 'LME call: ', strong(format(formula(lmer_results))), br(), + + 'Number of obs: ', strong(smry$devcomp$dims[["n"]]), 'groups: ', + strong(paste(paste(names(smry$ngrps), smry$ngrps, sep = ', '), collapse = '; ')), br(), + + br(), + # Convergence criteria + local({ + aictab = smry$AICtab + t.4 <- round(aictab, 1) + if (length(aictab) == 1 && names(aictab) == "REML") + res = tagList(paste("REML criterion at convergence:", t.4), br()) + else { + # t.4F <- format(t.4) + # t.4F["df.resid"] <- format(t.4["df.resid"]) + # res = capture.output(print(t.4F, quote = FALSE)) + res = NULL } - ) - }else{ - filter_uis = NULL - minus_btn = NULL - } - - tagList( - filter_uis, - div( - # Put a div to make buttons within a row - actionButton(ns('filter_add'), shiny::icon('plus')), - minus_btn - ) - ) -} - -# A function to collect filters -# Non-reactive mode, please use isolate(get_filters()) to avoid unwanted updates!!! -get_filters = function(){ - fcounts = local_data$filter_count - if(!length(fcounts)){ - removeNotification(id = ns('filter_noti')) - # Always returns a list - return(list( - content = list(), - error_counts = 0 - )) - } - - lapply(seq_len(fcounts), function(ii){ - var = input[['filter_var_' %&% ii]] - op = input[['filter_op_' %&% ii]] - val = input[['filter_val_' %&% ii]] - - # TODO Check data - failed = TRUE - msg = 'Filter Blablabla' - - list( - # Don't change - var = var, op = op, val = val, failed = failed, msg = msg - # Add filtered value, var, op here - # filtered_val = ... - ) - }) -> - re - - err_msg = lapply(re, function(v){ - if(v$failed){ - return(tags$li(v$msg)) - }else{ - return() - } - }) - err_msg = dropNulls(err_msg) - - if(length(err_msg)){ - showNotification(p(strong('Filter error: '), tags$ul(tagList(err_msg))), id = ns('filter_noti'), duration = 60, type = 'error') - }else{ - removeNotification(id = ns('filter_noti')) - } - return(list( - content = re, - error_counts = length(err_msg) - )) -} - -observeEvent(input$filter_add, { - local_data$filter_count = local_data$filter_count + 1 -}) -observeEvent(input$filter_minus, { - # Make sure - local_data$filter_count = max(local_data$filter_count - 1, 0) -}) - -# test, remove this observer later -# Save filters to local_data -observe({ - filters = get_filters() - local_data$filters = get_val(filters, 'content', default = list()) -}) - - -lme_out = function() { - # put analysis information in here - if(!is.null(local_data$lmer_results)) { - return(htmlOutput(ns('lme_output'))) - } - return('no calculations yet') - -} - -# rave_execute({ -# # local_data$participants = participants -# -# # Compromise, I'll just look at the first subject -# r = lapply(participants, get_analysis); names(r) = participants -# local_data$potential_analysis = r -# }) - - -##### Input responses - - -# function to check analysis names for subjects - right now it's slow -# this will be changed later once group analysis table comes out #????? -get_analysis = function(subject_code){ - rave:::module_analysis_names(module_id = 'power_explorer') -} - -analysis_name_ui = function(){ - # It's depending on local_data$potential_analysis, only checks chosen subject - ps = participants - r = local_data$potential_analysis - - tbl = table(unlist(r[ps])) - choice = names(tbl)[tbl == length(ps)] - selected = local_data$analysis_name - - if(length(selected) == 1 && choice %in% selected){ - imported = TRUE - btn = actionButtonStyled(ns('import_analysis'), 'Load Analysis', width = '100%', type = 'primary', disabled = TRUE) - }else{ - imported = FALSE - btn = actionButtonStyled(ns('import_analysis'), 'Load Analysis', width = '100%', type = 'primary') - } - - selected = selected[selected %in% choice] - - tagList( - selectInput(ns('analysis_name'), 'Analysis', choices = choice, selected = selected), - btn + res + }), + + # residual + do.call('sprintf', c( + list('Scaled residual: %.4g (min), %.4g (25%%), %.4g (median), %.4g (75%%), %.4g (max)'), + structure(as.list(quantile(smry$residuals, na.rm = TRUE)), names = NULL) + )), + + # coef table + tbl_html$table + ) } - -observeEvent(input$import_analysis, { - analysis_name = input$analysis_name - if(!length(analysis_name) || is.blank(analysis_name)){ - showNotification(p('Analysis cannot be blank!'), type = 'error', id = ns('notif')) - return() - } - module_table = rave::module_analysis_table(subject$project_name, module_id = 'power_explorer', analysis_name = analysis_name) - - file = module_table$file[1] - - # file = file.path(project_dir, participants[1], 'rave', 'module_data', 'condition_explorer', analysis_name) - # file = "/Volumes/data/rave_data/ent_data/congruency/YAB/rave/module_data/condition_explorer/stat_out.RDS" - if(!file.exists(file)){ - showNotification(p('File ', file, ' does not exist!'), type = 'error', id = ns('notif')) - return() - } - - tbl = readRDS(file) - - ### Please check your data here - if(FALSE){ - showNotification(p('File ', file, ' does not exist!'), type = 'error', id = ns('notif')) - return() - } - - local_data$sample_table = tbl - local_data$analysis_name = analysis_name - showNotification(p('Analysis loaded!'), type = 'message', id = ns('notif')) -}) - -# Cache inputs to restore -observe({ - local_data$var_dependent = input$var_dependent -}) -observe({ - local_data$var_fixed_effects = input$var_fixed_effects -}) -observe({ - local_data$var_rand_effects = input$var_rand_effects -}) - - -### filters -build_op <- function(nm) {return ( - function() { - selectInput(ns(nm), 'Op', - choices = c('=', '!=', '>', '>=', '<', '<=', 'in', '! in'), - selected = '=') - }) -} -build_var <- function(nm) { - return ( function() { - tbl = local_data$sample_table - vars = names(tbl) - vars %?<-% '' - selectInput(ns(nm), 'Var', choices = vars, selected = '') - }) -} -build_val <- function(nm) return ( function() {textInput(ns(nm), 'Val')}) - - -# build the filters using assign just so it's more compact if we end up wanting to have >2 filters -f1var_ui <- build_var('f1var_ui') -f2var_ui <- build_var('f2var_ui') -f1op_ui <- build_op('f1op_ui') -f2op_ui <- build_op('f2op_ui') -f1val_ui <- build_val('f1val_ui') -f2val_ui <- build_val('f2val_ui') - -# sapply(1:10, function(ii) { -# for(v in c('var', 'op', 'val')) { -# nm <- sprintf('f%s%s_ui', ii, v) -# assign(nm, do.call(paste0('build_', v), list(nm)), -# envir = globalenv()) -# } -# }) - - -var_dependent_ui = function(){ - tbl = local_data$sample_table - vars = names(tbl) - vars %?<-% '' - - selectInput(ns('var_dependent'), 'Dependent', choices = vars, selected = 'power') -} - - -var_fixed_effects_ui = function(){ - tbl = local_data$sample_table - vars = names(tbl) - - vars = vars[!vars %in% local_data$var_dependent] - - vars %?<-% '' - selectInput(ns('var_fixed_effects'), 'Fixed Effects', choices = vars, selected = isolate(local_data$var_fixed_effects), multiple = T) -} - -var_rand_effects_ui = function(){ - tbl = local_data$sample_table - vars = names(tbl) - - vars = vars[!vars %in% c(local_data$var_dependent, local_data$var_fixed_effects)] - vars %?<-% '' - selectInput(ns('var_rand_effects'), 'Random Effects', choices = vars, selected = isolate(local_data$var_rand_effects), multiple = T) -} - - -var_formula_ui = function(){ - tbl = local_data$sample_table - - dv <- local_data$var_dependent - fe <- paste0(local_data$var_fixed_effects, collapse=' + ') - .f <- sprintf('%s ~ %s + (1|subject_id/elec)', dv, fe) - - textInput(ns('var_formula'), 'Formula (editable)', value = as.character(.f)) -} - - - - -do_btn_ui = function(){ - actionButtonStyled(ns('do_btn'), 'Run Analysis', type = 'info') -} - - -observeEvent(input$do_btn, { - main_function() -}) - - - - -main_function = function(){ - var_fe = local_data$var_fixed_effects - if(!length(var_fe)){ - local_data$results <- NULL - showNotification(p('Something is wrong, go back and re-select'), type = 'error', id = ns('notif')) - }else{ - progress = progress('Analysis', max = length(subjects)+1) - on.exit({progress$close()}) - - module_table = rave::module_analysis_table(subject$project_name, module_id = 'power_explorer', analysis_name = local_data$analysis_name) - - - full_table <- lapply_async(subjects, function(sbj) { - tryCatch({ - readRDS(file = module_table$file[module_table$subject_code == sbj]) - }, error = function(e){ - NULL - }) - }, .call_back = function(ii) { - progress$inc('Loading data for ' %>% paste0(subjects[ii])) - }) %>% {do.call(rbind, (.))} - - var_fixed_effects <- c('condition') - dv <- 'power' - fe <- paste0(var_fixed_effects, collapse=' + ') - .f <- sprintf('%s ~ %s + (1|subject_id/elec)', dv, fe) - - progress$inc('Running LME: ' %&% .f) - - local_data$full_table <- full_table - local_data$lmer_results <- lmer(.f, data=full_table) - - # summary(lmer_results) - # - # lmer_full <- lmer(power ~ condition + - # (1|subject_id) + (1|subject_id:elec) + (1|subject_id:trial), data=full_table) - # summary(lmer_full) - # ranef(lmer_full) - # - - # .l <- length(ranef(lmer_full)) - # - # par(mfrow=c(1, .l)) - # lapply(seq_along(ranef(lmer_full)), function(re_i) { - # plot((ranef(lmer_full)[[re_i]][[1]]), main = names(ranef(lmer_full))[re_i]) - # }) - - - - # lmer1 <- lmer(power ~ condition + (condition|subject_id/elec), data=full_table) - # summary(lmer1) - # ranef(lmer1) - - # lmer(power ~ condition + (1|subject_id/elec), data=full_table, REML = FALSE) -> lmer_red - # summary(lmer_red) - # ranef(lmer_red) - - # ranef(lmer_full)[['subject_id:trial']][[1]] %>% hist - # ranef(lmer_full)[['elec:subject_id']][[1]] %>% which.max - # - # ranef(lmer_full)[['elec:subject_id']][617,,drop=F] - # - # colf <- factor(rownames(ranef(lmer_full)[['elec:subject_id']]) %>% str_remove_all('[0-9]|:')) - # plot(ranef(lmer_full)[['elec:subject_id']][[1]], col=as.integer(colf), pch=19) - - # agg_table <- aggregate(power ~ elec + subject_id + condition, data=full_table, mean) - - # local_data$lmer_results@formula <- as.character(.f) - # - # summary(lmer_full) %>% coef %>% round(3) - # summary(lmer_red) %>% coef %>% round(3) - - } -} - - diff --git a/inst/modules/group_analysis_lme/comp.R b/inst/modules/group_analysis_lme/comp.R index 79eb891..90eb04f 100644 --- a/inst/modules/group_analysis_lme/comp.R +++ b/inst/modules/group_analysis_lme/comp.R @@ -14,11 +14,11 @@ module_id <- 'group_analysis_lme' # >>>>>>>>>>>> Start ------------- [DO NOT EDIT THIS LINE] --------------------- - # ---------------------- Initializing Global variables ----------------------- load_scripts( - get_path('inst/modules/group_analysis_lme/reactive_main.R'), + get_path('inst/modules/group_analysis_lme/reactives.R'), get_path('inst/modules/group_analysis_lme/common.R'), + get_path('inst/modules/group_analysis_lme/outputs.R'), asis = TRUE ) @@ -26,12 +26,91 @@ define_initialization({ project_name = subject$project_name project_dir = dirname(subject$dirs$subject_dir) subjects = get_subjects(project_name) + + power_explorer_dir = file.path(project_dir, '_project_data', 'power_explorer') + group_analysis_src = file.path(project_dir, '_project_data', 'group_analysis_lme', 'source') + + rescan_source = function(update = TRUE, new_selected = NULL){ + choices = c( + list.files(power_explorer_dir, pattern = '\\.[cC][sS][vV]$'), + list.files(group_analysis_src, pattern = '\\.[cC][sS][vV]$') + ) + # Order file names by date-time (descending order) + dt = stringr::str_extract(choices, '[0-9]{8}-[0-9]{6}') + od = order(strptime(dt, '%Y%m%d-%H%M%S'), decreasing = TRUE) + choices = choices[od] + if(update && is_reactive_context()){ + selected = c(source_files, new_selected) + updateSelectInput(session, 'source_files', choices = choices, selected = selected) + } + return(choices) + } + }) # --------------------------------- Inputs ----------------------------------- # Define inputs +# Part 1: data selector: + +# define_input( +# selectInput('source_files', 'Data files', choices = '', selected = NULL, multiple = TRUE), +# init_args = c('choices', 'selected'), +# init_expr = { +# # Check csv files in project/_project_data/power_explorer and project/_project_data/group_analysis_lme/source +# choices = rescan_source(update = FALSE) +# selected = cache_input('source_files', val = character(0)) +# } +# ) +# define_input( +# definition = shiny::fileInput('csv_file', label = 'Upload a csv Data File', accept = 'text/csv', multiple = FALSE) +# ) +# # define_input(definition = customizedUI('file_check', width = '100%')) +# define_input( +# definition = actionButtonStyled('load_csvs', 'Load analysis tables', type = 'primary') +# ) + +define_input_analysis_data_csv( + inputId= 'analysis_data', label = 'Data files', paths = c('_project_data/group_analysis_lme/source', '_project_data/power_explorer'), + reactive_target = 'local_data$analysis_data' +) + +# define_input( +# customizedUI('var_sel') +# ) +define_input_table_filters('var_sel', label = 'Filter', watch_target = 'local_data$analysis_data', + reactive_target = 'local_data[["analysis_data_filtered"]]') + + + +#### Define model + +define_input( + selectInput('model_dependent', 'Dependent', choices = '', selected = character(0)) +) +define_input( + selectInput('model_fixed_effects', 'Fixed effects', choices = '', selected = character(0), multiple = TRUE) +) +define_input( + selectInput('model_random_effects', 'Random effects', choices = '', selected = character(0), multiple = TRUE) +) +define_input( + textInput('model_formula', 'Formula', value = '') +) +define_input( + checkboxInput('model_embedsubject', HTML('Embed subject into electrode (only if both Subject and Electrode are selected as random effect)'), value = TRUE) +) + +define_input( + actionButtonStyled('run_analysis', 'Run Analysis', type = 'primary', width = '100%') +) + +manual_inputs = c('source_files', 'csv_file', 'load_csvs', 'model_dependent', + 'model_fixed_effects', 'model_random_effects', + 'model_formula', 'model_embedsubject', 'run_analysis') + + define_input( selectInput('participants', 'Participants', choices = '', selected = NULL, multiple = T), init_args = c('choices', 'selected'), @@ -77,9 +156,7 @@ define_input( # customizedUI('f1var_ui'),customizedUI('f1op_ui'),customizedUI('f1val_ui'), # customizedUI('f2var_ui'),customizedUI('f2op_ui'),customizedUI('f2val_ui'), -define_input( - customizedUI('var_sel') -) + # # selectInput('electrode', 'Electrode', choices = '', multiple = F), @@ -90,21 +167,27 @@ define_input( # input_layout = list( '[#cccccc]Dataset' = list( - c('participants'), - c('analysis_name_ui') - ), - 'Feature Selection' = list( - c('omnibus_f', 'fcutoff'), - # c('f1var_ui', 'f1op_ui', 'f1val_ui', ''), - # c('f2var_ui', 'f2op_ui', 'f2val_ui', '') - c('var_sel') + # c('participants'), + # c('analysis_name_ui') + # 'source_files', 'csv_file', 'load_csvs' + 'analysis_data', + 'var_sel' ), + # 'Feature Selection' = list( + # c('omnibus_f', 'fcutoff') + # ), 'Model Building' = list( - 'var_dependent_ui', - 'var_fixed_effects_ui', - 'var_rand_effects_ui', - 'var_formula_ui', - 'nested_electrode' + c('model_dependent'), + c('model_fixed_effects', 'model_random_effects'), + 'model_embedsubject', + 'model_formula', + 'run_analysis' + + # 'var_dependent_ui', + # 'var_fixed_effects_ui', + # 'var_rand_effects_ui', + # 'var_formula_ui', + # 'nested_electrode' ), 'Model Running' = list( 'do_btn_ui' @@ -116,10 +199,17 @@ input_layout = list( # End of input # ---------------------------------- Outputs ---------------------------------- # Define Outputs + +define_output( + definition = customizedUI('src_data_snapshot', style='min-height:500px'), + title = 'Data Snapshot', + width = 4, + order = 1 +) define_output( - definition = customizedUI('lme_out', width = 12), + definition = customizedUI('lme_out', width = 12, style='min-height:500px'), title = 'LME Output', - width=12, + width = 8, order = 1 ) # rave_outputs( @@ -143,4 +233,4 @@ define_output( module_id <- 'group_analysis_lme' quos = env$parse_components(module_id) -view_layout(module_id, launch.browser = T) +view_layout(module_id, launch.browser = T, sidebar_width = 3) diff --git a/inst/modules/group_analysis_lme/input_analysis.R b/inst/modules/group_analysis_lme/input_analysis.R new file mode 100644 index 0000000..c748bd5 --- /dev/null +++ b/inst/modules/group_analysis_lme/input_analysis.R @@ -0,0 +1,30 @@ +# Module 1: file uploader + + +##### Step 1: Add the following into define_initialization #### + +# project_name = subject$project_name +# project_dir = dirname(subject$dirs$subject_dir) +# subjects = get_subjects(project_name) +# +# power_explorer_dir = file.path(project_dir, '_project_data', 'power_explorer') +# group_analysis_src = file.path(project_dir, '_project_data', 'group_analysis_lme', 'source') +# +# rescan_source = function(update = TRUE, new_selected = NULL){ +# choices = c( +# list.files(power_explorer_dir, pattern = '\\.[cC][sS][vV]$'), +# list.files(group_analysis_src, pattern = '\\.[cC][sS][vV]$') +# ) +# # Order file names by date-time (descending order) +# dt = stringr::str_extract(choices, '[0-9]{8}-[0-9]{6}') +# od = order(strptime(dt, '%Y%m%d-%H%M%S'), decreasing = TRUE) +# choices = choices[od] +# if(update && is_reactive_context()){ +# selected = c(source_files, new_selected) +# updateSelectInput(session, 'source_files', choices = choices, selected = selected) +# } +# return(choices) +# } + +##### Step 2: + diff --git a/inst/modules/group_analysis_lme/input_filters.R b/inst/modules/group_analysis_lme/input_filters.R new file mode 100644 index 0000000..b45c74f --- /dev/null +++ b/inst/modules/group_analysis_lme/input_filters.R @@ -0,0 +1 @@ +# Input to filter data diff --git a/inst/modules/group_analysis_lme/outputs.R b/inst/modules/group_analysis_lme/outputs.R new file mode 100644 index 0000000..e4bfa5b --- /dev/null +++ b/inst/modules/group_analysis_lme/outputs.R @@ -0,0 +1,106 @@ +src_data_snapshot <- function(){ + + if(!is.data.frame(local_data$analysis_data)){ + return(htmltools::div(style='color:#a1a1a1; text-align:center', 'Analysis data not loaded yet.')) + } + + # show snapshot of analysis table + tbl_raw = local_data$analysis_data + vars = names(tbl_raw) + tbl = local_data$analysis_data_filtered + + dv = input$model_dependent; dv = dv[dv %in% vars] + fe = input$model_fixed_effects; fe = fe[fe %in% vars] + fr = input$model_random_effects; fr = fr[fr %in% vars] + rest = vars[!vars %in% c(dv,fe,fr)] + + str2 = function(val, v){ + suppressWarnings({ + if(is.character(val) || v %in% fr || is.factor(val)){ + val = as.factor(val) + lv = levels(val); + nlv = length(lv) + if(nlv){ lv = lv[1:min(nlv, 4)] } + str = sprintf(' Factor w/ %d level%s [%s%s]', nlv, + ifelse(nlv>1, 's', ''), + paste(lv, collapse = ', '), ifelse(nlv>4, ', ...', '')) + }else if(is.numeric(val)){ + str = sprintf(' %s [range: %.4g ~ %.4g]', storage.mode(val), + min(val, na.rm = TRUE), max(val, na.rm = TRUE)) + }else{ + str = utils::capture.output(str(val)) + } + str + }) + } + dv_tag = rest_tag = fe_tag = fr_tag = NULL + if(length(dv)){ + dv_tag = tagList( + '- Dependent -', + tags$ul( + tags$li(strong(dv), ': ', str2(tbl[[dv]], dv)) + ) + ) + } + + if(length(fe)){ + fe_tag = tagList( + '- Fixed effects -', + tags$ul( + lapply(fe, function(v){ + tags$li(strong(v), ': ', str2(tbl[[v]], v)) + }) + ) + ) + } + + if(length(fr)){ + fr_tag = tagList( + '- Random effects -', + tags$ul( + lapply(fr, function(v){ + tags$li(strong(v), ': ', str2(tbl[[v]], v)) + }) + ) + ) + } + + if(length(rest)){ + rest_tag = tagList( + '- Variables not in the model -', + tags$ul( + lapply(rest, function(v){ + tags$li(strong(v), ': ', str2(tbl[[v]], v)) + }) + ) + ) + } + + if(length(c(dv, fe, fr))){ + n_complete = sum(complete.cases(tbl[,c(dv, fe, fr)])) + }else{ + n_complete = nrow(tbl) + } + + tags$p( + # 1. dimensions + 'Original analysis table (raw): ', strong(sprintf('%d rows x %d columns', nrow(tbl_raw), ncol(tbl_raw))), br(), + + # 2. columns + 'Columns: ', strong(paste(vars, collapse = ', ')), br(), + + hr(), + + # 3. filtered table + 'Filtered analysis table (input data): ', strong(sprintf( + '%d rows (%d complete entries)', nrow(tbl), n_complete + )), br(), + + # 3. column types + 'Column types: ', br(), + + dv_tag, fe_tag, fr_tag, rest_tag + + ) + +} diff --git a/inst/modules/group_analysis_lme/reactives.R b/inst/modules/group_analysis_lme/reactives.R new file mode 100644 index 0000000..7a585b0 --- /dev/null +++ b/inst/modules/group_analysis_lme/reactives.R @@ -0,0 +1,422 @@ +input = getDefaultReactiveInput() +output = getDefaultReactiveOutput() +session = getDefaultReactiveDomain() + +local_data %?<-% reactiveValues( + analysis_data = NULL, + + potential_analysis = list(), + analysis_name = NULL, + sample_table = NULL, + var_dependent = NULL, + var_fixed_effects = NULL, + lmer_results = NULL +) +local_filters = reactiveValues( + filter_count = 0, + filter_observers = 0 +) + + +# build Model +observe({ + if(!is.data.frame(local_data$analysis_data)){ return() } + local_data$sample_table = head(local_data$analysis_data) + vars = names(local_data$analysis_data) + vars = vars[!vars %in% c('Project')] + if(!length(vars)){ vars = '' } + dep = 'Power' + if(!dep %in% vars){ + tmp = vars[!vars %in% c('Time')] + if(length(tmp)){ + dep = tmp[[1]] + }else{ + dep = vars[[1]] + } + } + vars2 = vars[!vars %in% dep]; if(length(vars2) == ''){vars2 = ''} + updateSelectInput(session, 'model_fixed_effects', choices = vars2, selected = shiny::isolate(local_data$fixed)) + updateSelectInput(session, 'model_random_effects', choices = vars2, selected = shiny::isolate(local_data$rand)) + updateSelectInput(session, 'model_dependent', choices = vars, selected = dep) +}) + +collect_model = function(..., exclude = NULL){ + re = list() + re$dependent %?<-% { + var = input$model_dependent + var[!var %in% exclude] + } + re$fixed %?<-% { + var = input$model_fixed_effects + var[!var %in% exclude] + } + re$random %?<-% { + var = input$model_random_effects + var[!var %in% exclude] + } + re +} + +rave::sync_shiny_inputs( + input = input, session = session, inputIds = c('model_dependent', 'model_fixed_effects', 'model_random_effects'), + uniform = list( + function(var_y){ + vars = names(local_data$analysis_data) + vars = vars[!vars %in% c('Project', var_y)] + if(!length(vars)){ vars = '' } + updateSelectInput(session, 'model_fixed_effects', choices = vars) + updateSelectInput(session, 'model_random_effects', choices = vars) + collect_model(dependent = var_y, exclude = var_y) + }, + function(fixed_x){ collect_model(fixed = fixed_x, exclude = fixed_x) }, + function(rand_x){ collect_model(random = rand_x, exclude = rand_x) } + ), updates = list( + function(val){ updateSelectInput(session, 'model_dependent', selected = val$dependent) }, + function(val){ updateSelectInput(session, 'model_fixed_effects', selected = val$fixed) }, + function(val){ updateSelectInput(session, 'model_random_effects', selected = val$random) } + ) +) + + +# Formula +observe({ + # build formular + fo = get_formula(input$model_dependent, input$model_fixed_effects, input$model_random_effects, isTRUE(input$model_embedsubject)) + local_data$fixed = input$model_fixed_effects + local_data$rand = input$model_random_effects + updateTextInput(session, 'model_formula', value = fo) +}) + +get_formula = function(dv, fe, fr, embed_subject = TRUE){ + if(!is.data.frame(local_data$analysis_data)){ + return('') + } + if(length(fe)){ + fe = paste(fe, collapse = '+') + }else{ + fe = '1' + } + fr_valid = sapply(fr, function(v){ + v = unique(local_data$analysis_data[[v]]) + v = v[!is.na(v)] + length(v) > 1 + }) + fr = fr[fr_valid] + + fr_template = '(1|%s)' + if(all(c('Subject', 'Electrode') %in% fr) && embed_subject){ + fr_add = '(1|Subject/Electrode)' + fr = fr[!fr %in% c('Subject', 'Electrode')] + fr = paste(c(fr_add, sprintf(fr_template, fr)), collapse = '+') + }else{ + fr = paste(sprintf(fr_template, fr), collapse = '+') + } + if(fr != ''){ + fr = paste(' +', fr) + } + + fo = sprintf('%s ~ %s%s', dv,fe,fr) + fo +} + +observeEvent(input$run_analysis, { + showNotification(p('Fitting mixed effect model. Please wait...'), duration = NULL, type = 'default', id = ns('noti')) + fo = input$model_formula + fo = as.formula(fo) + tryCatch({ + local_data$lmer_results = lmerTest::lmer(fo, data=local_data$analysis_data, na.action=na.omit) + removeNotification(id = ns('noti')) + }, error = function(e){ + # grouping factors must have > 1 sampled level + showNotification(p('Some random effects only have one level. Please remove them and run again'), duration = 20, type = 'error', id = ns('noti')) + local_data$lmer_results = NULL + }) + + +}) + +#### File upload to MLE source #### +# Once data is loaded, +# 1. local_data$full_table will be a data.frame +# 2. local_data$all_vars will be a vector +# is_reactive_context = function(){ +# any(c('ShinySession', 'session_proxy') %in% class(session)) +# } +# +# # Find csv file within directory +# find_source = function(fname){ +# fpath = file.path(group_analysis_src, fname) +# if( !file.exists(fpath) ){ +# fpath = file.path(power_explorer_dir, fname) +# } +# if( !file.exists(fpath) ){ +# fpath = NULL +# } +# return(fpath) +# } +# +# observeEvent(input$csv_file, { +# csv_headers = c('Project', 'Subject', 'Electrode') +# path = input$csv_file$datapath +# tryCatch({ +# # try to load as csv, check column names +# dat = read.csv(path, header = TRUE, nrows = 10) +# if(all(csv_headers %in% names(dat))){ +# now = strftime(Sys.time(), '-%Y%m%d-%H%M%S(manual).csv') +# # pass, write to group_analysis_src with name +# fname = input$csv_file$name +# fname = stringr::str_replace_all(fname, '[\\W]+', '_') +# fname = stringr::str_to_lower(fname) +# fname = stringr::str_replace(fname, '_csv$', now) +# if(!dir.exists(group_analysis_src)){ +# dir.create(group_analysis_src, recursive = TRUE, showWarnings = FALSE) +# } +# file.copy(path, file.path(group_analysis_src, fname), overwrite = TRUE) +# rescan_source(new_selected = fname) +# return() +# } +# showNotification(p('The file uploaded does not have enough columns.'), type = 'error') +# }, error = function(e){ +# showNotification(p('Upload error: ', e), type = 'error') +# }) +# }) +# +# observeEvent(input$load_csvs, { +# progress = rave::progress('Loading analysis', max = length(source_files) + 1) +# on.exit({ progress$close() }) +# +# progress$inc('Checking files...') +# # find all the source files and get headers +# metas = lapply(source_files, function(fpath){ +# fpath = find_source(fpath) +# if( is.null(fpath) ){ return(NULL) } +# dat = read.csv( fpath , header = TRUE, nrows = 1) +# list( +# fpath = fpath, +# header = names(dat) +# ) +# }) +# metas = rave::dropNulls(metas) +# headers = unique(unlist(lapply(metas, '[[', 'header'))) +# +# # Read all data +# res = lapply(metas, function(x){ +# progress$inc('Loading...') +# tbl = data.table::fread(file = x$fpath, stringsAsFactors = FALSE, header = TRUE) +# mish = headers[!headers %in% names(tbl)] +# for(m in mish){ +# tbl[[m]] = NA +# } +# return( tbl ) +# }) +# local_data$all_vars = headers +# local_data$full_table = do.call('rbind', res) +# }) + + +#### Feature selection field handlers #### + +# UI for filters +# var_sel = function(){ +# if(!is.data.frame(local_data$analysis_data)){ +# return(span(style = 'color: #a1a1a1', 'Analysis table not loaded')) +# } +# n_filters = local_filters$filter_count +# vars = local_data$analysis_data; vars %?<-% '' +# +# filter_uis = NULL +# minus_btn = NULL +# +# if(n_filters > 0){ +# minus_btn = actionButton(ns('filter_minus'), shiny::icon('minus')) +# filter_uis = lapply( seq_len(n_filters), function(ii){ get_ui( ii , vars ) } ) +# } +# +# tagList( +# filter_uis, +# div( +# # Put a div to make buttons within a row +# actionButton(ns('filter_add'), shiny::icon('plus')), +# minus_btn +# ), +# actionLink(ns('view_filtered'), 'Preview filtered data') +# ) +# } +# +# observeEvent(input$view_filtered, { +# # Collect data +# shiny::showModal(shiny::modalDialog( +# title = 'Preview input data', size = 'l', easyClose = TRUE, fade = FALSE, +# tags$style('.modal-lg { min-width: 80vw; }'), +# DT::dataTableOutput(ns('view_filtered_tbl')) +# )) +# }) +# output$view_filtered_tbl <- DT::renderDataTable({ +# shiny::validate(shiny::need(is.data.frame(local_data$analysis_data), message = 'No analysis loaded')) +# sel = filter_summary() +# local_data$analysis_data[sel,] +# }) +# +# get_ui = function(ii, vars = ''){ +# filter = shiny::isolate(local_filters[[paste0('filter', ii)]]) +# if(!is.list(filter)){ filter = list() } +# tagList( +# tagList( +# tags$label(sprintf('Filter %d', ii), style = ifelse(ii == 1, '', 'margin-top: 15px;')), +# div( +# # To make a box to wrap group inputs +# class = 'rave-grid-inputs', +# div( +# style = 'flex-basis: 25%; min-height: 80px;', +# selectInput(ns('filter_var_' %&% ii), 'Variable', choices = vars, selected = get_val(filter, 'var', default = NULL)) +# ), +# div( +# style = 'flex-basis: 25%; min-height: 80px;', +# selectInput(ns('filter_op_' %&% ii), 'Operator', choices = c('=', '!=', '>', '>=', '<', '<=', 'in', 'not in', 'between'), selected = get_val(filter, 'op', default = '=')) +# ), +# div( +# style = 'flex-basis: 25%; min-height: 80px;', +# textInput(ns('filter_val_' %&% ii), 'Value', value = get_val(filter, 'val', default = NULL)) +# ), +# div( +# style = 'flex-basis: 25%; min-height: 80px;', +# uiOutput(ns('filter_msg_' %&% ii)) +# ) +# ) +# +# ) +# ) +# } +# +# get_operator = function(op){ +# switch (op, +# '=' = '%s == %s', +# 'in' = '%s %%in%% %s', +# 'between' = '%s %%within%% %s', +# 'not in' = '!%s %%in%% %s', +# { +# paste('%s', op, '%s') +# } +# ) +# } +# +# filter_data = function(dat, op, val){ +# if( is.numeric(dat) && is.character(val) ){ +# val = parse_svec(val, sort = FALSE, unique = FALSE) +# } +# expr = get_operator(op) +# expr = sprintf(expr, 'dat', deparse(val)) +# sel = rlang::eval_tidy(rlang::parse_expr(expr), data = list(dat = dat)) +# sel +# } +# +# get_filter_results = function(ii){ +# filter = local_filters[[paste0('filter', ii)]] +# if(!is.data.frame(local_data$analysis_data) || !is.list(filter) || !isFALSE(filter$failed)){ return(NULL) } +# var = filter$var; op = filter$op; val = filter$val +# dat = local_data$analysis_data[[var]] +# if( is.numeric(dat) ){ +# val = parse_svec(val) +# } +# sel = filter_data(dat, op, val) +# sel[is.na(sel)] = FALSE +# sel +# } +# add_filter_observer = function(ii){ +# +# +# local({ +# observe({ +# n_filters = local_filters$filter_count +# if(!is.data.frame(local_data$analysis_data) || !length(n_filters) || n_filters < ii ){ return(NULL) } +# var = input[[sprintf('filter_var_%d', ii)]]; op = input[[sprintf('filter_op_%d', ii)]]; val = input[[sprintf('filter_val_%d', ii)]] +# var %?<-% ''; op %?<-% '='; val %?<-% '' +# val_txt = val +# # Do checks +# msg = '' +# failed = FALSE +# if( !var %in% shiny::isolate(local_data$all_vars) ){ +# msg = 'Variable not found' +# failed = TRUE +# }else{ +# dat = shiny::isolate({ local_data$analysis_data[[var]] }) +# if( is.numeric(dat) ){ +# val = parse_svec(val) +# if( !length(val) || any(is.na(val)) ){ +# msg = 'Value is blank or contains NA' +# failed = TRUE +# } +# } +# if( !failed ){ +# sel = filter_data(dat, op, val) +# n_na = sum(is.na(dat[sel])) +# n_sel = sum(sel, na.rm = TRUE) +# msg = sprintf('%d of %d selected (%d NAs)', n_sel, length(sel), n_na) +# if(n_sel == 0){ +# msg = 'No data selected' +# failed = TRUE +# } +# } +# } +# +# re = list( +# var = var, op = op, val = val_txt, failed = failed, msg = msg +# ) +# local_filters[[paste0('filter', ii)]] = re +# }) +# +# output[[sprintf('filter_msg_%d', ii)]] = shiny::renderUI({ +# n_filters = shiny::isolate(local_filters$filter_count) +# if(!is.data.frame(local_data$analysis_data) || !length(n_filters) || n_filters < ii ){ return(NULL) } +# +# filter = local_filters[[paste0('filter', ii)]] +# if(!is.list(filter)){ return() } +# +# col = ifelse( isTRUE(filter$failed) , 'red', 'grey' ) +# filter$msg %?<-% '' +# htmltools::span(style = col2hex(col, prefix = 'color:#'), filter$msg) +# }) +# }) +# +# } +# +# # Add/remove filters +# observeEvent(input$filter_add, { +# n_filters = shiny::isolate(local_filters$filter_count) + 1 +# n_observers = shiny::isolate(local_filters$filter_observers) +# local_filters$filter_count = n_filters +# # Check if observers are needed +# if( n_filters > n_observers ){ +# add_filter_observer( n_filters ) +# local_filters$filter_observers = n_filters +# } +# }) +# observeEvent(input$filter_minus, { +# n_filters = shiny::isolate(local_filters$filter_count) - 1 +# local_filters$filter_count = max(n_filters, 0) +# }) +# +# # summarise filters +# filter_summary = function(){ +# n_filters = shiny::isolate(local_filters$filter_count) +# nrows = shiny::isolate({ +# re = 0 +# if(is.data.frame(local_data$analysis_data)){ +# re = nrow(local_data$analysis_data) +# } +# re +# }) +# filters = shiny::isolate({ +# res = rep(TRUE, nrows) +# for(ii in seq_len(n_filters)){ +# fil = get_filter_results( ii ) +# res = res & fil +# } +# res +# }) +# filters +# } +# +# observeEvent(local_filters$filter_count,{ +# print(sum(filter_summary())) +# }) diff --git a/inst/tools/input_widgets.R b/inst/tools/input_widgets.R index aed901e..db9ffeb 100644 --- a/inst/tools/input_widgets.R +++ b/inst/tools/input_widgets.R @@ -322,3 +322,461 @@ define_input_condition_groups <- function(inputId, label = 'Group', initial_grou rave::eval_dirty(quo, env = parent_frame) } + + + +define_input_analysis_data_csv <- function( + inputId, label, paths, reactive_target = sprintf('local_data[[%s]]', inputId), + multiple = TRUE, label_uploader = 'Upload'){ + + input_ui = inputId + input_selector = paste0(inputId, '_source_files') + input_uploader = paste0(inputId, '_uploader') + input_btn = paste0(inputId, '_btn') + input_evt = paste0(inputId, '__register_events') + reactive_target = substitute(reactive_target) + + quo = rlang::quo({ + define_input(definition = customizedUI(!!input_ui)) + + load_scripts(rlang::quo({ + ...ravemodule_environment_reserved %?<-% new.env(parent = emptyenv()) + ...ravemodule_environment_reserved[[!!input_ui]] = new.env(parent = emptyenv()) + + assign(!!input_ui, function(){ + project_dir = dirname(subject$dirs$subject_dir) + search_paths = file.path(project_dir, !!paths) + choices = unlist(lapply(search_paths, list.files, pattern = '\\.[cC][sS][vV]$')) + # Order file names by date-time (descending order) + dt = stringr::str_extract(choices, '[0-9]{8}-[0-9]{6}') + od = order(strptime(dt, '%Y%m%d-%H%M%S'), decreasing = TRUE) + choices = choices[od] + + # function to render UI + htmltools::div( + class = 'rave-grid-inputs', + htmltools::div( + style = 'flex-basis: 80%; min-height: 80px;', + selectInput(inputId = ns(!!input_selector), label = !!label, choices = choices, selected = character(0), multiple = !!multiple) + ), + htmltools::div( + style = 'flex-basis: 20%; min-height: 80px;', + htmltools::tags$label('Additional'), + fileInputMinimal(inputId = ns(!!input_uploader), label = !!label_uploader, multiple = FALSE, width = '100%', type = 'default') + ), + htmltools::div( + style = 'flex-basis: 100%', + actionButtonStyled(inputId = ns(!!input_btn), label = 'Load analysis data', width = '100%', type = 'primary') + ) + ) + }) + ...ravemodule_environment_reserved[[!!input_ui]][[!!input_evt]] = function(){ + .env = environment() + .local_data = reactiveValues() + + is_reactive_context = function(){ + session = getDefaultReactiveDomain() + any(c('ShinySession', 'session_proxy') %in% class(session)) + } + + # 1. function to scan source files + rescan_source = function(search_paths, update = TRUE, new_selected = NULL){ + if(!length(search_paths)){ + return(NULL) + } + choices = unlist(lapply(search_paths, list.files, pattern = '\\.[cC][sS][vV]$')) + # Order file names by date-time (descending order) + dt = stringr::str_extract(choices, '[0-9]{8}-[0-9]{6}') + od = order(strptime(dt, '%Y%m%d-%H%M%S'), decreasing = TRUE) + choices = choices[od] + + if(update && is_reactive_context()){ + session = getDefaultReactiveDomain() + selected = c(shiny::isolate(input[[!!input_selector]]), new_selected) + updateSelectInput(session, inputId = !!input_selector, choices = choices, selected = selected) + } + return(choices) + } + + # 2. Find csv file within directory + find_source = function(search_paths, fname){ + fpaths = file.path(search_paths, fname) + fexists = file.exists(fpaths) + if(!any(fexists)){ return(NULL) } + return(fpaths[which(fexists)[1]]) + } + # 3. Monitor subject change + local_reactives = get_execenv_local_reactive() + observe({ + if(monitor_subject_change()){ + project_dir = dirname(subject$dirs$subject_dir) + .local_data$search_paths = search_paths = file.path(project_dir, !!paths) + .local_data$group_analysis_src = search_paths[[1]] + # Do not change it here because renderui will override update inputs + # rescan_source(search_paths, update = TRUE) + } + }, env = .env, priority = -1) + + + # 3 listen to event to upload file + observeEvent(input[[!!input_uploader]], { + csv_headers = c('Project', 'Subject', 'Electrode') + path = input[[!!input_uploader]]$datapath + group_analysis_src = .local_data$group_analysis_src + tryCatch({ + # try to load as csv, check column names + dat = read.csv(path, header = TRUE, nrows = 10) + if(all(csv_headers %in% names(dat))){ + now = strftime(Sys.time(), '-%Y%m%d-%H%M%S(manual).csv') + # pass, write to group_analysis_src with name + fname = input[[!!input_uploader]]$name + fname = stringr::str_replace_all(fname, '[\\W]+', '_') + fname = stringr::str_to_lower(fname) + fname = stringr::str_replace(fname, '_csv$', now) + if(!dir.exists(group_analysis_src)){ + dir.create(group_analysis_src, recursive = TRUE, showWarnings = FALSE) + } + file.copy(path, file.path(group_analysis_src, fname), overwrite = TRUE) + rescan_source(.local_data$search_paths, new_selected = fname) + return() + } + showNotification(p('The file uploaded does not have enough columns.'), type = 'error') + }, error = function(e){ + showNotification(p('Upload error: ', e), type = 'error') + }) + }, event.env = .env, handler.env = .env) + + observeEvent(input[[!!input_btn]], { + source_files = input[[!!input_selector]] + search_paths = .local_data$search_paths + progress = rave::progress('Loading analysis', max = length(source_files) + 1) + on.exit({ progress$close() }) + + progress$inc('Checking files...') + # find all the source files and get headers + metas = lapply(source_files, function(fpath){ + fpath = find_source(search_paths, fpath) + if( is.null(fpath) ){ return(NULL) } + dat = read.csv( fpath , header = TRUE, nrows = 1) + list( + fpath = fpath, + header = names(dat) + ) + }) + metas = rave::dropNulls(metas) + headers = unique(unlist(lapply(metas, '[[', 'header'))) + + # Read all data + project_name = subject$project_name + res = rave::dropNulls(lapply(metas, function(x){ + progress$inc('Loading...') + tbl = data.table::fread(file = x$fpath, stringsAsFactors = FALSE, header = TRUE) + tbl = tbl[tbl$Project %in% project_name, ] + if(!nrow(tbl)){ + return(NULL) + } + mish = headers[!headers %in% names(tbl)] + for(m in mish){ + tbl[[m]] = NA + } + return( tbl ) + })) + res = do.call('rbind', res) + if(!is.data.frame(res) || !nrow(res)){ + res = NULL + } + if(is.character(!!reactive_target)){ + eval(parse(text = sprintf('%s <- res', !!reactive_target))) + }else{ + do.call('<-', list(!!reactive_target, res)) + } + }, event.env = .env, handler.env = .env) + } + + eval_when_ready(function(){ + ...ravemodule_environment_reserved[[!!input_ui]][[!!input_evt]]() + }) + })) + }) + + parent_frame = parent.frame() + rave::eval_dirty(quo, env = parent_frame) +} + + + + +define_input_table_filters <- function(inputId, label = 'Filter', watch_target = 'local_data[["analysis_data"]]', reactive_target = 'local_data[["analysis_data_filtered"]]',table_not_present = p('Analysis table not loaded')){ + input_ui = inputId + watch_target = substitute(watch_target) + reactive_target = substitute(reactive_target) + input_add = paste0(inputId, '_add_btn') + input_remove = paste0(inputId, '_remove_btn') + input_preview = paste0(inputId, '_preview_btn') + input_preview_table = paste0(inputId, '_preview_btn_table') + input_filter_prefix = paste0(inputId, '_filter') + + quo = rlang::quo({ + define_input(definition = customizedUI(!!input_ui)) + + load_scripts(rlang::quo({ + input %?<-% getDefaultReactiveInput() + ...ravemodule_environment_reserved %?<-% new.env(parent = emptyenv()) + ...ravemodule_environment_reserved[[!!input_ui]] = new.env(parent = emptyenv()) + ...ravemodule_environment_reserved[[!!input_ui]]$local_filters = reactiveValues( + filter_count = 0, + filter_observers = 0 + ) + + # Function to generate UI for iith filter + ...ravemodule_environment_reserved[[!!input_ui]]$get_ui = function(ii, vars = ''){ + filter = shiny::isolate(...ravemodule_environment_reserved[[!!input_ui]]$local_filters[[paste0('filter', ii)]]) + if(!is.list(filter)){ filter = list() } + tagList( + tagList( + tags$label(sprintf('%s %d', !!label, ii), style = ifelse(ii == 1, '', 'margin-top: 15px;')), + div( + # To make a box to wrap group inputs + class = 'rave-grid-inputs', + div( + style = 'flex-basis: 25%; min-height: 80px;', + selectInput(ns(sprintf('%s_var_', !!input_filter_prefix, ii)), 'Variable', choices = vars, selected = get_val(filter, 'var', default = NULL)) + ), + div( + style = 'flex-basis: 25%; min-height: 80px;', + selectInput(ns(sprintf('%s_op_', !!input_filter_prefix, ii)), 'Operator', choices = c('=', '!=', '>', '>=', '<', '<=', 'in', 'not in', 'between'), selected = get_val(filter, 'op', default = '=')) + ), + div( + style = 'flex-basis: 25%; min-height: 80px;', + textInput(ns(sprintf('%s_val_', !!input_filter_prefix, ii)), 'Value', value = get_val(filter, 'val', default = NULL)) + ), + div( + style = 'flex-basis: 25%; min-height: 80px;', + uiOutput(ns(sprintf('%s_msg_', !!input_filter_prefix, ii))) + ) + ) + + ) + ) + } + + # Given string like '=' return expression + ...ravemodule_environment_reserved[[!!input_ui]]$get_operator = function(op){ + switch (op, + '=' = '%s == %s', + 'in' = '%s %%in%% %s', + 'between' = '%s %%within%% %s', + 'not in' = '!%s %%in%% %s', + { + paste('%s', op, '%s') + } + ) + } + + # Given data, operator and criteria, return logical filters + ...ravemodule_environment_reserved[[!!input_ui]]$filter_data = function(dat, op, val){ + if( is.numeric(dat) && is.character(val) ){ + if( op %in% c('in', 'not in', 'between') ){ + val = as.numeric(stringr::str_split(val, '[^0-9-.]+')[[1]]) + }else{ + val = as.numeric(val) + } + } + expr = ...ravemodule_environment_reserved[[!!input_ui]]$get_operator(op) + expr = sprintf(expr, 'dat', deparse(val)) + sel = rlang::eval_tidy(rlang::parse_expr(expr), data = list(dat = dat)) + sel + } + + ...ravemodule_environment_reserved[[!!input_ui]]$get_filter_results = function(ii){ + ...ravemodule_environment_reserved[[!!input_ui]]$local_filters$update + filter = ...ravemodule_environment_reserved[[!!input_ui]]$local_filters[[paste0('filter', ii)]] + + if(!is.data.frame(...ravemodule_environment_reserved[[!!input_ui]]$data) || !is.list(filter) || !isFALSE(filter$failed)){ return(NULL) } + var = filter$var; op = filter$op; val = filter$val + dat = ...ravemodule_environment_reserved[[!!input_ui]]$data[[var]] + if( op %in% c('in', 'not in', 'between') ){ + val = as.numeric(stringr::str_split(val, '[^0-9-.]+')[[1]]) + }else{ + val = as.numeric(val) + } + sel = ...ravemodule_environment_reserved[[!!input_ui]]$filter_data(dat, op, val) + sel[is.na(sel)] = FALSE + sel + } + ...ravemodule_environment_reserved[[!!input_ui]]$add_filter_observer = function(ii){ + .env = environment() + observe({ + ...ravemodule_environment_reserved[[!!input_ui]]$local_filters$update + n_filters = ...ravemodule_environment_reserved[[!!input_ui]]$local_filters$filter_count + if(!is.data.frame(...ravemodule_environment_reserved[[!!input_ui]]$data) || !length(n_filters) || n_filters < ii ){ return(NULL) } + all_vars = names(...ravemodule_environment_reserved[[!!input_ui]]$data) + var = input[[sprintf('%s_var_', !!input_filter_prefix, ii)]]; op = input[[sprintf('%s_op_', !!input_filter_prefix, ii)]]; val = input[[sprintf('%s_val_', !!input_filter_prefix, ii)]] + var %?<-% ''; op %?<-% '='; val %?<-% '' + val_txt = val + # Do checks + msg = '' + failed = FALSE + if( !var %in% all_vars ){ + msg = 'Variable not found' + failed = TRUE + }else{ + dat = ...ravemodule_environment_reserved[[!!input_ui]]$data[[var]] + if( is.numeric(dat) ){ + if( op %in% c('in', 'not in', 'between') ){ + val = as.numeric(stringr::str_split(val, '[^0-9-.]+')[[1]]) + }else{ + val = as.numeric(val) + } + if( !length(val) || any(is.na(val)) ){ + msg = 'Value is blank or invalid' + failed = TRUE + } + } + if( !failed ){ + sel = ...ravemodule_environment_reserved[[!!input_ui]]$filter_data(dat, op, val) + n_na = sum(is.na(dat[sel])) + n_sel = sum(sel, na.rm = TRUE) + msg = sprintf('%d of %d selected (%d NAs)', n_sel, length(sel), n_na) + if(n_sel == 0){ + msg = 'No data selected' + failed = TRUE + } + } + } + + re = list( + var = var, op = op, val = val_txt, failed = failed, msg = msg + ) + ...ravemodule_environment_reserved[[!!input_ui]]$local_filters[[paste0('filter', ii)]] = re + ...ravemodule_environment_reserved[[!!input_ui]]$local_filters$filter_has_update = Sys.time() + }, env = .env) + + output[[sprintf('%s_msg_', !!input_filter_prefix, ii)]] = shiny::renderUI({ + ...ravemodule_environment_reserved[[!!input_ui]]$local_filters$update + n_filters = shiny::isolate(...ravemodule_environment_reserved[[!!input_ui]]$local_filters$filter_count) + + if(!is.data.frame(...ravemodule_environment_reserved[[!!input_ui]]$data) || !length(n_filters) || n_filters < ii ){ return(NULL) } + + filter = ...ravemodule_environment_reserved[[!!input_ui]]$local_filters[[paste0('filter', ii)]] + if(!is.list(filter)){ return() } + + col = ifelse( isTRUE(filter$failed) , 'red', 'grey' ) + filter$msg %?<-% '' + htmltools::span(style = col2hex(col, prefix = 'color:#'), filter$msg) + }) + + } + + + # Add/remove filters + observeEvent(input[[!!input_add]], { + n_filters = shiny::isolate(...ravemodule_environment_reserved[[!!input_ui]]$local_filters$filter_count) + 1 + n_observers = shiny::isolate(...ravemodule_environment_reserved[[!!input_ui]]$local_filters$filter_observers) + ...ravemodule_environment_reserved[[!!input_ui]]$local_filters$filter_count = n_filters + # Check if observers are needed + if( n_filters > n_observers ){ + ...ravemodule_environment_reserved[[!!input_ui]]$add_filter_observer( n_filters ) + ...ravemodule_environment_reserved[[!!input_ui]]$local_filters$filter_observers = n_filters + } + }) + observeEvent(input[[!!input_remove]], { + n_filters = shiny::isolate(...ravemodule_environment_reserved[[!!input_ui]]$local_filters$filter_count) - 1 + ...ravemodule_environment_reserved[[!!input_ui]]$local_filters$filter_count = max(n_filters, 0) + }) + + # summarise filters + ...ravemodule_environment_reserved[[!!input_ui]]$filter_summary = function(){ + n_filters = ...ravemodule_environment_reserved[[!!input_ui]]$local_filters$filter_count + nrows = 0 + if(is.data.frame(...ravemodule_environment_reserved[[!!input_ui]]$data)){ + nrows = nrow(...ravemodule_environment_reserved[[!!input_ui]]$data) + } + if(nrows == 0){ + return(logical(0)) + } + filters = rep(TRUE, nrows) + for(ii in seq_len(n_filters)){ + fil = ...ravemodule_environment_reserved[[!!input_ui]]$get_filter_results( ii ) + filters = filters & fil + } + filters + } + + + # UI renderer + assign(!!input_ui, function(){ + + if(is.character(!!watch_target)){ + eval(parse(text = sprintf('dat <- %s', !!watch_target))) + }else{ + do.call('<-', list(quote(dat), !!watch_target)) + } + ...ravemodule_environment_reserved[[!!input_ui]]$data = dat + ...ravemodule_environment_reserved[[!!input_ui]]$local_filters$update = Sys.time() + if(!is.data.frame(dat)){ + return(span(style = 'color: #a1a1a1', !!table_not_present)) + } + n_filters = ...ravemodule_environment_reserved[[!!input_ui]]$local_filters$filter_count + vars = names(dat); vars %?<-% '' + + filter_uis = NULL + minus_btn = NULL + + if(n_filters > 0){ + minus_btn = actionButton(ns(!!input_remove), shiny::icon('minus')) + filter_uis = lapply( seq_len(n_filters), function(ii){ ...ravemodule_environment_reserved[[!!input_ui]]$get_ui( ii , vars ) } ) + } + + tagList( + filter_uis, + div( + # Put a div to make buttons within a row + actionButton(ns(!!input_add), shiny::icon('plus')), + minus_btn + ), + actionLink(ns(!!input_preview), 'Preview filtered data') + ) + }) + + + # Misc: + + # preview data table + observeEvent(input[[!!input_preview]], { + # Collect data + shiny::showModal(shiny::modalDialog( + title = 'Preview filtered data', size = 'l', easyClose = TRUE, fade = FALSE, + tags$style('.modal-lg { min-width: 80vw; }'), + DT::dataTableOutput(ns(!!input_preview_table)) + )) + }) + output[[!!input_preview_table]] <- DT::renderDataTable({ + ...ravemodule_environment_reserved[[!!input_ui]]$local_filters$data_filtered + }) + + observe({ + ...ravemodule_environment_reserved[[!!input_ui]]$local_filters$update + ...ravemodule_environment_reserved[[!!input_ui]]$local_filters$filter_has_update + if( !is.data.frame(...ravemodule_environment_reserved[[!!input_ui]]$data) ){ + res = NULL + }else{ + sel = ...ravemodule_environment_reserved[[!!input_ui]]$filter_summary() + res = ...ravemodule_environment_reserved[[!!input_ui]]$data[sel,] + } + ...ravemodule_environment_reserved[[!!input_ui]]$local_filters$data_filtered = res + if(is.character(!!reactive_target)){ + eval(parse(text = sprintf('%s <- res', !!reactive_target))) + }else{ + do.call('<-', list(!!reactive_target, res)) + } + }) + + + + })) + }) + + parent_frame = parent.frame() + rave::eval_dirty(quo, env = parent_frame) +} From e86b5138101dcb9f4c897377799c3dc2418ffa86 Mon Sep 17 00:00:00 2001 From: dipterix Date: Thu, 10 Oct 2019 18:26:01 -0500 Subject: [PATCH 13/24] power export name contains subjectcode --- inst/modules/power_explorer/comp.R | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/inst/modules/power_explorer/comp.R b/inst/modules/power_explorer/comp.R index d851e9c..cdc82b9 100644 --- a/inst/modules/power_explorer/comp.R +++ b/inst/modules/power_explorer/comp.R @@ -179,7 +179,11 @@ define_input( { define_input( definition = textInput('analysis_prefix', value = 'power_by_condition', - label = HTML('
Export filename (no spaces)'))) + label = HTML('
Export filename (no spaces)')), + init_args = 'value', + init_expr = { + value = cache_input('analysis_prefix', sprintf('%s_pow_by_cond', subject$subject_code)) + }) define_input( definition = checkboxInput('analysis_mask_export',value = FALSE, label = 'Export Electrode Mask')) From 8c3db5f1b86ed6c2ebb93fb6d83af36663c0644a Mon Sep 17 00:00:00 2001 From: dipterix Date: Fri, 11 Oct 2019 15:22:04 -0500 Subject: [PATCH 14/24] Force electrode, subject and condition to be factors when loading group analysis data --- inst/tools/input_widgets.R | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/inst/tools/input_widgets.R b/inst/tools/input_widgets.R index db9ffeb..ddc939d 100644 --- a/inst/tools/input_widgets.R +++ b/inst/tools/input_widgets.R @@ -356,11 +356,11 @@ define_input_analysis_data_csv <- function( htmltools::div( class = 'rave-grid-inputs', htmltools::div( - style = 'flex-basis: 80%; min-height: 80px;', + style = 'flex-basis: 75%; min-height: 80px;', selectInput(inputId = ns(!!input_selector), label = !!label, choices = choices, selected = character(0), multiple = !!multiple) ), htmltools::div( - style = 'flex-basis: 20%; min-height: 80px;', + style = 'flex-basis: 25%; min-height: 80px;', htmltools::tags$label('Additional'), fileInputMinimal(inputId = ns(!!input_uploader), label = !!label_uploader, multiple = FALSE, width = '100%', type = 'default') ), @@ -484,6 +484,12 @@ define_input_analysis_data_csv <- function( res = do.call('rbind', res) if(!is.data.frame(res) || !nrow(res)){ res = NULL + }else{ + try({ + res$Electrode = as.character(res$Electrode) + res$Subject = as.character(res$Subject) + res$Condition = as.character(res$Condition) + }, silent = TRUE) } if(is.character(!!reactive_target)){ eval(parse(text = sprintf('%s <- res', !!reactive_target))) @@ -493,7 +499,7 @@ define_input_analysis_data_csv <- function( }, event.env = .env, handler.env = .env) } - eval_when_ready(function(){ + eval_when_ready(function(...){ ...ravemodule_environment_reserved[[!!input_ui]][[!!input_evt]]() }) })) From d752ff5c8ebcee4e79846d68a2873150f18e76ff Mon Sep 17 00:00:00 2001 From: dipterix Date: Fri, 11 Oct 2019 15:22:33 -0500 Subject: [PATCH 15/24] Adjust 3D viewer according to updated defined 3D output function widget --- inst/modules/power_explorer/event_handlers.R | 6 +- inst/modules/power_explorer/exports.R | 105 +++--- inst/tools/output_widgets.R | 336 ++++++++++--------- 3 files changed, 236 insertions(+), 211 deletions(-) diff --git a/inst/modules/power_explorer/event_handlers.R b/inst/modules/power_explorer/event_handlers.R index e9b7573..3c8f58c 100644 --- a/inst/modules/power_explorer/event_handlers.R +++ b/inst/modules/power_explorer/event_handlers.R @@ -11,13 +11,13 @@ local_data = reactiveValues( calculate_flag = 0 ) -observeEvent(input$power_3d_mouse_dblclicked, { +observeEvent(input$power_3d_widget_mouse_dblclicked, { # mouse_event = input$power_3d__mouse_dblclicked$event # object = input$power_3d__mouse_dblclicked$object - .data <- input$power_3d_mouse_dblclicked + .data <- input$power_3d_widget_mouse_dblclicked - # print(input$power_3d_mouse_dblclicked) + # print(input$power_3d_widget_mouse_dblclicked) if(isTRUE(.data$is_electrode)) { e <- .data$electrode_number diff --git a/inst/modules/power_explorer/exports.R b/inst/modules/power_explorer/exports.R index 9786fe6..e99e447 100644 --- a/inst/modules/power_explorer/exports.R +++ b/inst/modules/power_explorer/exports.R @@ -1,61 +1,72 @@ input <- getDefaultReactiveInput() output = getDefaultReactiveOutput() -power_3d_fun = function(brain){ - showNotification(p('Generating 3d viewer...')) - - # brain = rave::rave_brain2(subject = subject); - # brain$load_surfaces(subject = subject, surfaces = c('pial', 'white', 'smoothwm')) - - dat = rave::cache(key = list( - list(BASELINE_WINDOW, preload_info) - ), val = get_summary()) +power_3d_fun = function(need_calc, side_width, daemon_env){ - # for each electrode, we want to test the different conditions - .FUN <- if(length(levels(dat$condition)) > 1) { - if (length(levels(dat$condition)) == 2) { - function(x) { - res = get_t(power ~ condition, data=x) - res = c(res[1] - res[2], res[3], res[4]) - res %>% set_names(c('b', 't', 'p')) + showNotification(p('Generating 3d viewer...')) + brain = rave::rave_brain2(subject = subject); + shiny::validate(shiny::need(!is.null(brain), message = 'No surface/volume file found!')) + re = NULL + if( need_calc ){ + dat = rave::cache(key = list( + list(BASELINE_WINDOW, preload_info) + ), val = get_summary()) + + # for each electrode, we want to test the different conditions + .FUN <- if(length(levels(dat$condition)) > 1) { + if (length(levels(dat$condition)) == 2) { + function(x) { + res = get_t(power ~ condition, data=x) + res = c(res[1] - res[2], res[3], res[4]) + res %>% set_names(c('b', 't', 'p')) + } + } else { + function(x) { + get_f(power ~ condition, data=x) + } } } else { function(x) { - get_f(power ~ condition, data=x) + get_t(x$power) %>% set_names(c('b', 't', 'p')) } } - } else { - function(x) { - get_t(x$power) %>% set_names(c('b', 't', 'p')) - } + + # names(dat) = c('Subject', 'Electrode', 'trial', + # 'condition', 'power') + + values = lapply(unique(dat$elec), function(e){ + sub = dat[dat$elec == e, ] + re = .FUN(sub) + # v = re[input$viewer_3d_type] + # brain$set_electrode_value(subject, e, v) + return(re) + }) %>% rbind_list + + values = as.data.frame(values) + values$Subject = as.factor(subject$subject_code) + values$Electrode = unique(dat$elec) + + + # b t p Subject Electrode Time + # 1 120.36184 13.83425 7.733204e-22 sub_large 14 0 + # 2 45.21445 8.11932 1.004675e-11 sub_large 15 0 + + brain$set_electrode_values(values) + + + re = brain$plot(symmetric = 0, palettes = list( + b = rave_heat_map_colors, + p = c('red', 'red', 'grey') + ), side_width = side_width) + }else{ + # optional, if you want to change the way 3D viewer looks in additional tab + daemon_env$widget = brain$plot(side_width = side_width, side_canvas = TRUE) + + # Just initialization, no need to show sidebar + re = brain$plot(side_width = side_width, side_canvas = FALSE) } - # names(dat) = c('Subject', 'Electrode', 'trial', - # 'condition', 'power') - - values = lapply(unique(dat$elec), function(e){ - sub = dat[dat$elec == e, ] - re = .FUN(sub) - # v = re[input$viewer_3d_type] - # brain$set_electrode_value(subject, e, v) - return(re) - }) %>% rbind_list - - values = as.data.frame(values) - values$Subject = as.factor(subject$subject_code) - values$Electrode = unique(dat$elec) - - - # b t p Subject Electrode Time - # 1 120.36184 13.83425 7.733204e-22 sub_large 14 0 - # 2 45.21445 8.11932 1.004675e-11 sub_large 15 0 - - brain$set_electrode_values(values) - - brain$plot(symmetric = 0, palettes = list( - b = rave_heat_map_colors, - p = c('red', 'red', 'grey') - ), side_shift = c(-265, 0)) + re # brain$view(value_range = c(-1,1) * max(abs(values)), # color_ramp = rave_heat_map_colors, side_shift = c(-265, 0)) diff --git a/inst/tools/output_widgets.R b/inst/tools/output_widgets.R index 9c4daff..d63dc9d 100644 --- a/inst/tools/output_widgets.R +++ b/inst/tools/output_widgets.R @@ -1,110 +1,223 @@ define_output_3d_viewer <- function( outputId, title, surfaces = 'pial', multiple_subject = F, - message = 'Click here to Generate 3D viewer', - height = '500px', width = 12, order = 0, additional_ui = NULL + message = 'Generate 3D Viewer ', + height = NULL, width = 12, order = 0, additional_ui = NULL, + hide_btn = FALSE, ... ){ - - # Generate reactives output_call = paste0(outputId, '_widget') output_btn = paste0(outputId, '_btn') + output_new = paste0(outputId, '_new') output_fun = paste0(outputId, '_fun') additional_ui = substitute(additional_ui) + + + quo = rlang::quo({ - assign(!!output_call, function(){ + + ...local_env = new.env() + + assign(!!outputId, function(){ clicked = shiny::isolate(input[[!!output_btn]]) + if( !!hide_btn ){ + btn = NULL + }else{ + btn = tagList(htmltools::a( + id = ns(!!output_btn), + href = '#', + class = "action-button", + !!message + ), + ' | ') + } + + if(is.null(!!height)){ + client_size = get_client_size() + client_height = client_size$available_size[[2]] - 200 + height = sprintf('%.0fpx', client_height) + }else{ + height = !!height + } + + htmltools::tagList( htmltools::div( - style = 'padding: 10px;', + btn, htmltools::a( - id = ns(!!output_btn), + id = ns(!!output_new), href = '#', class = "action-button", - !!message + ' Open Viewer in a New Window ' + ), + ' | ', + htmltools::a( + href = 'https://github.com/dipterix/threeBrain/blob/dev/shortcuts.md', + target = '_blank', ' Keyboard Shortcuts ', shiny::icon('external-link') ), eval(!!additional_ui) ), - threeBrain::threejsBrainOutput(ns(!!outputId), height = !!height) + htmltools::div( + style = 'margin: 0 -10px -10px -10px', + threeBrain::threejsBrainOutput(ns(!!output_call), height = height) + ) ) }, envir = environment()) local({ `%?<-%` <- rave::`%?<-%` - ns %?<-% function(x) {x} - input = getDefaultReactiveInput() output = getDefaultReactiveOutput() session = getDefaultReactiveDomain() - local_data %?<-% reactiveValues() - ...local_env %?<-% new.env(parent = emptyenv()) + .env = environment() + .env$local_signal = 0 - output[[!!outputId]] <- threeBrain::renderBrain({ - render_func = function(){ - threeBrain::renderBrain({ - brain = rave::rave_brain2(subject = subject, surfaces = !!surfaces) - - shiny::validate( - shiny::need(!is.null(brain), message = 'Cannot find surface/volume files') - ) - - re = brain - # Render function - if(input[[!!output_btn]] > 0){ - f = get0(!!output_fun, envir = ..runtime_env, ifnotfound = function(...){ - rutabaga::cat2('3D Viewer', !!outputId, 'cannot find function', !!output_fun, level = 'INFO') - }) - - tryCatch({ - re = f(brain) - }, error = function(e){ - rave::logger(e, level = 'ERROR') - }) - - } - - if('htmlwidget' %in% class(re)){ - # User called $view() with additional params, directly call the widget - ...local_env$widget = re - re - }else if('rave-brain' %in% class(re)){ - # User just returned brain object - ...local_env$widget = re$plot() - re$plot(side_shift = c(-265, 0)) - }else{ - # User returned nothing - ...local_env$widget = brain$plot() - brain$plot(side_shift = c(-265, 0)) - } - - - }) + observeEvent(input[[!!output_new]], { + + cat2('Opening a side window...') + + if(!is.null(...local_env$widget)){ + + # tryCatch({ + # widget = ...local_env$widget + # + # rave::send_to_daemon({ + # widget + # }, type = 'threeBrain', outputId = ns(!!outputId), + # save = c('widget')) + # }, error = function(e){ + # showNotification(p('Failed to launch the side viewer. Error message: ', e), type = 'error') + # }) + + # generate url + session = getDefaultReactiveDomain() + rave_id = session$userData$rave_id + if(is.null(rave_id)){ rave_id = '' } + token = session$userData$token + if(is.null(token)){ token = '' } + globalId = ns(!!output_call) + + query_str = list( + type = '3dviewer', + globalId = htmltools::urlEncodePath(globalId), + sessionId = htmltools::urlEncodePath(rave_id), + token = token + ) + url = paste(sprintf('%s=%s', names(query_str), as.vector(query_str)), collapse = '&') + + shinyjs::runjs(sprintf('window.open("/?%s");', url)) } + }) + + render_func = function(){ + threeBrain::renderBrain({ + + # Monitor subject change. If changed, then refresh! + if(!monitor_subject_change()){ + return(NULL) + } + local_signal = input[[!!output_btn]] + render_value = length(local_signal) && local_signal > .env$local_signal + if( render_value ){ + .env$local_signal = local_signal + } + + # get render function + f = get0(!!output_fun, envir = ..runtime_env, ifnotfound = function(...){ + rutabaga::cat2('3D Viewer', !!outputId, 'cannot find function', !!output_fun, level = 'INFO') + }) + + # get client size + client_size = get_client_size() + if(!is.null(client_size)){ + side_width = min(ceiling((client_size$available_size[[2]] - 300) / 3), 300) + }else{ + side_width = 250 + } + ...local_env$widget = NULL + re = f(render_value, side_width, ...local_env) + if(is.null(...local_env$widget)){ + ...local_env$widget = re + } + re + # + # brain = rave::rave_brain2(subject = subject, surfaces = !!surfaces) + # + # shiny::validate( + # shiny::need(!is.null(brain), message = 'Cannot find surface/volume files') + # ) + # + # re = brain + # + # + # + # # Render function + # if( length(local_signal) && local_signal > .env$local_signal ){ + # .env$local_signal = local_signal + # f = get0(!!output_fun, envir = ..runtime_env, ifnotfound = function(...){ + # rutabaga::cat2('3D Viewer', !!outputId, 'cannot find function', !!output_fun, level = 'INFO') + # }) + # + # tryCatch({ + # re = f(brain) + # }, error = function(e){ + # rave::logger(e, level = 'ERROR') + # }) + # + # }else{ + # ...local_env$widget = re$plot() + # return(re$plot(side_display = FALSE)) + # } + # + # if('htmlwidget' %in% class(re)){ + # # User called $view() with additional params, directly call the widget + # ...local_env$widget = re + # re + # }else if('R6' %in% class(re)){ + # # User just returned brain object + # ...local_env$widget = re$plot() + # re$plot(side_display = FALSE) + # }else{ + # # User returned nothing + # ...local_env$widget = brain$plot() + # brain$plot(side_display = FALSE) + # } + + + }) + } + + # Because monitor_subject_change needs execenv to be ready + eval_when_ready(function(...){ # Register render function - output[[!!outputId]] <- render_func() - - # Register cross-session function so that other sessions can register the same output widget - session$userData$cross_session_funcs %?<-% list() - # ns must be defined, but in get_module(..., local=T) will raise error - # because we are not in shiny environment - ns %?<-% function(x){x} - session$userData$cross_session_funcs[[ns(!!outputId)]] = render_func + output[[!!output_call]] <- render_func() }) + + + # Register cross-session function so that other sessions can register the same output widget + session$userData$cross_session_funcs %?<-% list() + # ns must be defined, but in get_module(..., local=T) will raise error + # because we are not in shiny environment + ns %?<-% function(x){x} + session$userData$cross_session_funcs[[ns(!!output_call)]] = render_func }) }) # generate output df = rlang::quo({ define_output( - definition = customizedUI(!!output_call), + definition = customizedUI(!!outputId), title = !!title, width = !!width, order = !!order ) + # https://github.com/r-lib/rlang/issues/772 + # This seems to be an issue of rlang + # load_scripts(rlang::quo({!!quo})) will throw error of (Error: `arg` must be a symbol) load_scripts(rlang::quo(!!quo)) }) eval(rlang::quo_squash(df), envir = parent.frame()) @@ -113,102 +226,3 @@ define_output_3d_viewer <- function( invisible(quo) } - -# define_output_3d_viewer <- function( -# outputId, title, surfaces = 'pial', multiple_subject = F, -# message = 'Click here to Generate 3D viewer', -# height = '500px', width = 12, order = 0, additional_ui = NULL -# ){ -# -# # Generate reactives -# output_call = paste0(outputId, '_widget') -# output_btn = paste0(outputId, '_btn') -# output_fun = paste0(outputId, '_fun') -# -# additional_ui = substitute(additional_ui) -# -# -# quo = rlang::quo({ -# assign(!!output_call, function(){ -# clicked = shiny::isolate(input[[!!output_btn]]) -# -# htmltools::tagList( -# htmltools::div( -# style = 'padding: 10px;', -# htmltools::a( -# id = ns(!!output_btn), -# href = '#', -# class = "action-button", -# !!message -# ), -# eval(!!additional_ui) -# ), -# threeBrain::threejsBrainOutput(ns(!!outputId), height = !!height) -# ) -# }, envir = environment()) -# local({ -# `%?<-%` <- rave::`%?<-%` -# input = getDefaultReactiveInput() -# output = getDefaultReactiveOutput() -# session = getDefaultReactiveDomain() -# local_data %?<-% reactiveValues( -# -# ) -# -# output[[!!outputId]] <- threeBrain::renderBrain({ -# brain = rave::rave_brain2(surfaces = !!surfaces, multiple_subject = !!multiple_subject) -# brain$load_electrodes(subject) -# brain$load_surfaces(subject) -# -# re = brain -# # Render function -# if(input[[!!output_btn]] > 0){ -# f = get0(!!output_fun, envir = ..runtime_env, ifnotfound = function(...){ -# rutabaga::cat2('3D Viewer', !!outputId, 'cannot find function', !!output_fun, level = 'INFO') -# }) -# -# tryCatch({ -# re = f(brain) -# }, error = function(e){ -# rave::logger(e, level = 'ERROR') -# }) -# -# } -# -# if('htmlwidget' %in% class(re)){ -# # User called $view() with additional params, directly call the widget -# re -# }else if('rave_three_brain' %in% class(re)){ -# # User just returned brain object -# re$view() -# }else{ -# # User returned nothing -# brain$view() -# } -# -# -# }) -# }) -# }) -# -# # generate output -# df = rlang::quo({ -# define_output( -# definition = customizedUI(!!output_call), -# title = !!title, -# width = !!width, -# order = !!order -# ) -# -# load_scripts(rlang::quo({!!quo})) -# }) -# eval(rlang::quo_squash(df), envir = parent.frame()) -# # evaluate -# -# invisible(quo) -# -# } -# -# -# -# From cd826cc22264e1a0764c0a13b64fd857fc880548 Mon Sep 17 00:00:00 2001 From: dipterix Date: Fri, 11 Oct 2019 15:22:56 -0500 Subject: [PATCH 16/24] Added 3Dviewer to LMER and some fixes/cleans --- inst/modules/group_analysis_lme/common.R | 1 + inst/modules/group_analysis_lme/comp.R | 73 +++++---------------- inst/modules/group_analysis_lme/main.R | 7 +- inst/modules/group_analysis_lme/outputs.R | 70 ++++++++++++++++++++ inst/modules/group_analysis_lme/reactives.R | 2 +- 5 files changed, 89 insertions(+), 64 deletions(-) diff --git a/inst/modules/group_analysis_lme/common.R b/inst/modules/group_analysis_lme/common.R index 9c12593..9f50617 100644 --- a/inst/modules/group_analysis_lme/common.R +++ b/inst/modules/group_analysis_lme/common.R @@ -34,6 +34,7 @@ lme_out = function() { } lmer_results = local_data$lmer_results + # flat_data <- isolate(local_data$full_table) # # # ranef diff --git a/inst/modules/group_analysis_lme/comp.R b/inst/modules/group_analysis_lme/comp.R index 90eb04f..9f4b3ad 100644 --- a/inst/modules/group_analysis_lme/comp.R +++ b/inst/modules/group_analysis_lme/comp.R @@ -111,54 +111,6 @@ manual_inputs = c('source_files', 'csv_file', 'load_csvs', 'model_dependent', 'model_formula', 'model_embedsubject', 'run_analysis') -define_input( - selectInput('participants', 'Participants', choices = '', selected = NULL, multiple = T), - init_args = c('choices', 'selected'), - init_expr = { - choices = subjects - selected=unique(subjects) - } -) - -define_input( - customizedUI('analysis_name_ui') -) - -define_input( - customizedUI('var_dependent_ui') -) - -define_input( - customizedUI('var_fixed_effects_ui') -) - -define_input( - customizedUI('var_rand_effects_ui') -) - -define_input( - customizedUI('var_formula_ui') -) - -define_input( - checkboxInput('nested_electrode', 'Nest Electrode in Subject', value = T) -) - -define_input( - customizedUI('collapse_trial', 'Collapse over trials (not recommended)', value = F) -) - -define_input( - customizedUI('do_btn_ui') -) - - -# customizedUI('f1var_ui'),customizedUI('f1op_ui'),customizedUI('f1val_ui'), -# customizedUI('f2var_ui'),customizedUI('f2op_ui'),customizedUI('f2val_ui'), - - - - # # selectInput('electrode', 'Electrode', choices = '', multiple = F), # textInput('electrode_text', 'Electrodes', value = "", placeholder = '1-5,8,11-20'), # @@ -212,15 +164,22 @@ define_output( width = 8, order = 1 ) -# rave_outputs( -# 'LME Output' = customizedUI('lme_out', width = 12) -# # 'Activity over time by trial (Collapse freq)' = plotOutput('by_trial_heat_map', width = 12), -# # 'Activity over time (Collapse freq + trial)' = plotOutput('over_time_plot', width = 8), -# # 'Windowed Comparison (Collapse time + freq)' = plotOutput('windowed_comparison_plot', width = 4), -# # 'Side Message' = textOutput('msg_out', width = 4), -# # 'Async Message' = textOutput('async_out', width = 4), -# # '3D Viewer' = customizedUI('viewer_3d') -# ) + +define_output_3d_viewer( + outputId = 'lme_3dviewer', + message = 'Reload Viewer', + title = 'Statistical results by electrode', + order = 1e4 +) + + +output_layout = list( + 'Tabset One' = list( + 'Multiple Output' = c('lme_out', 'src_data_snapshot'), + '3D Visualization' = c('lme_3dviewer') + ) + # 'Multiple Output' = 'src_data_snapshot' +) # <<<<<<<<<<<< End ----------------- [DO NOT EDIT THIS LINE] ------------------- diff --git a/inst/modules/group_analysis_lme/main.R b/inst/modules/group_analysis_lme/main.R index 44d400b..12d7f1e 100644 --- a/inst/modules/group_analysis_lme/main.R +++ b/inst/modules/group_analysis_lme/main.R @@ -10,12 +10,7 @@ init_module(module_id = 'group_analysis_lme', debug = TRUE) # >>>>>>>>>>>> Start ------------- [DO NOT EDIT THIS LINE] --------------------- ######' @auto=TRUE -# local_data$participants = participants - -# Compromise, I'll just look at the first subject -r = lapply(participants, get_analysis); names(r) = participants -local_data$potential_analysis = r - +# not really used # <<<<<<<<<<<< End ----------------- [DO NOT EDIT THIS LINE] ------------------- # Debug diff --git a/inst/modules/group_analysis_lme/outputs.R b/inst/modules/group_analysis_lme/outputs.R index e4bfa5b..b5f155c 100644 --- a/inst/modules/group_analysis_lme/outputs.R +++ b/inst/modules/group_analysis_lme/outputs.R @@ -104,3 +104,73 @@ src_data_snapshot <- function(){ ) } + + +# 3D viewer, takes 3 args +lme_3dviewer_fun <- function(need_calc, side_width, daemon_env, ...){ + # Check whether load is needed + lmer_results = local_data$lmer_results + + shiny::validate(shiny::need(!is.null(lmer_results), message = 'Please run LMER model first')) + + tbl = local_data$analysis_data + + assign('lmer_results', lmer_results, envir = globalenv()) + assign('tbl', tbl, envir = globalenv()) + + # Get Random effect + # randef = lme4::ranef(lmer_results) + coef = stats::coefficients(lmer_results); coef + project_name = subject$project_name + + # two cases: + # Electrode:Subject + elec_table = NULL + val_ranges = list() + if('Electrode:Subject' %in% names(coef)){ + dat = data.matrix(coef$`Electrode:Subject`) + if('(Intercept)' %in% names(coef$`Electrode:Subject`)[[1]]){ + dat[, -1] = dat[, -1] + dat[, 1] + } + data_range = max(abs(range(dat))) + tmp = rownames(dat) + tmp = stringr::str_split_fixed(tmp, ':', n = 2) + dat = as.data.frame(dat) + val_ranges = sapply(names(dat), function(d){ c(-data_range, data_range) }, + simplify = FALSE, USE.NAMES = TRUE) + dat$Electrode = as.integer(tmp[,1]) + dat$Subject = tmp[,2] + elec_table = dat + }else if('Electrode' %in% names(coef)){ + # Subject only has one + + dat = data.matrix(coef$Electrode) + if('(Intercept)' %in% names(coef$Electrode)[[1]]){ + dat[, -1] = dat[, -1] + dat[, 1] + } + data_range = max(abs(range(dat))) + dat = as.data.frame(dat) + + val_ranges = sapply(names(dat), function(d){ c(-data_range, data_range) }, + simplify = FALSE, USE.NAMES = TRUE) + dat$Electrode = rownames(coef$Electrode) + elec_table = merge(unique(tbl[, c('Project', 'Subject', 'Electrode')]), dat, by = 'Electrode') + + } + + re = NULL + if(is.data.frame(elec_table)){ + elec_table$Project = project_name + # load brain + brains = lapply(unique(elec_table$Subject), function(sub){ + tryCatch({ + rave::rave_brain2(sprintf('%s/%s', project_name, sub)) + }, error = function(e){ NULL }) + }) + brains = rave::dropNulls(brains) + brain = threeBrain::merge_brain(.list = brains) + brain$set_electrode_values(elec_table) + re = brain$plot(side_width = side_width, val_ranges = val_ranges) + } + +} diff --git a/inst/modules/group_analysis_lme/reactives.R b/inst/modules/group_analysis_lme/reactives.R index 7a585b0..9f9ace6 100644 --- a/inst/modules/group_analysis_lme/reactives.R +++ b/inst/modules/group_analysis_lme/reactives.R @@ -128,7 +128,7 @@ observeEvent(input$run_analysis, { removeNotification(id = ns('noti')) }, error = function(e){ # grouping factors must have > 1 sampled level - showNotification(p('Some random effects only have one level. Please remove them and run again'), duration = 20, type = 'error', id = ns('noti')) + showNotification(p(e), duration = 20, type = 'error', id = ns('noti')) local_data$lmer_results = NULL }) From 61763308ba07a6c773f2f9d0424cb0828181f6b6 Mon Sep 17 00:00:00 2001 From: dipterix Date: Sun, 13 Oct 2019 18:01:56 -0500 Subject: [PATCH 17/24] Updated cond group input, fixed lme UI looping issue --- inst/modules/group_analysis_lme/comp.R | 63 +++++-- inst/modules/group_analysis_lme/outputs.R | 95 ++++++++-- inst/modules/group_analysis_lme/reactives.R | 130 ++++++++++++- inst/tools/input_widgets.R | 195 +++++++++++++++----- 4 files changed, 400 insertions(+), 83 deletions(-) diff --git a/inst/modules/group_analysis_lme/comp.R b/inst/modules/group_analysis_lme/comp.R index 9f4b3ad..148472f 100644 --- a/inst/modules/group_analysis_lme/comp.R +++ b/inst/modules/group_analysis_lme/comp.R @@ -73,7 +73,7 @@ define_initialization({ define_input_analysis_data_csv( inputId= 'analysis_data', label = 'Data files', paths = c('_project_data/group_analysis_lme/source', '_project_data/power_explorer'), - reactive_target = 'local_data$analysis_data' + reactive_target = 'local_data$analysis_data_raw' ) # define_input( @@ -99,16 +99,38 @@ define_input( textInput('model_formula', 'Formula', value = '') ) define_input( - checkboxInput('model_embedsubject', HTML('Embed subject into electrode (only if both Subject and Electrode are selected as random effect)'), value = TRUE) + checkboxInput('model_embedsubject', HTML('Embed subject into electrode [only if both Subject and Electrode are selected as random effect]'), value = TRUE) +) +define_input( + checkboxInput('model_splinetime', HTML('Wrap Time with Splines [use splines::bs(Time)]'), value = TRUE) ) define_input( actionButtonStyled('run_analysis', 'Run Analysis', type = 'primary', width = '100%') ) +# We can't use define_input_condition_groups as it defaults to preload_info$condition +# In fact every project might have different stimulus for each subjects, then condition is not +# the same sometime +# define_input( +# definition = compoundInput( +# inputId = 'cond_group', prefix= 'Condition Group', inital_ncomp = 1, components = { +# textInput('group_name', 'Name', value = '', placeholder = 'Condition Name') +# selectInput('group_conditions', ' ', choices = '', multiple = TRUE, selected = character(0)) +# }, max_ncomp = 20) +# ) + +define_input( + definition = customizedUI('cond_group_ui') +) + + manual_inputs = c('source_files', 'csv_file', 'load_csvs', 'model_dependent', - 'model_fixed_effects', 'model_random_effects', - 'model_formula', 'model_embedsubject', 'run_analysis') + 'model_fixed_effects', 'model_random_effects', 'model_splinetime', + 'model_formula', 'model_embedsubject', 'run_analysis', 'cond_group_ui', + sprintf('%s_%s_%d', 'group_name', c('group_name', 'group_conditions'), + rep(1:20, each = 2)) + ) # # selectInput('electrode', 'Electrode', choices = '', multiple = F), @@ -118,12 +140,15 @@ manual_inputs = c('source_files', 'csv_file', 'load_csvs', 'model_dependent', # choices = c('none', 'z-score', 'max-scale', '0-1 scale', 'rank'), multiple = F, selected = 'none'), # input_layout = list( - '[#cccccc]Dataset' = list( + '[#cccccc]Data Import' = list( # c('participants'), # c('analysis_name_ui') # 'source_files', 'csv_file', 'load_csvs' 'analysis_data', - 'var_sel' + 'cond_group_ui' + ), + '[-]Data Filter' = list( + 'var_sel' ), # 'Feature Selection' = list( # c('omnibus_f', 'fcutoff') @@ -132,6 +157,7 @@ input_layout = list( c('model_dependent'), c('model_fixed_effects', 'model_random_effects'), 'model_embedsubject', + 'model_splinetime', 'model_formula', 'run_analysis' @@ -140,9 +166,6 @@ input_layout = list( # 'var_rand_effects_ui', # 'var_formula_ui', # 'nested_electrode' - ), - 'Model Running' = list( - 'do_btn_ui' ) ) @@ -155,16 +178,28 @@ input_layout = list( define_output( definition = customizedUI('src_data_snapshot', style='min-height:500px'), title = 'Data Snapshot', - width = 4, - order = 1 + width = 5, + order = 2 ) + define_output( - definition = customizedUI('lme_out', width = 12, style='min-height:500px'), + definition = customizedUI('lme_out', width = 12, style='min-height:300px'), title = 'LME Output', - width = 8, + width = 12, order = 1 ) +define_output( + definition = plotOutput('lmer_diagnosis', height = '520px'), + title = 'Diagnostic Plots', + width = 7, + order = 3 +) + + +# hr(), +# h4('Diagnostic Plots'), +# shiny::plotOutput(ns('lmer_diagnosis')) define_output_3d_viewer( outputId = 'lme_3dviewer', message = 'Reload Viewer', @@ -175,7 +210,7 @@ define_output_3d_viewer( output_layout = list( 'Tabset One' = list( - 'Multiple Output' = c('lme_out', 'src_data_snapshot'), + 'Multiple Output' = c('lme_out'), '3D Visualization' = c('lme_3dviewer') ) # 'Multiple Output' = 'src_data_snapshot' diff --git a/inst/modules/group_analysis_lme/outputs.R b/inst/modules/group_analysis_lme/outputs.R index b5f155c..a6b5689 100644 --- a/inst/modules/group_analysis_lme/outputs.R +++ b/inst/modules/group_analysis_lme/outputs.R @@ -82,29 +82,81 @@ src_data_snapshot <- function(){ n_complete = nrow(tbl) } - tags$p( - # 1. dimensions - 'Original analysis table (raw): ', strong(sprintf('%d rows x %d columns', nrow(tbl_raw), ncol(tbl_raw))), br(), - - # 2. columns - 'Columns: ', strong(paste(vars, collapse = ', ')), br(), - - hr(), - - # 3. filtered table - 'Filtered analysis table (input data): ', strong(sprintf( - '%d rows (%d complete entries)', nrow(tbl), n_complete - )), br(), - - # 3. column types - 'Column types: ', br(), - - dv_tag, fe_tag, fr_tag, rest_tag + + tagList( + tags$p( + # 1. dimensions + 'Original analysis table (raw): ', strong(sprintf('%d rows x %d columns', nrow(tbl_raw), ncol(tbl_raw))), br(), + + # 2. columns + 'Columns: ', strong(paste(vars, collapse = ', ')), br(), + + hr(), + + # 3. filtered table + 'Filtered analysis table (input data): ', strong(sprintf( + '%d rows (%d complete entries)', nrow(tbl), n_complete + )), br(), + + # 3. column types + 'Column types: ', br(), + + dv_tag, fe_tag, fr_tag, rest_tag + + ) ) } +lmer_diagnosis = function(){ + lmer_results = local_data$lmer_results + shiny::validate(shiny::need(!is.null(lmer_results), message = 'No model calculated')) + resid = stats::residuals(lmer_results, type = 'pearson', scaled = TRUE) + fitt = fitted(lmer_results) + hat_val = hatvalues(lmer_results) + tbl = shiny::isolate(local_data$analysis_data_filtered) + sub = as.factor(tbl$Subject) + + nobs = length(resid); n_plot = min(10000, nobs) + if(nobs > n_plot){ + sel = sample(nobs, n_plot) + resid = resid[sel] + fitt = fitt[sel] + hat_val = hat_val[sel] + sub = sub[sel] + } + pretty2 = function(v, digits = 2){ + c(pretty(v), round(range(v), digits)) + } + + graphics::layout(matrix(c(1,1,2,3), 2, byrow = TRUE)) + par(mar = c(4.1, 2.1, 4.1, 1)) + # 1. resid vs fitted + rutabaga::plot_clean(xlim = fitt, ylim = resid, + main = sprintf('Resid vs. Fitted (%d of %d)', n_plot, nobs)) + points(fitt, resid, pch = 20, cex = 0.3) + rutabaga::ruta_axis(1, pretty(fitt)) + rutabaga::ruta_axis(2, pretty(resid)) + abline(h = 0, col = 'orange3', lty = 2, lwd = 2) + + # 2. qqplot + tmp = sort(rnorm(n_plot)) + rutabaga::plot_clean(xlim = tmp, ylim = resid, + main = 'Normal Q-Q plot') + points(tmp, sort(resid), pch = 20, cex = 0.3) + rutabaga::ruta_axis(1, pretty(tmp)) + rutabaga::ruta_axis(2, pretty(resid)) + abline(a = 0, b = sd(resid)/sd(tmp), col = 'orange3', lty = 2, lwd = 2) + + # 3. Boxplot of residual vs subjects + boxplot(resid ~ sub, axes = FALSE, + main = 'BoxPlot of Resid/Subj', cex.main = 1.5, cex.lab = 1.4) + rutabaga::ruta_axis(2, pretty(resid)) + + # 4. Boxplot of residuals vs Electrodes +} + # 3D viewer, takes 3 args lme_3dviewer_fun <- function(need_calc, side_width, daemon_env, ...){ @@ -113,7 +165,7 @@ lme_3dviewer_fun <- function(need_calc, side_width, daemon_env, ...){ shiny::validate(shiny::need(!is.null(lmer_results), message = 'Please run LMER model first')) - tbl = local_data$analysis_data + tbl = shiny::isolate(local_data$analysis_data_filtered) assign('lmer_results', lmer_results, envir = globalenv()) assign('tbl', tbl, envir = globalenv()) @@ -174,3 +226,8 @@ lme_3dviewer_fun <- function(need_calc, side_width, daemon_env, ...){ } } + + +lme_diagnosis <- function(){ + plot(1:10) +} diff --git a/inst/modules/group_analysis_lme/reactives.R b/inst/modules/group_analysis_lme/reactives.R index 9f9ace6..528dbb9 100644 --- a/inst/modules/group_analysis_lme/reactives.R +++ b/inst/modules/group_analysis_lme/reactives.R @@ -3,6 +3,10 @@ output = getDefaultReactiveOutput() session = getDefaultReactiveDomain() local_data %?<-% reactiveValues( + # Full data has two parts: local_data$analysis_data_raw, and local_data$additional_data + # togeither makes analysis_data + analysis_data_raw = NULL, + additional_data = NULL, analysis_data = NULL, potential_analysis = list(), @@ -18,22 +22,134 @@ local_filters = reactiveValues( ) +cond_group_ui = function(){ + rave::compoundInput( + inputId = ns('cond_group'), prefix= 'Condition Group', inital_ncomp = 1, components = { + textInput('group_name', 'Name', value = '', placeholder = 'Condition Name') + selectInput('group_conditions', ' ', choices = '', multiple = TRUE, selected = character(0)) + }, max_ncomp = 10) +} + + +# Sync all group_names +lapply(1:0, function(ii){ + name_id = paste0('cond_group_group_name_', ii) + .env = environment() + observeEvent(input[[name_id]], { + val = val_raw = input[[name_id]] + if(length(val)){ + if( stringr::str_detect(val, '^CondGroup[0-9]*') || + val %in% names(local_data$analysis_data_raw) ){ + # Invalid group name, reset to default + val = sprintf('CondGroup%d', ii) + } + if( val != val_raw ){ + updateTextInput(session, name_id, value = val) + } + } + }, event.env = .env, handler.env = .env) +}) + +observe({ + raw = local_data$analysis_data_raw + conditions = NULL + if( is.data.frame(raw) ){ + conditions = unique(raw$Condition) + } + if(!length(conditions)){ conditions = '' } + + # Update cond_group + lapply(seq_len(20), function(ii){ + cond_groups = lapply(1:20, function(jj){ + shiny::isolate(input[[paste0('cond_group_group_conditions_', jj)]]) + }) + selected = character(0) + if( length(cond_groups) >= ii ){ + selected = unlist(cond_groups[[ii]]) + if( !length(selected) ){ selected = character(0) } + } + updateSelectInput(session, inputId = sprintf('%s_%d', 'cond_group_group_conditions', ii), + choices = conditions, selected = selected) + }) +}) + +# Get additional data +observe({ + cond_groups = lapply(1:20, function(jj){input[[paste0('cond_group_group_conditions_', jj)]]}) + cond_groups = rave::dropNulls(cond_groups) + conditions = NULL + if( is.data.frame(local_data$analysis_data_raw) ){ + conditions = local_data$analysis_data_raw$Condition + } + if(length(cond_groups) && length(conditions)){ + + cols = lapply(cond_groups, function(conds){ + as.numeric(conditions %in% unlist(conds)) + }) + gnames = lapply(seq_along(cols), function(jj){input[[paste0('cond_group_group_name_', jj)]]}) + names(cols) = gnames + local_data$additional_data = do.call('data.frame', cols) + }else{ + local_data$additional_data = NULL + } + +}) + + +# Combine raw and additional_data +observe({ + raw = local_data$analysis_data_raw + add = local_data$additional_data + if( is.data.frame(raw) ){ + if(is.data.frame(add)){ + raw = cbind(raw, add) + } + local_data$analysis_data = raw + }else{ + local_data$analysis_data = NULL + } + +}) + + # build Model observe({ - if(!is.data.frame(local_data$analysis_data)){ return() } - local_data$sample_table = head(local_data$analysis_data) - vars = names(local_data$analysis_data) - vars = vars[!vars %in% c('Project')] + if(!is.data.frame(local_data$analysis_data)){ + local_data$table_headers = NULL + local_data$sample_table = NULL + }else{ + local_data$sample_table = head(local_data$analysis_data) + local_data$table_headers = names(local_data$analysis_data) + } +}) + + + + + + +get_table_headers = function(){ + vars = local_data$table_headers if(!length(vars)){ vars = '' } + vars = vars[!vars %in% c('Project')] + if( isTRUE(input$model_splinetime) && 'Time' %in% vars ){ + vars[vars == 'Time'] = 'splines::bs(Time)' + } + vars +} + +observe({ + vars = get_table_headers() dep = 'Power' if(!dep %in% vars){ - tmp = vars[!vars %in% c('Time')] + tmp = vars[!vars %in% c('Time', 'splines::bs(Time)')] if(length(tmp)){ dep = tmp[[1]] }else{ dep = vars[[1]] } } + vars2 = vars[!vars %in% dep]; if(length(vars2) == ''){vars2 = ''} updateSelectInput(session, 'model_fixed_effects', choices = vars2, selected = shiny::isolate(local_data$fixed)) updateSelectInput(session, 'model_random_effects', choices = vars2, selected = shiny::isolate(local_data$rand)) @@ -61,7 +177,7 @@ rave::sync_shiny_inputs( input = input, session = session, inputIds = c('model_dependent', 'model_fixed_effects', 'model_random_effects'), uniform = list( function(var_y){ - vars = names(local_data$analysis_data) + vars = get_table_headers() vars = vars[!vars %in% c('Project', var_y)] if(!length(vars)){ vars = '' } updateSelectInput(session, 'model_fixed_effects', choices = vars) @@ -124,7 +240,7 @@ observeEvent(input$run_analysis, { fo = input$model_formula fo = as.formula(fo) tryCatch({ - local_data$lmer_results = lmerTest::lmer(fo, data=local_data$analysis_data, na.action=na.omit) + local_data$lmer_results = lmerTest::lmer(fo, data=local_data$analysis_data_filtered, na.action=na.omit) removeNotification(id = ns('noti')) }, error = function(e){ # grouping factors must have > 1 sampled level diff --git a/inst/tools/input_widgets.R b/inst/tools/input_widgets.R index ddc939d..6cbdbc0 100644 --- a/inst/tools/input_widgets.R +++ b/inst/tools/input_widgets.R @@ -283,7 +283,38 @@ define_input_time <- function(inputId, label = 'Time Range', is_range = TRUE, ro rave::eval_dirty(quo, env = parent_frame) } -define_input_condition_groups <- function(inputId, label = 'Group', initial_groups = 1){ +define_input_condition_groups <- function( + inputId, label = 'Group', initial_groups = 1, + init_args, init_expr, quoted = FALSE, ...){ + + if(missing(init_args)){ + init_args = c('initialize', 'value') + } + + if(missing(init_expr)){ + init_expr = rlang::quo({ + cond = unique(preload_info$condition) + + initialize = list( + group_conditions = list( + choices = cond + ) + ) + default_val = list( + list( + group_name = 'All Conditions', + group_conditions = list(cond) + ) + ) + value = cache_input(!!inputId, default_val) + if( !length(value) || !length(value[[1]]$group_conditions) || !any(value[[1]]$group_conditions %in% cond)){ + value = default_val + } + }) + }else if (!quoted){ + init_expr = substitute(init_expr) + } + quo = rlang::quo({ define_input( @@ -293,26 +324,10 @@ define_input_condition_groups <- function(inputId, label = 'Group', initial_grou selectInput('group_conditions', ' ', choices = '', multiple = TRUE) }), - init_args = c('initialize', 'value'), + init_args = !!init_args, init_expr = { - cond = unique(preload_info$condition) - - initialize = list( - group_conditions = list( - choices = cond - ) - ) - default_val = list( - list( - group_name = 'All Conditions', - group_conditions = list(cond) - ) - ) - value = cache_input(!!inputId, default_val) - if( !length(value) || !length(value[[1]]$group_conditions) || !any(value[[1]]$group_conditions %in% cond)){ - value = default_val - } + eval(!!init_expr) } ) }) @@ -324,6 +339,70 @@ define_input_condition_groups <- function(inputId, label = 'Group', initial_grou } +define_input_condition_groups2 <- function( + inputId, label = 'Group', initial_groups = 1, max_group = 10, min_group = 1, + label_color = rep('black', max_group), init_args, init_expr, quoted = FALSE, ... +){ + if( !rutabaga::package_installed('dipsaus') ){ + call = match.call() + call[[1]] = quote(define_input_condition_groups) + eval(call) + return() + } + + get_from_package('registerCompoundInput2', 'dipsaus', internal = TRUE)() + if(missing(init_args)){ + init_args = c('initialization', 'value') + } + + if(missing(init_expr)){ + init_expr = rlang::quo({ + cond = unique(preload_info$condition) + + initialization = list( + group_conditions = list( + choices = cond + ) + ) + default_val = list( + list( + group_name = 'All Conditions', + group_conditions = list(cond) + ) + ) + value = cache_input(!!inputId, default_val) + if( !length(value) || !length(value[[1]]$group_conditions) || !any(value[[1]]$group_conditions %in% cond)){ + value = default_val + } + }) + }else if (!quoted){ + init_expr = substitute(init_expr) + } + + quo = rlang::quo({ + + define_input( + definition = dipsaus::compoundInput2( + inputId = !!inputId, label = !!label, inital_ncomp = !!initial_groups, + components = htmltools::div( + textInput('group_name', 'Name', value = '', placeholder = 'Condition Name'), + selectInput('group_conditions', ' ', choices = '', multiple = TRUE) + ), + label_color = !!label_color, max_ncomp = !!max_group, min_group = !!min_group + ), + + init_args = !!init_args, + + init_expr = eval(!!init_expr) + ) + }) + + parent_frame = parent.frame() + + rave::eval_dirty(quo, env = parent_frame) + +} + define_input_analysis_data_csv <- function( inputId, label, paths, reactive_target = sprintf('local_data[[%s]]', inputId), @@ -512,7 +591,12 @@ define_input_analysis_data_csv <- function( -define_input_table_filters <- function(inputId, label = 'Filter', watch_target = 'local_data[["analysis_data"]]', reactive_target = 'local_data[["analysis_data_filtered"]]',table_not_present = p('Analysis table not loaded')){ +define_input_table_filters <- function( + inputId, label = 'Filter', + watch_target = 'local_data[["analysis_data"]]', + reactive_target = 'local_data[["analysis_data_filtered"]]', + table_not_present = p('Analysis table not loaded') +){ input_ui = inputId watch_target = substitute(watch_target) reactive_target = substitute(reactive_target) @@ -545,19 +629,19 @@ define_input_table_filters <- function(inputId, label = 'Filter', watch_target = # To make a box to wrap group inputs class = 'rave-grid-inputs', div( - style = 'flex-basis: 25%; min-height: 80px;', + style = 'flex-basis: 33%; min-height: 80px;', selectInput(ns(sprintf('%s_var_', !!input_filter_prefix, ii)), 'Variable', choices = vars, selected = get_val(filter, 'var', default = NULL)) ), div( - style = 'flex-basis: 25%; min-height: 80px;', + style = 'flex-basis: 33%; min-height: 80px;', selectInput(ns(sprintf('%s_op_', !!input_filter_prefix, ii)), 'Operator', choices = c('=', '!=', '>', '>=', '<', '<=', 'in', 'not in', 'between'), selected = get_val(filter, 'op', default = '=')) ), div( - style = 'flex-basis: 25%; min-height: 80px;', + style = 'flex-basis: 33%; min-height: 80px;', textInput(ns(sprintf('%s_val_', !!input_filter_prefix, ii)), 'Value', value = get_val(filter, 'val', default = NULL)) ), div( - style = 'flex-basis: 25%; min-height: 80px;', + style = 'flex-basis: 100%;', uiOutput(ns(sprintf('%s_msg_', !!input_filter_prefix, ii))) ) ) @@ -581,17 +665,21 @@ define_input_table_filters <- function(inputId, label = 'Filter', watch_target = # Given data, operator and criteria, return logical filters ...ravemodule_environment_reserved[[!!input_ui]]$filter_data = function(dat, op, val){ - if( is.numeric(dat) && is.character(val) ){ - if( op %in% c('in', 'not in', 'between') ){ - val = as.numeric(stringr::str_split(val, '[^0-9-.]+')[[1]]) - }else{ - val = as.numeric(val) + tryCatch({ + if( is.numeric(dat) && is.character(val) ){ + if( op %in% c('in', 'not in', 'between') ){ + val = as.numeric(stringr::str_split(val, '[^0-9-.]+')[[1]]) + }else{ + val = as.numeric(val) + } } - } - expr = ...ravemodule_environment_reserved[[!!input_ui]]$get_operator(op) - expr = sprintf(expr, 'dat', deparse(val)) - sel = rlang::eval_tidy(rlang::parse_expr(expr), data = list(dat = dat)) - sel + expr = ...ravemodule_environment_reserved[[!!input_ui]]$get_operator(op) + expr = sprintf(expr, 'dat', deparse(val)) + sel = rlang::eval_tidy(rlang::parse_expr(expr), data = list(dat = dat)) + sel + }, error = function(e){ + NULL + }) } ...ravemodule_environment_reserved[[!!input_ui]]$get_filter_results = function(ii){ @@ -601,12 +689,22 @@ define_input_table_filters <- function(inputId, label = 'Filter', watch_target = if(!is.data.frame(...ravemodule_environment_reserved[[!!input_ui]]$data) || !is.list(filter) || !isFALSE(filter$failed)){ return(NULL) } var = filter$var; op = filter$op; val = filter$val dat = ...ravemodule_environment_reserved[[!!input_ui]]$data[[var]] - if( op %in% c('in', 'not in', 'between') ){ - val = as.numeric(stringr::str_split(val, '[^0-9-.]+')[[1]]) + if( var == 'Electrode' ){ + dat = as.numeric(dat) + } + if(is.numeric(dat)){ + if( op %in% c('in', 'not in', 'between') ){ + val = as.numeric(stringr::str_split(val, '[^0-9-.]+')[[1]]) + }else{ + val = as.numeric(val) + } }else{ - val = as.numeric(val) + if( op %in% c('in', 'not in') ){ + val = stringr::str_split(val, ',[ ]{0,1}')[[1]] + } } sel = ...ravemodule_environment_reserved[[!!input_ui]]$filter_data(dat, op, val) + if(is.null(sel)){ return(NULL) } sel[is.na(sel)] = FALSE sel } @@ -638,15 +736,24 @@ define_input_table_filters <- function(inputId, label = 'Filter', watch_target = msg = 'Value is blank or invalid' failed = TRUE } + }else{ + if( op %in% c('in', 'not in') ){ + val = stringr::str_split(val, ',[ ]{0,1}')[[1]] + } } if( !failed ){ sel = ...ravemodule_environment_reserved[[!!input_ui]]$filter_data(dat, op, val) - n_na = sum(is.na(dat[sel])) - n_sel = sum(sel, na.rm = TRUE) - msg = sprintf('%d of %d selected (%d NAs)', n_sel, length(sel), n_na) - if(n_sel == 0){ - msg = 'No data selected' + if( is.null(sel) ){ + msg = 'Filter has error, will be ignored' failed = TRUE + }else{ + n_na = sum(is.na(dat[sel])) + n_sel = sum(sel, na.rm = TRUE) + msg = sprintf('%d of %d selected (%d NAs)', n_sel, length(sel), n_na) + if(n_sel == 0){ + msg = 'No data selected' + failed = TRUE + } } } } @@ -704,7 +811,9 @@ define_input_table_filters <- function(inputId, label = 'Filter', watch_target = filters = rep(TRUE, nrows) for(ii in seq_len(n_filters)){ fil = ...ravemodule_environment_reserved[[!!input_ui]]$get_filter_results( ii ) - filters = filters & fil + if(length(fil)){ + filters = filters & fil + } } filters } From 6cc057f32a79de1597ed41a02372f9ecf0f16948 Mon Sep 17 00:00:00 2001 From: dipterix Date: Sun, 13 Oct 2019 18:28:48 -0500 Subject: [PATCH 18/24] pass R checks --- NAMESPACE | 3 +++ R/aaa.R | 3 +++ R/common_plotting_functions.R | 1 + R/power_explorer_plots.R | 4 ++-- R/utils.R | 2 +- man/draw_many_heat_maps.Rd | 2 ++ 6 files changed, 12 insertions(+), 3 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 0d97833..96e5417 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -29,8 +29,11 @@ importFrom(magrittr,"%<>%") importFrom(magrittr,"%>%") importFrom(magrittr,extract) importFrom(magrittr,extract2) +importFrom(methods,getMethod) importFrom(methods,is) importFrom(stats,median) importFrom(stats,median.default) +importFrom(stats,p.adjust) importFrom(stats,pt) importFrom(stats,quantile) +importFrom(stats,symnum) diff --git a/R/aaa.R b/R/aaa.R index b31673b..19a7998 100644 --- a/R/aaa.R +++ b/R/aaa.R @@ -13,6 +13,7 @@ #' @import lmerTest #' #' @importFrom methods is +#' @importFrom methods getMethod #' @import circular #' #' @importFrom grDevices dev.off @@ -28,6 +29,8 @@ #' @importFrom stats median.default #' @importFrom stats pt #' @importFrom stats quantile +#' @importFrom stats p.adjust +#' @importFrom stats symnum #' NULL diff --git a/R/common_plotting_functions.R b/R/common_plotting_functions.R index d1dc177..c1f43c6 100644 --- a/R/common_plotting_functions.R +++ b/R/common_plotting_functions.R @@ -13,6 +13,7 @@ #' Don't depend on this call order, use PANEL.LAST if you want to draw things on top of the heatmap #' @param PANEL.LAST a function that is called after the rendering of each heat map. It is not called after the rendering of the color bar. #' @param axes vector of logicals, whether to draw axis +#' @param xrange x range, similar to \code{xlim} #' @description Easy way to make a bunch of heatmaps with consistent look/feel and get a colorbar. #' By default it is setup for time/freq, but by swapping labels and decorators you can do anything. #' @seealso layout_heat_maps diff --git a/R/power_explorer_plots.R b/R/power_explorer_plots.R index 6306389..0fe55bb 100644 --- a/R/power_explorer_plots.R +++ b/R/power_explorer_plots.R @@ -175,7 +175,7 @@ across_electrodes_corrected_pvalue <- function(results, ...) { if(!is.null(cut)) { segments(x0=0, x1=ncol(omnibus_results), y0=nl10(cut), lty=2, col='orangered') - rave_axis(4, at=nl10(cut), label=results$get_value('pval_operand'), + rave_axis(4, at=nl10(cut), labels=results$get_value('pval_operand'), tcl=0, cex.axis = 1, lwd=0, mgpy=c(-3, -1, -0)) } @@ -192,7 +192,7 @@ across_electrodes_corrected_pvalue <- function(results, ...) { # not sure how to vectorize an expression involving bquote :( rave_axis(2, at=axt, labels = F, tcl=0) for(ii in seq_along(axt)) { - rave_axis(2, at=axt[ii], label=bquote(10**-.(axt[ii])), cex.axis = rave_cex.axis*.9) + rave_axis(2, at=axt[ii], labels=bquote(10**-.(axt[ii])), cex.axis = rave_cex.axis*.9) } print(omnibus_results[3,]) } diff --git a/R/utils.R b/R/utils.R index 4aec6ef..e238ee9 100644 --- a/R/utils.R +++ b/R/utils.R @@ -111,7 +111,7 @@ htmltable_coefmat <- function( # Make Cf a table # print.default(Cf, quote = quote, right = right, na.print = na.print, ...) re = list() - tags = htmltools::tags + tags = shiny::tags rnames = rownames(Cf) if(length(caption) != 1){ diff --git a/man/draw_many_heat_maps.Rd b/man/draw_many_heat_maps.Rd index 8852083..49ba824 100644 --- a/man/draw_many_heat_maps.Rd +++ b/man/draw_many_heat_maps.Rd @@ -30,6 +30,8 @@ Don't depend on this call order, use PANEL.LAST if you want to draw things on to \item{PANEL.LAST}{a function that is called after the rendering of each heat map. It is not called after the rendering of the color bar.} \item{axes}{vector of logicals, whether to draw axis} + +\item{xrange}{x range, similar to \code{xlim}} } \description{ Easy way to make a bunch of heatmaps with consistent look/feel and get a colorbar. From 61fdefdb9dbc206a98295c446ee0931353934992 Mon Sep 17 00:00:00 2001 From: dipterix Date: Mon, 14 Oct 2019 16:41:43 -0500 Subject: [PATCH 19/24] Fixed power expl export baseline error --- inst/modules/group_analysis_lme/comp.R | 4 +- inst/modules/power_explorer/exports.R | 64 ++++++++++++++++++++------ 2 files changed, 51 insertions(+), 17 deletions(-) diff --git a/inst/modules/group_analysis_lme/comp.R b/inst/modules/group_analysis_lme/comp.R index 148472f..dac1339 100644 --- a/inst/modules/group_analysis_lme/comp.R +++ b/inst/modules/group_analysis_lme/comp.R @@ -127,9 +127,7 @@ define_input( manual_inputs = c('source_files', 'csv_file', 'load_csvs', 'model_dependent', 'model_fixed_effects', 'model_random_effects', 'model_splinetime', - 'model_formula', 'model_embedsubject', 'run_analysis', 'cond_group_ui', - sprintf('%s_%s_%d', 'group_name', c('group_name', 'group_conditions'), - rep(1:20, each = 2)) + 'model_formula', 'model_embedsubject', 'run_analysis' ) diff --git a/inst/modules/power_explorer/exports.R b/inst/modules/power_explorer/exports.R index e99e447..df48a75 100644 --- a/inst/modules/power_explorer/exports.R +++ b/inst/modules/power_explorer/exports.R @@ -357,19 +357,19 @@ export_data_function <- function(){ progress$inc('Collecting data') # Get trial conditions - conditions = trial_type_filter + conditions = input$trial_type_filter conditions = conditions[conditions %in% preload_info$condition] trials = module_tools$get_meta('trials') trial_number = trials$Trial[trials$Condition %in% conditions] # Get timepoints,frequency range time_points = preload_info$time_points - time_points = time_points[time_points %within% export_time_window] + time_points = time_points[time_points %within% input$export_time_window] freq_range = preload_info$frequencies - freq_range = freq_range[freq_range %within% FREQUENCY] + freq_range = freq_range[freq_range %within% input$FREQUENCY] # get baseline - baseline_range = BASELINE_WINDOW + baseline_range = input$BASELINE_WINDOW # Do some checks @@ -398,22 +398,39 @@ export_data_function <- function(){ cond_list = list(); cond_list[trials$Trial] = trials$Condition # Use async lapply to speed up the calculation as it's really per electrode analysis - res = rave::lapply_async(electrodes, function(e){ - bl = baseline(power$subset(Trial = Trial %in% trial_number, - Time = Time %within% time_points, - Frequency = Frequency %within% freq_range, - Electrode = Electrode %in% e), - from = baseline_range[1], to = baseline_range[2], hybrid = FALSE, mem_optimize = FALSE) + # res = rave::lapply_async(electrodes, function(e){ + # bl = baseline(power$subset(Trial = Trial %in% trial_number, + # Time = Time %within% time_points, + # Frequency = Frequency %within% freq_range, + # Electrode = Electrode %in% e), + # from = baseline_range[1], to = baseline_range[2], hybrid = FALSE, mem_optimize = FALSE) + # flat = bl$collapse(keep = c(1,3)) + # dimnames(flat) = dimnames(bl)[c(1,3)] + # flat = reshape2::melt(flat, value.name = 'Power') # trial time, value + # flat$Condition = unlist(cond_list[flat$Trial]) + # flat$Electrode = e + # flat + # }, .call_back = function(ii){ + # progress$inc(sprintf('Electrode %d', electrodes[[ii]])) + # # specify all variables in .globals, in this way we can avoid the whole memory mappings + # }, .globals = c('power', 'trial_number', 'time_points', 'freq_range', 'e', 'baseline_range', 'cond_list')) + + res = lapply(electrodes, function(e){ + progress$inc(sprintf('Electrode %d', e)) + # Important p_sub is assigned, otherwise, it will get gc before baselined + p_sub = power$subset(Trial = Trial %in% trial_number, + Frequency = Frequency %within% freq_range, + Electrode = Electrode %in% e) + bl = baseline(p_sub, from = baseline_range[1], to = baseline_range[2], hybrid = FALSE, mem_optimize = FALSE) + bl = bl$subset(Time = Time %within% time_points) flat = bl$collapse(keep = c(1,3)) dimnames(flat) = dimnames(bl)[c(1,3)] flat = reshape2::melt(flat, value.name = 'Power') # trial time, value flat$Condition = unlist(cond_list[flat$Trial]) flat$Electrode = e flat - }, .call_back = function(ii){ - progress$inc(sprintf('Electrode %d', electrodes[[ii]])) - # specify all variables in .globals, in this way we can avoid the whole memory mappings - }, .globals = c('power', 'trial_number', 'time_points', 'freq_range', 'e', 'baseline_range', 'cond_list')) + }) + res = do.call('rbind', res) res$Project = project_name res$Subject = subject_code @@ -427,6 +444,25 @@ export_data_function <- function(){ dirname = file.path(subject$dirs$subject_dir, '..', '_project_data', 'power_explorer') dir.create(dirname, showWarnings = FALSE, recursive = TRUE) data.table::fwrite(res, file.path(dirname, fname), append = FALSE) + + # Collapse time + res_collapse_time = lapply(split(res, paste(res$Trial, res$Electrode)), function(x){ + data.frame(stringsAsFactors = FALSE, + Trial = x$Trial[1], Power = mean( x$Power ), Condition = x$Condition[1], + Electrode = x$Electrode[1], Project = x$Project[1], Subject = x$Subject[1]) + }) + res_collapse_time = do.call('rbind', res_collapse_time) + data.table::fwrite(res_collapse_time, file.path(dirname, paste0(analysis_prefix, '-collapse_time-', now, '.csv')), append = FALSE) + + # Collapse Trial + res_collapse_trial = lapply(split(res, paste0(res$Condition, res$Electrode, res$Time)), function(x){ + data.frame(stringsAsFactors = FALSE, + Power = mean( x$Power ), Condition = x$Condition[1], Time = x$Time[1], + Electrode = x$Electrode[1], Project = x$Project[1], Subject = x$Subject[1]) + }) + res_collapse_trial = do.call('rbind', res_collapse_trial) + data.table::fwrite(res_collapse_trial, file.path(dirname, paste0(analysis_prefix, '-collapse_trial-', now, '.csv')), append = FALSE) + return(normalizePath(file.path(dirname, fname))) } From 3df32d19d03b8ce7937682c702512d0af75e5f1a Mon Sep 17 00:00:00 2001 From: John Magnotti Date: Thu, 17 Oct 2019 22:19:23 -0500 Subject: [PATCH 20/24] updates to group analysis --- DESCRIPTION | 20 +- inst/modules/group_analysis_lme/common.R | 64 ++-- inst/modules/group_analysis_lme/comp.R | 144 +++++--- inst/modules/group_analysis_lme/main.R | 12 +- inst/modules/group_analysis_lme/outputs.R | 216 +++++++----- inst/modules/group_analysis_lme/reactives.R | 335 +++++++++++-------- inst/modules/power_explorer/comp.R | 26 +- inst/modules/power_explorer/event_handlers.R | 53 +++ inst/modules/power_explorer/exports.R | 60 +++- inst/modules/power_explorer/main.R | 3 + inst/tools/input_widgets.R | 169 +++++++++- inst/tools/viewers.R | 4 +- 12 files changed, 769 insertions(+), 337 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 4808ff7..f6379e5 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -16,6 +16,13 @@ Authors@R: c( Imports: methods, stats, + graphics, + grid, + abind, + car, + utils, + data.table, + yaml (>= 2.2.0), shiny (>= 1.2.0), rlang (>= 0.3.0), stringr (>= 1.3.1), @@ -24,12 +31,19 @@ Imports: magrittr (>= 1.5), circular (>= 0.4-93), lmerTest (>= 3.1-0), + knitr, + assertthat, + shinyjs, + shinyFiles, + reshape2, + digest, + DT, + fst, + htmltools, rave, - rutabaga, - abind + rutabaga Suggests: devtools, - yaml (>= 2.2.0), rstudioapi (>= 0.9.0) Remotes: github::dipterix/rutabaga, diff --git a/inst/modules/group_analysis_lme/common.R b/inst/modules/group_analysis_lme/common.R index 9f50617..56eab71 100644 --- a/inst/modules/group_analysis_lme/common.R +++ b/inst/modules/group_analysis_lme/common.R @@ -26,41 +26,60 @@ matrix_to_table <- function(mat, row_label=' ') { return(str) } +multiple_comparisons <- function() { + # return() + # lmer_results = local_data$lmer_results + # + # if(is.null(local_data$lmer_results)){ + return(htmltools::div(style='color:#a1a1a1; text-align:center; ', 'No model calculated yet')) + # } + print('in MC') + + test_conditions <- htmltable_coefmat(ls_means(lmer_results)) + compare_conditions <- htmltable_coefmat(ls_means(lmer_results, pairwise = TRUE)) + + htmltools::p( + test_conditions$table, + hr(), + compare_conditions$table + ) +} -lme_out = function() { +lme_out <- function() { # put analysis information in here if(is.null(local_data$lmer_results)){ return(htmltools::div(style='color:#a1a1a1; text-align:center; ', 'No model calculated yet')) } + print('in lme out') + + lmer_results = local_data$lmer_results + lmer_summary = local_data$lmer_results_summary + + deviance_summary = car::Anova(lmer_results) - # flat_data <- isolate(local_data$full_table) - # - # # ranef - # ngrps(.lmer) - # - # model.matrix(.lmer, 'fixed') %>% str - # model.frame(.lmer) %>% str - # - # plot(fitted(.lmer) + resid(.lmer), fitted(.lmer), asp=1) - # - smry = summary(lmer_results) + print('got deviance summary') + + tbl_html = htmltable_coefmat(lmer_summary$coefficients, caption = 'LME Summary Table') + anova_html = htmltable_coefmat(deviance_summary, caption = 'LME Analysis of Deviance Table') + + test_conditions <- htmltable_coefmat(ls_means(lmer_results)) + compare_conditions <- htmltable_coefmat(ls_means(lmer_results, pairwise = TRUE)) - tbl_html = htmltable_coefmat(smry$coefficients, caption = 'LME Summary Table') # put a description row htmltools::p( - smry$methTitle, sprintf(' (%s)', smry$objClass), br(), + lmer_summary$methTitle, sprintf(' (%s)', lmer_summary$objClass), br(), 'LME call: ', strong(format(formula(lmer_results))), br(), - 'Number of obs: ', strong(smry$devcomp$dims[["n"]]), 'groups: ', - strong(paste(paste(names(smry$ngrps), smry$ngrps, sep = ', '), collapse = '; ')), br(), + 'Number of obs: ', strong(lmer_summary$devcomp$dims[["n"]]), 'groups: ', + strong(paste(paste(names(lmer_summary$ngrps), lmer_summary$ngrps, sep = ', '), collapse = '; ')), br(), br(), # Convergence criteria local({ - aictab = smry$AICtab + aictab = lmer_summary$AICtab t.4 <- round(aictab, 1) if (length(aictab) == 1 && names(aictab) == "REML") res = tagList(paste("REML criterion at convergence:", t.4), br()) @@ -76,11 +95,16 @@ lme_out = function() { # residual do.call('sprintf', c( list('Scaled residual: %.4g (min), %.4g (25%%), %.4g (median), %.4g (75%%), %.4g (max)'), - structure(as.list(quantile(smry$residuals, na.rm = TRUE)), names = NULL) + structure(as.list(quantile(lmer_summary$residuals, na.rm = TRUE)), names = NULL) )), # coef table - tbl_html$table - + tbl_html$table, + hr(), + anova_html$table, + hr(), + test_conditions$table, + hr(), + compare_conditions$table ) } diff --git a/inst/modules/group_analysis_lme/comp.R b/inst/modules/group_analysis_lme/comp.R index dac1339..9efd4d0 100644 --- a/inst/modules/group_analysis_lme/comp.R +++ b/inst/modules/group_analysis_lme/comp.R @@ -72,38 +72,75 @@ define_initialization({ # ) define_input_analysis_data_csv( - inputId= 'analysis_data', label = 'Data files', paths = c('_project_data/group_analysis_lme/source', '_project_data/power_explorer'), - reactive_target = 'local_data$analysis_data_raw' + inputId= 'analysis_data', label = "Data files located in this project's RAVE directory", + paths = c('_project_data/group_analysis_lme/source', '_project_data/power_explorer/exports'), + reactive_target = 'local_data$analysis_data_raw', try_load_yaml = TRUE ) # define_input( # customizedUI('var_sel') # ) -define_input_table_filters('var_sel', label = 'Filter', watch_target = 'local_data$analysis_data', - reactive_target = 'local_data[["analysis_data_filtered"]]') +# define_input_table_filters('var_sel', label = 'Filter', watch_target = 'local_data$analysis_data', +# reactive_target = 'local_data[["analysis_data_filtered"]]') + +data_dir = rave_options('data_dir'); names(data_dir) = NULL +# define_input_analysis_file_chooser( +# 'lmer_yaml', labels = c('Save settings', 'Load settings'), +# name_prefix = 'lmer_settings_', +# read_source = c('Analysis Settings' = '', 'RAVE Home' = '../..'), +# write_source = 'group_analysis_lme', +# default_path = 'power_explorer' +# ) +load_scripts(rlang::quo({ + observeEvent(input$lmer_yaml_load, { + fdata = input$lmer_yaml_load + if(!is.list(fdata) || !length(fdata$files)){ return() } + assign('fdata', fdata, envir = globalenv()) + f_name = unlist(fdata$files); names(f_name) = NULL + + read_source = list( + 'Power Explorer Analysis' = 'power_explorer', + 'LME Analysis' = 'group_analysis_lme' + ) + + f_name = c(subject$dirs$subject_dir, '..', '_project_data', read_source[[fdata$root]], f_name) + f_path = do.call(file.path, as.list(f_name)) + print(f_path) + conf = yaml::read_yaml(f_path) + print(conf) + + # updateCheckboxInput(session, inputId = 'auto_calculate', value = FALSE) + # lapply(1:10, function(ii){ + # gc_id = sprintf('GROUPS_group_conditions_%d', ii) + # gc = conf[[gc_id]] + # if(!length(gc)){ gc = character(0) } + # print(paste(ii, c(gc))) + # updateSelectInput(session, gc_id, selected = gc) + # }) + }) +})) -#### Define model +# define_input( +# selectInput('model_dependent', 'Dependent', choices = '', selected = character(0)) +# ) +# define_input( +# selectInput('model_fixed_effects', 'Fixed effects', choices = '', selected = character(0), multiple = TRUE) +# ) +# define_input( +# selectInput('model_random_effects', 'Random effects', choices = '', selected = character(0), multiple = TRUE) +# ) define_input( - selectInput('model_dependent', 'Dependent', choices = '', selected = character(0)) -) -define_input( - selectInput('model_fixed_effects', 'Fixed effects', choices = '', selected = character(0), multiple = TRUE) -) -define_input( - selectInput('model_random_effects', 'Random effects', choices = '', selected = character(0), multiple = TRUE) -) -define_input( - textInput('model_formula', 'Formula', value = '') -) -define_input( - checkboxInput('model_embedsubject', HTML('Embed subject into electrode [only if both Subject and Electrode are selected as random effect]'), value = TRUE) -) -define_input( - checkboxInput('model_splinetime', HTML('Wrap Time with Splines [use splines::bs(Time)]'), value = TRUE) + textInput('model_formula', 'Formula', value = 'Power ~ Group + (1|Subject/Electrode)') ) +# define_input( +# checkboxInput('model_embedsubject', HTML('Embed subject into electrode [only if both Subject and Electrode are selected as random effect]'), value = TRUE) +# ) +# define_input( +# checkboxInput('model_splinetime', HTML('Wrap Time with Splines [use splines::bs(Time)]'), value = TRUE) +# ) define_input( actionButtonStyled('run_analysis', 'Run Analysis', type = 'primary', width = '100%') @@ -125,12 +162,16 @@ define_input( ) -manual_inputs = c('source_files', 'csv_file', 'load_csvs', 'model_dependent', - 'model_fixed_effects', 'model_random_effects', 'model_splinetime', +define_input( + definition = sliderInput('analysis_window', 'Analysis Window', + min = 0, max = 1, value=c(0,1), round=-2, step=0.01) +) + +manual_inputs = c('source_files', 'csv_file', 'load_csvs', 'analysis_window', + 'model_dependent', 'model_fixed_effects', 'model_random_effects', 'model_splinetime', 'model_formula', 'model_embedsubject', 'run_analysis' ) - # # selectInput('electrode', 'Electrode', choices = '', multiple = F), # textInput('electrode_text', 'Electrodes', value = "", placeholder = '1-5,8,11-20'), # @@ -142,28 +183,25 @@ input_layout = list( # c('participants'), # c('analysis_name_ui') # 'source_files', 'csv_file', 'load_csvs' - 'analysis_data', - 'cond_group_ui' + 'analysis_data' + ), + 'Analysis Settings' = list( + 'cond_group_ui', + 'analysis_window' ), - '[-]Data Filter' = list( + 'Filter Data' = list( 'var_sel' ), # 'Feature Selection' = list( # c('omnibus_f', 'fcutoff') # ), - 'Model Building' = list( + 'Build Model' = list( c('model_dependent'), c('model_fixed_effects', 'model_random_effects'), 'model_embedsubject', 'model_splinetime', 'model_formula', 'run_analysis' - - # 'var_dependent_ui', - # 'var_fixed_effects_ui', - # 'var_rand_effects_ui', - # 'var_formula_ui', - # 'nested_electrode' ) ) @@ -177,39 +215,51 @@ define_output( definition = customizedUI('src_data_snapshot', style='min-height:500px'), title = 'Data Snapshot', width = 5, - order = 2 + order = 1e2 ) define_output( definition = customizedUI('lme_out', width = 12, style='min-height:300px'), title = 'LME Output', width = 12, - order = 1 + order = 2 ) define_output( - definition = plotOutput('lmer_diagnosis', height = '520px'), + definition = customizedUI('group_figures', width = 12, style='min-height:300px'), + title = 'Group-level figures', + width = 12, + order = 1 +) + +define_output( + definition = customizedUI('multiple_comparisons', width = 12, style='min-height:300px'), + title = 'Statistics for Groups', + width = 12, + order = 3 +) + +define_output( + definition = plotOutput('lme_diagnosis', height = '520px'), title = 'Diagnostic Plots', width = 7, - order = 3 + order = 1e3 ) - -# hr(), -# h4('Diagnostic Plots'), -# shiny::plotOutput(ns('lmer_diagnosis')) define_output_3d_viewer( outputId = 'lme_3dviewer', message = 'Reload Viewer', title = 'Statistical results by electrode', - order = 1e4 + order = 4 ) +# 'Multiple Comparisons' = c('multiple_comparisons'), output_layout = list( 'Tabset One' = list( - 'Multiple Output' = c('lme_out'), - '3D Visualization' = c('lme_3dviewer') + 'Model Fitting Results' = c('lme_out'), + 'Graphs' = c('group_figures'), + 'Results on Surface' = c('lme_3dviewer') ) # 'Multiple Output' = 'src_data_snapshot' ) @@ -217,10 +267,6 @@ output_layout = list( # <<<<<<<<<<<< End ----------------- [DO NOT EDIT THIS LINE] ------------------- - - - - # -------------------------------- View layout --------------------------------- module_id <- 'group_analysis_lme' quos = env$parse_components(module_id) diff --git a/inst/modules/group_analysis_lme/main.R b/inst/modules/group_analysis_lme/main.R index 12d7f1e..0566f38 100644 --- a/inst/modules/group_analysis_lme/main.R +++ b/inst/modules/group_analysis_lme/main.R @@ -22,12 +22,12 @@ mount_demo_subject(force_reload_subject = T) # module_id = 'group_analysis_lme' module = ravebuiltins:::debug_module('group_analysis_lme') - -result = module(ANALYSIS_WINDOW = 0) -result$phase_histogram() -result$itpc_plot() -result$itpc_time_plot() -result$phase_plot() +# +# result = module(ANALYSIS_WINDOW = 0) +# result$phase_histogram() +# result$itpc_plot() +# result$itpc_time_plot() +# result$phase_plot() results = result$results diff --git a/inst/modules/group_analysis_lme/outputs.R b/inst/modules/group_analysis_lme/outputs.R index a6b5689..f76b18f 100644 --- a/inst/modules/group_analysis_lme/outputs.R +++ b/inst/modules/group_analysis_lme/outputs.R @@ -1,31 +1,25 @@ -src_data_snapshot <- function(){ - - if(!is.data.frame(local_data$analysis_data)){ +src_data_snapshot <- function() { + if(!is.list(local_data$analysis_data_raw)){ return(htmltools::div(style='color:#a1a1a1; text-align:center', 'Analysis data not loaded yet.')) } # show snapshot of analysis table - tbl_raw = local_data$analysis_data - vars = names(tbl_raw) - tbl = local_data$analysis_data_filtered - - dv = input$model_dependent; dv = dv[dv %in% vars] - fe = input$model_fixed_effects; fe = fe[fe %in% vars] - fr = input$model_random_effects; fr = fr[fr %in% vars] - rest = vars[!vars %in% c(dv,fe,fr)] + tbl_header = local_data$analysis_data_raw$headers + tbl_dim = dim(local_data$analysis_data_raw$data) + collapsed_data = local_data$collapsed_data - str2 = function(val, v){ + str2 = function(val){ suppressWarnings({ - if(is.character(val) || v %in% fr || is.factor(val)){ + if(is.character(val) || is.factor(val)){ val = as.factor(val) - lv = levels(val); + lv = levels(val); nlv = length(lv) if(nlv){ lv = lv[1:min(nlv, 4)] } - str = sprintf(' Factor w/ %d level%s [%s%s]', nlv, + str = sprintf(' Factor w/ %d level%s [%s%s]', nlv, ifelse(nlv>1, 's', ''), paste(lv, collapse = ', '), ifelse(nlv>4, ', ...', '')) }else if(is.numeric(val)){ - str = sprintf(' %s [range: %.4g ~ %.4g]', storage.mode(val), + str = sprintf(' %s [range: %.4g ~ %.4g]', storage.mode(val), min(val, na.rm = TRUE), max(val, na.rm = TRUE)) }else{ str = utils::capture.output(str(val)) @@ -33,85 +27,150 @@ src_data_snapshot <- function(){ str }) } - dv_tag = rest_tag = fe_tag = fr_tag = NULL - if(length(dv)){ - dv_tag = tagList( - '- Dependent -', - tags$ul( - tags$li(strong(dv), ': ', str2(tbl[[dv]], dv)) - ) - ) - } - - if(length(fe)){ - fe_tag = tagList( - '- Fixed effects -', - tags$ul( - lapply(fe, function(v){ - tags$li(strong(v), ': ', str2(tbl[[v]], v)) - }) - ) - ) - } - - if(length(fr)){ - fr_tag = tagList( - '- Random effects -', - tags$ul( - lapply(fr, function(v){ - tags$li(strong(v), ': ', str2(tbl[[v]], v)) - }) - ) - ) - } - - if(length(rest)){ - rest_tag = tagList( - '- Variables not in the model -', - tags$ul( - lapply(rest, function(v){ - tags$li(strong(v), ': ', str2(tbl[[v]], v)) - }) - ) - ) - } - - if(length(c(dv, fe, fr))){ - n_complete = sum(complete.cases(tbl[,c(dv, fe, fr)])) - }else{ - n_complete = nrow(tbl) - } tagList( tags$p( # 1. dimensions - 'Original analysis table (raw): ', strong(sprintf('%d rows x %d columns', nrow(tbl_raw), ncol(tbl_raw))), br(), + 'Original analysis table (raw): ', strong(sprintf('%d rows x %d columns', tbl_dim[1], tbl_dim[2])), br(), # 2. columns - 'Columns: ', strong(paste(vars, collapse = ', ')), br(), + 'Variables: ', strong(paste(tbl_header, collapse = ', ')), br(), hr(), # 3. filtered table 'Filtered analysis table (input data): ', strong(sprintf( - '%d rows (%d complete entries)', nrow(tbl), n_complete - )), br(), - - # 3. column types - 'Column types: ', br(), - - dv_tag, fe_tag, fr_tag, rest_tag - + '%d rows ', nrow(collapsed_data) + )), br() ) - ) - +} + +# src_data_snapshot.orig <- function(){ +# +# if(!is.data.frame(local_data$analysis_data)){ +# return(htmltools::div(style='color:#a1a1a1; text-align:center', 'Analysis data not loaded yet.')) +# } +# +# # show snapshot of analysis table +# tbl_raw = local_data$analysis_data +# vars = names(tbl_raw) +# tbl = local_data$analysis_data_filtered +# +# dv = input$model_dependent; dv = dv[dv %in% vars] +# fe = input$model_fixed_effects; fe = fe[fe %in% vars] +# fr = input$model_random_effects; fr = fr[fr %in% vars] +# rest = vars[!vars %in% c(dv,fe,fr)] +# +# str2 = function(val, v){ +# suppressWarnings({ +# if(is.character(val) || v %in% fr || is.factor(val)){ +# val = as.factor(val) +# lv = levels(val); +# nlv = length(lv) +# if(nlv){ lv = lv[1:min(nlv, 4)] } +# str = sprintf(' Factor w/ %d level%s [%s%s]', nlv, +# ifelse(nlv>1, 's', ''), +# paste(lv, collapse = ', '), ifelse(nlv>4, ', ...', '')) +# }else if(is.numeric(val)){ +# str = sprintf(' %s [range: %.4g ~ %.4g]', storage.mode(val), +# min(val, na.rm = TRUE), max(val, na.rm = TRUE)) +# }else{ +# str = utils::capture.output(str(val)) +# } +# str +# }) +# } +# dv_tag = rest_tag = fe_tag = fr_tag = NULL +# if(length(dv)){ +# dv_tag = tagList( +# '- Dependent -', +# tags$ul( +# tags$li(strong(dv), ': ', str2(tbl[[dv]], dv)) +# ) +# ) +# } +# +# if(length(fe)){ +# fe_tag = tagList( +# '- Fixed effects -', +# tags$ul( +# lapply(fe, function(v){ +# tags$li(strong(v), ': ', str2(tbl[[v]], v)) +# }) +# ) +# ) +# } +# +# if(length(fr)){ +# fr_tag = tagList( +# '- Random effects -', +# tags$ul( +# lapply(fr, function(v){ +# tags$li(strong(v), ': ', str2(tbl[[v]], v)) +# }) +# ) +# ) +# } +# +# if(length(rest)){ +# rest_tag = tagList( +# '- Variables not in the model -', +# tags$ul( +# lapply(rest, function(v){ +# tags$li(strong(v), ': ', str2(tbl[[v]], v)) +# }) +# ) +# ) +# } +# +# if(length(c(dv, fe, fr))){ +# n_complete = sum(complete.cases(tbl[,c(dv, fe, fr)])) +# }else{ +# n_complete = nrow(tbl) +# } +# +# +# tagList( +# tags$p( +# # 1. dimensions +# 'Original analysis table (raw): ', strong(sprintf('%d rows x %d columns', nrow(tbl_raw), ncol(tbl_raw))), br(), +# +# # 2. columns +# 'Columns: ', strong(paste(vars, collapse = ', ')), br(), +# +# hr(), +# +# # 3. filtered table +# 'Filtered analysis table (input data): ', strong(sprintf( +# '%d rows (%d complete entries)', nrow(tbl), n_complete +# )), br(), +# +# # 3. column types +# 'Column types: ', br(), +# +# dv_tag, fe_tag, fr_tag, rest_tag +# +# ) +# +# ) +# +# } + +group_figures <- function() { + lmer_results = local_data$lmer_results + shiny::validate(shiny::need(!is.null(lmer_results), message = 'No model calculated')) + plot(1:20) } lmer_diagnosis = function(){ lmer_results = local_data$lmer_results shiny::validate(shiny::need(!is.null(lmer_results), message = 'No model calculated')) + + plot_clean(1:10, 1:20) + pointr(rnorm(10, mean = 10)) + return() resid = stats::residuals(lmer_results, type = 'pearson', scaled = TRUE) fitt = fitted(lmer_results) hat_val = hatvalues(lmer_results) @@ -157,7 +216,6 @@ lmer_diagnosis = function(){ # 4. Boxplot of residuals vs Electrodes } - # 3D viewer, takes 3 args lme_3dviewer_fun <- function(need_calc, side_width, daemon_env, ...){ # Check whether load is needed @@ -167,8 +225,8 @@ lme_3dviewer_fun <- function(need_calc, side_width, daemon_env, ...){ tbl = shiny::isolate(local_data$analysis_data_filtered) - assign('lmer_results', lmer_results, envir = globalenv()) - assign('tbl', tbl, envir = globalenv()) + # assign('lmer_results', lmer_results, envir = globalenv()) + # assign('tbl', tbl, envir = globalenv()) # Get Random effect # randef = lme4::ranef(lmer_results) diff --git a/inst/modules/group_analysis_lme/reactives.R b/inst/modules/group_analysis_lme/reactives.R index 528dbb9..1f7d915 100644 --- a/inst/modules/group_analysis_lme/reactives.R +++ b/inst/modules/group_analysis_lme/reactives.R @@ -4,24 +4,26 @@ session = getDefaultReactiveDomain() local_data %?<-% reactiveValues( # Full data has two parts: local_data$analysis_data_raw, and local_data$additional_data - # togeither makes analysis_data + # together makes analysis_data analysis_data_raw = NULL, additional_data = NULL, analysis_data = NULL, + collapsed_data = NULL, potential_analysis = list(), analysis_name = NULL, sample_table = NULL, var_dependent = NULL, var_fixed_effects = NULL, - lmer_results = NULL + lmer_results = NULL, + lmer_results_summary = NULL + ) local_filters = reactiveValues( filter_count = 0, filter_observers = 0 ) - cond_group_ui = function(){ rave::compoundInput( inputId = ns('cond_group'), prefix= 'Condition Group', inital_ncomp = 1, components = { @@ -32,55 +34,73 @@ cond_group_ui = function(){ # Sync all group_names -lapply(1:0, function(ii){ - name_id = paste0('cond_group_group_name_', ii) - .env = environment() - observeEvent(input[[name_id]], { - val = val_raw = input[[name_id]] - if(length(val)){ - if( stringr::str_detect(val, '^CondGroup[0-9]*') || - val %in% names(local_data$analysis_data_raw) ){ - # Invalid group name, reset to default - val = sprintf('CondGroup%d', ii) - } - if( val != val_raw ){ - updateTextInput(session, name_id, value = val) - } - } - }, event.env = .env, handler.env = .env) -}) +# lapply(1:0, function(ii){ +# name_id = paste0('cond_group_group_name_', ii) +# .env = environment() +# observeEvent(input[[name_id]], { +# val = val_raw = input[[name_id]] +# if(length(val)){ +# if( stringr::str_detect(val, '^CondGroup[0-9]*') || +# val %in% names(local_data$analysis_data_raw$headers) ){ +# # Invalid group name, reset to default +# val = sprintf('CondGroup%d', ii) +# } +# if( val != val_raw ){ +# updateTextInput(session, name_id, value = val) +# } +# } +# }, event.env = .env, handler.env = .env) +# }) observe({ raw = local_data$analysis_data_raw - conditions = NULL - if( is.data.frame(raw) ){ - conditions = unique(raw$Condition) + + if( !is.list(raw) ){ + local_data$analysis_data_filtered = NULL + return() } - if(!length(conditions)){ conditions = '' } + local_data$analysis_data_filtered = raw$data + conditions = unique(raw$data$Condition); if(!length(conditions)){ conditions = '' } + time_range = range(raw$data$Time, na.rm = TRUE) + analysis_window = time_range + confs = rave::dropNulls(raw$confs) + groups = list() + if(length(confs)){ + confs = confs[[1]] + groups = confs$GROUPS + analysis_window = sort(c(confs$ANALYSIS_WINDOW, time_range)[1:2]) + } + + rave::updateCompoundInput(session, 'cond_group', to = length(groups)) # Update cond_group lapply(seq_len(20), function(ii){ - cond_groups = lapply(1:20, function(jj){ - shiny::isolate(input[[paste0('cond_group_group_conditions_', jj)]]) - }) - selected = character(0) - if( length(cond_groups) >= ii ){ - selected = unlist(cond_groups[[ii]]) - if( !length(selected) ){ selected = character(0) } + g = list(group_name = '', group_conditions = character(0)) + if( length(groups) >= ii ){ + g = groups[[ii]] } updateSelectInput(session, inputId = sprintf('%s_%d', 'cond_group_group_conditions', ii), - choices = conditions, selected = selected) + choices = conditions, selected = g$group_conditions) + updateTextInput(session, inputId = sprintf('%s_%d', 'cond_group_group_name', ii), + value = g$group_name) }) + + updateSliderInput(session, 'analysis_window', min = time_range[[1]], + max=time_range[[2]], value=analysis_window) }) + + # Get additional data observe({ cond_groups = lapply(1:20, function(jj){input[[paste0('cond_group_group_conditions_', jj)]]}) cond_groups = rave::dropNulls(cond_groups) conditions = NULL - if( is.data.frame(local_data$analysis_data_raw) ){ - conditions = local_data$analysis_data_raw$Condition + + if( is.list(local_data$analysis_data_raw) ){ + conditions = local_data$analysis_data_raw$data$Condition } + if(length(cond_groups) && length(conditions)){ cols = lapply(cond_groups, function(conds){ @@ -96,36 +116,35 @@ observe({ }) -# Combine raw and additional_data -observe({ - raw = local_data$analysis_data_raw - add = local_data$additional_data - if( is.data.frame(raw) ){ - if(is.data.frame(add)){ - raw = cbind(raw, add) - } - local_data$analysis_data = raw - }else{ - local_data$analysis_data = NULL - } - -}) +# Combine raw and additional_data, update analysis window range +# observe({ +# raw = local_data$analysis_data_raw +# # add = local_data$additional_data +# if( is.list(raw) ){ +# # if(is.data.frame(add)){ +# # raw = cbind(raw$data, add) +# # } +# local_data$analysis_data_filtered = raw$data +# time_range = range(raw$data$Time, na.rm = TRUE) +# updateSliderInput(session, 'analysis_window', min = time_range[[1]], max=time_range[[2]], +# value=cache_input('analysis_window', time_range)) +# }else{ +# local_data$analysis_data_filtered = NULL +# } +# +# }) # build Model -observe({ - if(!is.data.frame(local_data$analysis_data)){ - local_data$table_headers = NULL - local_data$sample_table = NULL - }else{ - local_data$sample_table = head(local_data$analysis_data) - local_data$table_headers = names(local_data$analysis_data) - } -}) - - - - +# observe({ +# if(!is.data.frame(local_data$analysis_data)){ +# local_data$table_headers = NULL +# local_data$sample_table = NULL +# }else{ +# local_data$sample_table = head(local_data$analysis_data) +# local_data$table_headers = names(local_data$analysis_data) +# } +# }) get_table_headers = function(){ @@ -138,23 +157,23 @@ get_table_headers = function(){ vars } -observe({ - vars = get_table_headers() - dep = 'Power' - if(!dep %in% vars){ - tmp = vars[!vars %in% c('Time', 'splines::bs(Time)')] - if(length(tmp)){ - dep = tmp[[1]] - }else{ - dep = vars[[1]] - } - } - - vars2 = vars[!vars %in% dep]; if(length(vars2) == ''){vars2 = ''} - updateSelectInput(session, 'model_fixed_effects', choices = vars2, selected = shiny::isolate(local_data$fixed)) - updateSelectInput(session, 'model_random_effects', choices = vars2, selected = shiny::isolate(local_data$rand)) - updateSelectInput(session, 'model_dependent', choices = vars, selected = dep) -}) +# observe({ +# vars = get_table_headers() +# dep = 'Power' +# if(!dep %in% vars){ +# tmp = vars[!vars %in% c('Time', 'splines::bs(Time)')] +# if(length(tmp)){ +# dep = tmp[[1]] +# }else{ +# dep = vars[[1]] +# } +# } +# +# vars2 = vars[!vars %in% dep]; if(length(vars2) == ''){vars2 = ''} +# updateSelectInput(session, 'model_fixed_effects', choices = vars2, selected = shiny::isolate(local_data$fixed)) +# updateSelectInput(session, 'model_random_effects', choices = vars2, selected = shiny::isolate(local_data$rand)) +# updateSelectInput(session, 'model_dependent', choices = vars, selected = dep) +# }) collect_model = function(..., exclude = NULL){ re = list() @@ -173,82 +192,120 @@ collect_model = function(..., exclude = NULL){ re } -rave::sync_shiny_inputs( - input = input, session = session, inputIds = c('model_dependent', 'model_fixed_effects', 'model_random_effects'), - uniform = list( - function(var_y){ - vars = get_table_headers() - vars = vars[!vars %in% c('Project', var_y)] - if(!length(vars)){ vars = '' } - updateSelectInput(session, 'model_fixed_effects', choices = vars) - updateSelectInput(session, 'model_random_effects', choices = vars) - collect_model(dependent = var_y, exclude = var_y) - }, - function(fixed_x){ collect_model(fixed = fixed_x, exclude = fixed_x) }, - function(rand_x){ collect_model(random = rand_x, exclude = rand_x) } - ), updates = list( - function(val){ updateSelectInput(session, 'model_dependent', selected = val$dependent) }, - function(val){ updateSelectInput(session, 'model_fixed_effects', selected = val$fixed) }, - function(val){ updateSelectInput(session, 'model_random_effects', selected = val$random) } - ) -) +# rave::sync_shiny_inputs( +# input = input, session = session, inputIds = c('model_dependent', 'model_fixed_effects', 'model_random_effects'), +# uniform = list( +# function(var_y){ +# vars = get_table_headers() +# vars = vars[!vars %in% c('Project', var_y)] +# if(!length(vars)){ vars = '' } +# updateSelectInput(session, 'model_fixed_effects', choices = vars) +# updateSelectInput(session, 'model_random_effects', choices = vars) +# collect_model(dependent = var_y, exclude = var_y) +# }, +# function(fixed_x){ collect_model(fixed = fixed_x, exclude = fixed_x) }, +# function(rand_x){ collect_model(random = rand_x, exclude = rand_x) } +# ), updates = list( +# function(val){ updateSelectInput(session, 'model_dependent', selected = val$dependent) }, +# function(val){ updateSelectInput(session, 'model_fixed_effects', selected = val$fixed) }, +# function(val){ updateSelectInput(session, 'model_random_effects', selected = val$random) } +# ) +# ) # Formula -observe({ - # build formular - fo = get_formula(input$model_dependent, input$model_fixed_effects, input$model_random_effects, isTRUE(input$model_embedsubject)) - local_data$fixed = input$model_fixed_effects - local_data$rand = input$model_random_effects - updateTextInput(session, 'model_formula', value = fo) -}) +# observe({ +# # build formula +# fo = get_formula(input$model_dependent, input$model_fixed_effects, input$model_random_effects, isTRUE(input$model_embedsubject)) +# local_data$fixed = input$model_fixed_effects +# local_data$rand = input$model_random_effects +# updateTextInput(session, 'model_formula', value = fo) +# }) -get_formula = function(dv, fe, fr, embed_subject = TRUE){ - if(!is.data.frame(local_data$analysis_data)){ - return('') - } - if(length(fe)){ - fe = paste(fe, collapse = '+') - }else{ - fe = '1' +# get_formula = function(dv, fe, fr, embed_subject = TRUE){ +# if(!is.data.frame(local_data$analysis_data)){ +# return('') +# } +# if(length(fe)){ +# fe = paste(fe, collapse = '+') +# }else{ +# fe = '1' +# } +# fr_valid = sapply(fr, function(v){ +# v = unique(local_data$analysis_data[[v]]) +# v = v[!is.na(v)] +# length(v) > 1 +# }) +# fr = fr[fr_valid] +# +# fr_template = '(1|%s)' +# if(all(c('Subject', 'Electrode') %in% fr) && embed_subject){ +# fr_add = '(1|Subject/Electrode)' +# fr = fr[!fr %in% c('Subject', 'Electrode')] +# fr = paste(c(fr_add, sprintf(fr_template, fr)), collapse = '+') +# }else{ +# fr = paste(sprintf(fr_template, fr), collapse = '+') +# } +# if(fr != ''){ +# fr = paste(' +', fr) +# } +# +# fo = sprintf('%s ~ %s%s', dv,fe,fr) +# fo +# } + +observeEvent(input$run_analysis, { + cond_group <- rave::dropNulls(lapply(input$cond_group, function(g){ + if(length(g$group_conditions) == 0) return( NULL ) + return(g) + })) + if(!length(cond_group)) { + showNotification(p('Must specify at least 1 Group to run analysis'), + duration=5, type='warning', id=ns('noti')) + + return() } - fr_valid = sapply(fr, function(v){ - v = unique(local_data$analysis_data[[v]]) - v = v[!is.na(v)] - length(v) > 1 - }) - fr = fr[fr_valid] + # first we need to collapse the data + # print(str(local_data$analysis_data_filtered)) - fr_template = '(1|%s)' - if(all(c('Subject', 'Electrode') %in% fr) && embed_subject){ - fr_add = '(1|Subject/Electrode)' - fr = fr[!fr %in% c('Subject', 'Electrode')] - fr = paste(c(fr_add, sprintf(fr_template, fr)), collapse = '+') - }else{ - fr = paste(sprintf(fr_template, fr), collapse = '+') - } - if(fr != ''){ - fr = paste(' +', fr) + # assign('ldf', value = local_data$analysis_data_filtered, envir = globalenv()) + all_trial_types <- cond_group %>% lapply(`[[`, 'group_conditions') %>% unlist %>% unique + + # create a joint variable representing the Group as a factor + + ldf <- local_data$analysis_data_filtered + subset_data <- subset(ldf, subset = Time %within% analysis_window & Condition %in% all_trial_types) + + subset_data$Group = cond_group[[1]]$group_name + for(ii in seq_along(cond_group)[-1]) { + subset_data$Group[subset_data$Condition %in% cond_group[[ii]]$group_conditions] = cond_group[[ii]]$group_name } + subset_data$Group %<>% factor(levels = sapply(cond_group, `[[`, 'group_name')) + + collapsed_data <- do_aggregate(Power ~ Group + Electrode + Subject, data=subset_data, FUN=mean) + local_data$collapsed_data = collapsed_data - fo = sprintf('%s ~ %s%s', dv,fe,fr) - fo -} - -observeEvent(input$run_analysis, { showNotification(p('Fitting mixed effect model. Please wait...'), duration = NULL, type = 'default', id = ns('noti')) - fo = input$model_formula - fo = as.formula(fo) + + # fo = input$model_formula + fo = as.formula('Power ~ Group + (1|Subject:Electrode)') tryCatch({ - local_data$lmer_results = lmerTest::lmer(fo, data=local_data$analysis_data_filtered, na.action=na.omit) - removeNotification(id = ns('noti')) + lmer_results = lmerTest::lmer(fo, data=collapsed_data, na.action=na.omit) + assign('..lmer_results', value = lmer_results, envir = globalenv()) + local_data$lmer_results_summary <- summary(lmer_results) + local_data$lmer_results = lmer_results + showNotification(p('Model finished!'), duration = 3, type = 'default', id = ns('noti')) }, error = function(e){ + print(e) + if(is.list(e)){ + msg = e$message; msg %?<-% '' + cal = e$call; cal %?<-% '' + e = sprintf('%s in %s', msg, cal) + } # grouping factors must have > 1 sampled level showNotification(p(e), duration = 20, type = 'error', id = ns('noti')) local_data$lmer_results = NULL }) - - }) #### File upload to MLE source #### diff --git a/inst/modules/power_explorer/comp.R b/inst/modules/power_explorer/comp.R index cdc82b9..41d34e1 100644 --- a/inst/modules/power_explorer/comp.R +++ b/inst/modules/power_explorer/comp.R @@ -18,6 +18,9 @@ load_scripts( asis = TRUE ) +# split up the UI into multiple files to make it easier to manage +# source(..., local=TRUE) + define_initialization({ ## ## Make sure power (referenced) exists @@ -98,10 +101,17 @@ define_input( ) +define_input_condition_groups(inputId = 'GROUPS') + define_input_frequency(inputId = 'FREQUENCY', initial_value = c(70,150)) define_input_time(inputId = 'ANALYSIS_WINDOW', label='Analysis', initial_value = c(0,1)) define_input_time(inputId = 'BASELINE_WINDOW', label='Baseline', initial_value = c(-1,0)) -define_input_condition_groups(inputId = 'GROUPS') + + + + +# define_input_analysis_file_chooser('analysis_settings', read_source = c('Analysis Settings' = 'analysis_yamls')) + define_input( definition = selectInput('combine_method', 'Electrode Transforms', @@ -182,7 +192,7 @@ define_input( label = HTML('
Export filename (no spaces)')), init_args = 'value', init_expr = { - value = cache_input('analysis_prefix', sprintf('%s_pow_by_cond', subject$subject_code)) + value = sprintf('%s_pow_by_cond', subject$subject_code) }) define_input( definition = checkboxInput('analysis_mask_export',value = FALSE, @@ -217,7 +227,7 @@ define_input( , init_args = c('choices', 'selected'), init_expr = { choices = c('none', names(electrodes_csv)) - selected = ifelse('Hemisphere' %in% names(electrodes_csv), 'Hemisphere', 'none') + selected = 'none' } ) @@ -381,6 +391,7 @@ define_input( # determine which variables only need to be set, not triggering rendering nor executing manual_inputs <- c( 'graph_export', 'filter_3d_viewer', 'trial_type_filter', 'synch_with_trial_selector', 'download_electrodes_csv', + 'btn_save_analysis_settings', 'btn_load_analysis_settings', 'export_what', 'analysis_prefix', 'analysis_mask_export', 'export_data', 'current_active_set', 'export_also_download', 'export_time_window' ) @@ -400,14 +411,9 @@ input_layout = list( ), #[#99ccff] 'Compare trial types' = list( - 'GROUPS' + 'GROUPS', + 'analysis_settings' ), - # 'Set analysis options' = list( - # 'FREQUENCY', - # 'BASELINE_WINDOW', - # 'ANALYSIS_WINDOW', - # 'do_calculate_btn', 'auto_calculate' - # ), '[-]Set plot options' = list( 'plot_time_range', c('PLOT_TITLE'), diff --git a/inst/modules/power_explorer/event_handlers.R b/inst/modules/power_explorer/event_handlers.R index 3c8f58c..1c2f17c 100644 --- a/inst/modules/power_explorer/event_handlers.R +++ b/inst/modules/power_explorer/event_handlers.R @@ -11,6 +11,59 @@ local_data = reactiveValues( calculate_flag = 0 ) + +# observeEvent(input$btn_save_analysis_settings, { +# tstmp <- strftime(Sys.time(), format = '%Y-%h-%d') +# +# shiny::showModal(shiny::modalDialog( +# title = 'Save Analysis Settings', +# size = 's', +# easyClose = TRUE, +# textInput(ns('modal_analysis_settings_name'), label = 'Settings Name', value = paste0('power_explorer_settings_', tstmp)), +# tags$small('Will overwrite settings with the same name currently in RAVE settings folder'), +# footer = tagList( +# rave::actionButtonStyled(ns('btn_do_save_analysis'), 'Save'), +# shiny::modalButton("Cancel") +# ) +# )) +# }) + + +# observeEvent(input$btn_do_save_analysis, { +# # save +# fname = input$modal_analysis_settings_name +# fname = stringr::str_replace_all(fname, '[^a-zA-Z0-9]+', '_') +# fname = paste0(fname, '.yaml') +# save_dir = file.path(subject$dirs$subject_dir, '..', '_project_data', 'analysis_yamls') +# dir.create(save_dir, recursive = TRUE, showWarnings = FALSE) +# save_inputs(file.path(save_dir, fname)) +# shiny::removeModal() +# }) +observeEvent(input$analysis_settings_load, { + fdata = input$analysis_settings_load + if(!is.list(fdata) || !length(fdata$files)){ return() } + assign('fdata', fdata, envir = globalenv()) + f_name = unlist(fdata$files); names(f_name) = NULL + + read_source = c('Analysis Settings' = 'analysis_yamls') + + f_name = c(subject$dirs$subject_dir, '..', '_project_data', read_source[[fdata$root]], f_name) + f_path = do.call(file.path, as.list(f_name)) + print(f_path) + conf = yaml::read_yaml(f_path) + print(conf) + + updateCheckboxInput(session, inputId = 'auto_calculate', value = FALSE) + lapply(1:10, function(ii){ + gc_id = sprintf('GROUPS_group_conditions_%d', ii) + gc = conf[[gc_id]] + if(!length(gc)){ gc = character(0) } + print(paste(ii, c(gc))) + updateSelectInput(session, gc_id, selected = gc) + }) +}) + + observeEvent(input$power_3d_widget_mouse_dblclicked, { # mouse_event = input$power_3d__mouse_dblclicked$event # object = input$power_3d__mouse_dblclicked$object diff --git a/inst/modules/power_explorer/exports.R b/inst/modules/power_explorer/exports.R index df48a75..5d93ad5 100644 --- a/inst/modules/power_explorer/exports.R +++ b/inst/modules/power_explorer/exports.R @@ -337,11 +337,29 @@ output$export_data_and_download <- downloadHandler( file.copy(res_path, to=con) } ) + observeEvent(input$export_data_only, { export_data_function() showNotification(p('Done saving'), duration = 3, type = 'message') }) +save_inputs <- function(yaml_path, variables_to_export){ + if( !shiny_is_running() || !exists('getDefaultReactiveInput') ){ return(FALSE) } + + input <- getDefaultReactiveInput() + cache_list = shiny::isolate(shiny::reactiveValuesToList(input)) + if(!missing(variables_to_export)) { + cache_list =cache_list[variables_to_export] + } + # if( exists('local_data') && shiny::is.reactivevalues(local_data) ){ + # local_dat = shiny::isolate(shiny::reactiveValuesToList(local_data)) + # cl = names(cache_list); cl = cl[cl %in% names(local_dat)] + # cache_list[cl] = local_dat[cl] + # } + yaml::write_yaml(x = cache_list, fileEncoding = 'utf-8', file = yaml_path) + return(TRUE) +} + # export data for group analysis export_data_function <- function(){ @@ -441,28 +459,34 @@ export_data_function <- function(){ now = strftime(Sys.time(), '-%Y%m%d-%H%M%S') fname = paste0(analysis_prefix, now, '.csv') - dirname = file.path(subject$dirs$subject_dir, '..', '_project_data', 'power_explorer') + dirname = file.path(subject$dirs$subject_dir, '..', '_project_data', 'power_explorer', 'exports') dir.create(dirname, showWarnings = FALSE, recursive = TRUE) data.table::fwrite(res, file.path(dirname, fname), append = FALSE) - # Collapse time - res_collapse_time = lapply(split(res, paste(res$Trial, res$Electrode)), function(x){ - data.frame(stringsAsFactors = FALSE, - Trial = x$Trial[1], Power = mean( x$Power ), Condition = x$Condition[1], - Electrode = x$Electrode[1], Project = x$Project[1], Subject = x$Subject[1]) - }) - res_collapse_time = do.call('rbind', res_collapse_time) - data.table::fwrite(res_collapse_time, file.path(dirname, paste0(analysis_prefix, '-collapse_time-', now, '.csv')), append = FALSE) - - # Collapse Trial - res_collapse_trial = lapply(split(res, paste0(res$Condition, res$Electrode, res$Time)), function(x){ - data.frame(stringsAsFactors = FALSE, - Power = mean( x$Power ), Condition = x$Condition[1], Time = x$Time[1], - Electrode = x$Electrode[1], Project = x$Project[1], Subject = x$Subject[1]) - }) - res_collapse_trial = do.call('rbind', res_collapse_trial) - data.table::fwrite(res_collapse_trial, file.path(dirname, paste0(analysis_prefix, '-collapse_trial-', now, '.csv')), append = FALSE) + + + save_inputs(file.path(dirname, paste0(fname, '.yaml'))) + + + # # Collapse time + # res_collapse_time = lapply(split(res, paste(res$Trial, res$Electrode)), function(x){ + # data.frame(stringsAsFactors = FALSE, + # Trial = x$Trial[1], Power = mean( x$Power ), Condition = x$Condition[1], + # Electrode = x$Electrode[1], Project = x$Project[1], Subject = x$Subject[1]) + # }) + # res_collapse_time = do.call('rbind', res_collapse_time) + # data.table::fwrite(res_collapse_time, file.path(dirname, paste0(analysis_prefix, '-collapse_time-', now, '.csv')), append = FALSE) + # + # # Collapse Trial + # res_collapse_trial = lapply(split(res, paste0(res$Condition, res$Electrode, res$Time)), function(x){ + # data.frame(stringsAsFactors = FALSE, + # Power = mean( x$Power ), Condition = x$Condition[1], Time = x$Time[1], + # Electrode = x$Electrode[1], Project = x$Project[1], Subject = x$Subject[1]) + # }) + # res_collapse_trial = do.call('rbind', res_collapse_trial) + # data.table::fwrite(res_collapse_trial, file.path(dirname, paste0(analysis_prefix, '-collapse_trial-', now, '.csv')), append = FALSE) + # return(normalizePath(file.path(dirname, fname))) } diff --git a/inst/modules/power_explorer/main.R b/inst/modules/power_explorer/main.R index 214a56a..7df312e 100644 --- a/inst/modules/power_explorer/main.R +++ b/inst/modules/power_explorer/main.R @@ -365,6 +365,9 @@ ravebuiltins:::dev_ravebuiltins(T) mount_demo_subject(force_reload_subject = T) module = ravebuiltins:::debug_module('power_explorer') + +eval_when_ready %?<-% function(FUN, ...) {FUN(...)} + result = module(ELECTRODE_TEXT = '14', GROUPS = list(list(group_name='A', group_conditions=c('known_a', 'last_a', 'drive_a', 'meant_a')), # putting in an empty group to test our coping mechanisms diff --git a/inst/tools/input_widgets.R b/inst/tools/input_widgets.R index 6cbdbc0..ce61bea 100644 --- a/inst/tools/input_widgets.R +++ b/inst/tools/input_widgets.R @@ -406,7 +406,7 @@ define_input_condition_groups2 <- function( define_input_analysis_data_csv <- function( inputId, label, paths, reactive_target = sprintf('local_data[[%s]]', inputId), - multiple = TRUE, label_uploader = 'Upload'){ + multiple = TRUE, label_uploader = '...', try_load_yaml = TRUE, allow_uploader = FALSE){ input_ui = inputId input_selector = paste0(inputId, '_source_files') @@ -431,22 +431,27 @@ define_input_analysis_data_csv <- function( od = order(strptime(dt, '%Y%m%d-%H%M%S'), decreasing = TRUE) choices = choices[od] + uploader_tag = NULL + if(!!allow_uploader){ + uploader_tag = htmltools::div( + style = 'flex-basis: 50%; min-height: 80px;', + htmltools::tags$label("Upload new files to this project's RAVE directory"), + fileInput(inputId = ns(!!input_uploader), label = !!label_uploader, multiple = FALSE, width = '100%') + ) + } + # function to render UI htmltools::div( class = 'rave-grid-inputs', htmltools::div( - style = 'flex-basis: 75%; min-height: 80px;', + style = 'flex-basis: 100%; min-height: 80px;', selectInput(inputId = ns(!!input_selector), label = !!label, choices = choices, selected = character(0), multiple = !!multiple) ), - htmltools::div( - style = 'flex-basis: 25%; min-height: 80px;', - htmltools::tags$label('Additional'), - fileInputMinimal(inputId = ns(!!input_uploader), label = !!label_uploader, multiple = FALSE, width = '100%', type = 'default') - ), htmltools::div( style = 'flex-basis: 100%', actionButtonStyled(inputId = ns(!!input_btn), label = 'Load analysis data', width = '100%', type = 'primary') - ) + ), + uploader_tag ) }) ...ravemodule_environment_reserved[[!!input_ui]][[!!input_evt]] = function(){ @@ -547,7 +552,7 @@ define_input_analysis_data_csv <- function( # Read all data project_name = subject$project_name - res = rave::dropNulls(lapply(metas, function(x){ + tbls = rave::dropNulls(lapply(metas, function(x){ progress$inc('Loading...') tbl = data.table::fread(file = x$fpath, stringsAsFactors = FALSE, header = TRUE) tbl = tbl[tbl$Project %in% project_name, ] @@ -558,9 +563,26 @@ define_input_analysis_data_csv <- function( for(m in mish){ tbl[[m]] = NA } - return( tbl ) + + # Load YAML files + conf = NULL + if( !!try_load_yaml ){ + yaml_path = paste0(x$fpath, '.yaml') + if(file.exists(yaml_path)){ + conf = yaml::read_yaml(yaml_path) + } + } + + return(list( + data = tbl, + conf = conf, + path = x$fpath, + subject = tbl$Subject[[1]] + )) })) - res = do.call('rbind', res) + + res = do.call('rbind', lapply(tbls, '[[', 'data')) + if(!is.data.frame(res) || !nrow(res)){ res = NULL }else{ @@ -569,12 +591,25 @@ define_input_analysis_data_csv <- function( res$Subject = as.character(res$Subject) res$Condition = as.character(res$Condition) }, silent = TRUE) + + subjects = sapply(tbls, '[[', 'subject') + confs = lapply(tbls, '[[', 'conf') + names(confs) = subjects + + res = list( + data = res, + subjects = subjects, + confs = confs, + headers = names(res) + ) + } if(is.character(!!reactive_target)){ eval(parse(text = sprintf('%s <- res', !!reactive_target))) }else{ do.call('<-', list(!!reactive_target, res)) } + }, event.env = .env, handler.env = .env) } @@ -895,3 +930,115 @@ define_input_table_filters <- function( parent_frame = parent.frame() rave::eval_dirty(quo, env = parent_frame) } + + + + +# options to save and load analysis parameters +# define_input_analysis_file_chooser <- function( +# inputId, labels = c('Save settings', 'Load settings'), +# name_prefix = 'power_explorer_settings_', +# read_source = c('Analysis Settings' = 'analysis_yamls'), +# write_source = 'settings', +# default_path = '' +# ){ +# save_btn = paste0(inputId, '_save') +# load_btn = paste0(inputId, '_load') +# save_text = paste0(inputId, '_savename') +# do_save = paste0(inputId, '_do_save') +# quo = rlang::quo({ +# define_input(customizedUI(inputId = !!inputId)) +# load_scripts(rlang::quo({ +# assign(!!inputId, function(){ +# +# read_source = c('/' = '/') +# +# load_btn = as.character(!!load_btn) +# fp = names(!!read_source) +# shinyFiles::shinyFileChoose( +# input = input, +# id = load_btn, roots= c('/' = '/'), +# filetypes = c('yaml', 'yml'), defaultRoot = '/', +# defaultPath = !!default_path +# ) +# +# div( +# class = 'rave-grid-inputs', style='border:none', +# div( +# style = 'flex-basis:50%', +# rave::actionButtonStyled(inputId = ns(!!save_btn), +# label=!!labels[[1]], icon = shiny::icon('save'), width = '100%') +# ), +# div( +# style = 'flex-basis:50%', +# shinyFiles::shinyFilesButton(id = ns(load_btn), label = !!labels[[2]], title = 'Select Analysis Settings', +# multiple = FALSE, icon = shiny::icon('puzzle-piece'), style = 'width:100%') +# ) +# ) +# }) +# +# # redirect shiny server file chooser home directory +# eval_when_ready(function(.env, ...){ +# +# with(.env, { +# input %?<-% getDefaultReactiveInput() +# shiny_is_running <- function() { +# cls <- class(getDefaultReactiveDomain()) +# any(cls %in% c('ShinySession', 'session_proxy')) +# } +# save_inputs <- function(yaml_path, variables_to_export){ +# if( !shiny_is_running() || !exists('getDefaultReactiveInput') ){ return(FALSE) } +# +# input <- getDefaultReactiveInput() +# cache_list = shiny::isolate(shiny::reactiveValuesToList(input)) +# if(!missing(variables_to_export)) { +# cache_list =cache_list[variables_to_export] +# } +# # if( exists('local_data') && shiny::is.reactivevalues(local_data) ){ +# # local_dat = shiny::isolate(shiny::reactiveValuesToList(local_data)) +# # cl = names(cache_list); cl = cl[cl %in% names(local_dat)] +# # cache_list[cl] = local_dat[cl] +# # } +# yaml::write_yaml(x = cache_list, fileEncoding = 'utf-8', file = yaml_path) +# return(TRUE) +# } +# +# # save Modal pop up +# observeEvent(input[[!!save_btn]], { +# tstmp <- strftime(Sys.time(), format = '%Y-%h-%d') +# +# shiny::showModal(shiny::modalDialog( +# title = 'Save Analysis Settings', +# size = 's', +# easyClose = TRUE, +# textInput(ns(!!save_text), label = 'Settings Name', value = paste0(!!name_prefix, tstmp)), +# tags$small('Will overwrite settings with the same name currently in RAVE settings folder'), +# footer = tagList( +# rave::actionButtonStyled(ns(!!do_save), 'Save'), +# shiny::modalButton("Cancel") +# ) +# )) +# }) +# +# # Modal do save +# observeEvent(input[[!!do_save]], { +# # save +# fname = input[[!!save_text]] +# fname = stringr::str_replace_all(fname, '[^a-zA-Z0-9]+', '_') +# fname = paste0(fname, '.yaml') +# save_dir = file.path(subject$dirs$subject_dir, '..', '_project_data', !!write_source) +# dir.create(save_dir, recursive = TRUE, showWarnings = FALSE) +# save_inputs(file.path(save_dir, fname)) +# shiny::removeModal() +# }) +# +# }) +# +# }) +# })) +# +# }) +# +# parent_env = parent.frame() +# rave::eval_dirty(quo, env = parent_env) +# } diff --git a/inst/tools/viewers.R b/inst/tools/viewers.R index c0c9795..88cde5b 100644 --- a/inst/tools/viewers.R +++ b/inst/tools/viewers.R @@ -76,11 +76,11 @@ to_module <- function(module_id, sidebar_width = 3){ m } -view_layout <- function(module_id, sidebar_width = 5, launch.browser = rstudio_viewer){ +view_layout <- function(module_id, sidebar_width = 5, launch.browser = rstudio_viewer, ...){ # Always reload the package to the newest status and preview env = reload_this_package() m = env$to_module(module_id = module_id, sidebar_width = sidebar_width) - rave::init_app(m, launch.browser = launch.browser, disable_sidebar = T, simplify_header = T) + rave::init_app(m, launch.browser = launch.browser, disable_sidebar = T, simplify_header = T, ...) } From 61f3dc6586dcf95219edbbf507a89059e2b2f65e Mon Sep 17 00:00:00 2001 From: dipterix Date: Fri, 18 Oct 2019 03:04:53 -0500 Subject: [PATCH 21/24] added yaml selector for settings --- inst/modules/group_analysis_lme/outputs.R | 28 ++- inst/modules/power_explorer/comp.R | 7 +- inst/tools/input_widgets.R | 213 +++++++++++----------- 3 files changed, 134 insertions(+), 114 deletions(-) diff --git a/inst/modules/group_analysis_lme/outputs.R b/inst/modules/group_analysis_lme/outputs.R index f76b18f..2b99182 100644 --- a/inst/modules/group_analysis_lme/outputs.R +++ b/inst/modules/group_analysis_lme/outputs.R @@ -221,6 +221,8 @@ lme_3dviewer_fun <- function(need_calc, side_width, daemon_env, ...){ # Check whether load is needed lmer_results = local_data$lmer_results + # assign('lmer_results', lmer_results, envir = globalenv()) + shiny::validate(shiny::need(!is.null(lmer_results), message = 'Please run LMER model first')) tbl = shiny::isolate(local_data$analysis_data_filtered) @@ -239,9 +241,9 @@ lme_3dviewer_fun <- function(need_calc, side_width, daemon_env, ...){ val_ranges = list() if('Electrode:Subject' %in% names(coef)){ dat = data.matrix(coef$`Electrode:Subject`) - if('(Intercept)' %in% names(coef$`Electrode:Subject`)[[1]]){ - dat[, -1] = dat[, -1] + dat[, 1] - } + # if('(Intercept)' %in% names(coef$`Electrode:Subject`)[[1]]){ + # dat[, -1] = dat[, -1] + dat[, 1] + # } data_range = max(abs(range(dat))) tmp = rownames(dat) tmp = stringr::str_split_fixed(tmp, ':', n = 2) @@ -251,13 +253,27 @@ lme_3dviewer_fun <- function(need_calc, side_width, daemon_env, ...){ dat$Electrode = as.integer(tmp[,1]) dat$Subject = tmp[,2] elec_table = dat + }else if('Subject:Electrode' %in% names(coef)){ + dat = data.matrix(coef$`Subject:Electrode`) + # if('(Intercept)' %in% names(coef$`Subject:Electrode`)[[1]]){ + # dat[, -1] = dat[, -1] + dat[, 1] + # } + data_range = max(abs(range(dat))) + tmp = rownames(dat) + tmp = stringr::str_split_fixed(tmp, ':', n = 2) + dat = as.data.frame(dat) + val_ranges = sapply(names(dat), function(d){ c(-data_range, data_range) }, + simplify = FALSE, USE.NAMES = TRUE) + dat$Electrode = as.integer(tmp[,2]) + dat$Subject = tmp[,1] + elec_table = dat }else if('Electrode' %in% names(coef)){ # Subject only has one dat = data.matrix(coef$Electrode) - if('(Intercept)' %in% names(coef$Electrode)[[1]]){ - dat[, -1] = dat[, -1] + dat[, 1] - } + # if('(Intercept)' %in% names(coef$Electrode)[[1]]){ + # dat[, -1] = dat[, -1] + dat[, 1] + # } data_range = max(abs(range(dat))) dat = as.data.frame(dat) diff --git a/inst/modules/power_explorer/comp.R b/inst/modules/power_explorer/comp.R index 41d34e1..acbd69a 100644 --- a/inst/modules/power_explorer/comp.R +++ b/inst/modules/power_explorer/comp.R @@ -111,7 +111,12 @@ define_input_time(inputId = 'BASELINE_WINDOW', label='Baseline', initial_value = # define_input_analysis_file_chooser('analysis_settings', read_source = c('Analysis Settings' = 'analysis_yamls')) - +define_input_analysis_yaml_chooser( + 'analysis_settings', name_prefix = 'power_explorer_settings_', + # Relative to project directory + read_path = 'power_explorer/settings', + labels = c('Save settings', 'Load settings') +) define_input( definition = selectInput('combine_method', 'Electrode Transforms', diff --git a/inst/tools/input_widgets.R b/inst/tools/input_widgets.R index ce61bea..61b69b8 100644 --- a/inst/tools/input_widgets.R +++ b/inst/tools/input_widgets.R @@ -935,110 +935,109 @@ define_input_table_filters <- function( # options to save and load analysis parameters -# define_input_analysis_file_chooser <- function( -# inputId, labels = c('Save settings', 'Load settings'), -# name_prefix = 'power_explorer_settings_', -# read_source = c('Analysis Settings' = 'analysis_yamls'), -# write_source = 'settings', -# default_path = '' -# ){ -# save_btn = paste0(inputId, '_save') -# load_btn = paste0(inputId, '_load') -# save_text = paste0(inputId, '_savename') -# do_save = paste0(inputId, '_do_save') -# quo = rlang::quo({ -# define_input(customizedUI(inputId = !!inputId)) -# load_scripts(rlang::quo({ -# assign(!!inputId, function(){ -# -# read_source = c('/' = '/') -# -# load_btn = as.character(!!load_btn) -# fp = names(!!read_source) -# shinyFiles::shinyFileChoose( -# input = input, -# id = load_btn, roots= c('/' = '/'), -# filetypes = c('yaml', 'yml'), defaultRoot = '/', -# defaultPath = !!default_path -# ) -# -# div( -# class = 'rave-grid-inputs', style='border:none', -# div( -# style = 'flex-basis:50%', -# rave::actionButtonStyled(inputId = ns(!!save_btn), -# label=!!labels[[1]], icon = shiny::icon('save'), width = '100%') -# ), -# div( -# style = 'flex-basis:50%', -# shinyFiles::shinyFilesButton(id = ns(load_btn), label = !!labels[[2]], title = 'Select Analysis Settings', -# multiple = FALSE, icon = shiny::icon('puzzle-piece'), style = 'width:100%') -# ) -# ) -# }) -# -# # redirect shiny server file chooser home directory -# eval_when_ready(function(.env, ...){ -# -# with(.env, { -# input %?<-% getDefaultReactiveInput() -# shiny_is_running <- function() { -# cls <- class(getDefaultReactiveDomain()) -# any(cls %in% c('ShinySession', 'session_proxy')) -# } -# save_inputs <- function(yaml_path, variables_to_export){ -# if( !shiny_is_running() || !exists('getDefaultReactiveInput') ){ return(FALSE) } -# -# input <- getDefaultReactiveInput() -# cache_list = shiny::isolate(shiny::reactiveValuesToList(input)) -# if(!missing(variables_to_export)) { -# cache_list =cache_list[variables_to_export] -# } -# # if( exists('local_data') && shiny::is.reactivevalues(local_data) ){ -# # local_dat = shiny::isolate(shiny::reactiveValuesToList(local_data)) -# # cl = names(cache_list); cl = cl[cl %in% names(local_dat)] -# # cache_list[cl] = local_dat[cl] -# # } -# yaml::write_yaml(x = cache_list, fileEncoding = 'utf-8', file = yaml_path) -# return(TRUE) -# } -# -# # save Modal pop up -# observeEvent(input[[!!save_btn]], { -# tstmp <- strftime(Sys.time(), format = '%Y-%h-%d') -# -# shiny::showModal(shiny::modalDialog( -# title = 'Save Analysis Settings', -# size = 's', -# easyClose = TRUE, -# textInput(ns(!!save_text), label = 'Settings Name', value = paste0(!!name_prefix, tstmp)), -# tags$small('Will overwrite settings with the same name currently in RAVE settings folder'), -# footer = tagList( -# rave::actionButtonStyled(ns(!!do_save), 'Save'), -# shiny::modalButton("Cancel") -# ) -# )) -# }) -# -# # Modal do save -# observeEvent(input[[!!do_save]], { -# # save -# fname = input[[!!save_text]] -# fname = stringr::str_replace_all(fname, '[^a-zA-Z0-9]+', '_') -# fname = paste0(fname, '.yaml') -# save_dir = file.path(subject$dirs$subject_dir, '..', '_project_data', !!write_source) -# dir.create(save_dir, recursive = TRUE, showWarnings = FALSE) -# save_inputs(file.path(save_dir, fname)) -# shiny::removeModal() -# }) -# -# }) -# -# }) -# })) -# -# }) -# -# parent_env = parent.frame() -# rave::eval_dirty(quo, env = parent_env) -# } +define_input_analysis_yaml_chooser <- function( + inputId, name_prefix = 'settings_', + # Relative to project directory + read_path, write_path = read_path, + labels = c('Save settings', 'Load settings') +){ + save_btn = paste0(inputId, '_save') + load_btn = paste0(inputId, '_load') + save_text = paste0(inputId, '_savename') + do_save = paste0(inputId, '_do_save') + quo = rlang::quo({ + define_input(customizedUI(inputId = !!inputId)) + load_scripts(rlang::quo({ + assign(!!inputId, function(){ + + defaultPath = do.call(file.path, as.list(c(subject$project_name, '_project_data', !!read_path))) + dir.create(file.path(subject$dirs$data_dir, defaultPath), showWarnings = FALSE, recursive = TRUE) + defaultPath = normalizePath(defaultPath) + shinyFiles::shinyFileChoose( + input = input, + id = !!load_btn, roots= c('RAVE Home' = normalizePath(subject$dirs$data_dir), 'root' = '/'), + filetypes = c('yaml', 'yml'), defaultRoot = 'RAVE Home', + defaultPath = defaultPath + ) + + div( + class = 'rave-grid-inputs', style='border:none', + div( + style = 'flex-basis:50%', + rave::actionButtonStyled(inputId = ns(!!save_btn), + label=!!labels[[1]], icon = shiny::icon('save'), width = '100%') + ), + div( + style = 'flex-basis:50%', + shinyFiles::shinyFilesButton(id = ns(!!load_btn), label = !!labels[[2]], title = 'Select Analysis Settings', + multiple = FALSE, icon = shiny::icon('puzzle-piece'), style = 'width:100%') + ) + ) + }) + + # redirect shiny server file chooser home directory + eval_when_ready(function(.env, ...){ + + with(.env, { + input %?<-% getDefaultReactiveInput() + shiny_is_running <- function() { + cls <- class(getDefaultReactiveDomain()) + any(cls %in% c('ShinySession', 'session_proxy')) + } + save_inputs <- function(yaml_path, variables_to_export){ + if( !shiny_is_running() || !exists('getDefaultReactiveInput') ){ return(FALSE) } + + input <- getDefaultReactiveInput() + cache_list = shiny::isolate(shiny::reactiveValuesToList(input)) + if(!missing(variables_to_export)) { + cache_list =cache_list[variables_to_export] + } + # if( exists('local_data') && shiny::is.reactivevalues(local_data) ){ + # local_dat = shiny::isolate(shiny::reactiveValuesToList(local_data)) + # cl = names(cache_list); cl = cl[cl %in% names(local_dat)] + # cache_list[cl] = local_dat[cl] + # } + yaml::write_yaml(x = cache_list, fileEncoding = 'utf-8', file = yaml_path) + return(TRUE) + } + + # save Modal pop up + observeEvent(input[[!!save_btn]], { + tstmp <- strftime(Sys.time(), format = '%Y-%h-%d') + + shiny::showModal(shiny::modalDialog( + title = 'Save Analysis Settings', + size = 's', + easyClose = TRUE, + textInput(ns(!!save_text), label = 'Settings Name', value = paste0(!!name_prefix, tstmp)), + tags$small('Will overwrite settings with the same name currently in RAVE settings folder'), + footer = tagList( + rave::actionButtonStyled(ns(!!do_save), 'Save'), + shiny::modalButton("Cancel") + ) + )) + }) + + # Modal do save + observeEvent(input[[!!do_save]], { + # save + fname = input[[!!save_text]] + fname = stringr::str_replace_all(fname, '[^a-zA-Z0-9]+', '_') + fname = paste0(fname, '.yaml') + save_dir = do.call(file.path, as.list(c(normalizePath(subject$dirs$subject_dir, mustWork = TRUE), '..', '_project_data', !!write_path))) + print(save_dir) + dir.create(save_dir, recursive = TRUE, showWarnings = FALSE) + save_inputs(file.path(save_dir, fname)) + shiny::removeModal() + }) + + }) + + }) + })) + + }) + + parent_env = parent.frame() + rave::eval_dirty(quo, env = parent_env) +} From b3dc8f461a59cc5b06032b3944d25cda8b92a8c2 Mon Sep 17 00:00:00 2001 From: dipterix Date: Fri, 18 Oct 2019 03:05:03 -0500 Subject: [PATCH 22/24] Fixed 3D viewer in lmer --- inst/modules/power_explorer/event_handlers.R | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/inst/modules/power_explorer/event_handlers.R b/inst/modules/power_explorer/event_handlers.R index 1c2f17c..7aa15af 100644 --- a/inst/modules/power_explorer/event_handlers.R +++ b/inst/modules/power_explorer/event_handlers.R @@ -42,24 +42,25 @@ local_data = reactiveValues( observeEvent(input$analysis_settings_load, { fdata = input$analysis_settings_load if(!is.list(fdata) || !length(fdata$files)){ return() } - assign('fdata', fdata, envir = globalenv()) + # assign('fdata', fdata, envir = globalenv()) f_name = unlist(fdata$files); names(f_name) = NULL - read_source = c('Analysis Settings' = 'analysis_yamls') + roots = c('RAVE Home' = normalizePath(subject$dirs$data_dir), 'root' = '/') - f_name = c(subject$dirs$subject_dir, '..', '_project_data', read_source[[fdata$root]], f_name) - f_path = do.call(file.path, as.list(f_name)) - print(f_path) + f_path = do.call(file.path, as.list(c(roots[[fdata$root]], f_name))) conf = yaml::read_yaml(f_path) - print(conf) updateCheckboxInput(session, inputId = 'auto_calculate', value = FALSE) lapply(1:10, function(ii){ gc_id = sprintf('GROUPS_group_conditions_%d', ii) gc = conf[[gc_id]] if(!length(gc)){ gc = character(0) } - print(paste(ii, c(gc))) updateSelectInput(session, gc_id, selected = gc) + + gc_id = sprintf('GROUPS_group_names_%d', ii) + gc = conf[[gc_id]] + if(length(gc) != 1){ gc = '' } + updateTextInput(session, gc_id, value = gc) }) }) From 2d8a4b455ca49b505e1dfa69922fec8dd48a1ea3 Mon Sep 17 00:00:00 2001 From: dipterix Date: Fri, 18 Oct 2019 06:24:46 -0500 Subject: [PATCH 23/24] Also export to 3d viewer --- .../modules/channel_reference/reactive_main.R | 2 +- inst/modules/power_explorer/exports.R | 24 +++++-------------- 2 files changed, 7 insertions(+), 19 deletions(-) diff --git a/inst/modules/channel_reference/reactive_main.R b/inst/modules/channel_reference/reactive_main.R index d132f0f..39e93d3 100644 --- a/inst/modules/channel_reference/reactive_main.R +++ b/inst/modules/channel_reference/reactive_main.R @@ -697,7 +697,7 @@ write_ref_table = function(){ utils = rave_preprocess_tools() utils$load_subject(subject_code = subject$subject_code, project_name = subject$project_name) utils$save_to_subject(checklevel = 4) # 4 means referenced - switch_to('condition_explorer') + # switch_to('condition_explorer') return(fname) } diff --git a/inst/modules/power_explorer/exports.R b/inst/modules/power_explorer/exports.R index 5d93ad5..0ea424c 100644 --- a/inst/modules/power_explorer/exports.R +++ b/inst/modules/power_explorer/exports.R @@ -469,24 +469,12 @@ export_data_function <- function(){ save_inputs(file.path(dirname, paste0(fname, '.yaml'))) - # # Collapse time - # res_collapse_time = lapply(split(res, paste(res$Trial, res$Electrode)), function(x){ - # data.frame(stringsAsFactors = FALSE, - # Trial = x$Trial[1], Power = mean( x$Power ), Condition = x$Condition[1], - # Electrode = x$Electrode[1], Project = x$Project[1], Subject = x$Subject[1]) - # }) - # res_collapse_time = do.call('rbind', res_collapse_time) - # data.table::fwrite(res_collapse_time, file.path(dirname, paste0(analysis_prefix, '-collapse_time-', now, '.csv')), append = FALSE) - # - # # Collapse Trial - # res_collapse_trial = lapply(split(res, paste0(res$Condition, res$Electrode, res$Time)), function(x){ - # data.frame(stringsAsFactors = FALSE, - # Power = mean( x$Power ), Condition = x$Condition[1], Time = x$Time[1], - # Electrode = x$Electrode[1], Project = x$Project[1], Subject = x$Subject[1]) - # }) - # res_collapse_trial = do.call('rbind', res_collapse_trial) - # data.table::fwrite(res_collapse_trial, file.path(dirname, paste0(analysis_prefix, '-collapse_trial-', now, '.csv')), append = FALSE) - # + # Collapse Trial and save to 3D viewer + collapsed_trial = reshape2::dcast(res, Project+Subject+Electrode+Time~Condition, mean, value.var = 'Power') + dirname_viewer = file.path(subject$dirs$subject_dir, '..', '_project_data', '3dviewer') + dir.create(dirname_viewer, showWarnings = FALSE, recursive = TRUE) + data.table::fwrite(collapsed_trial, file.path(dirname_viewer, paste0(analysis_prefix, '-collapse_trial-', now, '.csv')), append = FALSE) + return(normalizePath(file.path(dirname, fname))) } From 6793061bb0bd83bcf435b1321419bdaa2e371c85 Mon Sep 17 00:00:00 2001 From: John Magnotti Date: Fri, 18 Oct 2019 11:27:43 -0500 Subject: [PATCH 24/24] lmer 3D viewer more surfaces --- inst/modules/group_analysis_lme/comp.R | 48 +++++++-------- inst/modules/group_analysis_lme/outputs.R | 65 ++++++++++++++++++--- inst/modules/group_analysis_lme/reactives.R | 18 +++--- 3 files changed, 91 insertions(+), 40 deletions(-) diff --git a/inst/modules/group_analysis_lme/comp.R b/inst/modules/group_analysis_lme/comp.R index 9efd4d0..a5d3237 100644 --- a/inst/modules/group_analysis_lme/comp.R +++ b/inst/modules/group_analysis_lme/comp.R @@ -188,18 +188,18 @@ input_layout = list( 'Analysis Settings' = list( 'cond_group_ui', 'analysis_window' - ), - 'Filter Data' = list( - 'var_sel' - ), + ), + # 'Filter Data' = list( + # 'var_sel' + # ), # 'Feature Selection' = list( # c('omnibus_f', 'fcutoff') # ), 'Build Model' = list( - c('model_dependent'), - c('model_fixed_effects', 'model_random_effects'), - 'model_embedsubject', - 'model_splinetime', + # c('model_dependent'), + # c('model_fixed_effects', 'model_random_effects'), + # 'model_embedsubject', + # 'model_splinetime', 'model_formula', 'run_analysis' ) @@ -219,32 +219,27 @@ define_output( ) define_output( - definition = customizedUI('lme_out', width = 12, style='min-height:300px'), + definition = customizedUI('lme_out', style='min-height:300px'), title = 'LME Output', width = 12, order = 2 ) define_output( - definition = customizedUI('group_figures', width = 12, style='min-height:300px'), - title = 'Group-level figures', - width = 12, + definition = plotOutput('power_over_time', height='500px'), + title = 'Power over time', + width = 8, order = 1 ) define_output( - definition = customizedUI('multiple_comparisons', width = 12, style='min-height:300px'), - title = 'Statistics for Groups', - width = 12, - order = 3 + definition = plotOutput('windowed_activity', height='500px'), + title = 'Mean activity within anlaysis window', + width = 4, + order = 1 ) -define_output( - definition = plotOutput('lme_diagnosis', height = '520px'), - title = 'Diagnostic Plots', - width = 7, - order = 1e3 -) + define_output_3d_viewer( outputId = 'lme_3dviewer', @@ -256,10 +251,11 @@ define_output_3d_viewer( # 'Multiple Comparisons' = c('multiple_comparisons'), output_layout = list( - 'Tabset One' = list( - 'Model Fitting Results' = c('lme_out'), - 'Graphs' = c('group_figures'), - 'Results on Surface' = c('lme_3dviewer') + 'Model Results' = list( + 'Model Fitting Results' = c('power_over_time', 'windowed_activity', 'lme_out'), + # 'Graphs' = c('group_figures'), + 'Results on Surface' = c('lme_3dviewer'), + 'Data Description' = c('src_data_snapshot') ) # 'Multiple Output' = 'src_data_snapshot' ) diff --git a/inst/modules/group_analysis_lme/outputs.R b/inst/modules/group_analysis_lme/outputs.R index 2b99182..63f4c4d 100644 --- a/inst/modules/group_analysis_lme/outputs.R +++ b/inst/modules/group_analysis_lme/outputs.R @@ -158,10 +158,57 @@ src_data_snapshot <- function() { # # } -group_figures <- function() { + +windowed_activity <- function() { + lmer_results = local_data$lmer_results + shiny::validate(shiny::need(!is.null(lmer_results), message = 'No model calculated')) + .y <- aggregate(Power ~ Group, m_se, data=local_data$collapsed_data) + + xp <- rutabaga::rave_barplot(.y$Power[,1], axes=F, col = adjustcolor(1:nrow(.y), 0.7), + border=NA, + ylim = range(pretty(c(0, plus_minus(.y$Power[,1], .y$Power[,2])))), + names.arg=.y$Group) + + rave_axis(2, at=axTicks(2)) + rave_axis_labels(xlab='Group', ylab='Power') + abline(h=0) + + ebars(xp, .y$Power, col=1:nrow(.y), code=0, lwd=2, lend=0) + +} + +power_over_time <- function() { lmer_results = local_data$lmer_results shiny::validate(shiny::need(!is.null(lmer_results), message = 'No model calculated')) - plot(1:20) + + sample_size = local_data$collapsed_data %>% do_aggregate(Power ~ Group, length) %$% { + names(Power) = Group + Power + } + + lpd <- local_data$agg_over_trial %>% split((.)$Group) %>% lapply(function(aot) { + res = list( + x = aot$Time, + data = aot$Power, + N= sample_size[as.character(aot$Group[1])], + range = range(plus_minus(aot$Power[,1], aot$Power[,2])), + has_trials = TRUE, + name = aot$Group[1] + ) + + attr(res$data, 'xlab') = 'Time' + attr(res$data, 'ylab') = 'Power' + res + }) + + set_palette('OrBlGrRdBrPr') + time_series_plot(plot_data = lpd) + axis_label_decorator(lpd) + + abline(v=input$analysis_window, lty=2) + + legend_include = c('name', 'N') + legend_decorator(lpd, include = legend_include) } lmer_diagnosis = function(){ @@ -169,7 +216,7 @@ lmer_diagnosis = function(){ shiny::validate(shiny::need(!is.null(lmer_results), message = 'No model calculated')) plot_clean(1:10, 1:20) - pointr(rnorm(10, mean = 10)) + # pointr(rnorm(10, mean = 10)) return() resid = stats::residuals(lmer_results, type = 'pearson', scaled = TRUE) fitt = fitted(lmer_results) @@ -294,14 +341,18 @@ lme_3dviewer_fun <- function(need_calc, side_width, daemon_env, ...){ }, error = function(e){ NULL }) }) brains = rave::dropNulls(brains) - brain = threeBrain::merge_brain(.list = brains) + brain = threeBrain::merge_brain(.list = brains, template_surface_types = c('pial', 'inf_200', 'smoothwm')) + + # set_palette() brain$set_electrode_values(elec_table) - re = brain$plot(side_width = side_width, val_ranges = val_ranges) + re = brain$plot(side_width = side_width, val_ranges = val_ranges, + side_display = FALSE, control_display=FALSE) } - } lme_diagnosis <- function(){ - plot(1:10) + shiny::validate(shiny::need(TRUE == FALSE, message = 'Not implemented')) + + # plot(1:10) } diff --git a/inst/modules/group_analysis_lme/reactives.R b/inst/modules/group_analysis_lme/reactives.R index 1f7d915..768ac19 100644 --- a/inst/modules/group_analysis_lme/reactives.R +++ b/inst/modules/group_analysis_lme/reactives.R @@ -2,6 +2,7 @@ input = getDefaultReactiveInput() output = getDefaultReactiveOutput() session = getDefaultReactiveDomain() + local_data %?<-% reactiveValues( # Full data has two parts: local_data$analysis_data_raw, and local_data$additional_data # together makes analysis_data @@ -17,7 +18,6 @@ local_data %?<-% reactiveValues( var_fixed_effects = NULL, lmer_results = NULL, lmer_results_summary = NULL - ) local_filters = reactiveValues( filter_count = 0, @@ -272,26 +272,30 @@ observeEvent(input$run_analysis, { all_trial_types <- cond_group %>% lapply(`[[`, 'group_conditions') %>% unlist %>% unique # create a joint variable representing the Group as a factor + showNotification(p('Fitting mixed effect model. Please wait...'), duration = NULL, type = 'default', id = ns('noti')) ldf <- local_data$analysis_data_filtered - subset_data <- subset(ldf, subset = Time %within% analysis_window & Condition %in% all_trial_types) - + subset_data <- subset(ldf, subset = Condition %in% all_trial_types) subset_data$Group = cond_group[[1]]$group_name for(ii in seq_along(cond_group)[-1]) { subset_data$Group[subset_data$Condition %in% cond_group[[ii]]$group_conditions] = cond_group[[ii]]$group_name } subset_data$Group %<>% factor(levels = sapply(cond_group, `[[`, 'group_name')) + local_data$over_time_data = subset_data + subset_data %<>% subset(Time %within% analysis_window) collapsed_data <- do_aggregate(Power ~ Group + Electrode + Subject, data=subset_data, FUN=mean) local_data$collapsed_data = collapsed_data - showNotification(p('Fitting mixed effect model. Please wait...'), duration = NULL, type = 'default', id = ns('noti')) + local_data$agg_over_trial = aggregate(Power ~ Group + Time + Subject + Electrode, + local_data$over_time_data, FUN=mean) %>% do_aggregate(Power ~ Group + Time, .fast_mse) - # fo = input$model_formula - fo = as.formula('Power ~ Group + (1|Subject:Electrode)') + fo = input$model_formula + fo %<>% as.formula #as.formula('Power ~ Group + (1|Subject/Electrode)') tryCatch({ lmer_results = lmerTest::lmer(fo, data=collapsed_data, na.action=na.omit) - assign('..lmer_results', value = lmer_results, envir = globalenv()) + assign('..local_data', value = shiny::isolate(shiny:::reactiveValuesToList(local_data)), envir = globalenv()) + local_data$lmer_results_summary <- summary(lmer_results) local_data$lmer_results = lmer_results showNotification(p('Model finished!'), duration = 3, type = 'default', id = ns('noti'))