R/colourinput.R

In Edouard-Legoupil/unhcrdatapackage: UNHCR Population Statistics Database with Chart Library and Factsheet Template

# WARNING - Generated by {fusen} from /dev/dev_golem_module.Rmd: do not edit by hand

# all possible UI widgets used here
default_annotate_layer_widgets <- list(colourInput = function(inputId, label = 'Colour',
                                                              showColour = "text",
                                                              palette = "square",
                                                              value = "#000000",
                                                              ...) 
  colourpicker::colourInput(inputId = inputId,
                            label = label,
                            showColour = showColour, 
                            palette = palette,
                            value = value, ...),
   textInput = function(inputId, label, ...) textInput(inputId = inputId, label = label, ...),
   selectInput = function(inputId, label, ...) shiny::selectInput(inputId = inputId, label = label, ...),
   numericInput = function(inputId, label, ...) shiny::numericInput(inputId = inputId, label = label, ...),
   radioButton = function(inputId, label, choices, ...) shiny::radioButtons(inputId = inputId, label = label, choices = choices, ...)
)


# list of possible arguments
annotate_layer_args <- list(
  text = list(
    x = list(req = TRUE),
    y = list(req = TRUE),
    label = list(req = TRUE),
    parse = list(req = TRUE),
    color = list(req = FALSE),
    size = list(req = FALSE),
    alpha = list(req = FALSE),
    fontface = list(req = FALSE),
    # family = list(req = FALSE),
    angle = list(req = FALSE),
    hjust = list(req = FALSE), #"inward", # (“left”, “center”, “right”, “inward”, “outward”)
    vjust = list(req = FALSE) # "inward", # (“bottom”, “middle”, “top”, “inward”, “outward”)
    # check_overlap = list(req = FALSE) # TRUE # boolean
  ),
  hline = list(
    yintercept = list(req = TRUE),
    # y = list(req = TRUE),
    linetype = list(req = FALSE),
    color = list(req = FALSE),
    alpha = list(req = FALSE),
    size = list(req = FALSE)
  ),
  vline = list(
    xintercept = list(req = TRUE),
    # x = list(req = TRUE),
    linetype = list(req = FALSE),
    color = list(req = FALSE),
    alpha = list(req = FALSE),
    size = list(req = FALSE)
  ),
  rect = list(
    xmin = list(req = TRUE),
    xmax = list(req = TRUE),
    ymin = list(req = TRUE),
    ymax = list(req = TRUE),
    alpha = list(req = TRUE),
    color = list(req = FALSE),
    fill = list(req = FALSE)
  )
)




#' annotate UI Function
#'
#' @description A shiny Module.
#'
#' @param id,annotate,output,session Internal parameters for {shiny}.
#'
#' @noRd 
#'
#' @importFrom shiny NS tagList 
mod_annotate_ui <- function(id){
  ns <- NS(id)
  tagList(
    fluidRow(
      column(width = 12, 
             default_annotate_layer_widgets$selectInput(inputId = ns("geom_type"), 
                                                       label = "Select Annotation type",
                                                       choices = c(names(annotate_layer_args))) )),
    fluidRow(
      column(width = 3, tags$b("Read mouse")),
      column(width = 6, offset = -1, 
             style = 'padding-left: 5px; padding-right: 5px;',
             shiny::radioButtons(inputId = ns("read_mouse"), 
                                 label = NULL, 
                                 choices = list('Off' = FALSE, 'On' = TRUE), 
                                 selected = FALSE) )),
    fluidRow(
      column(width = 12, uiOutput(ns("multiple_args")))), # multiple select drop down
    fluidRow(
      column(width = 12, uiOutput(ns("widget"))))
  )
}
    
