闪亮的保存URL状态子页面和选项卡

Question

我希望有一个闪亮的网站,将URL中的动态选择保持为输出,这样您就可以复制和共享URL.我把这段代码作为例子:https: //gist.github.com/amackey/6841cf03e54d021175f0

并将其修改为我的案例,这是一个网页,navbarPage每个元素在栏中有一个和多个标签.

我想要的是将用户引导到第一级tabPanel中的右侧元素的URL,以及第二级tabPanel中的右侧选项卡.

这是,如果用户导航到"Delta Foxtrot"然后导航到"Hotel",然后将参数更改为 #beverage=Tea;milk=TRUE;sugarLumps=3;customer=mycustomer,我希望URL将用户发送到"Delta Foxtrot" - >"Hotel",而不是从第一个面板元素的第一个选项卡.

理想情况下,我想要一个有效的例子,因为到目前为止我尝试的一切都没有用.

有任何想法吗？

# ui.R
library(shiny)

hashProxy <- function(inputoutputID) {
  div(id=inputoutputID,class=inputoutputID,tag("div",""));
}

# Define UI for shiny d3 chatter application
shinyUI(navbarPage('URLtests', id="page", collapsable=TRUE, inverse=FALSE,
 tabPanel("Alfa Bravo",
   tabsetPanel(
    tabPanel("Charlie",
    tags$p("Nothing to see here. Everything is in the 'Delta Foxtrot' 'Hotel' tab")
             )
       )
    )
 ,tabPanel("Delta Foxtrot",
    tabsetPanel(
    tabPanel("Golf",
    tags$p("Nothing to see here. Everything is in the 'Delta Foxtrot' 'Hotel' tab")
             )
    ,tabPanel("Hotel",

    tags$p("This widget is a demonstration of how to preserve input state across sessions, using the URL hash."),
    selectInput("beverage", "Choose a beverage:",
                choices = c("Tea", "Coffee", "Cocoa")),
    checkboxInput("milk", "Milk"),
    sliderInput("sugarLumps", "Sugar Lumps:",
                min=0, max=10, value=3),
    textInput("customer", "Your Name:"),
    includeHTML("URL.js"),
    h3(textOutput("order")),
    hashProxy("hash")
       )
     )
   )
))


# server.R
library(shiny)
url_fields_to_sync <- c("beverage","milk","sugarLumps","customer");

# Define server logic required to respond to d3 requests
shinyServer(function(input, output, clientData) {

  # Generate a plot of the requested variable against mpg and only
  # include outliers if requested
  output$order <- reactiveText(function() {
    paste(input$beverage,
          if(input$milk) "with milk" else ", black",
          "and",
          if (input$sugarLumps == 0) "no" else input$sugarLumps,
          "sugar lumps",
          "for",
          if (input$customer == "") "next customer" else input$customer)
  })

  firstTime <- TRUE

  output$hash <- reactiveText(function() {

    newHash = paste(collapse=";",
                    Map(function(field) {
                          paste(sep="=",
                                field,
                                input[[field]])
                        },
                        url_fields_to_sync))

    # the VERY FIRST time we pass the input hash up.
    return(
      if (!firstTime) {
        newHash
      } else {
        if (is.null(input$hash)) {
          NULL
        } else {
          firstTime<<-F;
          isolate(input$hash)
        }
      }
    )
  })
})


