MetaShARK update

Trying to force a new architecture to replace the old one

shinyApp/main.R

@@ -4,26 +4,64 @@ setwd(dirname(rstudioapi::getActiveDocumentContext()$path))
 
 ### IMPORTS ###
 library(shiny)
+library(shinydashboard)
 
-
+source("modules/documentation/documentation.R")
 
 ### RESOURCES ###
 
 # IM: Id Modules - first: session - last: output id - others: intermediary id
-IM.navTree = c("navTreeModule", "navTree", "navTreeSelect","navPath","navSearch")
+IM.doc = c("docModule", "Documentation", "docSelect","docPath","docSearch")
+# IM.doc = c("fillModule", "Fill")
 
 ### UI ###
-ui <- fluidPage(
-
-    )
-  ),
-  tabsetPanel(
-    tabPanel("Fill", "Nothing yet"),
-    tabPanel("Documentation", navTreeUI(IM.navTree[1], IM = IM.navTree))
-  )
+ui <- dashboardPage(dashboardHeader(title = "MetaShARK"),
+                    ## Menus ##
+                    dashboardSidebar(
+                      sidebarMenu(
+                        menuItem("Generate EML", tabName = "generate", icon = icon("file")),
+                        menuItem("Fill in EML", tabName = "fill", icon = icon("file-import")),
+                        menuItem("EML Documentation", tabName = "documentation", icon = icon("glasses")),
+                        menuItem("About MetaShARK", tabName = "about", icon = icon("beer"))
+                      )
+                    ),
+                    ## Content ##
+                    dashboardBody(
+                      tabItems(
+                        tabItem(tabName = "generate"),
+                        tabItem(tabName = "fill"),
+                        tabItem(tabName = "documentation",
+                                docUI(IM.doc[1], IM = IM.doc)),
+                        tabItem(tabName = "about")
+                      )
+                    )
 )
 
+# ui <- fluidPage(
+#   # Styling and other user-friendly settings
+#   tags$head(
+#     tags$style(
+#       HTML("
+#         pre {
+#           white-space: pre-wrap;
+#           word-break: keep-all;
+#         }
+#       ")
+#     )
+#   ),
+#   tabsetPanel(
+#     tabPanel("Fill", "Nothing yet"),
+#     tabPanel("Documentation", )
+#   )
+# )
 
+### SERVER ###
+server <- function(input,output,session){
+  session$onSessionEnded(stopApp)
+
+  # modules called
+  output <- callModule(documentation, IM.doc[1], IM = IM.doc)
+  # callModule(fill, IM.fill[1], IM = IM.fill)
 }
 
 ### APP LAUNCH ###

shinyApp/modules/documentation/documentation.R

@@ -0,0 +1,85 @@
+### documentation.R
+
+# Imports
+library(shinyTree)
+source("modules/documentation/documentation_functions.R")
+source("modules/documentation/documentation_style.R")
+source("utils/multiApply.R")
+
+# Guidelines
+cat("Loading Guidelines: \n")
+cat("* Loading Doc Guideline ...\r")
+docGuideline = as.list(readRDS("resources/docGuideline.RData"))
+cat("* Doc Guideline successfully loaded !\n")
+cat("* Loading System Guideline ...\r")
+systemGuideline = as.list(readRDS("resources/systemGuideline.RData"))
+cat("* System Guideline successfully loaded !\n")
+
+# UI functions
+docUI <- function(id, IM){
+  ns <- NS(id)
+
+  # UI output
+  fluidRow(
+    # search sidebar
+    column(4,
+           box(shinyTree(outputId = ns(IM[2]), # render tree
+                         search = TRUE),
+               width = 12
+           )
+           , style = sidebarStyle
+    ),
+    # display main panel
+    column(8,
+           div(box(uiOutput( ns(IM[4]) ), # XPath
+                   uiOutput( ns(IM[3]) ), # Documentation
+                   width = 12
+               )
+               , style = mainpanelStyle
+           )
+    )
+  )
+}
+
+
+
+# Server functions
+documentation <- function(input, output, session, IM, tree = docGuideline){
+
+  # render tree
+  output[[IM[2]]] <- renderTree(tree)
+
+  # output selected node
+  output[[IM[3]]] <- renderText({
+    jstree <- input[[IM[2]]]
+    if (is.null(jstree)){
+      "None"
+    } else{
+      node <- get_selected(tree = jstree)
+      if(length(node) == 0)
+        return("(Select a node first)")
+      docPath <- gsub("^/","",
+                       paste(
+                         paste(attr(node[[1]], "ancestry"), collapse="/"),
+                         unlist(node),
+                         sep="/")
+      )
+      output[[IM[4]]] <- renderText(as.character(h3(docPath)))
+
+      # fetch the systemGuideLine path in the userGuideLine list
+      systemPath <- followPath(tree, docPath)
+
+      if(!is.character(systemPath))
+        systemPath <- commonPath(systemPath,unlist(node))
+      # return(userPath)
+
+      # fetch the eml-xsd content in the systemGuideLine list
+      systemContent <- followPath(systemGuideline, systemPath)
+      out <- extractContent(systemContent)
+      return(out)
+    }
+  })
+
+}
+
+