#' annotate Server Functions
#'
#' @noRd 
mod_annotate_server <- function(id){
  moduleServer( id, function(input, output, session){
    ns <- session$ns
    
    
      mrv <- reactiveValues()

      # all possible value arguments
      annotate_args <- list(label = list(initial = function(...) default_annotate_layer_widgets$textInput(inputId = ns('label'), label = NULL, value = "", ...),
                                         selected = function(selected, ...) default_annotate_layer_widgets$textInput(inputId = ns('label'), label = NULL, value = selected, ...)),

                            parse = list(initial = function(...) default_annotate_layer_widgets$radioButton(inputId = ns('parse'), label = NULL, choices = list('FALSE' = FALSE, 'TRUE' = TRUE), selected = FALSE, ...),
                                         selected = function(selected, ...) default_annotate_layer_widgets$radioButton(inputId = ns('parse'), label = NULL, choices = list('FALSE' = FALSE, 'TRUE' = TRUE), selected = selected, ...)),

                            x = list(initial = function(...) default_annotate_layer_widgets$numericInput(inputId = ns('x'), label = NULL, value = NULL, min = 0, max = NA, step = 1,...),
                                     selected = function(selected, ...) default_annotate_layer_widgets$numericInput(inputId = ns('x'), label = NULL, value = selected, min = 0, max = NA, step = 1, ...)),

                            y = list(initial = function(...) default_annotate_layer_widgets$numericInput(inputId = ns('y'), label = NULL, value = NULL, min = 0, max = NA, step = 1,...),
                                     selected = function(selected, ...) default_annotate_layer_widgets$numericInput(inputId = ns('y'), label = NULL, value = selected, min = 0, max = NA, step = 1, ...)),

                            xmin = list(initial = function(...) default_annotate_layer_widgets$numericInput(inputId = ns('xmin'), label = NULL, value = NULL, min = 0, max = NA, step = 1,...),
                                        selected = function(selected, ...) default_annotate_layer_widgets$numericInput(inputId = ns('xmin'), label = NULL, value = selected, min = 0, max = NA, step = 1, ...)),

                            xmax = list(initial = function(...) default_annotate_layer_widgets$numericInput(inputId = ns('xmax'), label = NULL, value = NULL, min = 0, max = NA, step = 1,...),
                                        selected = function(selected, ...) default_annotate_layer_widgets$numericInput(inputId = ns('xmax'), label = NULL, value = selected, min = 0, max = NA, step = 1, ...)),

                            ymin = list(initial = function(...) default_annotate_layer_widgets$numericInput(inputId = ns('ymin'), label = NULL, value = NULL, min = 0, max = NA, step = 1,...),
                                        selected = function(selected, ...) default_annotate_layer_widgets$numericInput(inputId = ns('ymin'), label = NULL, value = selected, min = 0, max = NA, step = 1, ...)),

                            ymax = list(initial = function(...) default_annotate_layer_widgets$numericInput(inputId = ns('ymax'), label = NULL, value = NULL, min = 0, max = NA, step = 1,...),
                                        selected = function(selected, ...) default_annotate_layer_widgets$numericInput(inputId = ns('ymax'), label = NULL, value = selected, min = 0, max = NA, step = 1, ...)),

                            color = list(initial = function(...) default_annotate_layer_widgets$colourInput(inputId = ns('color'), label = NULL, ...),
                                         selected = function(selected, ...) default_annotate_layer_widgets$colourInput(inputId = ns('color'), label = NULL, value = selected, ...)),

                            fill = list(initial = function(...) default_annotate_layer_widgets$colourInput(inputId = ns('fill'), label = NULL, value = "#d8d8ff", ...),
                                        selected = function(selected, ...) default_annotate_layer_widgets$colourInput(inputId = ns('fill'), label = NULL, value = selected, ...)),

                            size = list(initial = function(...) default_annotate_layer_widgets$numericInput(inputId = ns('size'), label = NULL, value = NULL, min = 0, max = 20, step = 1,...),
                                        selected = function(selected, ...) default_annotate_layer_widgets$numericInput(inputId = ns('size'), label = NULL, value = selected, min = 0, max = 20, step = 1, ...)),

                            fontface = list(initial = function(...) default_annotate_layer_widgets$selectInput(inputId = ns('fontface'), label = NULL, choices = c("", "plain", "bold", "italic"),...),
                                            selected = function(selected, ...) default_annotate_layer_widgets$selectInput(inputId = ns('fontface'), label = NULL, choices = c("", "plain", "bold", "italic"), selected = selected, ...)),

                            family = list(initial = function(...) default_annotate_layer_widgets$selectInput(inputId = ns('family'), label = NULL, choices = c("","sans", "serif", "mono"),...),
                                          selected = function(selected, ...) default_annotate_layer_widgets$selectInput(inputId = ns('family'), label = NULL, choices = c("", "sans", "serif", "mono"), selected = selected, ...)),

                            angle = list(initial = function(...) default_annotate_layer_widgets$numericInput(inputId = ns('angle'), label = NULL, value = NULL, min = 0, max = 360, step = 5,...),
                                         selected = function(selected, ...) default_annotate_layer_widgets$numericInput(inputId = ns('angle'), label = NULL, value = selected, min = 0, max = 360, step = 5, ...)),

                            alpha = list(initial = function(...) default_annotate_layer_widgets$numericInput(inputId = ns('alpha'), label = NULL, value = NULL, min = 0, max = 1, step = 0.1,...),
                                         selected = function(selected, ...) default_annotate_layer_widgets$numericInput(inputId = ns('alpha'), label = NULL, value = selected, min = 0, max = 1, step = 0.1, ...)),

                            vjust = list(initial = function(...) default_annotate_layer_widgets$selectInput(inputId = ns('vjust'), label = NULL, choices = c("", "middle", "inward", "outward", "bottom", "top"),...),
                                         selected = function(selected, ...) default_annotate_layer_widgets$selectInput(inputId = ns('vjust'), label = NULL, choices = c("", "middle", "inward", "outward", "bottom", "top"), selected = selected, ...)),

                            hjust = list(initial = function(...) default_annotate_layer_widgets$selectInput(inputId = ns('hjust'), label = NULL, choices = c("", "center", "inward", "outward", "left", "right"), ...),
                                         selected = function(selected, ...) default_annotate_layer_widgets$selectInput(inputId = ns('hjust'), label = NULL, choices = c("", "center", "inward", "outward", "left", "right"), selected = selected, ...)),

                            yintercept = list(initial = function(...) default_annotate_layer_widgets$numericInput(inputId = ns('yintercept'), label = NULL, value = NULL, min = 0, max = NA, step = 1,...),
                                              selected = function(selected, ...) default_annotate_layer_widgets$numericInput(inputId = ns('yintercept'), label = NULL, value = selected, min = 0, max = NA, step = 1, ...)),

                            xintercept = list(initial = function(...) default_annotate_layer_widgets$numericInput(inputId = ns('xintercept'), label = NULL, value = NULL, min = 0, max = NA, step = 1,...),
                                              selected = function(selected, ...) default_annotate_layer_widgets$numericInput(inputId = ns('xintercept'), label = NULL, value = selected, min = 0, max = NA, step = 1, ...)),

                            linetype = list(initial = function(...) default_annotate_layer_widgets$selectInput(inputId = ns('linetype'), label = NULL, choices = c("", "twodash","blank", "solid", "dashed", "dotted", "dotdash", "longdash","11", "18", "1f", "81", "88", "8f", "f1", "f8", "ff"), ...),
                                            selected = function(selected, ...) default_annotate_layer_widgets$selectInput(inputId = ns('linetype'), label = NULL, choices = c("", "twodash","blank", "solid", "dashed", "dotted", "dotdash", "longdash","11", "18", "1f", "81", "88", "8f", "f1", "f8", "ff"), selected = selected, ...))
      )

      if(isFALSE(is.null(selected[["geom"]]))){
        updateSelectInput(session = session, inputId = "geom_type", selected = selected[["geom"]])
      }

      # update read mouse to off whenever user switches annotate type
      observeEvent(input$geom_type,{
        updateRadioButtons(inputId = 'read_mouse', selected = FALSE)
      }, ignoreInit = TRUE)

      # show/hide attributes based on multiple_args selection
      output$multiple_args <- renderUI({
        if (isTRUE(length(selected) == 0)) {
          if(input$geom_type == ""){
            return(NULL)
          } else {
            shiny::selectInput(
              inputId = ns('geom_attr'),
              label = "Attribute(s) Selector",
              # width = '90%',
              choices = names(annotate_layer_args[[input$geom_type]]),
              multiple = TRUE,
              selected = names(annotate_layer_args[[input$geom_type]])[sapply(annotate_layer_args[[input$geom_type]], function(element_i) {
                if (isTRUE(element_i[["req"]] == TRUE))
                  return(TRUE)
                else
                  return(FALSE)
              })]
            )
          }
        } else {
          shiny::selectInput(
            inputId = ns('geom_attr'),
            label = "Attribute(s) Selector",
            # width = '90%',
            choices = names(annotate_layer_args[[input$geom_type]]),
            multiple = TRUE,
            selected = names(selected)
          )
        }
      })

      output$widget <- renderUI({

        if(isFALSE(input$geom_type == "")){

          # building widgets for geom
          annotate_widgets <- annotate_layer_args[[input$geom_type]]

          for(arg_i in names(annotate_widgets)){

            if(isTRUE(is.null(selected[[arg_i]]))){
              annotate_widgets[[arg_i]]$widget$name <- arg_i
              annotate_widgets[[arg_i]]$widget$ui <- annotate_args[[arg_i]]$initial()
            } else {
              annotate_widgets[[arg_i]]$widget$name <- arg_i
              annotate_widgets[[arg_i]]$widget$ui <- annotate_args[[arg_i]]$selected(selected[[arg_i]])
            }

          } # close for loop

          # return
          tagList(
            lapply(annotate_widgets, FUN = function(fun_i){
              fluidRow(
                class = ns(fun_i$widget$name), style = 'display:none;',
                column(width = 3, style = 'padding-top: 5px;',
                       fun_i$widget$name),
                column(width = 6, offset = -1, style = 'padding-left: 5px; padding-right: 5px;',
                       fun_i$widget$ui)
              )
            })
          )

        } # close of input$geom_type check
      }) # close of widget renderUI


      # read Attribute selector and force `req` attribute to always re-populate if user removes it
      observeEvent(input[["geom_attr"]], {
        # observe({
        if (isFALSE(input$geom_type == "")) {

          geom_req_attr <-
            names(annotate_layer_args[[input$geom_type]])[sapply(annotate_layer_args[[input$geom_type]], function(element_i) {
              if (isTRUE(element_i[["req"]] == TRUE))
                return(TRUE)
              else
                return(FALSE)
            })]

          if (isFALSE(all(geom_req_attr %in% input[["geom_attr"]]))) {
            shiny::updateSelectInput(
              session = session,
              inputId = 'geom_attr',
              selected = base::union(geom_req_attr, input[["geom_attr"]])
            )
          }

        } # close of outer if to check null input$geom_type
      }, ignoreInit = TRUE) # close of observe


      ############################################################################################
      ### geom text, hline, vline section - module server logic
      ############################################################################################
      ## Read mouse and update x and y inputs
      observeEvent(input$read_mouse,{
        if(input$geom_type != "rect"){

          if(input$read_mouse){
            if(input$geom_type == "text"){
              sanofiJS$disable(id = ns('x'))
              sanofiJS$disable(id = ns('y'))
            }
            else if(input$geom_type == "hline"){
              # yintercept
              sanofiJS$disable(id = ns('yintercept'))
              sanofiJS$disable(id = ns('y'))
            }
            else if(input$geom_type == "vline"){
              # xintercept
              sanofiJS$disable(id = ns('xintercept'))
              sanofiJS$disable(id = ns('x'))
            }

            mrv$x_hover <- NULL
            mrv$x_click <- NULL
            mrv$x_dynamic <- NULL

            mrv$y_hover <- NULL
            mrv$y_click <- NULL
            mrv$y_dynamic <- NULL

            mrv$click <- NULL

          } else {
            if(input$geom_type == "text"){
              sanofiJS$enable(id = ns('x'))
              sanofiJS$enable(id = ns('y'))
            }
            else if(input$geom_type == "hline"){
              # yintercept
              sanofiJS$enable(id = ns('yintercept'))
              sanofiJS$enable(id = ns('y'))
            }
            else if(input$geom_type == "vline"){
              # xintercept
              sanofiJS$enable(id = ns('xintercept'))
              sanofiJS$enable(id = ns('x'))
            }
          }

        }
      })


      # if reading mouse, clicking will record and turn off reading mouse
      observeEvent(plotClick(),{

        if(input$geom_type != "rect"){
          if(isFALSE(is.null(plotClick()$x)) && isFALSE(is.null(plotClick()$y))){
            if(input$read_mouse) {

              if(is.null(mrv$x_click)) {
                updateRadioButtons(inputId = 'read_mouse', selected = FALSE)
                mrv$x_click <- plotClick()$x
              } else {
                mrv$x_click <- NULL
                mrv$x_dynamic <- NULL
              }

              if(is.null(mrv$y_click)) {
                updateRadioButtons(inputId = 'read_mouse', selected = FALSE)
                mrv$y_click <- plotClick()$y
              } else {
                mrv$y_click <- NULL
                mrv$y_dynamic <- NULL
              }

            }
          }
        }
      })

      # current hover: as the plot updates, current hover is lost
      observe({
        # if(input$geom_type != "rect"){
        if(!is.null(plotHover()$x)){
          mrv$x_hover <- plotHover()$x
        }
        if(!is.null(plotHover()$y)){
          mrv$y_hover <- plotHover()$y
        }
        # }
      })

      # selecting the appropriate coordinate
      observeEvent(plotHover(),{
        # if(input$geom_type != "rect"){
        if(isFALSE(is.null(plotHover()$x)) && isFALSE(is.null(plotHover()$y))){

          if(!is.null(mrv$x_click)) {
            mrv$x_dynamic <- mrv$x_click
          } else {
            mrv$x_dynamic <- mrv$x_hover
          }

          if(!is.null(mrv$y_click)) {
            mrv$y_dynamic <- mrv$y_click
          } else {
            mrv$y_dynamic <- mrv$y_hover
          }

        }
        # }
      })

      # updating the input widgets
      observeEvent(mrv$x_dynamic, ignoreNULL = FALSE,{
        if(input$read_mouse){
          if(input$geom_type == "text"){
            updateNumericInput(inputId = ('x'), value = mrv$x_dynamic)
            updateNumericInput(inputId = ('y'), value = mrv$y_dynamic)
          }
          else if(input$geom_type == "hline"){
            #yintercept
            updateNumericInput(inputId = ('yintercept'), value = mrv$y_dynamic)
            updateNumericInput(inputId = ('y'), value = mrv$y_dynamic)
          }
          else if(input$geom_type == "vline"){
            #xintercept
            updateNumericInput(inputId = ('xintercept'), value = mrv$x_dynamic)
            updateNumericInput(inputId = ('x'), value = mrv$x_dynamic)
          }
        }
      })

      ############################################################################################
      ### geom Rectangle section - module server logic
      ############################################################################################

      observeEvent(input$read_mouse,{
        if(input$geom_type == "rect"){
          if(input$read_mouse){
            # rect
            sanofiJS$disable(id = ns('xmin'))
            sanofiJS$disable(id = ns('xmax'))
            sanofiJS$disable(id = ns('ymin'))
            sanofiJS$disable(id = ns('ymax'))

            mrv$x_min <- NULL
            mrv$x_max <- NULL
            mrv$y_min <- NULL
            mrv$y_max <- NULL

            mrv$dbl_x_click <- NULL
            mrv$dbl_y_click <- NULL

          } else {
            # rect
            sanofiJS$enable(id = ns('xmin'))
            sanofiJS$enable(id = ns('xmax'))
            sanofiJS$enable(id = ns('ymin'))
            sanofiJS$enable(id = ns('ymax'))
          }
        }
      })

      # double click to confirm rectangle location and update read mouse to Off
      observeEvent(plotDblClick(),{
        if(input$geom_type == "rect"){
          if(isFALSE(is.null(plotBrush()$xmin)) && isFALSE(is.null(plotBrush()$xmax))
             && isFALSE(is.null(plotBrush()$ymin)) && isFALSE(is.null(plotBrush()$ymax))){
            if(input$read_mouse) {
              if(is.null(mrv$dbl_x_click) && is.null(mrv$dbl_y_click)){
                updateRadioButtons(inputId = 'read_mouse', selected = FALSE)
                mrv$dbl_x_click <- plotDblClick()$x
                mrv$dbl_y_click <- plotDblClick()$y
                # make plot hover height & width to 0 on double click
                if(plotName != "")
                  session$sendCustomMessage(type = 'plot_brush_minimize', message = list(id = paste0(plotName,"_brush")))
              } else {
                mrv$dbl_x_click <- NULL
                mrv$dbl_y_click <- NULL
              }
            }
          }
        }
      })

      # current rect: as the plot updates, current rect points are lost
      observe({
        if(input$geom_type == "rect"){
          if(!is.null(plotBrush()$xmin)){
            mrv$x_min <- plotBrush()$xmin
            mrv$dbl_x_click <- plotDblClick()$x
          }
          if(!is.null(plotBrush()$xmax)){
            mrv$x_max <- plotBrush()$xmax
          }
          if(!is.null(plotBrush()$ymin)){
            mrv$y_min <- plotBrush()$ymin
            mrv$dbl_y_click <- plotDblClick()$y
          }
          if(!is.null(plotBrush()$ymax)){
            mrv$y_max <- plotBrush()$ymax
          }
        }
      })

      # updating the input widgets
      observeEvent(list(mrv$x_min,mrv$x_max,mrv$y_min,mrv$y_max), ignoreNULL = FALSE,{
        if(input$read_mouse){
          #rect
          updateNumericInput(inputId = ('xmin'), value = mrv$x_min)
          updateNumericInput(inputId = ('xmax'), value = mrv$x_max)
          updateNumericInput(inputId = ('ymin'), value = mrv$y_min)
          updateNumericInput(inputId = ('ymax'), value = mrv$y_max)
        }
      })


      ############################################################################################
      # return Module
      ############################################################################################
      return(reactive({
        # ans <- list()
        ans <- list(.fn = "annotate", geom = input$geom_type)

        lapply(names(annotate_layer_args[[input$geom_type]]), FUN = function(arg_i) {
          if(arg_i %in% input[["geom_attr"]])
            sanofiJS$show(class = ns(arg_i), display = 'inherit', session = session)
          else
            sanofiJS$hide(class = ns(arg_i), session = session)
        })


        # for (arg_i in names(annotate_layer_args[[input$geom_type]])) {
        for (arg_i in input[["geom_attr"]]) { # to Module return values selected in 'Attribute Selector'
          if (isFALSE(input[[arg_i]] == "")) {

            # capture user input
            ans[[arg_i]] <- input[[arg_i]]

          }
        }

        # force x & y values for vline and hline respectively for it to work
        if(input$geom_type == 'hline'){
          ans[['y']] <- ans[['yintercept']]
        } else if(input$geom_type == 'vline'){
          ans[['x']] <- ans[['xintercept']]
        }

        # return
        ans

      })) # close of module end reactive return
    
    
    
    
 
  })
}
    
## To be copied in the UI
# mod_annotate_ui("annotate_1")
    
## To be copied in the server
# mod_annotate_server("annotate_1")