# URL.js
<script type="text/javascript">
(function(){

  this.countValue=0;

  var changeInputsFromHash = function(newHash) {
    // get hash OUTPUT
    var hashVal = $(newHash).data().shinyInputBinding.getValue($(newHash))
    if (hashVal == "") return
    // get values encoded in hash
    var keyVals = hashVal.substring(1).split(";").map(function(x){return x.split("=")})
    // find input bindings corresponding to them
    keyVals.map(function(x) {
      var el=$("#"+x[0])

      if (el.length > 0 && el.val() != x[1]) {

        console.log("Attempting to update input " + x[0] + " with value " + x[1]);
        if (el.attr("type") == "checkbox") {
            el.prop('checked',x[1]=="TRUE")
            el.change()
        } else if(el.attr("type") == "radio") {
          console.log("I don't know how to update radios")
        } else if(el.attr("type") == "slider") {
          // This case should be setValue but it's not implemented in shiny
          el.slider("value",x[1])
          //el.change()
        } else { 
            el.data().shinyInputBinding.setValue(el[0],x[1])
            el.change()
        }
      }
    })
  }

  var HashOutputBinding = new Shiny.OutputBinding();
  $.extend(HashOutputBinding, {
    find: function(scope) {
      return $(scope).find(".hash");
    },
    renderError: function(el,error) {
      console.log("Shiny app failed to calculate new hash");
    },
    renderValue: function(el,data) {
      console.log("Updated hash");
      document.location.hash=data;
      changeInputsFromHash(el);
    }
  });
  Shiny.outputBindings.register(HashOutputBinding);

  var HashInputBinding = new Shiny.InputBinding();
  $.extend(HashInputBinding, {
    find: function(scope) {
      return $(scope).find(".hash");
    },
    getValue: function(el) {
      return document.location.hash;
    },
    subscribe: function(el, callback) {
      window.addEventListener("hashchange",
        function(e) {
          changeInputsFromHash(el);
          callback();
        }
        , false);
    }
  });
  Shiny.inputBindings.register(HashInputBinding);


})()
</script>

编辑:我在答案中运行了示例代码,但无法使其工作.见截图.

Answer 1

UPDATE

CRAN现在提供的Shiny .14支持在URL中保存应用程序状态.看到这篇文章

这个答案比我第一次使用OP提供的整个示例代码更深入.鉴于赏金,我决定将其添加为新的答案.我的原始答案使用了这个的简化版本,以便其他人得到答案,不必阅读任何无关的代码来找到他们正在寻找的东西.希望这个扩展版本可以解决您遇到的任何困难.我添加到你的R代码的部分被包围了### ... ###.

server.r

# server.R
library(shiny)
url_fields_to_sync <- c("beverage","milk","sugarLumps","customer");

# Define server logic required to respond to d3 requests
shinyServer(function(input, output, session) { # session is the common name for this variable, not clientData

  # Generate a plot of the requested variable against mpg and only
  # include outliers if requested
  output$order <- reactiveText(function() {
    paste(input$beverage,
          if(input$milk) "with milk" else ", black",
          "and",
          if (input$sugarLumps == 0) "no" else input$sugarLumps,
          "sugar lumps",
          "for",
          if (input$customer == "") "next customer" else input$customer)
  })

  firstTime <- TRUE

  output$hash <- reactiveText(function() {

    newHash = paste(collapse=";",
                    Map(function(field) {
                          paste(sep="=",
                                field,
                                input[[field]])
                        },
                        url_fields_to_sync))

    # the VERY FIRST time we pass the input hash up.
    return(
      if (!firstTime) {
        newHash
      } else {
        if (is.null(input$hash)) {
          NULL
        } else {
          firstTime<<-F;
          isolate(input$hash)
        }
      }
    )
  })

  ###

  # whenever your input values change, including the navbar and tabpanels, send
  # a message to the client to update the URL with the input variables.
  # setURL is defined in url_handler.js
  observe({
      reactlist <- reactiveValuesToList(input)
      reactvals <- grep("^ss-|^shiny-", names(reactlist), value=TRUE, invert=TRUE) # strip shiny related URL parameters
      reactstr <- lapply(reactlist[reactvals], as.character) # handle conversion of special data types
      session$sendCustomMessage(type='setURL', reactstr)
  })

  observe({ # this observer executes once, when the page loads

      # data is a list when an entry for each variable specified 
      # in the URL. We'll assume the possibility of the following 
      # variables, which may or may not be present:
      #   nav= The navbar tab desired (either Alfa Bravo or Delta Foxtrot)
      #   tab= The desired tab within the specified nav bar tab, e.g., Golf or Hotel
      #   beverage= The desired beverage selection
      #   sugar= The desired number of sugar lumps
      # 
      # If any of these variables aren't specified, they won't be used, and 
      # the tabs and inputs will remain at their default value.
      data <- parseQueryString(session$clientData$url_search)
      # the navbar tab and tabpanel variables are two variables 
      # we have to pass to the client for the update to take place
      # if nav is defined, send a message to the client to set the nav tab
      if (! is.null(data$page)) {
          session$sendCustomMessage(type='setNavbar', data)
      }

      # if the tab variable is defined, send a message to client to update the tab
      if (any(sapply(data[c('alfa_bravo_tabs', 'delta_foxtrot_tabs')], Negate(is.null)))) {
          session$sendCustomMessage(type='setTab', data)
      }

      # the rest of the variables can be set with shiny's update* methods
      if (! is.null(data$beverage)) { # if a variable isn't specified, it will be NULL
          updateSelectInput(session, 'beverage', selected=data$beverage)
      }

      if (! is.null(data$sugarLumps)) {
          sugar <- as.numeric(data$sugarLumps) # variables come in as character, update to numeric
          updateNumericInput(session, 'sugarLumps', value=sugar)
      }
  })

  ###
})

