Bathymetry demo with echarty

app.R

#'  echarty demo for marmap
library(shiny)
library(shinydashboard)
library(shinybusy)
library(echarty)
library(marmap)

ui = dashboardPage(title='marmap', dashboardHeader(title='Bathymetry Demo'),
     sidebar = dashboardSidebar(
       fluidRow( column(12,
          selectInput('locat', 'Load data', 
                      choices = c("Choose one"='','Hawaii','NW.Atlantic','NW + metallo','Florida','Aleutians','Celt')), 
          checkboxInput('amp', 'add marmap 2D plot', value=FALSE),
          radioButtons('proj', '3D projection', 
                       choices=c('orthographic','perspective')),
          radioButtons('type', 'Chart type', 
                       choices=c('surface','scatter3D')),
          selectInput('elev', 'Land elev. max', 
                      choices = c('cut to:'='',50,100,500,1000))
       )),
       fluidRow( column(12, align = "center",
          htmlOutput("nrow"), br(),br(),
          actionButton("info", label=tags$img(src ="https://img.icons8.com/metro/2x/info.png", alt='Help', width= '30')),
          
          div(span('Made with '),tags$a(href="https://github.com/ericpante/marmap", "marmap"),
              br(),span('and '), tags$a(href="https://github.com/helgasoft/echarty", "echarty"))
       )) 
     ),
     body = dashboardBody(
       fillPage(
         ecs.output('bathy3D', height='70vh'),
         add_busy_spinner(spin = "fading-circle", margins=c(100, 100)),
         plotOutput("mmp", height="25vh")
       )
     )
)


