Legend (#7)

* Update legend functions * Update tests * Bump version * Update documentation * Fix vertical scalling * Update tests * Remove params * Fix graphical argument usage * Fix linting * Add tips for plotly * Tooltips available through text * Add tips to app * Fix tips usage * Supressa warning unknown aesthetics * Update documentation * Update documentation * Add spinner * Fix global * Fix doc * Update snapshot * Fix plot download * Remove unnecessary from namespace * Fix linting * Fix documentation * Add interactive usage in vignette * Fix vignette * Add magick dependency * Fix bioccheck * Update snaps * Unevaluate plotly function * Do not check for bioc version * Update news * Improve news and release on website * Set news to first level header * Set changes as h2 --------- Co-authored-by: Louis Le Nezet <[email protected]>
LouisLeNezet · Oct 9, 2024 · 67eb2ae · 67eb2ae
1 parent be1125f
commit 67eb2ae
Show file tree

Hide file tree

Showing 60 changed files with 3,603 additions and 2,938 deletions.
diff --git a/.github/workflows/check-bioc.yml b/.github/workflows/check-bioc.yml
@@ -216,6 +216,7 @@ jobs:
           BiocCheck::BiocCheck(
               dir('check', 'tar.gz$', full.names = TRUE),
               `quit-with-status` = TRUE,
+              `no-check-version-num` = TRUE,
               `no-check-R-ver` = TRUE,
               `no-check-bioc-help` = TRUE
           )

diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,5 +1,5 @@
 Package: Pedixplorer
-Version: 1.1.4
+Version: 1.1.5
 Date: 2024-10-01
 Title: Pedigree Functions
 Authors@R: c(
@@ -35,7 +35,8 @@ Imports:
     plotly,
     colourpicker,
     shinytoastr,
-    scales
+    scales,
+    shinycssloaders
 Description: Routines to handle family data with a Pedigree object. The initial
     purpose was to create correlation structures that describe family
     relationships such as kinship and identity-by-descent, which can be used to
@@ -62,7 +63,8 @@ Suggests:
     covr,
     devtools,
     R.devices,
-    usethis
+    usethis,
+    magick
 Config/testthat/edition: 3
 biocViews: Software, DataRepresentation, Genetics, GraphAndNetwork, Visualization
 BugReports: https://github.com/LouisLeNezet/Pedixplorer/issues

diff --git a/NAMESPACE b/NAMESPACE
@@ -27,7 +27,6 @@ export(Scales)
 export(affected)
 export(align)
 export(ancestors)
-export(anchor_to_factor)
 export(auto_hint)
 export(avail)
 export(best_hint)
@@ -71,9 +70,7 @@ export(isinf)
 export(kin)
 export(kindepth)
 export(kinship)
-export(make_class_info)
 export(make_famid)
-export(make_rownames)
 export(min_dist_inf)
 export(momid)
 export(na_to_length)
@@ -219,11 +216,13 @@ importFrom(dplyr,mutate_at)
 importFrom(dplyr,mutate_if)
 importFrom(dplyr,n)
 importFrom(dplyr,one_of)
+importFrom(dplyr,pull)
 importFrom(dplyr,rename)
 importFrom(dplyr,rowwise)
 importFrom(dplyr,select)
 importFrom(dplyr,summarise)
 importFrom(dplyr,sym)
+importFrom(dplyr,ungroup)
 importFrom(ggplot2,aes)
 importFrom(ggplot2,annotate)
 importFrom(ggplot2,element_blank)
@@ -319,6 +318,7 @@ importFrom(shiny,uiOutput)
 importFrom(shinyWidgets,pickerInput)
 importFrom(shinyWidgets,switchInput)
 importFrom(shinyWidgets,updateSwitchInput)
+importFrom(shinycssloaders,withSpinner)
 importFrom(shinytoastr,toastr_error)
 importFrom(shinytoastr,toastr_info)
 importFrom(shinytoastr,toastr_success)

diff --git a/NEWS.md b/NEWS.md
@@ -1,8 +1,15 @@
-# NEWS
+## Changes in v1.1.5
 
-NEWS file for the Pedixplorer package
+- Change code of ped_to_legdf
+- When plotting with the main plot, the legend gets its own
+space separate from the plot. This allow better control over
+the size and localisation of the legend.
+- The graphical parameters are reset after each use of plot_fromdf
+- Add tooltips control in Pedigree plots and add it to the app
+- Add example of interactivness in vignette
+- Fix plot area function and legend creation for better alignment
 
-## Changes in version 1.1.4
+## Changes in v1.1.4
 
 - Update website and logo
 - Improve `ped_shiny()` esthetics
@@ -16,17 +23,17 @@ functions for users
 - Standardize the vignettes and add more documentation
 - Fix label adjusting position in plot functions
 
-## Changes in version 1.1.3
+## Changes in v1.1.3
 
 - Fix github workflows
 - Disable `ped_shiny()` execution in markdown
 - Publish with `pkgdown`
 
-## Changes in version 1.1.2
+## Changes in v1.1.2
 
 - Use R version 4.4 and update workflows
 
-## Changes in version 1.1.1
+## Changes in v1.1.1
 
 - A [shiny application](https://shiny.posit.co/) is now available through
 the `ped_shiny()` function.
@@ -46,7 +53,7 @@ to reduce noise between platform.
 computed by `ped_to_plotdf()`.
 - `useful_inds()` function has been improved.
 
-## Changes in version 0.99.0
+## Changes in v0.99.0
 
 - Kinship2 is renamed to Pedixplorer and hosted on Bioconductor.
 - Pedigree is now a S4 object, all functions are updated to work with

diff --git a/R/app_plot_download.R b/R/app_plot_download.R
@@ -105,11 +105,11 @@ plot_download_server <- function(
                 paste(myfilename(), input$ext, sep = ".")
             }, content = function(file) {
                 if (input$ext == "html") {
-                    if ("ggplot" %in% class(my_plot())) {
+                    if ("htmlwidget" %in% class(my_plot())) {
+                        htmlwidgets::saveWidget(file = file, my_plot())
+                    } else if ("ggplot" %in% class(my_plot())) {
                         plot_html <- plotly::ggplotly(my_plot())
                         htmlwidgets::saveWidget(file = file, plot_html)
-                    } else if ("htmlwidget" %in% class(my_plot())) {
-                        htmlwidgets::saveWidget(file = file, my_plot())
                     } else {
                         shinytoastr::toastr_error(
                             title = "Error in plot type selected",

diff --git a/R/app_plot_legend.R b/R/app_plot_legend.R
@@ -1,8 +1,8 @@
 #### UI function of the module #### ----------
-#' @rdname plot_legend
+#' @rdname plot_legend_app
 #' @export
 #' @importFrom shiny NS column plotOutput
-plot_legend_ui <- function(id, height = "200px") {
+plot_legend_ui <- function(id, height = "400px") {
     ns <- shiny::NS(id)
     shiny::column(12,
         shiny::plotOutput(ns("plotlegend"), height = height)
@@ -25,13 +25,13 @@ plot_legend_ui <- function(id, height = "200px") {
 #' if (interactive()) {
 #'     plot_legend_demo()
 #' }
-#' @rdname plot_legend
+#' @rdname plot_legend_app
 #' @keywords internal
 #' @export
 #' @importFrom shiny moduleServer is.reactive renderPlot req
 plot_legend_server <- function(
-    id, pedi, leg_loc = c(0.2, 1, 0, 1),
-    lwd = par("lwd"), boxw = 1, boxh = 1,
+    id, pedi, leg_loc = c(0, 1, 0, 1),
+    lwd = par("lwd"), boxw = 0.1, boxh = 0.1,
     adjx = 0, adjy = 0
 ) {
     stopifnot(shiny::is.reactive(pedi))
@@ -51,11 +51,13 @@ plot_legend_server <- function(
 }
 
 #### Demo function of the module #### ----------
-#' @rdname plot_legend
+#' @rdname plot_legend_app
 #' @export
 #' @importFrom utils data
 #' @importFrom shiny shinyApp fluidPage reactive
-plot_legend_demo <- function(height = "200px", leg_loc = c(0.2, 1, 0, 1)) {
+plot_legend_demo <- function(
+    height = "400px", leg_loc = c(0.2, 0.8, 0.2, 0.6)
+) {
     data_env <- new.env(parent = emptyenv())
     utils::data("sampleped", envir = data_env, package = "Pedixplorer")
     pedi <- shiny::reactive({

diff --git a/R/app_plot_ped.R b/R/app_plot_ped.R
@@ -31,6 +31,7 @@ plot_ped_ui <- function(id) {
 #' @param precision An integer to set the precision of the plot.
 #' @param max_ind An integer to set the maximum number of individuals to plot.
 #' @inheritParams plot_fromdf
+#' @inheritParams ped_to_plotdf
 #' @returns A reactive ggplot or the pedigree object.
 #' @examples
 #' if (interactive()) {
@@ -46,15 +47,24 @@ plot_ped_ui <- function(id) {
 #' @importFrom shiny tagList checkboxInput plotOutput
 #' @importFrom ggplot2 scale_y_reverse theme element_blank
 #' @importFrom plotly ggplotly renderPlotly plotlyOutput
+#' @importFrom shinycssloaders withSpinner
 plot_ped_server <- function(
     id, pedi, title, precision = 2,
-    max_ind = 500, lwd = par("lwd")
+    max_ind = 500, lwd = par("lwd"),
+    tips = NULL
 ) {
     stopifnot(shiny::is.reactive(pedi))
     shiny::moduleServer(id, function(input, output, session) {
 
         ns <- shiny::NS(id)
 
+        mytips <- shiny::reactive({
+            if (shiny::is.reactive(tips)) {
+                tips <- tips()
+            }
+            tips
+        })
+
         mytitle <- shiny::reactive({
             if (shiny::is.reactive(title)) {
                 title <- title()
@@ -95,8 +105,9 @@ plot_ped_server <- function(
                 pedi_val(),
                 aff_mark = TRUE, label = NULL, ggplot_gen = input$interactive,
                 cex = 1, symbolsize = 1, force = TRUE,
-                mar = c(0.5, 0.5, 1.5, 0.5), title = mytitle(),
-                precision = precision, lwd = lwd
+                ped_par = list(mar = c(0.5, 0.5, 1.5, 0.5)),
+                title = mytitle(), tips = mytips(),
+                precision = precision, lwd = lwd / 3
             )
 
             ggp <- ped_plot_lst$ggplot + ggplot2::scale_y_reverse() +
@@ -115,7 +126,8 @@ plot_ped_server <- function(
                 ggp +
                     ggplot2::theme(legend.position = "none"),
                 tooltip = "text"
-            )
+            ) %>%
+                plotly::layout(hoverlabel = list(bgcolor = "darkgrey"))
         })
         output$plotpedi <- shiny::renderUI({
             if (is.null(input$interactive)) {
@@ -125,19 +137,22 @@ plot_ped_server <- function(
                 output$ped_plotly <- plotly::renderPlotly({
                     plotly_ped()
                 })
-                plotly::plotlyOutput(ns("ped_plotly"), height = "700px")
+                plotly::plotlyOutput(ns("ped_plotly"), height = "700px") %>%
+                    shinycssloaders::withSpinner(color = "#8aca25")
             } else {
                 output$ped_plot <- shiny::renderPlot({
                     shiny::req(pedi_val())
                     plot(
                         pedi_val(),
                         aff_mark = TRUE, label = NULL,
                         cex = 1, symbolsize = 1, force = TRUE,
-                        mar = c(0.5, 0.5, 1.5, 0.5), title = mytitle(),
+                        ped_par = list(mar = c(0.5, 0.5, 1.5, 0.5)),
+                        title = mytitle(),
                         precision = precision, lwd = lwd
                     )
                 })
-                shiny::plotOutput(ns("ped_plot"), height = "700px")
+                shiny::plotOutput(ns("ped_plot"), height = "700px") %>%
+                    shinycssloaders::withSpinner(color = "#8aca25")
             }
         })
 
@@ -156,7 +171,7 @@ plot_ped_server <- function(
 #' @rdname plot_ped
 #' @export
 #' @importFrom shiny shinyApp fluidPage
-plot_ped_demo <- function(pedi, precision = 2, max_ind = 500) {
+plot_ped_demo <- function(pedi, precision = 2, max_ind = 500, tips = NULL) {
     ui <- shiny::fluidPage(
         plot_ped_ui("plot_ped"),
         plot_download_ui("saveped")
@@ -165,7 +180,7 @@ plot_ped_demo <- function(pedi, precision = 2, max_ind = 500) {
         ped_plot <- plot_ped_server(
             "plot_ped", pedi,
             "My Pedigree", max_ind = max_ind,
-            precision = precision
+            precision = precision, tips = tips
         )
         plot_download_server("saveped", ped_plot)
     }

diff --git a/R/app_server.R b/R/app_server.R
@@ -298,7 +298,6 @@ ped_server <- function(
         )
 
         ## Plotting pedigree --------------------------------------------------
-
         cust_title <- function(short) {
             shiny::reactive({
                 shiny::req(lst_fam())
@@ -315,16 +314,35 @@ ped_server <- function(
             })
         }
 
+        ### Tips column selection --------------------------------------------
+        output$col_sel_tips <- renderUI({
+            shiny::req(ped_subfam())
+            all_cols <- colnames(Pedixplorer::as.data.frame(ped(ped_subfam())))
+            select <- c("affection", "affected", "avail", "status")
+            select <- select[select %in% all_cols]
+            shiny::selectInput(
+                "tips_col",
+                label = "Select columns for tips",
+                choices = all_cols, selected = select,
+                multiple = TRUE
+            )
+        })
+
+        my_tips <- shiny::reactive({
+            input$tips_col
+        })
+
         plot_ped <- plot_ped_server(
             "ped", ped_subfam,
             cust_title(short = FALSE),
-            precision = precision, lwd = 2
+            precision = precision, lwd = 2,
+            tips = my_tips
         )
 
         plot_legend_server(
             "legend", ped_subfam,
-            boxw = 0.03, boxh = 0.07, adjx = 0.3, adjy = -0.015,
-            leg_loc = c(0.2, 1.2, 0.2, 0.95), lwd = 2
+            boxw = 0.02, boxh = 0.08, adjx = 0, adjy = 0,
+            leg_loc = c(0.1, 0.7, 0.01, 0.95), lwd = 1.5
         )
 
         ## Download data and plot ---------------------------------------------

diff --git a/R/app_ui.R b/R/app_ui.R
@@ -129,7 +129,8 @@ ped_ui <- function() {
         shiny::fluidRow(
             shiny::column(5,
                 plot_download_ui("saveped"),
-                data_download_ui("plot_data_dwnl")
+                data_download_ui("plot_data_dwnl"),
+                shiny::uiOutput("col_sel_tips")
             ),
             shiny::column(7,
                 plot_legend_ui("legend", "350px")