更新

Question

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

并将其修改为我的案例，这是一个网页，其中包含navbarPage和每个元素的多个标签。

我想要的是将用户引导到正确元素的URL 在第一级tabPanel中，右侧选项卡在第二级中的TabPanel。

这是，如果用户已导航到＆＃34; Delta Foxtrot＆＃34;然后到＆＃34; Hotel＆＃34;，然后将参数更改为 #beverage=Tea;milk=TRUE;sugarLumps=3;customer=mycustomer，我愿意比如将用户发送到＆＃34; Delta Foxtrot＆＃34; - ＆GT; ＆＃34;酒店＆＃34;而不是从第一个面板元素的第一个选项卡开始。

理想情况下，我想要一个有效的例子，因为到目前为止我尝试的所有内容都没有效果。

有什么想法吗？

enter image description here

# 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>

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

enter image description here

Answer 1

更新

CRAN上现有的

Shiny .14支持在URL中保存应用状态。见this article

这个答案比我第一次使用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中未指定任何参数，因此默认为第一个导航栏项和该项中的第一个选项卡。要使用网址参数对其进行测试，请将浏览器指向：http://127.0.0.1:5678/?nav=Delta%20Foxtrot&tab=Hotel&beverage=Coffee。这应该指向第二个导航栏选项卡和该导航栏项目中的第二个选项卡，其中咖啡作为所选饮料。

Answer 2

以下是演示如何使用网址中定义的变量更新导航栏选择，标签集选择和窗口小部件选择的示例

ui <- navbarPage('TEST', id='page', collapsable=TRUE, inverse=FALSE,
    # define a message handler that will receive the variables on the client side
    # from the server and update the page accordingly.
    tags$head(tags$script("
        Shiny.addCustomMessageHandler('updateSelections',
            function(data) {
                var nav_ref = '#page a:contains(\"' + data.nav + '\")';
                var tabpanel_id = data.nav == 'Alpha' ? '#alpha_tabs' : '#beta_tabs';
                var tab_ref = tabpanel_id + ' a:contains(\"' + data.tab + '\")';
                $(nav_ref).tab('show');
                $(tab_ref).tab('show');
            }
        )
    ")),
    tabPanel('Alpha',
        tabsetPanel(id='alpha_tabs',
            tabPanel('Tab')
        )
    ),
    tabPanel('Beta',
        tabsetPanel(id='beta_tabs',
            tabPanel('Golf'),
            tabPanel('Hotel',
                selectInput("beverage", "Choose a beverage:", choices = c("Tea", "Coffee", "Cocoa"))
            )
        )
    )
)

server <- function(input, output, session) {
    observe({
        data <- parseQueryString(session$clientData$url_search)
        session$sendCustomMessage(type='updateSelections', data)
        updateSelectInput(session, 'beverage', selected=data$beverage)
    })

}

runApp(list(ui=ui, server=server), port=5678, launch.browser=FALSE)

启动应用后，将浏览器指向此网址：http://127.0.0.1:5678/?nav=Beta&tab=Hotel&beverage=Coffee

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

2 个答案:

更新

server.r

ui.r

url_handler.js