server = function(input, output, session) {
  
  lolarat <- function(df) {
    # ratio longitude/latitude for cartesian display
    if (is.null(df)) return(NULL)
    lon <- range(df$x)
    lat <- range(df$y)
    dx <- lon[2]-lon[1]
    dy <- lat[2]-lat[1]
    dx/dy  # ratio
  }
  arg <- NULL
  datu <- reactive({
    arg$ztop <<- 9999
    amp <- isolate(input$amp)
    elev <- isolate(input$elev)
    choice <- tolower(input$locat)
    if (startsWith(choice, 'nw')) choice <- 'nw'
    tmp <- switch(choice,
        hawaii = { arg$ztop <<- 100; data(hawaii);
        fortify.bathy(hawaii) },
        #tt <- fortify.bathy(hawaii); tt[1:8970,] }, # or 14950 = faster
        florida = { arg$ztop <<- 1; data(florida);
        fortify.bathy(florida) },
        celt = { arg$ztop <<- 21; data(celt);
        fortify.bathy(celt) },
        aleutians = { data(aleutians);
          fortify.bathy(aleutians) },
        nw = { arg$ztop <<- 5; data(nw.atlantic);
        tt <- nw.atlantic; colnames(tt) <- c('x','y','z'); 
        tt } 
    )
    arg$ratio <<- lolarat(tmp)
    if (!is.null(tmp)) {
      output$nrow <- renderUI({ 
        HTML(paste(input$locat,'=', nrow(tmp), 'points',
                   '<br/>lon/lat ratio =',round(arg$ratio,3)) ) })
      
      if (amp) output$mmp <- renderPlot({
        mmplot(tmp, input$locat)
      })
      if (elev!='') {
        mm <- as.numeric(elev)
        tmp[which(tmp$z > mm),]$z <- mm   # cut some land elevations as inaccurate
      }
    }
    tmp
  })
  mmplot <- function(tmp, choice) {
    if (grepl('metal', choice)) {
      # from ?metallo example:
      plot(as.bathy(tmp), deep=c(-8000,-4000,0), shallow=c(-4000,-500,0), step=c(500,500,0),
           lwd=c(0.5,0.5,1.5), lty=c(1,1,1),
           col=c("grey80", "grey20", "blue"),
           drawlabels=c(FALSE,FALSE,FALSE) )
      points(metallo, cex=1.5, pch=19,col=rgb(0,0,1,0.5))
    } else
      plot(as.bathy(tmp), image=TRUE)
  }
  
  output$bathy3D <- ecs.render({
    tmp <- datu()
    if (is.null(tmp)) return(NULL)
    afor <- htmlwidgets::JS("function(val){ return Math.round(val * 100) / 100;}")
    dname <- isolate(input$locat)
    series <- list(
      list(type=input$type, wireframe=list(show=FALSE), symbolSize=2, data= ec.data(tmp))
    )
    if (grepl('metal', dname)) {
      data(metallo); tt <- metallo; 
      colnames(tt) <- c('x','y','z'); tt$z <- -tt$z
      series <- append(series, list(list(
        type='scatter3D', symbolSize=10, 
        # color taken by visualMap, set border instead
        itemStyle = list(borderWidth=3, borderColor='magenta',opacity=1),
        data = ec.data(tt) )))
    }
    
    ec.init(load='3D', title=list(text= dname), 
        xAxis3D= list(scale=TRUE, name='Longitude',axisLabel=list(formatter=afor),
                      min=round(min(tmp$x)), max=round(max(tmp$x))),
        yAxis3D= list(scale=TRUE, name='Latitude', axisLabel=list(formatter=afor),
                      min=round(min(tmp$y)), max=round(max(tmp$y))),
        zAxis3D= list(name='Depth'),   # min=min(tmp$z)-1000, max=max(tmp$z)+1000, # flatten somewhat, too excessive
        grid3D= list( viewControl=list(projection = input$proj),
                      boxWidth = 100 * arg$ratio, boxHeight=100, boxDepth=100),
        visualMap= list(inRange=list(color=rev(rainbow(7))), calculable=TRUE,
                        min=min(tmp$z), max=max(tmp$z), dimension=3,
                        itemHeight=380, itemWidth=18, range=c(min(max(tmp$z),arg$ztop), min(tmp$z))),
        toolbox= list(feature= list(saveAsImage= list(backgroundColor= '#111'))),
        series= series
    ) |> ec.theme('dark-mushroom')
  })
  
  observeEvent(input$amp, {
    if (input$amp) {
      if (!is.null(datu()))
        output$mmp <- renderPlot({ mmplot(datu(), input$locat) }) 
    } else
      output$mmp <- renderPlot({ NULL })
  })
  
  observeEvent(input$info, {
    showModal(modalDialog(
      title = "Bathymetry in 3D interactive",
      tags$div("Presenting ",strong('marmap')," bathymetry data in 3D with ",
         tags$a(href="https://github.com/helgasoft/echarty", "echarty")," - a visualization library based on JavaScript library ",tags$a(href="https://echarts.apache.org","ECharts"),
         br(),"3D plots support zoom in/out and XYZ rotation. Color bar shows current depth on mouse hover, and can show/hide depth levels.",
         tags$ul(
           tags$li("Dropdown ",tags$em('Load data')," contains all marmap datasets sorted by size."),
           tags$li("Checkbox ",tags$em('add marmap 2D plot')," will display 2D plots for comparison."),
           tags$li("Dropdown ",tags$em('Land elev.max'),", if used, has to be set before ",tags$em('Load data'),". It limits dry land elevations to the selected value. It also changes the coloring since less elevation values match the same amount of colors.")
           #It is the only parameter which will not change the plot instantly
         ),
         "Notes:",
         br(),"When the ",strong('color slider')," overlaps a (zoomed) map, it does not respond  to mouse clicks. Probably a bug in ECharts - workaround is to zoom out until the slider separates from the map.",
         br(),"Dry land elevations in bathymetry data look random. In some examples we preset the color slider top to a certain value. This shows coastlines more clearly.",
         br(),br(),"Comments are welcome here in the gist, or in ",tags$a(href="https://github.com/helgasoft/echarty/issues", "echarty"),"."
      )
    ))
  })
}
if (interactive()) shinyApp(ui,server)

Here is a simple 3D surface display (inquiry by @nvelden)

library(echarty)
data(volcano)
ec.init(load='3D',
   series= list(list(
	type = 'surface'
	,data = ec.data(as.data.frame(as.table(volcano)), 'values')
	,wireframe= list(show= FALSE)
	,shading= 'realistic', realisticMaterial= list(metalness= 0.5, roughness= 0.6)
   )),
   visualMap= list(calculable=TRUE, dimension=2, inRange=list(color= rev(rainbow(10))) ),
   grid3D= list(viewControl= list(autoRotate= TRUE))
)