R/m_lopo.R

In kismet303/lopo3000: LoPo 3000 Experimental package using RShiny for interactive LoPo

# Module UI
  
#' @title   m_lopo_ui and mod_lopo_server
#' @description  A shiny Module.
#'
#' @param id shiny id
#' @param input internal
#' @param output internal
#' @param session internal
#'
#' @rdname m_lopo
#'
#' @keywords internal
#' @export 
#' @importFrom shiny NS tagList 

########js script to fix href links (browseUrl)#######
# define js function for opening urls in new tab/window
js_code <- "
shinyjs.browseURL = function(url) {
  window.open(url,'_blank');
}

shinyjs.reset = function() {history.go(0)}

"

m_lopo_ui <- function(id){
  ns <- NS(id)

  shinydashboard::tabItem(
    tabName = "LOPO", 
    div(style="display: inline-block;vertical-align:top; width: 300px;",   
        
        shinyWidgets::awesomeCheckboxGroup(
          inputId = ns("OutType"),
          label = "Type of Output", 
          choices = c("Table", "Listing", "Figure"),
          inline = TRUE,
          status = "danger"
        )),
    
    div(style="display: inline-block;vertical-align:top; width: 330px;",           
        shinyWidgets::pickerInput(
          inputId = ns("DomainC"),
          label = "Select Domain", 
          choices =  c( "AE", "Exposure", "Disposition", "Demography", "Deaths", "Con Med") ,
          multiple = TRUE,
          # selected = "NULL", 
          choicesOpt = list(
            content = sprintf("<span class='label label-%s'>%s</span>", 
                              c("danger", "success", "warning", "info", "default","primary"), 
                              c( "AE", "Exposure", "Disposition", "Demography","Deaths",  "Con Med"))) 
        )),
    
    div(style="display: inline-block;vertical-align: center; width:100px;",      
        tags$br(),
        shinyWidgets::actionBttn(
          inputId = ns("tabFilt"),
          label = "Filter",
          color = "primary",
          style = "simple",
          size= "sm",
          icon = icon("sliders"),
          block = TRUE
        ),
        shinyBS::bsTooltip("tabFilt", "Edit Filters",
                           "top", options = list(container = "body")),  
        "   ",
        shinyBS::bsModal("modalFilter", "Filters", "tabFilt", size = "large",
                         dataTableOutput(ns("filtTable")))
    ),
    
    shinyjs::useShinyjs(),
    shinyjs::extendShinyjs(text = js_code),
    DT::dataTableOutput(ns('myLopo3000')),  
    
    conditionalPanel(condition =  "output.lopoExist == 'NO' ", 
                     p("Lopo template must follow the standard you can find here"),
                     sidebarLayout(
                       sidebarPanel(
                         df <- fileInput(ns('file1'), 'Choose xlsx file', accept = c(".xls"))
                       ),
                       mainPanel( 
                         tableOutput(ns('contents')) 
                       ) 
                     ) 
    )
  ) #tabItem
}
    
# Module Server
#' @rdname m_lopo
#' @export
#' @keywords internal
    
