bumped to 25.2.1 - new visuals tab - all functions in place - code cleanup has started

DESCRIPTION

@@ -36,7 +36,6 @@ Imports:
     patchwork,
     easystats,
     DHARMa,
-    teal,
     IDEAFilter,
     sparkline,
     datamods,
@@ -52,7 +51,6 @@ Imports:
     rlang,
     data.table,
     apexcharter,
-    teal.modules.general,
     esquisse,
     janitor,
     flextable,
@@ -64,7 +62,9 @@ Imports:
     psych,
     jtools,
     Hmisc,
-    ggstats
+    ggstats,
+    rempsyc,
+    ggridges
 Suggests: 
     styler,
     devtools,

NEWS.md

@@ -4,6 +4,25 @@ First steps towards a more focused and simplified interface.
 
 Focus will be on ease of use, handling basic functionality for data inspection and descriptive analyses.
 
+Inspired by the Stroke Center implementation guidelines of the WSO, we will apply a similar approach to this project in order to keep the interface simple and robust. Basic functions for descriptive analyses and data browsing are the basics. More advanced features like regression analyses are added for learning purposes, but really should be done by one self in software like *R* to ensure learning and reproducibility.
+
+Teal dependencies removed. The teal framework really seems very powerful and promising, but it will also mean less control and more clutter. May come up again later.
+
+All main components have been implemented.
+
+Next steps are:
+
+-   Polished code export
+
+-   Improved workflow and thorough step-wise guide/documentation
+
+-   Implement in clinical projects
+
+-   Implement in data analysis courses
+
+-   Extensive testing and bug squashing
+
+
 # freesearcheR 25.1.1
 
 * UI tweaks.

QA.md

@@ -0,0 +1,8 @@
+# Questions and answers
+
+A complete instructions set is not available, but below are a collection of questions and answers about the project and use of the app.
+
+## Are you keeping the uploaded data?
+
+No! All uploaded data is deleted when the session ends, so only stored for your analyses and the immediately deleted.
+

R/app_version.R

@@ -1 +1 @@
-app_version <- function()'250207_1709'
+app_version <- function()'250225_0948'

R/columnSelectInput.R