shinyApp/modules/documentation/documentation_functions.R

@@ -0,0 +1,210 @@
+# documentation_functions.R
+
+# --- UI display
+
+# extracts the targetted EML content from a list
+extractContent <- function(content){
+  # modules annotation is stored in 'eml-module/schema'
+  if(any(grepl("schema", attr(content,"names"))))
+    content <- content[[which(grepl("schema",attr(content,"names")))]]
+  if(any(grepl("annotation", attr(content,"names")))){
+
+    ## content
+    out <- unlist(content[grepl("annotation", attr(content, "names"))])
+    # preprocess 'ulink' tags that require their URL attributes (R-Attributes needed)
+    {
+      ulinks.ind = which(grepl("ulink", attr(out, "names"))) # ulinks are always structured the same way
+      # browser()
+      out[ ulinks.ind[1:length(ulinks.ind) %% 3 == 1] ] <- paste(out[ ulinks.ind[1:length(ulinks.ind) %% 3 == 1] ], # raw text
+                                                                 out[ ulinks.ind[1:length(ulinks.ind) %% 3 == 2] ], # URL
+                                                                 sep = "[RECOGNIZED]")
+    }
+    out <- out[!grepl("R-Attributes", attr(out, "names"))]
+    out <- sapply(out, gsub,  pattern = " +", replacement = " ")
+
+    ## titles
+    attr(out, "names") <- gsub("\\.[0-9]+_$","", attr(out, "names"))
+    attr(out, "names") <- gsub("^.*_","", attr(out, "names"))
+    attr(out, "names") <- gsub("([a-z])([A-Z])","\\1 \\2", attr(out, "names"))
+
+    #- reorganizing
+    out <- nt.titles(out, list(remove = "emphasis",
+                               remove = "citetitle",
+                               replace = "module Name",
+                               moveback = "documentation",
+                               tocode = "literal Layout",
+                               use = "title",
+                               use = "para",
+                               addurl = "ulink"))
+
+    out <- sapply(seq_along(out),
+                  function(o){
+                    if(attr(out,"names")[o] %in% c("recommended Usage",
+                                                   "tooltip",
+                                                   "stand Alone"))
+                      return(paste(tags$b(attr(out, "names")[o]),
+                                   ":", out[o],
+                                   "\n",
+                                   sep = " "))
+                    else
+                      return(paste(h2(attr(out, "names")[o]),
+                                   out[o],
+                                   sep = "\n"))
+                  })
+
+    return(paste0(out, sep = "<br>"))
+  }
+  if(any(grepl("REF",attr(content[["R-Attributes"]],"names")))){
+    return(paste0(tags$b("See also: "),
+                  content[["R-Attributes"]][["REF"]],
+                  "\n"))
+  }
+  else {
+    return("No content found")
+  }
+}
+
+# Apply @action on elements from @vec named after @targets
+nt.titles <- function(vec, action_target){
+  sapply(action_target,
+         function(target){
+
+           # parse args
+           action = attr(action_target, "names")[match(target, action_target)]
+
+           # validity check
+           possibleActions <- c("remove","replace","moveback",
+                                "tocode", "use", "addurl")
+           if(!any(sapply(possibleActions, grepl, action)))
+             stop("Action not recognized, must be one of those:\n", 
+                  paste(possibleActions,sep=" "))
+
+           #--- process - The commands are executed one by one as the rest of
+           #              the list is processed automatically
+           targeted <- which(attr(vec,"names") %in% target)
+           if(length(targeted) > 0){
+
+             # remove unwanted
+             if(action == "remove"){
+               for(i in targeted){
+                 j = i-1
+                 while(j %in% targeted) j <- j-1
+                 vec[j] <- paste(vec[j], tags$cite(vec[i]), vec[i+1], sep = " ")
+               }
+               vec <- vec[-c(targeted, targeted+1)]
+             }
+
+             # replace names
+             if(action == "replace"){
+               attr(vec, "names")[targeted] <- vec[targeted]
+               vec[targeted] <- ""
+             }
+
+             # move back the section
+             if(action == "moveback"){
+               vec <- c(vec[-targeted], vec[targeted])
+             }
+
+             # change literalLayout to code tag
+             if(action == "tocode"){
+               attr(vec,"names")[targeted] <- ""
+               for(t in targeted)
+                 vec[t] <- as.character(pre(code(vec[t])))
+             }
+
+             # use the section name as HTML tag
+             if(action == "use"){
+               attr(vec,"names")[targeted] <- ""
+
+               if(target == "title")
+                 vec[targeted] <- HTML(as.character(
+                   gsub("\n","",tags$h4(vec[targeted]))
+                 ))
+
+               if(target == "p")
+                 vec[targeted] <- p(vec[targeted])
+             }
+
+             if(action == "addurl"){
+               # browser()
+               work <- unlist(strsplit(vec[targeted],
+                                       split = "\\[RECOGNIZED]"))
+               work[1] <- gsub("\n", "", work[1])
+               vec[targeted] <- HTML(as.character(
+                 a(work[1],
+                   href = work[2])
+               ))
+               # empirical: ulink never occurs as first element, neither as last
+               vec[targeted-1] <- paste(vec[(targeted-1):(targeted+1)],
+                                        collapse = " ")
+               vec <- vec[-c(targeted, targeted+1)]
+             }
+           }
+           #--- end of process
+
+           # commit changes to vec
+           vec <<- vec
+         })
+  # end of nt.titles
+  return(vec)
+
+}
+
+# Extract the path made common from every leaf path
+commonPath <- function(li,name){
+  paths <- unlist(li)
+  paths <- sapply(paths, strsplit, split = "/")
+  minLength <- min(sapply(paths, length))
+  minInd <- min(sapply(paths, function(path){
+    length(which(path[1:minLength] == paths[[1]][1:minLength]))
+  }))
+  common <- paste(paths[[1]][1:minInd], collapse = "/")
+  # browser()
+  common <- gsub(paste0("(",
+                        gsub("(.*_| )",
+                             "",
+                             name),
+                        ").*"),
+                 "\\1",
+                 common)
+  return(common)
+}
+
+# --- List handling
+
+# Takes a hierarchy list (tree), a path written in a vector pasted
+# with sep = @ep, and returns the leaf
+# @param tree: explored hierarchy list thanks to @path
+# @param path: vector of characters matching some of @tree names and
+#              separated with @sep
+# @param sep: separators between @path elements (aka @tree names)
+followPath <- function(tree, path, sep = "/"){
+  # Validity checks
+  if(is.null(tree) || is.null(path))
+    stop("'tree' and 'path' args must be specified")
+  if(length(path) > 1)
+    stop("path shall be a vector of characters")
+  if(sep == "")
+    stop("path can't be parsed with @sep")
+
+  if(is.list(path))
+    path <- unlist(path)
+
+  # Processing
+  path <- unlist(strsplit(path,sep))
+  path = path[!path == "Root"]
+
+  while(length(path) != 0){
+    tree <- tree[[ path[1] ]]
+    path = path[-1]
+  }
+
+  return(tree)
+}
+
+
+# check if one of the children of the input list is a list
+has_child <- function(li){
+  if(!is.list(li)) return(FALSE)
+  return(any(sapply(li, is.list)))
+}

shinyApp/modules/documentation/documentation_style.R

@@ -0,0 +1,10 @@
+# documentation_style.R
+# Style sheet for NavTree module
+
+
+
+sidebarStyle = "overflow-y: scroll;
+                  max-height: 800px;"
+
+mainpanelStyle = "overflow-y: scroll;
+                  max-height: 800px;"