inst/shiny-server/ui.R

In IOHanalyzer: Data Analysis Part of 'IOHprofiler'

for (f in list.files('ui', pattern = '.R', full.names = T)) {
  source(f)
}

# NOTE: this is copied from `shinydashboard`
#' Assert that a tag has specified properties
#' @param tag A tag object.
#' @param type The type of a tag, like "div", "a", "span".
#' @param class An HTML class.
#' @param allowUI If TRUE (the default), allow dynamic outputs generated by
#'   \code{\link[shiny]{uiOutput}} or \code{\link[shiny]{htmlOutput}}. When a
#'   dynamic output is provided, \code{tagAssert} won't try to validate the the
#'   contents.
#' @keywords internal
tagAssert <- function(tag, type = NULL, class = NULL, allowUI = TRUE) {
  if (!inherits(tag, "shiny.tag")) {
    print(tag)
    stop("Expected an object with class 'shiny.tag'.")
  }

  # Skip dynamic output elements
  if (allowUI &&
      (hasCssClass(tag, "shiny-html-output") ||
       hasCssClass(tag, "shinydashboard-menu-output"))) {
    return()
  }

  if (!is.null(type) && tag$name != type) {
    stop("Expected tag to be of type ", type)
  }

  if (!is.null(class)) {
    if (is.null(tag$attribs$class)) {
      stop("Expected tag to have class '", class, "'")

    } else {
      tagClasses <- strsplit(tag$attribs$class, " ")[[1]]
      if (!(class %in% tagClasses)) {
        stop("Expected tag to have class '", class, "'")
      }
    }
  }
}

# Modified dashboard header from the original source for incorporating two `select input` widgets
.dashboardHeader <- function(..., title = NULL, titleWidth = NULL, disable = FALSE, .list = NULL) {
  items <- c(list(...), .list)
  lapply(items, tagAssert, type = "li", class = "dropdown")

  titleWidth <- validateCssUnit(titleWidth)

  # Set up custom CSS for custom width.
  custom_css <- NULL
  if (!is.null(titleWidth)) {
    # This CSS is derived from the header-related instances of '230px' (the
    # default sidebar width) from inst/AdminLTE/AdminLTE.css. One change is that
    # instead making changes to the global settings, we've put them in a media
    # query (min-width: 768px), so that it won't override other media queries
    # (like max-width: 767px) that work for narrower screens.
    custom_css <- tags$head(
      tags$style(
        HTML(
          gsub(
            "_WIDTH_", titleWidth, fixed = TRUE, '
            @media (min-width: 768px) {
              .main-header > .navbar {
                margin-left: _WIDTH_;
              }
              .main-header .logo {
                width: _WIDTH_;
              }
            }'
          )
        )
      )
    )
  }

  tags$header(
    class = "main-header",
    id = 'header',
    custom_css,
    style = if (disable) "display: none;",
    span(class = "logo", title),
    tags$nav(
      class = "navbar navbar-static-top", role = "navigation",
      # Embed hidden icon so that we get the font-awesome dependency
      span(shiny::icon("bars"), style = "display:none;"),
      # Sidebar toggle button
      a(
        href="#", class="sidebar-toggle", `data-toggle`="offcanvas",
        role="button", span(class="sr-only", "Toggle navigation")
      ),

      # select inputs for dimension and function/problem ID

      # HTML('
      #  <div class="col-sm-1">
      #  </div>
      #  <table class=".table">
      #    <tr>
      #      <td>
      #        <b>Dimension:</b>
      #        <select id="Overall.Dim" style="width: 100px; margin: 7px 20px 5px 1px;">
      #        </select>
      #      </td>
      #      <td>
      #        <b>Problem ID:</b>
      #        <select id="Overall.Funcid" style="width: 100px; margin: 7px 20px 5px 1px;">
      #        </select>
      #      </td>
      #    </tr>
      #  </table>'
      # ),

      div(
        class = "navbar-custom-menu",
        tags$ul(class = "nav navbar-nav", items)
      )
    )
  )
}

header <- .dashboardHeader(title = HTML('<div align="center"><b>IOHanalyzer</b></div>'))