@@ -0,0 +1,82 @@
+#' A selectizeInput customized for data frames with column labels
+#'
+#' @description
+#' Copied and modified from the IDEAFilter package
+#' Adds the option to select "none" which is handled later
+#'
+#' @param inputId passed to \code{\link[shiny]{selectizeInput}}
+#' @param label passed to \code{\link[shiny]{selectizeInput}}
+#' @param data \code{data.frame} object from which fields should be populated
+#' @param selected default selection
+#' @param ... passed to \code{\link[shiny]{selectizeInput}}
+#' @param col_subset a \code{vector} containing the list of allowable columns to select
+#' @param placeholder passed to \code{\link[shiny]{selectizeInput}} options
+#' @param onInitialize passed to \code{\link[shiny]{selectizeInput}} options
+#' @param none_label label for "none" item
+#'
+#' @return a \code{\link[shiny]{selectizeInput}} dropdown element
+#'
+#' @importFrom shiny selectizeInput
+#' @keywords internal
+#'
+columnSelectInput <- function(inputId, label, data, selected = "", ...,
+                              col_subset = NULL, placeholder = "", onInitialize, none_label="No variable selected") {
+  datar <- if (is.reactive(data)) data else reactive(data)
+  col_subsetr <- if (is.reactive(col_subset)) col_subset else reactive(col_subset)
+
+  labels <- Map(function(col) {
+    json <- sprintf(
+      IDEAFilter:::strip_leading_ws('
+    {
+      "name": "%s",
+      "label": "%s",
+      "datatype": "%s"
+    }'),
+      col,
+      attr(datar()[[col]], "label") %||% "",
+      IDEAFilter:::get_dataFilter_class(datar()[[col]])
+    )
+  }, col = names(datar()))
+
+  if (!"none" %in% names(datar())){
+    labels <- c("none"=list(sprintf('\n    {\n      \"name\": \"none\",\n      \"label\": \"%s\",\n      \"datatype\": \"\"\n    }',none_label)),labels)
+    choices <- setNames(names(labels), labels)
+    choices <- choices[match(if (length(col_subsetr()) == 0 || isTRUE(col_subsetr() == "")) names(datar()) else col_subsetr(), choices)]
+  } else {
+    choices <- setNames(names(datar()), labels)
+    choices <- choices[match(if (length(col_subsetr()) == 0 || isTRUE(col_subsetr() == "")) choices else col_subsetr(), choices)]
+  }
+
+  shiny::selectizeInput(
+    inputId = inputId,
+    label = label,
+    choices = choices,
+    selected = selected,
+    ...,
+    options = c(
+      list(render = I("{
+        // format the way that options are rendered
+        option: function(item, escape) {
+          item.data = JSON.parse(item.label);
+          return '<div style=\"padding: 3px 12px\">' +
+                   '<div><strong>' +
+                      escape(item.data.name) + ' ' +
+                      '<span style=\"opacity: 0.3;\"><code style=\"color: black;\"> ' +
+                        item.data.datatype +
+                      '</code></span>' +
+                   '</strong></div>' +
+                   (item.data.label != '' ? '<div style=\"line-height: 1em;\"><small>' + escape(item.data.label) + '</small></div>' : '') +
+                 '</div>';
+        },
+
+        // avoid data vomit splashing on screen when an option is selected
+        item: function(item, escape) {
+        item.data = JSON.parse(item.label);
+        return '<div>' +
+                 escape(item.data.name) +
+               '</div>';
+        }
+      }"))
+    )
+  )
+}

R/contrast_text.R

@@ -0,0 +1,51 @@
+#' @title Contrast Text Color
+#' @description Calculates the best contrast text color for a given
+#' background color.
+#' @param background A hex/named color value that represents the background.
+#' @param light_text A hex/named color value that represents the light text
+#' color.
+#' @param dark_text A hex/named color value that represents the dark text color.
+#' @param threshold A numeric value between 0 and 1 that is used to determine
+#' the luminance threshold of the background color for text color.
+#' @param method A character string that specifies the method for calculating
+#' the luminance. Three different methods are available:
+#' c("relative","perceived","perceived_2")
+#' @param ... parameter overflow. Ignored.
+#' @details
+#' This function aids in deciding the font color to print on a given background.
+#' The function is based on the example provided by teppo:
+#' https://stackoverflow.com/a/66669838/21019325.
+#' The different methods provided are based on the methods outlined in the
+#' StackOverflow thread:
+#' https://stackoverflow.com/questions/596216/formula-to-determine-perceived-brightness-of-rgb-color
+#' @return A character string that contains the best contrast text color.
+#' @examples
+#' contrast_text(c("#F2F2F2", "blue"))
+#'
+#' contrast_text(c("#F2F2F2", "blue"), method="relative")
+#' @export
+#'
+#' @importFrom grDevices col2rgb
+#'
+contrast_text <- function(background,
+                          light_text = 'white',
+                          dark_text = 'black',
+                          threshold = 0.5,
+                          method = "perceived_2",
+                          ...) {
+  if (method == "relative") {
+    luminance <-
+      c(c(.2126, .7152, .0722) %*% grDevices::col2rgb(background) / 255)
+  } else if (method == "perceived") {
+    luminance <-
+      c(c(.299, .587, .114) %*% grDevices::col2rgb(background) / 255)
+  } else if (method == "perceived_2") {
+    luminance <- c(sqrt(colSums((
+      c(.299, .587, .114) * grDevices::col2rgb(background)
+    ) ^ 2)) / 255)
+  }
+
+  ifelse(luminance < threshold,
+         light_text,
+         dark_text)
+}

R/data_plots.R

@@ -0,0 +1,619 @@
+# source(here::here("functions.R"))
+
+#' Data correlations evaluation module
+#'
+#' @param id Module id. (Use 'ns("id")')
+#'
+#' @name data-correlations
+#' @returns Shiny ui module
+#' @export
+#'
+data_visuals_ui <- function(id, tab_title="Plots", ...) {
+  ns <- shiny::NS(id)
+
+  # bslib::navset_bar(
+  list(
+
+    # Sidebar with a slider input
+    sidebar = bslib::sidebar(
+      bslib::accordion(
+        multiple = FALSE,
+        bslib::accordion_panel(
+          title = "Creating plot",
+          icon = bsicons::bs_icon("graph-up"),
+          shiny::uiOutput(outputId = ns("primary")),
+          shiny::uiOutput(outputId = ns("type")),
+          shiny::uiOutput(outputId = ns("secondary")),
+          shiny::uiOutput(outputId = ns("tertiary"))
+        ),
+        bslib::accordion_panel(
+          title = "Advanced",
+          icon = bsicons::bs_icon("gear")
+          ),
+        bslib::accordion_panel(
+          title = "Download",
+          icon = bsicons::bs_icon("download"),
+          shinyWidgets::noUiSliderInput(
+            inputId = ns("height"),
+            label = "Plot height (mm)",
+            min = 50,
+            max = 300,
+            value = 100,
+            step = 1,
+            format = shinyWidgets::wNumbFormat(decimals=0),
+            color = datamods:::get_primary_color()
+          ),
+          shinyWidgets::noUiSliderInput(
+            inputId = ns("width"),
+            label = "Plot width (mm)",
+            min = 50,
+            max = 300,
+            value = 100,
+            step = 1,
+            format = shinyWidgets::wNumbFormat(decimals=0),
+            color = datamods:::get_primary_color()
+          ),
+          shiny::selectInput(
+            inputId = ns("plot_type"),
+            label = "File format",
+            choices = list(
+              "png",
+              "tiff",
+              "eps",
+              "pdf",
+              "jpeg",
+              "svg"
+            )
+          ),
+          shiny::br(),
+          # Button
+          shiny::downloadButton(
+            outputId = ns("download_plot"),
+            label = "Download plot",
+            icon = shiny::icon("download")
+          )
+        )
+      )
+    ),
+    bslib::nav_panel(
+      title = tab_title,
+      shiny::plotOutput(ns("plot"))
+    )
+  )
+}
+
+
+#'
+#' @param data data
+#' @param ... ignored
+#'
+#' @name data-correlations
+#' @returns shiny server module
+#' @export
+data_visuals_server <- function(id,
+                                data,
+                                ...) {
+  shiny::moduleServer(
+    id = id,
+    module = function(input, output, session) {
+      ns <- session$ns
+
+      rv <- shiny::reactiveValues(
+        plot.params = NULL,
+        plot = NULL
+      )
+
+      output$primary <- shiny::renderUI({
+        columnSelectInput(
+          inputId = ns("primary"),
+          data = data,
+          placeholder = "Select variable",
+          label = "Response variable",
+          multiple = FALSE
+        )
+      })
+
+
+      output$type <- shiny::renderUI({
+        shiny::req(input$primary)
+        # browser()
+
+        if (!input$primary %in% names(data())) {
+          plot_data <- data()[1]
+        } else {
+          plot_data <- data()[input$primary]
+        }
+
+        plots <- possible_plots(
+          data = plot_data
+        )
+
+        shiny::selectizeInput(
+          inputId = ns("type"),
+          selected = NULL,
+          label = shiny::h4("Plot type"),
+          choices = plots,
+          multiple = FALSE
+        )
+      })
+
+      rv$plot.params <- shiny::reactive({
+        get_plot_options(input$type)
+      })
+
+      output$secondary <- shiny::renderUI({
+        shiny::req(input$type)
+        # browser()
+
+        columnSelectInput(
+          inputId = ns("secondary"),
+          data = data,
+          placeholder = "Select variable",
+          label = "Secondary/group variable",
+          multiple = FALSE,
+          col_subset = c(
+            purrr::pluck(rv$plot.params(), 1)[["secondary.extra"]],
+            all_but(
+              colnames(subset_types(
+                data(),
+                purrr::pluck(rv$plot.params(), 1)[["secondary.type"]]
+              )),
+              input$primary
+            )
+          ),
+          none_label = "No variable"
+        )
+
+      })
+
+      output$tertiary <- shiny::renderUI({
+        shiny::req(input$type)
+        columnSelectInput(
+          inputId = ns("tertiary"),
+          data = data,
+          placeholder = "Select variable",
+          label = "Strata variable",
+          multiple = FALSE,
+          col_subset = c(
+            "none",
+            all_but(
+              colnames(subset_types(
+                data(),
+                purrr::pluck(rv$plot.params(), 1)[["tertiary.type"]]
+              )),
+              input$primary,
+              input$secondary
+            )
+          ),
+          none_label = "No stratification"
+        )
+      })
+
+      rv$plot <- shiny::reactive({
+        shiny::req(input$primary)
+        shiny::req(input$type)
+        shiny::req(input$secondary)
+        shiny::req(input$tertiary)
+        create_plot(
+          data = data(),
+          type = names(rv$plot.params()),
+          x = input$primary,
+          y = input$secondary,
+          z = input$tertiary
+        )
+      })
+
+      output$plot <- shiny::renderPlot({
+        rv$plot()
+      })
+
+      output$download_plot <- shiny::downloadHandler(
+        filename = shiny::reactive({
+          paste0("plot.", input$plot_type)
+        }),
+        content = function(file) {
+          shiny::withProgress(message = "Drawing the plot. Hold on for a moment..", {
+          ggplot2::ggsave(filename = file,
+                          plot = rv$plot(),
+                          width = input$width,
+                          height = input$height,
+                          dpi = 300,
+                          units = "mm",scale = 2)
+          })
+        }
+      )
+
+
+      shiny::observe(
+        return(rv$plot)
+      )
+    }
+  )
+}
+
+
+
+#' Select all from vector but
+#'
+#' @param data vector
+#' @param ... exclude
+#'
+#' @returns
+#' @export
+#'
+#' @examples
+#' all_but(1:10, c(2, 3), 11, 5)
+all_but <- function(data, ...) {
+  data[!data %in% c(...)]
+}
+
+#' Easily subset by data type function
+#'
+#' @param data data
+#' @param types desired types
+#' @param type.fun function to get type. Default is outcome_type
+#'
+#' @returns
+#' @export
+#'
+#' @examples
+#' default_parsing(mtcars) |> subset_types("ordinal")
+#' default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal"))
+#' #' default_parsing(mtcars) |> subset_types("factor",class)
+subset_types <- function(data, types, type.fun = outcome_type) {
+  data[sapply(data, type.fun) %in% types]
+}
+
+
+#' Implemented functions
+#'
+#' @description
+#' Library of supported functions. The list name and "descr" element should be
+#' unique for each element on list.
+#'
+#' -   descr: Plot description
+#'
+#' -   primary.type: Primary variable data type (continuous, dichotomous or ordinal)
+#'
+#' -   secondary.type: Secondary variable data type (continuous, dichotomous or ordinal)
+#'
+#' -   secondary.extra: "none" or NULL to have option to choose none.
+#'
+#' -   tertiary.type: Tertiary variable data type (continuous, dichotomous or ordinal)
+#'
+#'
+#' @returns list
+#' @export
+#'
+#' @examples
+#' supported_plots() |> str()
+supported_plots <- function() {
+  list(
+    plot_hbars = list(
+      descr = "Stacked horizontal bars (Grotta bars)",
+      primary.type = c("dichotomous", "ordinal"),
+      secondary.type = c("dichotomous", "ordinal"),
+      tertiary.type = c("dichotomous", "ordinal"),
+      secondary.extra = "none"
+    ),
+    plot_violin = list(
+      descr = "Violin plot",
+      primary.type = c("continuous", "dichotomous", "ordinal"),
+      secondary.type = c("dichotomous", "ordinal"),
+      tertiary.type = c("dichotomous", "ordinal"),
+      secondary.extra = "none"
+    ),
+    plot_ridge = list(
+      descr = "Ridge plot",
+      primary.type = "continuous",
+      secondary.type = c("dichotomous", "ordinal"),
+      tertiary.type = c("dichotomous", "ordinal"),
+      secondary.extra = NULL
+    ),
+    plot_scatter = list(
+      descr = "Scatter plot",
+      primary.type = "continuous",
+      secondary.type = c("continuous", "ordinal"),
+      tertiary.type = c("dichotomous", "ordinal"),
+      secondary.extra = NULL
+    )
+  )
+}
+
+#' Title
+#'
+#' @returns
+#' @export
+#'
+#' @examples
+#' mtcars |>
+#'   default_parsing() |>
+#'   plot_ridge(x = "mpg", y = "cyl")
+#' mtcars |> plot_ridge(x = "mpg", y = "cyl", z = "gear")
+plot_ridge <- function(data, x, y, z = NULL, ...) {
+  if (!is.null(z)) {
+    ds <- split(data, data[z])
+  } else {
+    ds <- list(data)
+  }
+
+  out <- lapply(ds, \(.ds){
+    ggplot2::ggplot(.ds, ggplot2::aes(x = !!dplyr::sym(x), y = !!dplyr::sym(y), fill = !!dplyr::sym(y))) +
+      ggridges::geom_density_ridges() +
+      ggridges::theme_ridges() +
+      ggplot2::theme(legend.position = "none") |> rempsyc:::theme_apa()
+  })
+
+  patchwork::wrap_plots(out)
+}
+
+
+#' Get possible regression models
+#'
+#' @param data data
+#'
+#' @returns character vector
+#' @export
+#'
+#' @examples
+#' mtcars |>
+#'   default_parsing() |>
+#'   dplyr::pull("cyl") |>
+#'   possible_plots()
+#'
+#' mtcars |>
+#'   default_parsing() |>
+#'   dplyr::select("mpg") |>
+#'   possible_plots()
+possible_plots <- function(data) {
+  # browser()
+  if (is.data.frame(data)) {
+    data <- data[[1]]
+  }
+
+  type <- outcome_type(data)
+
+  if (type == "unknown") {
+    out <- type
+  } else {
+    out <- supported_plots() |>
+      lapply(\(.x){
+        if (type %in% .x$primary.type) {
+          .x$descr
+        }
+      }) |>
+      unlist()
+  }
+  unname(out)
+}
+
+#' Get the function options based on the selected function description
+#'
+#' @param data vector
+#'
+#' @returns list
+#' @export
+#'
+#' @examples
+#' ls <- mtcars |>
+#'   default_parsing() |>
+#'   dplyr::pull(mpg) |>
+#'   possible_plots() |>
+#'   (\(.x){
+#'     .x[[1]]
+#'   })() |>
+#'   get_plot_options()
+get_plot_options <- function(data) {
+  descrs <- supported_plots() |>
+    lapply(\(.x){
+      .x$descr
+    }) |>
+    unlist()
+  supported_plots() |>
+    (\(.x){
+      .x[match(data, descrs)]
+    })()
+}
+
+
+
+#' Wrapper to create plot based on provided type
+#'
+#' @param type plot type (derived from possible_plots() and matches custom function)
+#' @param ... ignored for now
+#'
+#' @returns
+#' @export
+#'
+#' @examples
+#' create_plot(mtcars, "plot_violin", "mpg", "cyl")
+create_plot <- function(data, type, x, y, z = NULL, ...) {
+  if (!y %in% names(data)) {
+    y <- NULL
+  }
+
+  if (!z %in% names(data)) {
+    z <- NULL
+  }
+
+  do.call(
+    type,
+    list(data, x, y, z, ...)
+  )
+}
+
+
+#' Nice horizontal stacked bars (Grotta bars)
+#'
+#' @returns ggplot2 object
+#' @export
+#'
+#' @examples
+#' mtcars |> plot_hbars(x = "carb", y = "cyl")
+#' mtcars |> plot_hbars(x = "carb", y = NULL)
+plot_hbars <- function(data, x, y, z = NULL) {
+  out <- vertical_stacked_bars(data = data, score = x, group = y, strata = z)
+
+  out
+}
+
+
+#' Vertical stacked bar plot wrapper
+#'
+#' @param data
+#' @param score
+#' @param group
+#' @param strata
+#' @param t.size
+#'
+#' @return
+#' @export
+#'
+vertical_stacked_bars <- function(data,
+                                  score = "full_score",
+                                  group = "pase_0_q",
+                                  strata = NULL,
+                                  t.size = 10,
+                                  l.color = "black",
+                                  l.size = .5,
+                                  draw.lines = TRUE) {
+  if (is.null(group)) {
+    df.table <- data[c(score, group, strata)] |>
+      dplyr::mutate("All" = 1) |>
+      table()
+    group <- "All"
+    draw.lines <- FALSE
+  } else {
+    df.table <- data[c(score, group, strata)] |>
+      table()
+  }
+
+  p <- df.table |>
+    rankinPlot::grottaBar(
+      scoreName = score,
+      groupName = group,
+      textColor = c("black", "white"),
+      strataName = strata,
+      textCut = 6,
+      textSize = 20,
+      printNumbers = "none",
+      lineSize = l.size,
+      returnData = TRUE
+    )
+
+  colors <- viridisLite::viridis(nrow(df.table))
+  contrast_cut <-
+    sum(contrast_text(colors, threshold = .3) == "white")
+
+  score_label <- ifelse(is.na(REDCapCAST::get_attr(data$score, "label")), score, REDCapCAST::get_attr(data$score, "label"))
+  group_label <- ifelse(is.na(REDCapCAST::get_attr(data$group, "label")), group, REDCapCAST::get_attr(data$group, "label"))
+
+
+  p |>
+    (\(.x){
+      .x$plot +
+        ggplot2::geom_text(
+          data = .x$rectData[which(.x$rectData$n >
+            0), ],
+          size = t.size,
+          fontface = "plain",
+          ggplot2::aes(
+            x = group,
+            y = p_prev + 0.49 * p,
+            color = as.numeric(score) > contrast_cut,
+            # label = paste0(sprintf("%2.0f", 100 * p),"%"),
+            label = sprintf("%2.0f", 100 * p)
+          )
+        ) +
+        ggplot2::labs(fill = score_label) +
+        ggplot2::scale_fill_manual(values = rev(colors)) +
+        ggplot2::theme(
+          legend.position = "bottom",
+          axis.title = ggplot2::element_text(),
+        ) +
+        ggplot2::xlab(group_label) +
+        ggplot2::ylab(NULL)
+      # viridis::scale_fill_viridis(discrete = TRUE, direction = -1, option = "D")
+    })()
+}
+
+
+#' Print label, and if missing print variable name
+#'
+#' @param data vector or data frame
+#'
+#' @returns character string
+#' @export
+#'
+#' @examples
+#' mtcars |> get_label(var = "mpg")
+#' mtcars$mpg |> get_label()
+#' gtsummary::trial |> get_label(var = "trt")
+#' 1:10 |> get_label()
+get_label <- function(data, var = NULL) {
+  if (!is.null(var)) {
+    data <- data[[var]]
+  }
+
+  out <- REDCapCAST::get_attr(data = data, attr = "label")
+  if (is.na(out)) {
+    if (is.null(var)) {
+      out <- deparse(substitute(data))
+    } else {
+      out <- gsub('\"', "", deparse(substitute(var)))
+    }
+  }
+  out
+}
+
+
+#' Beatiful violin plot
+#'
+#' @returns ggplot2 object
+#' @export
+#'
+#' @examples
+#' mtcars |> plot_violin(x = "mpg", y = "cyl", z = "gear")
+plot_violin <- function(data, x, y, z = NULL) {
+  if (!is.null(z)) {
+    ds <- split(data, data[z])
+  } else {
+    ds <- list(data)
+  }
+
+  out <- lapply(ds, \(.ds){
+    rempsyc::nice_violin(
+      data = .ds,
+      group = y,
+      response = x, xtitle = get_label(data, var = x), ytitle = get_label(data, var = y)
+    )
+  })
+
+  patchwork::wrap_plots(out)
+}
+
+
+#' Beatiful violin plot
+#'
+#' @returns ggplot2 object
+#' @export
+#'
+#' @examples
+#' mtcars |> plot_scatter(x = "mpg", y = "wt")
+plot_scatter <- function(data, x, y, z = NULL) {
+  if (is.null(z)) {
+    rempsyc::nice_scatter(
+      data = data,
+      predictor = y,
+      response = x, xtitle = get_label(data, var = x), ytitle = get_label(data, var = y)
+    )
+  } else {
+    rempsyc::nice_scatter(
+      data = data,
+      predictor = y,
+      response = x,
+      group = z
+    )
+  }
+}
+

R/file-import-module.R

@@ -95,31 +95,31 @@ file_app <- function() {
 
 file_app()
 
-tdm_data_upload <- teal::teal_data_module(
+# tdm_data_upload <- teal::teal_data_module(
-  ui <- function(id) {
+#   ui <- function(id) {
-    shiny::fluidPage(
+#     shiny::fluidPage(
-      m_datafileUI(id)
+#       m_datafileUI(id)
-    )
+#     )
-  },
+#   },
-  server = function(id) {
+#   server = function(id) {
-    m_datafileServer(id, output.format = "teal")
+#     m_datafileServer(id, output.format = "teal")
-  }
+#   }
-)
+# )
-
+#
-tdm_data_read <- teal::teal_data_module(
+# tdm_data_read <- teal::teal_data_module(
-  ui <- function(id) {
+#   ui <- function(id) {
-    shiny::fluidPage(
+#     shiny::fluidPage(
-      m_redcap_readUI(id = "redcap")
+#       m_redcap_readUI(id = "redcap")
-    )
+#     )
-  },
+#   },
-  server = function(id) {
+#   server = function(id) {
-    moduleServer(
+#     moduleServer(
-      id,
+#       id,
-      function(input, output, session) {
+#       function(input, output, session) {
-        ns <- session$ns
+#         ns <- session$ns
-
+#
-        m_redcap_readServer(id = "redcap", output.format = "teal")
+#         m_redcap_readServer(id = "redcap", output.format = "teal")
-      }
+#       }
-    )
+#     )
-  }
+#   }
-)
+# )

R/helpers.R

@@ -266,3 +266,29 @@ remove_empty_cols <- function(data,cutoff=.7){
   }) >= cutoff
   data[filter]
 }
+
+
+#' Append list with named index
+#'
+#' @param data data to add to list
+#' @param list list
+#' @param index index name
+#'
+#' @returns list
+#'
+#' @examples
+#' ls_d <- list(test=c(1:20))
+#' ls_d <- list()
+#' data.frame(letters[1:20],1:20) |> append_list(ls_d,"letters")
+#' letters[1:20]|> append_list(ls_d,"letters")
+append_list <- function(data,list,index){
+  ## This will overwrite and not warn
+  ## Not very safe, but convenient to append code to list
+  if (index %in% names(list)){
+    list[[index]] <- data
+    out <- list
+  } else {
+    out <- setNames(c(list,list(data)),c(names(list),index))
+  }
+  out
+}

R/redcap_read_shiny_module.R

@@ -271,19 +271,19 @@ m_redcap_readServer <- function(id, output.format = c("df", "teal", "list")) {
   )
 }
 