m_lopo_server <- function(input, output, session, state){
  ns <- session$ns
  m_lopo_rv <- reactiveValues(db_query = NULL)
  
  lopo_reactive <- reactive({
    req(state)
    state$lopo
  })
  
 
#### Display an interactive LOPO ---------------------------------                                  
  output$myLopo3000 <- DT::renderDataTable({
    col_list <- c('See', 'Action', 'Domain', 'Titles', 'Footnotes', 'Filters', 'GDS Template', 
                  'Program ID','outType','idbis', 'CRUD')
    df <- lopo_reactive() %>% 
      dplyr::select(col_list)
    
    if (!is.null(input$OutType)) df <- dplyr::filter(df, outType %in% input$OutType)
    if (!is.null(input$DomainC)) df <- dplyr::filter(df, Domain %in% input$DomainC)
    # browser()
    lopo_viewer(df, ns)
  }, 
  server = TRUE,  
  selection = 'single', 
  rownames = FALSE)

  ##### Edit a line of LOPO  ------------------------------------------
  ### 1 Click on edit button on a line
  
  observeEvent(input$edit_button, {
    input.types <- c(Footnotes ='textAreaInput', Titles ='textAreaInput') 
    selectedIDBIS <- as.numeric(strsplit(input$edit_button, "_")[[1]][2])
    # browser()
    cat(file=stderr(), glue::glue("Edit row clicked {input$edit_button}\n"))
    editModal(selectedIDBIS)
  })  
  
  ###2 Display a Modal to update(edit) the line of the LOPO
  editModal <- function(selectedRow) {
    
    jscode_edit <- paste0( '
        $("#lopo_update").on("click", function(){
        Shiny.onInputChange("editClicked",', selectedRow  , '+ "_" + Math.random()',');
        })
        ')
    
    #output[['myoutput_message']] <- renderText('')
    # fields <- lopo_editable_fields('_edit_', values = values$dfWorking[values$dfWorking[,"idbis"] == selectedRow,] )
    # browser()
    edit.cols <- c('See', 'Action', 'Domain', 'Titles', 'Footnotes', 'Filters', 'GDS Template', 'Program ID','outType','CRUD','idbis')
    stopifnot(length(setdiff(edit.cols, names(lopo_reactive()))) ==0)
    fields <- lopo_editable_fields('_edit_', 
                                   lopo_row = dplyr::filter(lopo_reactive(), idbis == selectedRow),
                                   edit.cols = edit.cols
                                   )
    
    showModal(modalDialog(title = "Edit",
                          shiny::div(shiny::textOutput('myoutput_message'), style='color:red'),
                          fields,
                          footer = column(shiny::modalButton(ns('Cancel')),
                                          shiny::actionButton(ns("lopo_update"), 'Save'),
                                          width=12),
                          tags$script(HTML(jscode_edit)) ,
                          size =  'm',  ##modal.size
                          easyClose = TRUE
    ))
  }
  
  ###3 Update the databse when we click on the save button of the Modal TODO:
  
  observeEvent(input$editClicked,{
    if (!is.null(input$editClicked)) {
      
      ## selectedRow<-input$editClicked[[]]
      selectedRow<-as.numeric(strsplit(input$editClicked, "_")[[1]][1])
      print("kikou")
      print(selectedRow)
      print("kikou_Stop")
      newdata <- result$thedata
      newdata[newdata[,"idbis"]==selectedRow, names(newdata) != "idbis"] <- NA
      
      ###Update here with the correct row (idbis)  newdata[,"idbis"]==row  )
      for(i in edit.cols) {
        if(inputTypes[i] %in% c('selectInputMultiple')) {
          newdata[[i]][newdata[,"idbis"]==selectedRow] <- list(input[[paste0('myLopo_edit_', i)]])
        } else {
          newdata[newdata[,"idbis"]==selectedRow,i] <- input[[paste0('myLopo_edit_', i)]]
        }
      }

      # create update to send back to DB 
      query <- paste0("UPDATE  ", "study","  SET ",
                      "Domain = '",  as.character(data$Domain), "', ",
                      "Titles = '", as.character(data$Titles), "', ",
                      "Footnotes = '",  as.character(data$Footnotes), "', ",
                      "Filters = '", as.character(data$Filters), "' ",
                      "WHERE rowid = ", selectedRow)

      m_lopo_rv$query <- query 
      shiny::removeModal()
    }
  })
    
    #--------------------------------------------
    #  Delete row from lopo 
    #-------------------------------------------
    observeEvent(input$del_button, {
      cat(file=stderr(), "Delete lopo row requested\n")
      selectedIDBIS <- as.numeric(strsplit(input$del_button, "_")[[1]][2])
      cat(file=stderr(), input$del_button, "\n")
    
      if(is.numeric(selectedIDBIS)) deleteModal(data=lopo_reactive(), idbis = selectedIDBIS, ns = ns)
      if(!is.numeric(selectedIDBIS)) cat(file=stderr(), "Could not delete row", "\n")
    })
    
    observeEvent(input$buttonClicked,{
      cat(file=stderr(), "Delete lopo row confirmed\n")
      query <- paste0('DELETE FROM  ', "study",'  WHERE rowid = ', input$buttonClicked)
      shiny::removeModal()
      m_lopo_rv$query <- query
    })
    
    #--------------------------------------------
    # Check and Edit Filters
    #--------------------------------------------  
    
    #TO DO: Add handling for no filters supplied
    # filters_path <<- paste0(main_path,"Studies/",study,"/meta/FILTERS")
    
    # tab <- getFilters(filters_path)
    output$filtTable <- DT::renderDataTable({ 
      tab
    }, options = list( dom='t'), editable = TRUE)
    
    # edit a single cell
    # proxy5 = dataTableProxy('filtTable')
    
    observeEvent(input$filtTable_cell_edit, {
      info = input$filtTable_cell_edit
      str(info)  # check what info looks like (a data frame of 3 columns)
      tab <<- editData(tab, input$filtTable_cell_edit )
      
      ###update database
      # con <- dbConnect(RSQLite::SQLite(), paste0("Studies/",study,"/meta/FILTERS"))
      # dbWriteTable(con, "FILTERS", tab, overwrite=TRUE)
      # #dbBind(update, tab)  # send the updated data
      # # dbClearResult(update)  # release the prepared statement
      # dbDisconnect(con)
    })  
    
    #-----------------------------------------------------------------------------
    #  button functionalities
    #-----------------------------------------------------------------------------
    
    
    observeEvent(input$see_button, {
      cat(file=stderr(), "Request to view lopo program\n")
      selectedRow <- as.numeric(strsplit(input$see_button, "_")[[1]][2])
      outputid <- selectedRow
      
      showModal(modalDialog(
        title = "View program",
        "This should navigate to a second app containg a program viewer - not implemented yet"
      ))
      
      
      state$output_name <- "l_ae.R"
      # js$browseURL(paste0("https://shiny.roche.com/3.5.3/users/remusatp/output3000/?outputid=",outputid,"&study=",study,"&server=",server_))
      
    } )
    
    observeEvent(input$run_button, {
      cat(file=stderr(), "Request to view lopo program\n")
      selectedRow <- as.numeric(strsplit(input$run_button, "_")[[1]][2])
      print(selectedRow)
      showModal(modalDialog(
        title = "Run program",
        "This should trigger the program to be executed - not implemented yet"
      ))
      # execute_R_prog(study, lopoPath, selectedRow)
      
    })
    
    
    observeEvent(input$seeb, {
      outputid <- as.numeric(strsplit(input$seeb, "_")[[1]][2])
      js$browseURL(paste0("https://shiny.roche.com/3.5.3/users/remusatp/output3000/?outputid=",outputid,"&study=",study,"&server=",server_))
    })
    
    
    ####Create single program onclick
    
    observeEvent(input$create_button, {
      cat(file=stderr(), "Request to create lopo program\n")
      
      showModal(modalDialog(
        title = "Create program",
        "This triggers the creation of the selected program",
        easyClose = TRUE
      ))
      
      # s_path<-paste0(main_path,"Studies/",study,"/",study)
      # selectedRow <- as.numeric(strsplit(input$create_button, "_")[[1]][2])
      # metaOutput <- getOutput(study,s_path,selectedRow) 
      # create_R_program(paste0("Studies/",study,"/program/"),metaOutput$`Program ID`,"test")
      # 
      ##check_prog_exisit(paste0("Studies/",study,"/program/",metaOutput$`Program ID`))
      ##if prog exisit , update database
      
      # showModal(modalDialog(
      #   title = "Program created",
      #   "Program have been created",
      #   easyClose = TRUE
      # ))
      
      # myLopo <- getLopo(studyl,lopoPath)
      # js$reset()
    })
    
    # Updates goButton's label and icon
    # updateActionButton(session, "goButton",
    #                    label = "New label",
    #                    icon = icon("calendar"))
    
  return(reactive(m_lopo_rv$query))
}