# The side bar layout ---------------------------------------------
sidebar <- dashboardSidebar(
  tags$style(
    "#sidebarItemExpanded {
            overflow: auto;
            max-height: 100vh;
        }"
  ),
  useShinyjs(),
  sidebar_menu(),
  hr(),
  DIM_fID_panel()
)

body <- dashboardBody(
  tags$style(
    HTML('
       .popover-title {color:black;}
       .popover-content {color:black;}
       .main-sidebar {z-index:auto;}
       .fa-exclamation-triangle {color:#E87722}
       .sticky {
         position: fixed;
         top: 0;
         width: 100%;
        }

       .sticky2 {
         position: fixed;
        }

       .table {
          border-collapse: collapse;
          width: 100%;
        }
       .table td, tr {
          padding: 0px;
          margin: 0px;
          vertical-align: middle;
          height: 45px;
        }
       .table th {height: 0px;}'
    )
  ),

  # to show text on the header (heading banner)
  tags$head(
    tags$style(
      HTML('
        .myClass {
          font-size: 20px;
          line-height: 50px;
          text-align: left;
          font-family: "Helvetica Neue",Helvetica,Arial,sans-serif;
          padding: 0 15px;
          overflow: hidden;
          color: white;
        }'
      )
    )
  ),

  tags$head(
    tags$style(
      HTML(
        '.box-title {
            font-size: 20px;
            line-height: 50px;
            text-align: left;
            font-family: "Helvetica Neue",Helvetica,Arial,sans-serif;
            padding: 0 15px;
            overflow: hidden;
            color: white;
          }'
      )
    )
  ),

  tags$head(
    tags$style(
      HTML(
        "label { font-size:120%; }"
      )
    )
  ),

  tags$script(
    HTML('
      $(document).ready(function() {
        $("header").find("nav").append(\'<span class="myClass">Performance Evaluation for Iterative
        Optimization Heuristics</span>\');
      })'
    )
  ),

  tags$script(
    "Shiny.addCustomMessageHandler('background-color',
      function(color) {
        document.body.style.backgroundColor = color;
        document.body.innerText = color;
      });"
  ),

  tags$script(
    HTML('
      window.setInterval(function() {
        var elem = document.getElementById("process_data_promt");
        if (typeof elem !== "undefined" && elem !== null) elem.scrollTop = elem.scrollHeight;
      }, 20);'
    )
  ),

  tags$head(
    tags$script(
      HTML("
        Shiny.addCustomMessageHandler('manipulateMenuItem', function(message){
          var aNodeList = document.getElementsByTagName('a');

          for (var i = 0; i < aNodeList.length; i++) {
            if(aNodeList[i].getAttribute('data-value') == message.tabName || aNodeList[i].getAttribute('href') == message.tabName) {
              if(message.action == 'hide'){
                aNodeList[i].setAttribute('style', 'display: none;');
              } else {
                aNodeList[i].setAttribute('style', 'display: block;');
              };
            };
          }
        });
      ")
    )
  ),

  # make the data uploading prompt always scroll to the bottom
  tags$script(
    HTML('
       window.setInterval(function() {
         var elem = document.getElementById("upload_data_promt");
         if (typeof elem !== "undefined" && elem !== null) elem.scrollTop = elem.scrollHeight;
       }, 20);'
    )
  ),

  # render the header and the side bar 'sticky'
  tags$script(
    HTML(
      '// When the user scrolls the page, execute myFunction
      window.onscroll = function() {myFunction()};

      // Get the header
      var header = document.getElementById("header");

      // Get the side bar
      var sideBar = document.getElementById("sidebarCollapsed");
      sideBar.classList.add("sticky2");

      // Get the offset position of the navbar
      var sticky = header.offsetTop;

      // Add the sticky class to the header when you reach its scroll position.
      // Remove "sticky" when you leave the scroll position
      function myFunction() {
        if (window.pageYOffset > sticky) {
          header.classList.add("sticky");
        } else {
          header.classList.remove("sticky");
        }
      }'
    )
  ),

  # load MathJax
  # TODO: download MathJax and its license and include it in our package
  HTML("<head><script src='https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.4/MathJax.js?config=TeX-MML-AM_CHTML'
       async></script></head>"),
  use_bs_tooltip(),
  use_bs_popover(),

  # tabitems ----------------------
  tabItems(
    tabItem(tabName = 'about', includeMarkdown('markdown/about.md')),
    # tabItem(tabName = 'dataformat', includeMarkdown('markdown/dataformat.md')),

    # data uploading functionalities -----------------
    tabItem(
      tabName = 'upload',
      fluidRow(
        welcome_bar(width = 12)
      ),

      fluidRow(
        column(
          width = 6,
          upload_box(collapsible = F)
        ),

        column(
          width = 6,
          overal_loading_box(collapsible = F)
        )
        # column(
        #   width = 4,
        #   ontology_box(collapsible = F)
        # ),
      ),

      fluidRow(
        column(
          width = 6,
          upload_prompt_box(collapsible = F)
        ),
        column(
          width = 6,
          data_list_box(collapsible = F)
        )
      )
    ),

    # General data overview ----------------------
    tabItem(
      tabName = 'overview',
      fluidRow(
        column(
          width = 12,
          general_overview_box_all(collapsed = F),
          general_overview_box_single(collapsed = F)
        )
      )
    ),

    # RT (RunTime): Data Summary -----------------
    tabItem(
      tabName = 'ERT_data',
      fluidRow(
        column(
          width = 12,
          rt_overview_box(collapsed = F),
          rt_stats_box(collapsed = F),
          rt_sample_box()
        )
      )
    ),

    # RT: Expected Convergence Curve ---------------------------------------------
    tabItem(
      tabName = 'ERT_convergence_single',
      fluidRow(
        column(
          width = 12,
          ERT_box(collapsed = F),
          ERT_comparison_box_dim()
        )
      )
    ),

    tabItem(
      tabName = 'ERT_convergence_aggr',
      fluidRow(
        column(
          width = 12,
          ERT_agg_box(collapsed = F),
          ERT_comparison_box(collapsed = T)
        )
      )
    ),

    # RT: histograms, violin plots ------------------------------------------
    tabItem(
      tabName = 'RT_PMF',
      fluidRow(
        column(
          width = 12,
          rt_histogram_box(collapsed = F),
          rt_pmf_box(),
          rt_CDP_box()
        )
      )
    ),

    # RT ECDF ------------------------------------------
    tabItem(
      tabName = 'RT_ECDF_single',
      fluidRow(
        column(
          width = 12,
          rt_ecdf_single_target_box(collapsed = F),
          rt_ecdf_agg_targets_box()
          # rt_ecdf_auc_box()
        )
      )
    ),

    tabItem(
      tabName = 'RT_ECDF_aggr',
      fluidRow(
        column(
          width = 12,
          rt_ecdf_agg_fct_box(collapsed = F)
        )
      )
    ),

    # Parameter tab -------
    tabItem(
      tabName = 'RT_PARAMETER',
      fluidRow(
        column(
          width = 12,
          rt_par_summary_box(collapsed = F),
          rt_par_expected_value_box(),
          rt_par_sample_box()
        )
      )
    ),

    tabItem(
      tabName = 'RT_Statistics_single',
      fluidRow(
        column(
          width = 12,
          rt_heatmap_box()
        )
      )
    ),
    tabItem(tabName = 'RT_DSC',
            fluidRow(
              column(
                width = 12,
                rt_dsc_box_rank(),
                rt_dsc_box_omni(),
                rt_dsc_box_posthoc()
              )
            )
    ),
    tabItem(tabName = 'RT_Statistics_aggr',
            fluidRow(
              column(
                width = 12,
                fv_nevergrad_box(collapsed = F),
                rt_glicko2_box(collapsed = T)
              )
            )

    ),
    tabItem(tabName = 'RT_table_multi',
            fluidRow(
              column(
                width = 12,
                multi_function_ert_box(collapsed = F),
                multi_function_sample_box(collapsed = T)
              )
            )

    ),
    tabItem(tabName = 'RT_portfolio',
            fluidRow(
              column(
                width = 12,
                rt_shapleys_box(collapsed = F)
              )
            )

    ),
    # FCE: Data Summary -----------------
    tabItem(
      tabName = 'FCE_DATA',
      fluidRow(
        column(
          width = 12,
          fv_overview_box(collapsed = F),
          fv_stats_box(collapsed = F),
          fv_sample_box()
        )
      )
    ),

    # FCE: Expected Convergence Curve ---------------------------------------------
    tabItem(
      tabName = 'FCE_convergence_single',
      fluidRow(
        column(
          width = 12,
          fv_per_fct_box(collapsed = F)
         )
      )
    ),

    tabItem(
      tabName = 'FCE_convergence_aggr',
      fluidRow(
        column(
          width = 12,
          fv_agg_box(collapsed = F),
          fv_comparison_box()
        )
      )
    ),
    # FCE: historgrams, p.d.f. --------
    tabItem(
      tabName = 'FCE_PDF',
      fluidRow(
        column(
          width = 12,
          fv_histgram_box(collapsed = F),
          fv_pdf_box(),
          fv_CDP_box(collapsed = T)
        )
      )
    ),

    # FCE: empirical c.d.f. ------------------------------------------
    tabItem(
      tabName = 'FCE_ECDF',
      fluidRow(
        column(
          width = 12,
          fv_ecdf_single_budget_box(collapsed = F),
          fv_ecdf_agg_budgets_box(),
          fv_ecdf_auc_box()
        )
      )
    ),


    # Parameter tab -------
    tabItem(
      tabName = 'FCE_PARAMETER',
      fluidRow(
        column(
          width = 12,
          fv_par_expected_value_box(collapsed = F),
          fv_par_summary_box(),
          par_scatter_box(collapsed = T),
          fv_par_sample_box()
        )
      )
    ),

    tabItem(
      tabName = 'FCE_Statistics_single',
      fluidRow(
        column(
          width = 12,
          fv_heatmap_box(collapsed = F)
        )
      )
    ),
    tabItem(tabName = 'FV_table_multi',
            fluidRow(
              column(
                width = 12,
                multi_function_fv_box(collapsed = F),
                multi_function_sample_box_fv(collapsed = T)
              )
            )

    ),

    tabItem(tabName = 'FCE_DSC',
            fluidRow(
              column(
                width = 12,
                fv_dsc_box_rank(),
                fv_dsc_box_omni(),
                fv_dsc_box_posthoc()
              )
            )
    ),

    tabItem(tabName = 'FCE_Statistics_aggr',
            fluidRow(
              column(
                width = 12,
                rt_nevergrad_box(collapsed = F),
                fv_glicko2_box(collapsed = T)
              )
            )
    ),
    tabItem(tabName = 'Positions',
            fluidRow(
              column(
                width = 12,
                Par_coord_box()
              )
            )
    ),
    tabItem(tabName = 'EAF',
            fluidRow(
              column(
                width = 12,
                EAF_box()
              )
            )
    ),
    tabItem(tabName = 'EAF_Diff',
            fluidRow(
              column(
                width = 12,
                EAF_Diff_box()
              )
            )
    ),
    tabItem(tabName = 'EAF_CDF',
            fluidRow(
              column(
                width = 12,
                EAF_CDF_box()
              )
            )
    ),
    tabItem(tabName = 'EAF_mult',
            fluidRow(
              column(
                width = 12,
                EAF_mult_box()
              )
            )
    ),
    tabItem(tabName = 'EAF_CDF_mult',
            fluidRow(
              column(
                width = 12,
                EAF_CDF_mult_box()
              )
            )
    ),

    tabItem(
      tabName = 'Settings',
      fluidRow(
        column(
          width = 12,
          color_settings_box(),
          general_settings_box()
        )
      )
    )
    # tabItem(tabName = 'Report',
    #         fluidRow(
    #           column(
    #             width = 12,
    #             main_report_box()
    #           )
    #         )
    # )
  )
)

# -----------------------------------------------------------
dashboardPage(title = 'IOHanalyzer', header, sidebar, body)