R/mod_mappingTab.R

In safetyGraphics: Interactive Graphics for Monitoring Clinical Trial Safety

#' @title UI for mapping tab covering of all data domains
#' 
#' @param id module id
#' @param meta metadata for all domains
#' @param domainData list of data files for each domain
#' @param mappings optional data frame containing stacked mappings for all domains
#' @param standards optional list of data standards like the ones generated by \code{detectStandard()}
#' 
#' @importFrom stringr str_to_upper
#' 
#' @export

mappingTabUI <- function(id, meta, domainData, mappings=NULL, standards=NULL){  
  ns <- NS(id)
  if(is.null(mappings)){
    mappings<-unique(meta[,c('domain','text_key')]) %>% mutate(current="")
  }
  # check inputs
  stopifnot(
    is.data.frame(meta), 
    is.list(domainData), 
    all(domainData %>% lapply(is.data.frame) %>% unlist),
    is.data.frame(mappings),
    is.character(mappings$text_key),
    is.character(meta$text_key)
  )
  
  #intialize a domain mapping for each domain in the metadata with a data set in domainData
  domain_ui <- list()
  metaDomains <- unique(meta$domain)
  dataDomains <- names(domainData)
  domains <- metaDomains[metaDomains %in% dataDomains]
  
  for(i in 1:length(domains)){
    
    current_meta <- meta %>% filter(domain == !!domains[i])
    domain<-domains[i]
    current_mapping <- mappings %>% filter(domain %in% !!domains[i]) %>% select(-"domain")
    current_standard <- standards[[domain]]
    domain_ui[[i]] <-div(class="mapping-domain",
      div(class="domain-header",
        span(class="domain-title", str_to_upper(domain)),
        div(class="domain-wrap",
            span(class="domain-label", "Dimension"),
            span(class="domain-value", paste(dim(domainData[[domain]]),collapse="x")),
        ),
        div(class="domain-wrap",
            span(class="domain-label", "Standard"),
            span(class="domain-value", current_standard[["label"]])
        )
      ),
      div(class="domain-body row",
        div(class="domain-controls col-md-3", mappingDomainUI(ns(domain), current_meta, domainData[[domain]], current_mapping)),
        div(class="domain-preview col-md-9", DT::DTOutput(ns(paste0(domain,"-preview"))))
      )
    )
  }
  domain_ui<- list(
    h1("Data Mapping"),
    span("This page dynamically establishes which columns and fields from the loaded data map to different chart properties. When possible, data standards are automatically detected and values are pre-filled."),
    checkboxInput(ns("toggleData"), "Show Data Previews?", FALSE),
    br(),
    domain_ui
  )

  return(domain_ui)
}


#' @title Server for mapping tab covering of all data domains
#'
#' @param input Shiny input object
#' @param output  Shiny output object
#' @param session Shiny session object
#' @param meta metadata for all domains
#' @param domainData clinical data for all domains
#' 
#' @return list of mappings for all domains
#'
#' @importFrom shinyjs addClass show removeClass hide
#' 
#' @export

mappingTab <- function(input, output, session, meta, domainData){
  metaDomains <- unique(meta$domain)
  dataDomains <- names(domainData)
  domain_ids <- metaDomains[metaDomains %in% dataDomains]

  if(length(domain_ids) < length(metaDomains)){
    domains_noData <- metaDomains[!(metaDomains %in% dataDomains)]
    message("No data sets provided for the following domains listed in metadata: ",paste(domains_noData, collapse=", "))
  }

  observeEvent(input$toggleData,{
    if(input$toggleData){
      shinyjs::addClass(class="col-md-3", selector = ".domain-controls")
      shinyjs::show(selector = ".domain-body .domain-preview")
    }else{
      shinyjs::removeClass(class="col-md-3", selector = ".domain-controls")
      shinyjs::hide(selector = ".domain-body .domain-preview")
    }
  })

  #show data previews
  lapply(domain_ids, function(domain){
    output[[paste0(domain,"-preview")]] <- renderDT({
      DT::datatable(
        domainData[[domain]], 
        rownames = FALSE,
        options = list(
          scrollX=TRUE
        ),
        class="compact"
      )
    })
  })

  names(domain_ids)<-domain_ids # so that lapply() creates a named list below
  domain_modules <- domain_ids %>% lapply(function(domain){
    this_meta<- meta%>%filter(domain==!!domain)
    this_data <- domainData[[domain]]
    callModule(mappingDomain, domain, this_meta ,this_data)
  })

  reactive({
    data<-data.frame()
    for(domain in domain_ids){
      current<-domain_modules[[domain]]() 
      current$domain <- domain
      current <- current %>% select(.data$domain, .data$text_key, .data$current)
      data<-rbind(data, current)
    }
    return(data)
  })
}