-#' REDCap import teal data module
+# #' REDCap import teal data module
-#'
+# #'
-#' @rdname redcap_read_shiny_module
+# #' @rdname redcap_read_shiny_module
-tdm_redcap_read <- teal::teal_data_module(
+# tdm_redcap_read <- teal::teal_data_module(
-  ui <- function(id) {
+#   ui <- function(id) {
-    shiny::fluidPage(
+#     shiny::fluidPage(
-      m_redcap_readUI(id)
+#       m_redcap_readUI(id)
-    )
+#     )
-  },
+#   },
-  server = function(id) {
+#   server = function(id) {
-    m_redcap_readServer(id, output.format = "teal")
+#     m_redcap_readServer(id, output.format = "teal")
-  }
+#   }
-)
+# )
 
 
 #' Test app for the redcap_read_shiny_module

R/shiny_freesearcheR.R

@@ -15,7 +15,7 @@
 #' shiny_freesearcheR(launch.browser = TRUE)
 #' }
 shiny_freesearcheR <- function(...) {
-  appDir <- system.file("apps", "data_analysis_modules", package = "freesearcheR")
+  appDir <- system.file("apps", "freesearcheR", package = "freesearcheR")
   if (appDir == "") {
     stop("Could not find the app directory. Try re-installing `freesearcheR`.", call. = FALSE)
   }

R/update-factor-ext.R

@@ -0,0 +1,292 @@
+
+## Works, but not implemented
+##
+## These edits mainly allows for
+
+
+#' @title Module to Reorder the Levels of a Factor Variable
+#'
+#' @description
+#' This module contain an interface to reorder the levels of a factor variable.
+#'
+#'
+#' @param id Module ID.
+#'
+#' @return A [shiny::reactive()] function returning the data.
+#' @export
+#'
+#' @importFrom shiny NS fluidRow tagList column actionButton
+#' @importFrom shinyWidgets virtualSelectInput prettyCheckbox
+#' @importFrom toastui datagridOutput
+#' @importFrom htmltools tags
+#'
+#' @name update-factor
+#'
+#' @example examples/update_factor.R
+update_factor_ui <- function(id) {
+  ns <- NS(id)
+  tagList(
+    tags$style(
+      ".tui-grid-row-header-draggable span {width: 3px !important; height: 3px !important;}"
+    ),
+    fluidRow(
+      column(
+        width = 6,
+        virtualSelectInput(
+          inputId = ns("variable"),
+          label = i18n("Factor variable to reorder:"),
+          choices = NULL,
+          width = "100%",
+          zIndex = 50
+        )
+      ),
+      column(
+        width = 3,
+        class = "d-flex align-items-end",
+        actionButton(
+          inputId = ns("sort_levels"),
+          label = tagList(
+            ph("sort-ascending"),
+            i18n("Sort by levels")
+          ),
+          class = "btn-outline-primary mb-3",
+          width = "100%"
+        )
+      ),
+      column(
+        width = 3,
+        class = "d-flex align-items-end",
+        actionButton(
+          inputId = ns("sort_occurrences"),
+          label = tagList(
+            ph("sort-ascending"),
+            i18n("Sort by count")
+          ),
+          class = "btn-outline-primary mb-3",
+          width = "100%"
+        )
+      )
+    ),
+    datagridOutput(ns("grid")),
+    tags$div(
+      class = "float-end",
+      prettyCheckbox(
+        inputId = ns("new_var"),
+        label = i18n("Create a new variable (otherwise replaces the one selected)"),
+        value = FALSE,
+        status = "primary",
+        outline = TRUE,
+        inline = TRUE
+      ),
+      actionButton(
+        inputId = ns("create"),
+        label = tagList(ph("arrow-clockwise"), i18n("Update factor variable")),
+        class = "btn-outline-primary"
+      )
+    ),
+    tags$div(class = "clearfix")
+  )
+}
+
+
+#' @param data_r A [shiny::reactive()] function returning a `data.frame`.
+#'
+#' @export
+#'
+#' @importFrom shiny moduleServer observeEvent reactive reactiveValues req bindEvent isTruthy updateActionButton
+#' @importFrom shinyWidgets updateVirtualSelect
+#' @importFrom toastui renderDatagrid datagrid grid_columns grid_colorbar
+#'
+#' @rdname update-factor
+update_factor_server <- function(id, data_r = reactive(NULL)) {
+  moduleServer(
+    id,
+    function(input, output, session) {
+
+      rv <- reactiveValues(data = NULL, data_grid = NULL)
+
+      bindEvent(observe({
+        data <- data_r()
+        rv$data <- data
+        vars_factor <- vapply(data, is.factor, logical(1))
+        vars_factor <- names(vars_factor)[vars_factor]
+        updateVirtualSelect(
+          inputId = "variable",
+          choices = vars_factor,
+          selected = if (isTruthy(input$variable)) input$variable else vars_factor[1]
+        )
+      }), data_r(), input$hidden)
+
+      observeEvent(input$variable, {
+        data <- req(data_r())
+        variable <- req(input$variable)
+        grid <- as.data.frame(table(data[[variable]]))
+        rv$data_grid <- grid
+      })
+
+      observeEvent(input$sort_levels, {
+        if (input$sort_levels %% 2 == 1) {
+          decreasing <- FALSE
+          label <- tagList(
+            ph("sort-descending"),
+            "Sort Levels"
+          )
+        } else {
+          decreasing <- TRUE
+          label <- tagList(
+            ph("sort-ascending"),
+            "Sort Levels"
+          )
+        }
+        updateActionButton(inputId = "sort_levels", label = as.character(label))
+        rv$data_grid <- rv$data_grid[order(rv$data_grid[[1]], decreasing = decreasing), ]
+      })
+
+      observeEvent(input$sort_occurrences, {
+        if (input$sort_occurrences %% 2 == 1) {
+          decreasing <- FALSE
+          label <- tagList(
+            ph("sort-descending"),
+            i18n("Sort count")
+          )
+        } else {
+          decreasing <- TRUE
+          label <- tagList(
+            ph("sort-ascending"),
+            i18n("Sort count")
+          )
+        }
+        updateActionButton(inputId = "sort_occurrences", label = as.character(label))
+        rv$data_grid <- rv$data_grid[order(rv$data_grid[[2]], decreasing = decreasing), ]
+      })
+
+
+      output$grid <- renderDatagrid({
+        req(rv$data_grid)
+        gridTheme <- getOption("datagrid.theme")
+        if (length(gridTheme) < 1) {
+          datamods:::apply_grid_theme()
+        }
+        on.exit(toastui::reset_grid_theme())
+        data <- rv$data_grid
+        data <- add_var_toset(data, "Var1", "New label")
+
+        grid <- datagrid(
+          data = data,
+          draggable = TRUE,
+          sortable = FALSE,
+          data_as_input = TRUE
+        )
+        grid <- grid_columns(
+          grid,
+          columns = c("Var1", "Var1_toset", "Freq"),
+          header = c(i18n("Levels"), "New label", i18n("Count"))
+        )
+        grid <- grid_colorbar(
+          grid,
+          column = "Freq",
+          label_outside = TRUE,
+          label_width = "30px",
+          background = "#D8DEE9",
+          bar_bg = datamods:::get_primary_color(),
+          from = c(0, max(rv$data_grid$Freq) + 1)
+        )
+        grid <- toastui::grid_style_column(
+          grid = grid,
+          column = "Var1_toset",
+          fontStyle = "italic"
+        )
+        grid <- toastui::grid_editor(
+          grid = grid,
+          column = "Var1_toset",
+          type = "text"
+        )
+        grid
+      })
+
+      data_updated_r <- reactive({
+        data <- req(data_r())
+        variable <- req(input$variable)
+        grid <- req(input$grid_data)
+        name_var <- if (isTRUE(input$new_var)) {
+          paste0(variable, "_updated")
+        } else {
+          variable
+        }
+        data[[name_var]] <- factor(
+          as.character(data[[variable]]),
+          levels = grid[["Var1"]]
+        )
+        data[[name_var]] <- factor(
+          data[[variable]],
+          labels = ifelse(grid[["Var1_toset"]]=="New label",grid[["Var1"]],grid[["Var1_toset"]])
+        )
+        data
+      })
+
+      data_returned_r <- observeEvent(input$create, {
+        rv$data <- data_updated_r()
+      })
+      return(reactive(rv$data))
+    }
+  )
+}
+
+
+
+#' @inheritParams shiny::modalDialog
+#' @export
+#'
+#' @importFrom shiny showModal modalDialog textInput
+#' @importFrom htmltools tagList
+#'
+#' @rdname update-factor
+modal_update_factor <- function(id,
+                                title = i18n("Update levels of a factor"),
+                                easyClose = TRUE,
+                                size = "l",
+                                footer = NULL) {
+  ns <- NS(id)
+  showModal(modalDialog(
+    title = tagList(title, datamods:::button_close_modal()),
+    update_factor_ui(id),
+    tags$div(
+      style = "display: none;",
+      textInput(inputId = ns("hidden"), label = NULL, value = datamods:::genId())
+    ),
+    easyClose = easyClose,
+    size = size,
+    footer = footer
+  ))
+}
+
+
+#' @inheritParams shinyWidgets::WinBox
+#' @export
+#'
+#' @importFrom shinyWidgets WinBox wbOptions wbControls
+#' @importFrom htmltools tagList
+#' @rdname create-column
+winbox_update_factor <- function(id,
+                                 title = i18n("Update levels of a factor"),
+                                 options = shinyWidgets::wbOptions(),
+                                 controls = shinyWidgets::wbControls()) {
+  ns <- NS(id)
+  WinBox(
+    title = title,
+    ui = tagList(
+      update_factor_ui(id),
+      tags$div(
+        style = "display: none;",
+        textInput(inputId = ns("hidden"), label = NULL, value = genId())
+      )
+    ),
+    options = modifyList(
+      shinyWidgets::wbOptions(height = "615px", modal = TRUE),
+      options
+    ),
+    controls = controls,
+    auto_height = FALSE
+  )
+}
+

R/update-variables-ext.R

@@ -367,8 +367,8 @@ summary_vars <- function(data) {
     name = names(data),
     label = lapply(data, \(.x) REDCapCAST::get_attr(.x, "label")) |> unlist(),
     class = get_classes(data),
-    # n_missing = unname(colSums(is.na(data))),
+    n_missing = unname(colSums(is.na(data))),
-    # p_complete = 1 - n_missing / nrow(data),
+    p_complete = 1 - n_missing / nrow(data),
     n_unique = get_n_unique(data)
   )
 
@@ -440,11 +440,11 @@ update_variables_datagrid <- function(data, height = NULL, selectionId = NULL, b
     minWidth = 100
   )
 
-  # grid <- toastui::grid_format(
+  grid <- toastui::grid_format(
-  #   grid = grid,
+    grid = grid,
-  #   "p_complete",
+    "p_complete",
-  #   formatter = toastui::JS("function(obj) {return (obj.value*100).toFixed(0) + '%';}")
+    formatter = toastui::JS("function(obj) {return (obj.value*100).toFixed(0) + '%';}")
-  # )
+  )
   grid <- toastui::grid_style_column(
     grid = grid,
     column = "name_toset",

ROADMAP.md

@@ -26,11 +26,9 @@ Below are some (the actual list is quite long and growing) of the planned featur
 
     -   [ ] Select analyses to include in report
 
--   [ ] Plot regression analyses results
-
 -   [x] Export modified data. 2025-01-16
 
--   [ ] Include reproducible code for all steps
+-   [ ] Include reproducible code for all steps (maybe not all, but most steps, and the final dataset can be exported)
 
 -   [x] ~~Modify factor levels~~ Factor level modifications is possible through converting factors to numeric > cutting numeric with desired fixed values. 2024-12-12
 
@@ -38,8 +36,8 @@ Below are some (the actual list is quite long and growing) of the planned featur
 
 -   Graphs and plots
 
-    - [ ] Correlation matrix plot for data exploration
+    - [x] Correlation matrix plot for data exploration 2025-2-20
     
     - [ ] Grotta bars for ordianl outcomes
     
-    - [ ] Coefficient plotting for regression analyses (forest plot)
+    - [x] Coefficient plotting for regression analyses (forest plot) 2025-2-20

_pkgdown.yml

@@ -13,12 +13,15 @@ template:
 navbar:
   bg: primary
   structure:
-    left:  [intro, reference, roadmap, news]
+    left:  [intro, reference, roadmap, q_a, news]
     right: [search, github]
   components:
     roadmap:
       text: Roadmap
       href: ROADMAP.md
+    q_a:
+      text: Q&A
+      href: QA.md
 
 includes:
   in_header: umami-page.html

examples/visuals_module_demo.R

@@ -0,0 +1,32 @@
+visuals_demo_app <- function() {
+  ui <- bslib::page_fixed(
+    do.call(
+      bslib::navset_bar,
+      c(
+        data_visuals_ui("visuals"),
+        shiny::tagList(
+          bslib::nav_spacer(),
+          bslib::nav_panel(
+            title = "Notes",
+            shiny::fluidRow(
+              shiny::column(width = 2),
+              shiny::column(
+                width = 8,
+                shiny::markdown("Look, it **works**!"),
+                shiny::column(width = 2)
+              )
+            )
+          )
+        )
+      )
+    )
+  )
+  server <- function(input, output, session) {
+    pl <- data_visuals_server("visuals", data = shiny::reactive(default_parsing(mtcars)))
+  }
+  shiny::shinyApp(ui, server)
+}
+
+if (FALSE){
+visuals_demo_app()
+}

inst/apps/data_analysis/server.R

@@ -1,315 +0,0 @@
-
-library(readr)
-library(MASS)
-library(stats)
-library(gtsummary)
-library(gt)
-library(openxlsx2)
-library(haven)
-library(readODS)
-library(shiny)
-library(bslib)
-library(assertthat)
-library(dplyr)
-library(quarto)
-library(here)
-library(broom)
-library(broom.helpers)
-# library(REDCapCAST)
-library(easystats)
-library(patchwork)
-library(DHARMa)
-# if (!requireNamespace("webResearch")) {
-#   devtools::install_github("agdamsbo/webResearch", quiet = TRUE, upgrade = "never")
-# }
-# library(webResearch)
-
-if (file.exists(here::here("functions.R"))) {
-  source(here::here("functions.R"))
-}
-
-server <- function(input, output, session) {
-  ## Listing files in www in session start to keep when ending and removing
-  ## everything else.
-  files.to.keep <- list.files("www/")
-
-  v <- shiny::reactiveValues(
-    list = NULL,
-    ds = NULL,
-    input = exists("webResearch_data"),
-    local_temp = NULL,
-    quarto = NULL,
-    test = "no"
-  )
-
-  test_data <- shiny::eventReactive(input$test_data, {
-    v$test <- "test"
-  })
-
-  ds <- shiny::reactive({
-    # input$file1 will be NULL initially. After the user selects
-    # and uploads a file, head of that data file by default,
-    # or all rows if selected, will be shown.
-    if (v$input) {
-      out <- webResearch_data
-    } else if (v$test == "test") {
-      out <- gtsummary::trial
-    } else {
-      shiny::req(input$file)
-      out <- read_input(input$file$datapath)
-    }
-
-    v$ds <- "present"
-    if (input$factorize == "yes") {
-      out <- out |>
-        (\(.x){
-          suppressWarnings(
-            REDCapCAST::numchar2fct(.x)
-          )
-        })()
-    }
-    return(out)
-  })
-
-  output$include_vars <- shiny::renderUI({
-    selectizeInput(
-      inputId = "include_vars",
-      selected = NULL,
-      label = "Covariables to include",
-      choices = colnames(ds()),
-      multiple = TRUE
-    )
-  })
-
-  output$outcome_var <- shiny::renderUI({
-    selectInput(
-      inputId = "outcome_var",
-      selected = NULL,
-      label = "Select outcome variable",
-      choices = colnames(ds()),
-      multiple = FALSE
-    )
-  })
-
-  output$strat_var <- shiny::renderUI({
-    selectInput(
-      inputId = "strat_var",
-      selected = "none",
-      label = "Select variable to stratify baseline",
-      choices = c("none", colnames(ds()[base_vars()])),
-      multiple = FALSE
-    )
-  })
-
-  output$factor_vars <- shiny::renderUI({
-    selectizeInput(
-      inputId = "factor_vars",
-      selected = colnames(ds())[sapply(ds(), is.factor)],
-      label = "Covariables to format as categorical",
-      choices = colnames(ds()),
-      multiple = TRUE
-    )
-  })
-
-  base_vars <- shiny::reactive({
-    if (is.null(input$include_vars)) {
-      out <- colnames(ds())
-    } else {
-      out <- unique(c(input$include_vars, input$outcome_var))
-    }
-    return(out)
-  })
-
-  output$data.input <-
-    DT::renderDT({
-      shiny::req(input$file)
-      ds()[base_vars()]
-    })
-
-  output$data.classes <- gt::render_gt({
-    shiny::req(input$file)
-    data.frame(matrix(sapply(ds(), \(.x){
-      class(.x)[1]
-    }), nrow = 1)) |>
-      stats::setNames(names(ds())) |>
-      gt::gt()
-  })
-
-
-
-  shiny::observeEvent(
-    {
-      input$load
-    },
-    {
-      shiny::req(input$outcome_var)
-
-      # Assumes all character variables can be formatted as factors
-      data <- ds() |>
-        dplyr::mutate(dplyr::across(dplyr::where(is.character), as.factor))
-
-      data <- data |> factorize(vars = input$factor_vars)
-
-      # if (is.factor(data[[input$strat_var]])) {
-      #   by.var <- input$strat_var
-      # } else {
-      #   by.var <- NULL
-      # }
-
-      if (input$strat_var == "none") {
-        by.var <- NULL
-      } else {
-        by.var <- input$strat_var
-      }
-
-      data <- data[base_vars()]
-
-      # model <- data |>
-      #   regression_model(
-      #     outcome.str = input$outcome_var,
-      #     auto.mode = input$regression_auto == 1,
-      #     formula.str = input$regression_formula,
-      #     fun = input$regression_fun,
-      #     args.list = eval(parse(text = paste0("list(", input$regression_args, ")")))
-      #   )
-
-      models <- list(
-        "Univariable" = regression_model_uv,
-        "Multivariable" = regression_model
-      ) |>
-        lapply(\(.fun){
-          do.call(
-            .fun,
-            c(
-              list(data = data),
-              list(outcome.str = input$outcome_var),
-              list(formula.str = input$regression_formula),
-              list(fun = input$regression_fun),
-              list(args.list = eval(parse(text = paste0("list(", input$regression_args, ")"))))
-            )
-          )
-        })
-
-      # browser()
-      # check <- performance::check_model(purrr::pluck(models,"Multivariable") |>
-      #                                     (\(x){
-      #                                       class(x) <- class(x)[class(x) != "webresearch_model"]
-      #                                       return(x)
-      #                                     })())
-
-      check <- purrr::pluck(models, "Multivariable") |>
-        performance::check_model()
-
-
-      v$list <- list(
-        data = data,
-        check = check,
-        table1 = data |>
-          baseline_table(
-            fun.args =
-              list(
-                by = by.var
-              )
-          ) |>
-          (\(.x){
-            if (!is.null(by.var)) {
-              .x |> gtsummary::add_overall()
-            } else {
-              .x
-            }
-          })() |>
-          (\(.x){
-            if (input$add_p == "yes") {
-              .x |>
-                gtsummary::add_p() |>
-                gtsummary::bold_p()
-            } else {
-              .x
-            }
-          })(),
-        table2 = models |>
-          purrr::map(regression_table) |>
-          tbl_merge(),
-        input = input
-      )
-
-      output$table1 <- gt::render_gt(
-        v$list$table1 |>
-          gtsummary::as_gt()
-      )
-
-      output$table2 <- gt::render_gt(
-        v$list$table2 |>
-          gtsummary::as_gt()
-      )
-
-      output$check <- shiny::renderPlot({
-        p <- plot(check) +
-          patchwork::plot_annotation(title = "Multivariable regression model checks")
-        p
-        # Generate checks in one column
-        # layout <- sapply(seq_len(length(p)), \(.x){
-        #   patchwork::area(.x, 1)
-        # })
-        #
-        # p + patchwork::plot_layout(design = Reduce(c, layout))
-
-        # patchwork::wrap_plots(ncol=1) +
-        # patchwork::plot_annotation(title = 'Multivariable regression model checks')
-      })
-    }
-  )
-
-
-
-
-  output$uploaded <- shiny::reactive({
-    if (is.null(v$ds)) {
-      "no"
-    } else {
-      "yes"
-    }
-  })
-
-  shiny::outputOptions(output, "uploaded", suspendWhenHidden = FALSE)
-
-  output$has_input <- shiny::reactive({
-    if (v$input) {
-      "yes"
-    } else {
-      "no"
-    }
-  })
-
-  shiny::outputOptions(output, "has_input", suspendWhenHidden = FALSE)
-
-  # Could be rendered with other tables or should show progress
-  # Investigate quarto render problems
-  # On temp file handling: https://github.com/quarto-dev/quarto-cli/issues/3992
-  output$report <- downloadHandler(
-    filename = shiny::reactive({
-      paste0("report.", input$output_type)
-    }),
-    content = function(file, type = input$output_type) {
-      ## Notification is not progressing
-      ## Presumably due to missing
-      shiny::withProgress(message = "Generating report. Hold on for a moment..", {
-        v$list |>
-          write_quarto(
-            output_format = type,
-            input = file.path(getwd(), "www/report.qmd")
-          )
-      })
-      file.rename(paste0("www/report.", type), file)
-    }
-  )
-
-  session$onSessionEnded(function() {
-    cat("Session Ended\n")
-    files <- list.files("www/")
-    lapply(files[!files %in% files.to.keep], \(.x){
-      unlink(paste0("www/", .x), recursive = FALSE)
-      print(paste(.x, "deleted"))
-    })
-  })
-}

inst/apps/data_analysis/ui.R

@@ -1,212 +0,0 @@
-library(shiny)
-library(bslib)
-library(IDEAFilter)
-library(teal)
-requireNamespace("gt")
-
-panels <- list(
-  bslib::nav_panel(
-    title = "Data overview",
-    # shiny::uiOutput("data.classes"),
-    # shiny::uiOutput("data.input"),
-    # shiny::p("Classes of uploaded data"),
-    # gt::gt_output("data.classes"),
-    shiny::p("Subset data"),
-    DT::DTOutput("data.input")
-      ),
-  bslib::nav_panel(
-    title = "Baseline characteristics",
-    gt::gt_output(outputId = "table1")
-  ),
-  bslib::nav_panel(
-    title = "Regression table",
-    gt::gt_output(outputId = "table2")
-  ),
-  bslib::nav_panel(
-    title = "Regression checks",
-    shiny::plotOutput(outputId = "check")
-  )
-)
-
-ui <- bslib::page(
-  theme = bslib::bs_theme(
-    bootswatch = "minty",
-    base_font = font_google("Inter"),
-    code_font = font_google("JetBrains Mono")
-  ),
-  title = "webResearcher for easy data analysis",
-  bslib::page_navbar(
-    title = "webResearcher",
-    header = h6("Welcome to the webResearcher tool. This is an early alpha version to act as a proof-of-concept and in no way intended for wider public use."),
-    sidebar = bslib::sidebar(
-      width = 300,
-      open = "open",
-      shiny::h4("Upload your dataset"),
-      shiny::conditionalPanel(
-        condition = "output.has_input=='yes'",
-        # Input: Select a file ----
-        shiny::helpText("Analyses are performed on provided data")
-      ),
-      shiny::conditionalPanel(
-        condition = "output.has_input=='no'",
-        # Input: Select a file ----
-        shiny::fileInput(
-          inputId = "file",
-          label = "Choose data file",
-          multiple = FALSE,
-          accept = c(
-            ".csv",
-            ".xlsx",
-            ".xls",
-            ".dta",
-            ".ods",
-            ".rds"
-          )
-        ),
-        # Does not work??
-        #   shiny::actionButton(inputId = "test_data",
-        #                       label = "Load test data", class = "btn-primary")
-      ),
-      shiny::conditionalPanel(
-        condition = "output.uploaded=='yes'",
-        shiny::h4("Parameter specifications"),
-        shiny::radioButtons(
-          inputId = "factorize",
-          label = "Factorize variables with few levels?",
-          selected = "yes",
-          inline = TRUE,
-          choices = list(
-            "Yes" = "yes",
-            "No" = "no"
-          )
-        ),
-        shiny::radioButtons(
-          inputId = "regression_auto",
-          label = "Automatically choose function",
-          inline = TRUE,
-          choiceNames = c(
-            "Yes",
-            "No"
-          ),
-          choiceValues = c(1, 2)
-        ),
-        shiny::conditionalPanel(
-          condition = "input.regression_auto==2",
-          shiny::textInput(
-            inputId = "regression_formula",
-            label = "Formula string to render with 'glue::glue'",
-            value = NULL
-          ),
-          shiny::textInput(
-            inputId = "regression_fun",
-            label = "Function to use for analysis (needs pasckage and name)",
-            value = "stats::lm"
-          ),
-          shiny::textInput(
-            inputId = "regression_args",
-            label = "Arguments to pass to the function (provided as a string)",
-            value = ""
-          )
-        ),
-        shiny::helpText(em("Please specify relevant settings for your data, and press 'Analyse'")),
-        shiny::uiOutput("outcome_var"),
-        shiny::uiOutput("strat_var"),
-        shiny::conditionalPanel(
-          condition = "input.strat_var!='none'",
-          shiny::radioButtons(
-            inputId = "add_p",
-            label = "Compare strata?",
-            selected = "no",
-            inline = TRUE,
-            choices = list(
-              "No" = "no",
-              "Yes" = "yes"
-            )
-          ),
-          shiny::helpText("Option to perform statistical comparisons between strata in baseline table.")
-        ),
-        shiny::radioButtons(
-          inputId = "all",
-          label = "Specify covariables",
-          inline = TRUE, selected = 2,
-          choiceNames = c(
-            "Yes",
-            "No"
-          ),
-          choiceValues = c(1, 2)
-        ),
-        shiny::conditionalPanel(
-          condition = "input.all==1",
-          shiny::uiOutput("include_vars")
-        ),
-        shiny::radioButtons(
-          inputId = "specify_factors",
-          label = "Specify categorical variables?",
-          selected = "no",
-          inline = TRUE,
-          choices = list(
-            "Yes" = "yes",
-            "No" = "no"
-          )
-        ),
-        shiny::conditionalPanel(
-          condition = "input.specify_factors=='yes'",
-          shiny::uiOutput("factor_vars")
-        ),
-        bslib::input_task_button(
-          id = "load",
-          label = "Analyse",
-          icon = shiny::icon("pencil", lib = "glyphicon"),
-          label_busy = "Working...",
-          icon_busy = fontawesome::fa_i("arrows-rotate",
-            class = "fa-spin",
-            "aria-hidden" = "true"
-          ),
-          type = "primary",
-          auto_reset = TRUE
-        ),
-        shiny::helpText("If you change the parameters, press 'Analyse' again to update the tables"),
-        # shiny::actionButton("load", "Analyse", class = "btn-primary"),
-        #
-        # # Horizontal line ----
-        tags$hr(),
-        shiny::conditionalPanel(
-          condition = "input.load",
-          h4("Download results"),
-          shiny::helpText("Choose your favourite output file format for further work."),
-          shiny::selectInput(
-            inputId = "output_type",
-            label = "Choose your desired output format",
-            selected = NULL,
-            choices = list(
-              "Word" = "docx",
-              "LibreOffice" = "odt"
-              # ,
-              # "PDF" = "pdf",
-              # "All the above" = "all"
-            )
-          ),
-
-          # Button
-          downloadButton(
-            outputId = "report",
-            label = "Download",
-            icon = shiny::icon("download")
-          )
-        )
-      )
-    ),
-    bslib::nav_spacer(),
-    panels[[1]],
-    panels[[2]],
-    panels[[3]],
-    panels[[4]]
-
-    # layout_columns(
-    #   cards[[1]]
-    # ),
-    # layout_columns(
-    #   cards[[2]], cards[[3]]
-    # )
-  )
-)

inst/apps/data_analysis/www/report.qmd

@@ -1,68 +0,0 @@
----
-format: 
-  html:
-    embed-resources: true
-title: "webResearch analysis results"
-date: today
-author: webResearch Tool
-toc: true
-execute: 
-  echo: false
-params:
-  data.file: NA
----
-
-```{r setup}
-web_data <- readr::read_rds(file = params$data.file)
-library(gtsummary)
-library(gt)
-library(easystats)
-library(patchwork)
-# library(webResearch)
-```
-
-## Introduction
-
-Research should be free and open with easy access for all. The webResearch tool attempts to help lower the bar to participate in contributing to science.
-
-## Methods
-
-Analyses were conducted in R version `r paste(version["major"],version["minor"],sep=".")`.
-
-## Results
-
-Below is the baseline characteristics plotted.
-
-```{r}
-#| label: tbl-baseline
-#| tbl-cap: Baseline characteristics of included data
-web_data$table1
-```
-
-Here are the regression results.
-
-```{r}
-#| label: tbl-regression
-#| tbl-cap: Regression analysis results
-web_data$table2
-```
-
-## Discussion
-
-Good luck on your further work!
-
-## Sensitivity
-
-Here are the results from testing the regression model:
-
-
-```{r}
-#| label: tbl-checks
-#| fig-cap: Regression analysis checks
-#| fig-height: 8
-#| fig-width: 6
-#| fig-dpi: 600
-
-plot(web_data$check)
-
-```

inst/apps/data_analysis_modules/rsconnect/shinyapps.io/agdamsbo/webResearch.dcf

@@ -1,10 +0,0 @@
-name: webResearch
-title:
-username: agdamsbo
-account: agdamsbo
-server: shinyapps.io
-hostUrl: https://api.shinyapps.io/v1
-appId: 13276335
-bundleId: 9436643
-url: https://agdamsbo.shinyapps.io/webResearch/
-version: 1

inst/apps/freesearcheR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf

@@ -5,6 +5,6 @@ account: agdamsbo
 server: shinyapps.io
 hostUrl: https://api.shinyapps.io/v1
 appId: 13611288
-bundleId: 9765526
+bundleId: 9852208
 url: https://agdamsbo.shinyapps.io/freesearcheR/
 version: 1

inst/apps/freesearcheR/server.R

@@ -15,6 +15,7 @@ library(broom)
 library(broom.helpers)
 # library(REDCapCAST)
 library(easystats)
+library(esquisse)
 library(patchwork)
 library(DHARMa)
 library(apexcharter)
@@ -81,7 +82,8 @@ server <- function(input, output, session) {
     data_original = NULL,
     data = NULL,
     data_filtered = NULL,
-    models = NULL
+    models = NULL,
+    code = list()
   )
 
   ##############################################################################
@@ -99,23 +101,48 @@ server <- function(input, output, session) {
     return_class = "data.frame",
     read_fns = list(
       ods = function(file) {
-        readODS::read_ods(path = file, na = consider.na)
+        readODS::read_ods(
+          path = file,
+          # Sheet and skip not implemented for .ods in the original implementation
+          # sheet = sheet,
+          # skip = skip,
+          na = consider.na
+        )
       },
       dta = function(file) {
-        haven::read_dta(file = file, .name_repair = "unique_quiet")
+        haven::read_dta(
+          file = file,
+          .name_repair = "unique_quiet"
+          )
       },
       csv = function(file) {
-        readr::read_csv(file = file, na = consider.na, name_repair = "unique_quiet") #|>
+        readr::read_csv(
-          # janitor::remove_empty(which = "cols", cutoff = 1, quiet = TRUE)
+          file = file,
+          na = consider.na,
+          name_repair = "unique_quiet"
+          )
+      },
+      xls = function(file) {
+        openxlsx2::read_xlsx(
+          file = file,
+          sheet = sheet,
+          skip_empty_rows = TRUE,
+          start_row = skip - 1,
+          na.strings = consider.na
+          )
+      },
+      xlsx = function(file) {
+        openxlsx2::read_xlsx(
+          file = file,
+          sheet = sheet,
+          skip_empty_rows = TRUE,
+          start_row = skip - 1,
+          na.strings = consider.na)
       },
-      # xls = function(file){
-      #   openxlsx2::read_xlsx(file = file, na.strings = consider.na,)
-      # },
-      # xlsx = function(file){
-      #   openxlsx2::read_xlsx(file = file, na.strings = consider.na,)
-      # },
       rds = function(file) {
-        readr::read_rds(file = file, name_repair = "unique_quiet")
+        readr::read_rds(
+          file = file,
+          name_repair = "unique_quiet")
       }
     )
   )
@@ -123,6 +150,7 @@ server <- function(input, output, session) {
   shiny::observeEvent(data_file$data(), {
     shiny::req(data_file$data())
     rv$data_original <- data_file$data()
+    rv$code <- append_list(data = data_file$code(), list = rv$code, index = "import")
   })
 
   data_redcap <- m_redcap_readServer(
@@ -143,7 +171,7 @@ server <- function(input, output, session) {
     server = TRUE
   )
 
-  from_env <- import_globalenv_server(
+  from_env <- datamods::import_globalenv_server(
     id = "env",
     trigger_return = "change",
     btn_show_data = FALSE,
@@ -153,6 +181,7 @@ server <- function(input, output, session) {
   shiny::observeEvent(from_env$data(), {
     shiny::req(from_env$data())
     rv$data_original <- from_env$data()
+    # rv$code <- append_list(data = from_env$code(),list = rv$code,index = "import")
   })
 
 
@@ -214,12 +243,14 @@ server <- function(input, output, session) {
 
   shiny::observeEvent(
     input$modal_cut,
-    modal_cut_variable("modal_cut")
+    modal_cut_variable("modal_cut",title = "Modify factor levels")
   )
+
   data_modal_cut <- cut_variable_server(
     id = "modal_cut",
     data_r = shiny::reactive(rv$data)
   )
+
   shiny::observeEvent(data_modal_cut(), rv$data <- data_modal_cut())
 
   #########  Modify factor
@@ -228,10 +259,12 @@ server <- function(input, output, session) {
     input$modal_update,
     datamods::modal_update_factor(id = "modal_update")
   )
+
   data_modal_update <- datamods::update_factor_server(
     id = "modal_update",
     data_r = reactive(rv$data)
   )
+
   shiny::observeEvent(data_modal_update(), {
     shiny::removeModal()
     rv$data <- data_modal_update()
@@ -257,25 +290,26 @@ server <- function(input, output, session) {
   #########  Show result
   tryCatch(
     {
-  output$table_mod <- toastui::renderDatagrid({
+      output$table_mod <- toastui::renderDatagrid({
-    shiny::req(rv$data)
+        shiny::req(rv$data)
-    # data <- rv$data
+        # data <- rv$data
-    toastui::datagrid(
+        toastui::datagrid(
-      # data = rv$data # ,
+          # data = rv$data # ,
-      data = data_filter(),
+          data = data_filter(),
-      pagination = 10
+          pagination = 10
-      # bordered = TRUE,
+          # bordered = TRUE,
-      # compact = TRUE,
+          # compact = TRUE,
-      # striped = TRUE
+          # striped = TRUE
-    )
+        )
-  })
+      })
     },
-  warning = function(warn) {
+    warning = function(warn) {
-    showNotification(paste0(warn), type = "warning")
+      showNotification(paste0(warn), type = "warning")
-  },
+    },
-  error = function(err) {
+    error = function(err) {
-    showNotification(paste0(err), type = "err")
+      showNotification(paste0(err), type = "err")
-  })
+    }
+  )
 
   output$code <- renderPrint({
     attr(rv$data, "code")
@@ -312,46 +346,78 @@ server <- function(input, output, session) {
       shiny::reactive(rv$data),
       shiny::reactive(rv$data_original),
       data_filter(),
-      base_vars(),
+      regression_vars(),
       input$complete_cutoff
     ),
     {
       rv$data_filtered <- data_filter()
 
       rv$list$data <- data_filter() |>
-        REDCapCAST::fct_drop() |>
+        REDCapCAST::fct_drop()
-        (\(.x){
-          .x[base_vars()]
-        })() #|>
-      # janitor::remove_empty(
-      #   which = "cols",
-      #   cutoff = input$complete_cutoff / 100
-      # )
     }
   )
 
-  output$filtered_code <- shiny::renderPrint({
+  shiny::observeEvent(
-    out <- gsub(
+    list(
-      "filter", "dplyr::filter",
+      shiny::reactive(rv$data),
-      gsub(
+      shiny::reactive(rv$data_original),
-        "\\s{2,}", " ",
+      data_filter(),
-        paste0(
+      shiny::reactive(rv$data_filtered)
-          capture.output(attr(rv$data_filtered, "code")),
+    ),
-          collapse = " "
+    {
+      out <- gsub(
+        "filter", "dplyr::filter",
+        gsub(
+          "\\s{2,}", " ",
+          paste0(
+            capture.output(attr(rv$data_filtered, "code")),
+            collapse = " "
+          )
         )
       )
-    )
 
-    out <- strsplit(out, "%>%") |>
+      out <- strsplit(out, "%>%") |>
-      unlist() |>
+        unlist() |>
-      (\(.x){
+        (\(.x){
-        paste(c("data", .x[-1]), collapse = "|> \n ")
+          paste(c("data", .x[-1]), collapse = "|> \n ")
-      })()
+        })()
 
-    cat(out)
+      rv$code <- append_list(data = out, list = rv$code, index = "filter")
+    }
+  )
+
+  # output$filtered_code <- shiny::renderPrint({
+  #   out <- gsub(
+  #     "filter", "dplyr::filter",
+  #     gsub(
+  #       "\\s{2,}", " ",
+  #       paste0(
+  #         capture.output(attr(rv$data_filtered, "code")),
+  #         collapse = " "
+  #       )
+  #     )
+  #   )
+  #
+  #   out <- strsplit(out, "%>%") |>
+  #     unlist() |>
+  #     (\(.x){
+  #       paste(c("data", .x[-1]), collapse = "|> \n ")
+  #     })()
+  #
+  #   cat(out)
+  # })
+
+  output$code_import <- shiny::renderPrint({
+    cat(rv$code$import)
+    })
+
+  output$code_data <- shiny::renderPrint({
+    attr(rv$data, "code")
   })
 
-
+  output$code_filter <- shiny::renderPrint({
+    cat(rv$code$filter)
+  })
 
   ##############################################################################
   #########
@@ -410,7 +476,8 @@ server <- function(input, output, session) {
     )
   })
 
-  base_vars <- shiny::reactive({
+  ## Collected regression variables
+  regression_vars <- shiny::reactive({
     if (is.null(input$include_vars)) {
       out <- colnames(rv$data_filtered)
     } else {
@@ -426,7 +493,7 @@ server <- function(input, output, session) {
       label = "Select variable to stratify baseline",
       choices = c(
         "none",
-        rv$data_filtered[base_vars()] |>
+        rv$data_filtered |>
           (\(.x){
             lapply(.x, \(.c){
               if (identical("factor", class(.c))) {
@@ -520,7 +587,7 @@ server <- function(input, output, session) {
       choices = c(
         colnames(rv$list$data)
         # ,"none"
-        ),
+      ),
       multiple = FALSE
     )
   })
@@ -533,17 +600,26 @@ server <- function(input, output, session) {
       gt::tab_header(gt::md("**Table 1: Baseline Characteristics**"))
   })
 
-  data_correlations_server(id = "correlations",
+  data_correlations_server(
-                           data = shiny::reactive({
+    id = "correlations",
-                             out <- dplyr::select(rv$list$data,-!!input$outcome_var_cor)
+    data = shiny::reactive({
-                             #  input$outcome_var_cor=="none"){
+      shiny::req(rv$list$data)
-                             #   out <- rv$list$data
+      out <- dplyr::select(rv$list$data, -!!input$outcome_var_cor)
-                             # }
+      #  input$outcome_var_cor=="none"){
-                             out
+      #   out <- rv$list$data
-                           }),
+      # }
-                           cutoff = shiny::reactive(input$cor_cutoff))
+      out
+    }),
+    cutoff = shiny::reactive(input$cor_cutoff)
+  )
 
+  ##############################################################################
+  #########
+  #########  Data visuals
+  #########
+  ##############################################################################
 
+  pl <- data_visuals_server("visuals", data = shiny::reactive(rv$data))
 
   ##############################################################################
   #########
@@ -572,7 +648,10 @@ server <- function(input, output, session) {
               ls <- do.call(
                 .fun,
                 c(
-                  list(data = rv$list$data),
+                  list(data = rv$list$data|>
+                         (\(.x){
+                           .x[regression_vars()]
+                         })()),
                   list(outcome.str = input$outcome_var),
                   list(fun.descr = input$regression_type)
                 )
@@ -865,7 +944,7 @@ server <- function(input, output, session) {
         readr::write_rds(rv$list$data, file = file)
       } else if (type == "dta") {
         haven::write_dta(as.data.frame(rv$list$data), path = file)
-      } else if (type == "csv"){
+      } else if (type == "csv") {
         readr::write_csv(rv$list$data, file = file)
       }
     }

inst/apps/freesearcheR/ui.R

@@ -8,7 +8,14 @@ ui_elements <- list(
   ##############################################################################
   "home" = bslib::nav_panel(
     title = "freesearcheR",
-    shiny::markdown(readLines("www/intro.md")),
+    shiny::fluidRow(
+      shiny::column(width = 2),
+      shiny::column(
+        width = 8,
+        shiny::markdown(readLines("www/intro.md")),
+        shiny::column(width = 2)
+      )
+    ),
     icon = shiny::icon("home")
   ),
   ##############################################################################
@@ -18,21 +25,22 @@ ui_elements <- list(
   ##############################################################################
   "import" = bslib::nav_panel(
     title = "Import",
+    shiny::fluidRow(
+      shiny::column(width = 2),
+      shiny::column(
+        width = 8,
+
+
     shiny::h4("Choose your data source"),
     shiny::br(),
     shinyWidgets::radioGroupButtons(
       inputId = "source",
       selected = "env",
-      # label = "Choice: ",
       choices = c(
         "File upload" = "file",
         "REDCap server" = "redcap",
         "Local data" = "env"
       ),
-      # checkIcon = list(
-      #   yes = icon("square-check"),
-      #   no = icon("square")
-      # ),
       width = "100%"
     ),
     shiny::helpText("Upload a file from your device, get data directly from REDCap or select a sample data set for testing from the app."),
@@ -60,14 +68,15 @@ ui_elements <- list(
     shiny::h5("Exclude in-complete variables"),
     shiny::p("Before going further, you can exclude variables with a low degree of completeness."),
     shiny::br(),
-    shiny::sliderInput(
+    shinyWidgets::noUiSliderInput(
       inputId = "complete_cutoff",
       label = "Choose completeness threshold (%)",
       min = 0,
       max = 100,
       step = 10,
       value = 70,
-      ticks = FALSE
+      format = shinyWidgets::wNumbFormat(decimals = 0),
+      color = datamods:::get_primary_color()
     ),
     shiny::helpText("Only include variables with completeness above a specified percentage."),
     shiny::br(),
@@ -80,7 +89,10 @@ ui_elements <- list(
     ),
     shiny::helpText('After importing, hit "Start" or navigate to the desired tab.'),
     shiny::br(),
-    shiny::br()
+    shiny::br(),
+    shiny::column(width = 2)
+      )
+    )
   ),
   ##############################################################################
   #########
@@ -94,75 +106,15 @@ ui_elements <- list(
       title = "Data",
       bslib::navset_bar(
         fillable = TRUE,
-        bslib::nav_panel(
-          title = "Summary & filter",
-          tags$h3("Data summary and filtering"),
-          fluidRow(
-            shiny::column(
-              width = 9,
-              shiny::tags$p(
-                "Below is a short summary table of the provided data.
-              On the right hand side you have the option to create filters.
-              At the bottom you'll find a raw overview of the original vs the modified data."
-              )
-            )
-          ),
-          fluidRow(
-            # column(
-            #   width = 3,
-            #   shiny::uiOutput("filter_vars"),
-            #   shiny::conditionalPanel(
-            #     condition = "(typeof input.filter_vars !== 'undefined' && input.filter_vars.length > 0)",
-            #     datamods::filter_data_ui("filtering", max_height = "500px")
-            #   )
-            # ),
-            # column(
-            #   width = 9,
-            #   DT::DTOutput(outputId = "filtered_table"),
-            #   tags$b("Code dplyr:"),
-            #   verbatimTextOutput(outputId = "filtered_code")
-            # ),
-            shiny::column(
-              width = 9,
-              data_summary_ui(id = "data_summary")
-            ),
-            shiny::column(
-              width = 3,
-              IDEAFilter::IDEAFilter_ui("data_filter"),
-              shiny::tags$br(),
-              shiny::tags$b("Filter code:"),
-              shiny::verbatimTextOutput(outputId = "filtered_code"),
-              shiny::tags$br()
-            )
-          ),
-          fluidRow(
-            column(
-              width = 6,
-              tags$b("Original data:"),
-              # verbatimTextOutput("original"),
-              verbatimTextOutput("original_str")
-            ),
-            column(
-              width = 6,
-              tags$b("Modified data:"),
-              # verbatimTextOutput("modified"),
-              verbatimTextOutput("modified_str")
-            )
-          )
-        ),
-        # bslib::nav_panel(
-        #   title = "Overview",
-        #   DT::DTOutput(outputId = "table")
-        # ),
         bslib::nav_panel(
           title = "Modify",
           tags$h3("Subset, rename and convert variables"),
           fluidRow(
             shiny::column(
               width = 9,
-              shiny::tags$p("Below, you can subset the data (select variables to include on clicking 'Apply changes'), rename variables, set new labels (for nicer tables in the report) and change variable classes (numeric, factor/categorical etc.).
+              shiny::tags$p(shiny::markdown("Below, you can subset the data (select variables to include on clicking 'Apply changes'), rename variables, set new labels (for nicer tables in the report) and change variable classes (numeric, factor/categorical etc.).
                             Italic text can be edited/changed.
-                            On the right, you can create and modify factor/categorical variables as well as resetting the data to the originally imported data.")
+                            On the right, you can create and modify factor/categorical variables as well as create new variables with *R* code."))
             )
           ),
           fluidRow(
@@ -199,17 +151,8 @@ ui_elements <- list(
                 width = "100%"
               ),
               shiny::tags$br(),
-              shiny::helpText("Create a new variable/column based on an R-expression."),
+              shiny::helpText(shiny::markdown("Create a new variable/column based on an *R*-expression.")),
               shiny::tags$br(),
-              shiny::tags$br(),
-              tags$h4("Restore"),
-              shiny::actionButton(
-                inputId = "data_reset",
-                label = "Restore original data",
-                width = "100%"
-              ),
-              shiny::tags$br(),
-              shiny::helpText("Reset to original imported dataset. Careful! There is no un-doing."),
               shiny::tags$br() # ,
               # shiny::tags$br(),
               # shiny::tags$br(),
@@ -220,10 +163,88 @@ ui_elements <- list(
           )
         ),
         bslib::nav_panel(
-          title = "Browser",
+          title = "Filter",
+          tags$h3("Data filtering"),
+          fluidRow(
+            shiny::column(
+              width = 9,
+              shiny::tags$p(
+                "Below is a short summary table of the provided data.
+              On the right hand side you have the option to create filters.
+              At the bottom you'll find a raw overview of the original vs the modified data."
+              )
+            )
+          ),
+          fluidRow(
+            # column(
+            #   width = 3,
+            #   shiny::uiOutput("filter_vars"),
+            #   shiny::conditionalPanel(
+            #     condition = "(typeof input.filter_vars !== 'undefined' && input.filter_vars.length > 0)",
+            #     datamods::filter_data_ui("filtering", max_height = "500px")
+            #   )
+            # ),
+            # column(
+            #   width = 9,
+            #   DT::DTOutput(outputId = "filtered_table"),
+            #   tags$b("Code dplyr:"),
+            #   verbatimTextOutput(outputId = "filtered_code")
+            # ),
+            shiny::column(
+              width = 9,
+              data_summary_ui(id = "data_summary")
+            ),
+            shiny::column(
+              width = 3,
+              IDEAFilter::IDEAFilter_ui("data_filter"),
+              # shiny::tags$br(),
+              # shiny::tags$b("Filter code:"),
+              # shiny::verbatimTextOutput(outputId = "filtered_code"),
+              shiny::tags$br()
+            )
+          )
+        ),
+        bslib::nav_panel(
+          title = "Restore",
+          tags$h3("Compare to original and restore"),
+          fluidRow(
+            shiny::column(
+              width = 9,
+              shiny::tags$p(
+                "Right below, you have the option to restore to the originally imported data.
+                At the bottom you'll find a raw overview of the original vs the modified data."
+              )
+            ),
+            shiny::tags$br(),
+            tags$h4("Restore"),
+            shiny::actionButton(
+              inputId = "data_reset",
+              label = "Restore original data",
+              width = "100%"
+            ),
+            shiny::tags$br(),
+            shiny::helpText("Reset to original imported dataset. Careful! There is no un-doing.")
+          ),
+          fluidRow(
+            column(
+              width = 6,
+              tags$b("Original data:"),
+              # verbatimTextOutput("original"),
+              verbatimTextOutput("original_str")
+            ),
+            column(
+              width = 6,
+              tags$b("Modified data:"),
+              # verbatimTextOutput("modified"),
+              verbatimTextOutput("modified_str")
+            )
+          )
+        ),
+        bslib::nav_panel(
+          title = "Browse",
           tags$h3("Browse the provided data"),
           shiny::tags$p(
-            "Below is a data table with all the modified data provided to browse and understand data."
+            "Below is a table with all the modified data provided to browse and understand data."
           ),
           shinyWidgets::html_dependency_winbox(),
           # fluidRow(
@@ -323,14 +344,15 @@ ui_elements <- list(
               shiny::uiOutput("outcome_var_cor"),
               shiny::helpText("This variable will be excluded from the correlation plot."),
               shiny::br(),
-              shiny::sliderInput(
+              shinyWidgets::noUiSliderInput(
                 inputId = "cor_cutoff",
                 label = "Correlation cut-off",
                 min = 0,
                 max = 1,
-                step = .02,
+                step = .01,
                 value = .8,
-                ticks = FALSE
+                format = shinyWidgets::wNumbFormat(decimals = 2),
+                color = datamods:::get_primary_color()
               )
             )
           )
@@ -347,6 +369,35 @@ ui_elements <- list(
     ),
   ##############################################################################
   #########
+  #########  Download panel
+  #########
+  ##############################################################################
+  "visuals" = bslib::nav_panel(
+    title = "Visuals",
+    id = "navvisuals",
+    do.call(
+      bslib::navset_bar,
+      c(
+        data_visuals_ui("visuals"),
+        shiny::tagList(
+          bslib::nav_spacer(),
+          bslib::nav_panel(
+            title = "Notes",
+            shiny::fluidRow(
+              shiny::column(width = 2),
+              shiny::column(
+                width = 8,
+                shiny::markdown(readLines("www/notes_visuals.md")),
+                shiny::column(width = 2)
+              )
+            )
+          )
+        )
+      )
+    )
+  ),
+  ##############################################################################
+  #########
   #########  Regression analyses panel
   #########
   ##############################################################################
@@ -467,11 +518,17 @@ ui_elements <- list(
     bslib::nav_panel(
       title = "Download",
       id = "navdownload",
+      shiny::fluidRow(
+        shiny::column(width = 2),
+        shiny::column(
+          width = 8,
       shiny::fluidRow(
         shiny::column(
           width = 6,
           shiny::h4("Report"),
           shiny::helpText("Choose your favourite output file format for further work, and download, when the analyses are done."),
+          shiny::br(),
+          shiny::br(),
           shiny::selectInput(
             inputId = "output_type",
             label = "Output format",
@@ -497,6 +554,8 @@ ui_elements <- list(
           width = 6,
           shiny::h4("Data"),
           shiny::helpText("Choose your favourite output data format to download the modified data."),
+          shiny::br(),
+          shiny::br(),
           shiny::selectInput(
             inputId = "data_type",
             label = "Data format",
@@ -507,6 +566,8 @@ ui_elements <- list(
               "CSV" = "csv"
             )
           ),
+          shiny::helpText("No metadata is saved when exporting to csv."),
+          shiny::br(),
           shiny::br(),
           # Button
           shiny::downloadButton(
@@ -516,7 +577,17 @@ ui_elements <- list(
           )
         )
       ),
-      shiny::br()
+      shiny::br(),
+      shiny::br(),
+      shiny::tags$b("Code snippets:"),
+      shiny::verbatimTextOutput(outputId = "code_import"),
+      shiny::verbatimTextOutput(outputId = "code_data"),
+      shiny::verbatimTextOutput(outputId = "code_filter"),
+      shiny::tags$br(),
+      shiny::br(),
+      shiny::column(width = 2)
+        )
+      )
     ),
   ##############################################################################
   #########
@@ -568,6 +639,7 @@ ui <- bslib::page_fixed(
     ui_elements$import,
     ui_elements$overview,
     ui_elements$describe,
+    ui_elements$visuals,
     ui_elements$analyze,
     ui_elements$download,
     bslib::nav_spacer(),

inst/apps/freesearcheR/www/intro.md

@@ -1,6 +1,6 @@
 # Welcome
 
-This is the ***freesearcheR*** data analysis tool. We intend the ***freesearcheR*** to be a powerful and free tool for easy data evaluation and analysis at the hands of the clinician.
+This is the ***freesearcheR*** data analysis tool. We intend the ***freesearcheR*** to be a powerful and free tool for easy data evaluation and analysis at the hands of the clinician. If you need more advanced tools for regression models or plotting, you'll probably be better off using *R* or similar directly on your own machine.
 
 By intention, this tool has been designed to be simple to use with a minimum of mandatory options to keep the workflow streamlined, while also including a few options to go even further.
 
@@ -12,6 +12,8 @@ There are some simple steps to go through (see corresponding tabs in the top):
 
 1.  Evaluate data using descriptive analyses methods and inspect cross-correlations
 
+1.  Create simple, clean plots for data overview.
+
 1.  Create regression models for even more advanced data analyses
 
     -   Linear, dichotomous or ordinal logistic regression will be used depending on specified outcome variable

inst/apps/freesearcheR/www/notes_visuals.md

@@ -0,0 +1,11 @@
+# Basic visualisations
+
+This section on plotting data is kept very minimal, and includes only the most common plot types for clinical projects.
+
+If you want to go further, have a look at these sites with suggestions and sample code for data plotting:
+
+-   [*R* Charts](https://r-charts.com/): Extensive gallery with great plots
+
+-   [*R* Graph gallery](https://r-graph-gallery.com/): Another gallery with great graphs
+
+-   [grphics principles](https://graphicsprinciples.github.io/): Easy to follow recommendations for clear visuals. 

inst/apps/teal_test/app.R

@@ -1,113 +0,0 @@
-library(teal)
-library(teal.modules.general)
-library(teal.widgets)
-library(readr)
-library(MASS)
-library(stats)
-library(gtsummary)
-library(gt)
-library(openxlsx2)
-library(haven)
-library(readODS)
-library(shiny)
-library(bslib)
-library(assertthat)
-library(dplyr)
-library(quarto)
-library(here)
-library(broom)
-library(broom.helpers)
-library(REDCapCAST)
-library(easystats)
-library(patchwork)
-library(DHARMa)
-# library(IDEAFilter)
-# if (!requireNamespace("webResearch")) {
-#   devtools::install_github("agdamsbo/webResearch", quiet = TRUE, upgrade = "never")
-# }
-# library(webResearch)
-
-if (file.exists(here::here("functions.R"))) {
-  source(here::here("functions.R"))
-}
-
-## This setup works for a single possible source
-## The UI will work, even with server dependent selection and REDCap exports,
-## but when submitting, it only works for the module mentioned first in the server function
-## Also most data formatting is lost when passing to a teal_data_object. Bummer!
-##
-## FRUSTRATION!!
-##
-## As I read this, two different apps has to be created as things are now: one for upload, one for REDCap.
-## https://insightsengineering.github.io/teal/latest-tag/articles/data-as-shiny-module.html#warning
-##
-##
-##
-## Ad option to widen data or keep long (new function, would allow easy(ish) MMRM analyses)
-
-
-
-tm_variable_browser_module <- tm_variable_browser(
-  label = "Variable browser",
-  ggplot2_args = ggplot2_args(
-    labs = list(subtitle = "Plot generated by Variable Browser Module")
-  )
-)
-
-filters <- teal::teal_slices()
-
-app_source <- "https://github.com/agdamsbo/freesearcheR"
-gh_issues_page <- "https://github.com/agdamsbo/freesearcheR/issues"
-
-header <- tags$span(
-  style = "display: flex; align-items: center; justify-content: space-between; margin: 10px 0 10px 0;",
-  tags$span("REDCap data evaluation", style = "font-size: 30px;") # ,
-  # tags$span(
-  #   style = "display: flex; align-items: center;",
-  #   tags$img(src = nest_logo, alt = "NEST logo", height = "45px", style = "margin-right:10px;"),
-  #   tags$span(style = "font-size: 24px;", "agdamsbo")
-  # )
-)
-
-footer <- tags$p(
-  "This is a simple, app for REDCap-based data browsing and evaluation. Data is only stored temporarily and deleted when the browser is refreshed or closed. The app was developed by AGDamsbo using the {teal} framework for building Shiny apps:",
-  tags$a(href = app_source, target = "_blank", "Source Code"), ", ",
-  tags$a(href = gh_issues_page, target = "_blank", "Report Issues")
-)
-
-# teal_init <- function(data = tdm_redcap_read,
-#                       filter = filters,
-#                       modules = teal::modules(
-#                         teal.modules.general::tm_data_table("Data Table"),
-#                         tm_variable_browser_module
-#                       ),
-#                       title = teal::build_app_title("REDCap browser (teal)"),
-#                       header = header,
-#                       footer = footer, ...) {
-#   teal::init(data,
-#              filter,
-#              modules,
-#              title,
-#              header,
-#              footer,
-#              ...
-#              )
-# }
-#
-# redcap_browser_app <- teal_init(data = tdm_data_upload)
-
-app <- teal::init(
-  data=tdm_data_read,
-  # data = tdm_data_upload,
-  # data = tdm_redcap_read,
-  filter = filters,
-  modules = modules(
-    tm_data_table("Data Table"),
-    tm_variable_browser_module
-  ),
-  title = build_app_title("REDCap data evaluation"),
-  header = header,
-  footer = footer
-)
-
-shinyApp(app$ui, app$server)