ui.r

library(shiny)

hashProxy <- function(inputoutputID) {
  div(id=inputoutputID,class=inputoutputID,tag("div",""));
}

# Define UI for shiny d3 chatter application
shinyUI(navbarPage('URLtests', id="page", collapsable=TRUE, inverse=FALSE,
 tabPanel("Alfa Bravo",
   tabsetPanel(
    ###
    id='alfa_bravo_tabs', # you need to set an ID for your tabpanels
    ###
    tabPanel("Charlie",
    tags$p("Nothing to see here. Everything is in the 'Delta Foxtrot' 'Hotel' tab")
             )
       )
    )
 ,tabPanel("Delta Foxtrot",
    tabsetPanel(
    ###
    id='delta_foxtrot_tabs', # you need to set an ID for your tabpanels
    ###
    tabPanel("Golf",
    tags$p("Nothing to see here. Everything is in the 'Delta Foxtrot' 'Hotel' tab")
             )
    ,tabPanel("Hotel", id='hotel',

    tags$p("This widget is a demonstration of how to preserve input state across sessions, using the URL hash."),
    selectInput("beverage", "Choose a beverage:",
                choices = c("Tea", "Coffee", "Cocoa")),
    checkboxInput("milk", "Milk"),
    sliderInput("sugarLumps", "Sugar Lumps:",
                min=0, max=10, value=3),
    textInput("customer", "Your Name:"),
    #includeHTML("URL.js"),
    ###
    includeHTML('url_handler.js'), # include the new script
    ###
    h3(textOutput("order")),
    hashProxy("hash")
       )
     )
   )
))

url_handler.js

<script>
Shiny.addCustomMessageHandler('setNavbar',
    function(data) {
        // create a reference to the desired navbar tab. page is the 
        // id of the navbarPage. a:contains says look for 
        // the subelement that contains the contents of data.nav
        var nav_ref = '#page a:contains(\"' + data.page + '\")';
        $(nav_ref).tab('show');
    }
)

Shiny.addCustomMessageHandler('setTab',
    function(data) {
       // pick the right tabpanel ID based on the value of data.nav
       if (data.page == 'Alfa Bravo') {
            var tabpanel_id = 'alfa_bravo_tabs';
       } else {
            var tabpanel_id = 'delta_foxtrot_tabs';
       }
       // combine this with a reference to the desired tab itself.
       var tab_ref = '#' + tabpanel_id + ' a:contains(\"' + data[tabpanel_id] + '\")';
       $(tab_ref).tab('show');
    }
)

Shiny.addCustomMessageHandler('setURL',
    function(data) {
        // make each key and value URL safe (replacing spaces, etc.), then join
        // them and put them in the URL
        var search_terms = [];
        for (var key in data) {
            search_terms.push(encodeURIComponent(key) + '=' + encodeURIComponent(data[key]));
        }
        window.history.pushState('object or string', 'Title', '/?' + search_terms.join('&'));
    }
);

</script>

要对此进行测试,请runApp(port=5678)使用源文件调用目录.默认情况下,URL中未指定任何参数,因此默认为第一个导航栏项和该项中的第一个选项卡.要使用URL参数对其进行测试,请将浏览器指向:http://127.0.0.1:5678/?nav=Delta%20Foxtrot&tab=Hotel&beverage=Coffee.这应该指向第二个导航栏选项卡和该导航栏项目中的第二个选项卡,其中咖啡作为所选饮料.