Leaflet.LabelTextCollision plugin is a usefull feature for spatial visualisation. It hides labels on the map, which overlap with each other.
I try to use Leaflet.LabelTextCollision in R with leaflet package, but it doesn't work. What did i miss? I'm not familiar with JS, but, as far as i understand, i should implement JS function in the R code (see onRender in the example).
I asked the same question on Github a year ago, but still I haven't recieved an answer (https://gist.github.com/jcheng5/c084a59717f18e947a17955007dc5f92?permalink_comment_id=3814855#gistcomment-3814855).
Link to the Leaflet.LabelTextCollision plugin:
https://github.com/yakitoritabetai/Leaflet.LabelTextCollision
Here is an example of my code.
library(tidyverse)
library(leaflet)
library(htmltools)
library(htmlwidgets)
setwd("D:/Data/page_ex")
label <- data.frame(
lat = c(61.09049, 56.89039, 57.52678, 60.74516, 56.92379, 64.54302, 56.25897, 56.49648, 56.27996, 56.74812, 59.93873, 56.77972, 56.85867, 60.08370, 56.25897),
lon = c(43.17148, 32.65250, 38.31669, 42.04732, 32.74461, 40.53712, 32.08586, 31.64108, 31.66774, 33.51162, 30.31623, 31.25263, 35.92083, 30.27957, 32.08586),
name_label = c("label_1", "label_2", "label_1000", "label_10000", "label_70000", "label_8", "label_999999", "label_777", "label_888888", "label_888", "label_999", "label_7", "label_9", "label_777777777", "label_999999999")
)
col_Plugin <- htmlDependency(
"Leaflet.LabelTextCollision", "1.4.0",
src = "./Leaflet.LabelTextCollision-master/dist",
script = "L.LabelTextCollision.js"
)
registerPlugin <- function(map, plugin) {
map$dependencies <- c(map$dependencies, list(plugin))
map
}
leaflet() %>%
setView(35, 60, zoom = 4) %>%
addProviderTiles(provider = "OpenStreetMap") %>%
registerPlugin(col_Plugin) %>%
addLabelOnlyMarkers(lng = label$lon,
lat = label$lat,
label = lapply(label$name_label, HTML),
labelOptions = labelOptions(noHide = T,
textOnly = F,
direction = "top")
) %>%
onRender("function(el, x) {
L.LabelTextCollision(collisionFlg : true).addTo(this);}")
Related
The below reproducible code renders a user input matrix grid inside a modal dialog box (click on the single action button at the top when invoking the App), with the user input matrix: (a) automatically expanding to the right as the user inputs data into the columns, (b) automatically generating sequentially numbered column headers, and (c) rendered inside a scrollable well panel so that it expands without "scrunching" as it grows.
However, I would like to "freeze" the left-most column of the matrix input grid (the row headers), so the user doesn't lose the meanings of individual rows as the grid grows. The images at the bottom better illustrate. How can this be done?
I assume this requires some gyrations with shinyjs, an area I am very weak in. This is a follow-up evolution of earlier post In R shiny, how to incorporate scrolling into modal dialog box?
Reproducible code:
library(shiny)
library(shinyMatrix)
library(shinyjs)
library(shinyWidgets)
library(magrittr)
library(DT)
mat1DefaultRownames <- c('Item A','Item B','Item C','Item D')
mat1Default <- data.frame('Series 1'=c(1,24,0,100), row.names = mat1DefaultRownames) %>% as.matrix()
mat1Input <- function(inputId, mat1Default) {
matrixInput(
inputId = inputId,
label = "Input terms:",
value = mat1Default,
rows = list(extend = FALSE, names = TRUE),
cols = list(extend = TRUE, names = TRUE, editableNames = FALSE, delete = TRUE),
class = "numeric"
)
}
ui <-
fluidPage(
shinyjs::useShinyjs(),
div(style = "margin-top: 10px"),
actionButton('modInputs','Input terms', style = 'width:25%'),
DTOutput("table1")
)
server <- function(input,output,session)({
rv1 <- reactiveValues(
mat1 = mat1Input("mat1",mat1Default),
input = mat1Default,
colHeader = colnames(input)
)
mat1Inputs <- reactive({
if (isTruthy(input$modInputs)) {
req(input$mat1)
df <- input$mat1
rv1$mat1 <- mat1Input("mat1", df)
colnames(df) <- paste("Series",rep(1:ncol(df),each=1,length.out=ncol(df)))
rownames(df) <- mat1DefaultRownames
rv1$input <- df
updateMatrixInput(session, inputId = "mat1", value = rv1$input)
} else {
df <- mat1Default
colnames(df) <- paste("Series", 1:ncol(df))
}
df[3:4, ] <- sprintf('%.2f%%', df[3:4, ])
df
})
output$table1 <-
renderDT(server = TRUE, {
datatable(
data = mat1Inputs(),
options = list(
scrollX = T,
dom = 'ft',
autoWidth = FALSE,
info = FALSE,
searching = FALSE,
columnDefs =
list(
list(className = 'dt-left', targets = 0),
list(className = 'dt-right', targets = seq_len(ncol(mat1Inputs())))
)
),
class = "display nowrap"
)
})
observeEvent(input$modInputs, {
showModal(
modalDialog(
wellPanel(div(style = "overflow-x: auto;", rv1$mat1)),
footer = tagList(actionButton("resetInputs", "Reset"),modalButton("Close"))
)
)
})
observeEvent(c(input$modInputs, input$mat1), {
runjs(
paste0(
'$("#mat1").css("width","calc(100% + ', (dim(input$mat1)[2]-1 + dim(input$mat1)[2]%%2)*115, 'px")'
) # close paste0
) # close runjs
})
observeEvent(input$resetInputs, {updateMatrixInput(session,'mat1', mat1Default)})
})
shinyApp(ui, server)
Problem: In below Shiny app, I want to change and insert new rows to the following data via rhandsontable:
data.frame(car = c("Opel", "Nissan", "Opel", "VW"),
location = c("Ruesselsheim", "Frankreich", "Ruesselsheim", "Wolfsburg"))
If I change for example car == Opel to car == VW the location shall change from Ruesselsheim to Wolfsburg.
If I insert a new row and for example populate it with car == Opel then location shall be Ruesselsheim directly after providing the car input
Question: How can I conditionally change the cell values and define conditional default values?
Attempts: hot_col has a default argument but it only accepts a string and not a condition. Also tracking the changes via an observer seems not really the best way to do it.
Any ideas on how to approach this? Many thanks!
library(shiny)
library(rhandsontable)
ui = shinyUI(fluidPage(
titlePanel("Handsontable"),
sidebarLayout(
sidebarPanel(
rHandsontableOutput("hot")
),
mainPanel(
verbatimTextOutput("debug")
)
)
))
server = function(input, output) {
data <- reactive({
data.frame(car = c("Opel", "Nissan", "Opel", "VW"),
location = c("Ruesselsheim", "Frankreich", "Ruesselsheim", "Wolfsburg"))
})
output$hot <- renderRHandsontable({
DF <- data()
rhandsontable(DF, useTypes = FALSE, selectCallback = TRUE)
})
### DEBUG
output$debug <- renderPrint({
req(input$hot)
input$hot$changes
})
}
shinyApp(ui = ui, server = server)
The desired behaviour can be achived by using a reactiveVal and a lookup-table to merge the current selection with:
library(shiny)
library(rhandsontable)
ui = shinyUI(fluidPage(
titlePanel("Handsontable"),
sidebarLayout(
sidebarPanel(
rHandsontableOutput("hot")
),
mainPanel(
verbatimTextOutput("debug")
)
)
))
server = function(input, output) {
LUT_DF <- data.frame(car = c("Opel", "Nissan", "VW"),
location = c("Ruesselsheim", "Frankreich", "Wolfsburg"))
data <- reactiveVal(data.frame(car = c("Opel", "Nissan", "Opel", "VW"),
location = c("Ruesselsheim", "Frankreich", "Ruesselsheim", "Wolfsburg")))
output$hot <- renderRHandsontable({
rhandsontable(data(), useTypes = FALSE, selectCallback = TRUE)
})
observeEvent(input$hot, {
data(merge(LUT_DF, hot_to_r(input$hot)[1], by = "car"))
}, ignoreInit = TRUE)
}
shinyApp(ui = ui, server = server)
So, I have attached what my data looks like. I have all of the variables in 1 column and their values for a specific date and state in another column.
I want my users to be able to click on the graph and it take them to the corresponding data. You can do this in Javascript, but I am using Shiny, so my project is in R. So, I made the proper changes, using this and this as an examples, and this as a guide. Instead of using location.href like I would in Javascript, I used browseURL. When I use browseURL, it fires as soon as the page opens up instead of firing when I click the line graph. Is there a way to restrict browseURL so that it only fires when clicked?
library(shiny)
library(highcharter)
library(dplyr)
data <- read.csv("data/daily states.csv")
ui <- fluidPage(
titlePanel("Timeline"),
sidebarLayout(
sidebarPanel(
h2("Actions", align="center"),
fluidRow(
column(5,
selectizeInput("state",
h3("State:"),
c("All",
unique(data$state))))
),
fluidRow(
column(5,
selectInput("outcome",
h3("Outcome:"),
c("All",
unique(data$variable))))
),
fluidRow(
column(5,
dateRangeInput("date",
h3("Date range"),
min = "2020-01-22",
start = "2020-01-22",
end = as.character(Sys.Date())))
),
fluidRow(
column(5,
checkboxInput("federal",
"Show federal level",
value = TRUE))
)
),
mainPanel(
tabsetPanel(type = "tabs",
tabPanel("Plot", highchartOutput("hcontainer")),
tabPanel("Table", DT::dataTableOutput("table"))),
)
)
)
server <- function(input, output, session){
newData <- reactive({
if (input$state != "All"){
data <- filter(data, state == input$state)
}
if (input$outcome != "All"){
data <- filter(data, variable == input$outcome)
}
data
})
output$table <- DT::renderDataTable(DT::datatable({
newData()
}))
output$hcontainer <- renderHighchart({
hc <- highchart(type = "chart") %>%
hc_xAxis(categories = unique(newData()$date)) %>%
hc_plotOptions(series = list(
allowPointSelect = TRUE,
cursor = "pointer",
point = list(
events = list(
click = browseURL(paste('https://covidtracking.com/data/state/',input$state,'/#historical', sep = ""))
)
)
)
) %>%
hc_add_series(name = (paste(input$state,input$outcome)), data = newData()$value)
hc
})
}
shinyApp(ui = ui, server = server)
I am using DT::renderDT in a shiny app and am formatting background color for certain columns and rows. I need the row background color to be on top of column background color. I tried switching order of formatStyle but that didn't work. Here's a small example -
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
DTOutput("table")
),
server = function(input, output, session) {
output$table <- renderDT({
head(iris) %>%
datatable() %>%
formatStyle(c(2,4), backgroundColor = "#fcf4d9") %>%
formatStyle(1, target = 'row',
backgroundColor = styleEqual(c(4.7, 5), c("#fc8a8a", "#fc8a8a"))
# comment above row and ucomment below row for row color using styleInterval()
# backgroundColor = styleInterval(c(0, 5, 9), c('blue', 'green', 'red', 'orange'))
)
})
}
)
Result (incorrect) with styleEqual() -
Result (incorrect) with StyleInterval() -
The row colors need to be on top of yellow (column color).
Looking for a generalized solution that would work for multiple rows and with styleEqual() or styleInterval(). Any help is appreciated. Thanks!
Here is a solution:
rowCallback <- c(
"function(row, data, displayNum, displayIndex, dataIndex){",
" if(data[1] === 4.7){",
" $(row).find('td').addClass('red');",
" }",
"}"
)
shinyApp(
ui = fluidPage(
tags$head(
tags$style(
HTML(
"table.dataTable tbody tr td.red {background-color: #fc8a8a !important}"
)
)
),
DTOutput("table")
),
server = function(input, output, session) {
output$table <- renderDT({
head(iris) %>%
datatable(options = list(rowCallback = JS(rowCallback))) %>%
formatStyle(c(2,4), backgroundColor = "#fcf4d9")
})
}
)
I want to pull in data from 538, but I want the full data which is arrived at by clicking on "Show more polls"... Is there any way for the function to access the additional lines of the table?
http://projects.fivethirtyeight.com/2016-election-forecast/national-polls/
The code for pulling in the top level data is:
require(XML)
polls.html <- htmlTreeParse("http://projects.fivethirtyeight.com/2016-election-forecast/national-polls/",
useInternalNodes = TRUE)
parsedDoc <- readHTMLTable(polls.html, stringsAsFactors=FALSE)
pollData <- data.frame(parsedDoc[4])
I'm a little confused as to why this got downvoted... still doesn't seem obvious to me! But for anyone who wants to know the solution, I did figure it out (thanks to some help from #duncantl). (Also, the complete analysis is at: https://github.com/hardin47/prediction2016)
require(XML)
require(dplyr)
require(tidyr)
require(readr)
require(mosaic)
require(RCurl)
require(ggplot2)
require(lubridate)
require(RJSONIO)
url = "http://projects.fivethirtyeight.com/2016-election-forecast/national-polls/"
doc <- htmlParse(url, useInternalNodes = TRUE)
sc = xpathSApply(doc, "//script[contains(., 'race.model')]",
function(x) c(xmlValue(x), xmlAttrs(x)[["href"]]))
jsobj = gsub(".*race.stateData = (.*);race.pathPrefix.*", "\\1", sc)
data = fromJSON(jsobj)
allpolls <- data$polls
#unlisting the whole thing
indx <- sapply(allpolls, length)
pollsdf <- as.data.frame(do.call(rbind, lapply(allpolls, `length<-`, max(indx))))
#unlisting the weights
pollswt <- as.data.frame(t(as.data.frame(do.call(cbind, lapply(pollsdf$weight, data.frame,
stringsAsFactors=FALSE)))))
names(pollswt) <- c("wtpolls", "wtplus", "wtnow")
row.names(pollswt) <- NULL
pollsdf <- cbind(pollsdf, pollswt)
#unlisting the voting
indxv <- sapply(pollsdf$votingAnswers, length)
pollsvot <- as.data.frame(do.call(rbind, lapply(pollsdf$votingAnswers,
`length<-`, max(indxv))))
pollsvot1 <- rbind(as.data.frame(do.call(rbind, lapply(pollsvot$V1, data.frame,
stringsAsFactors=FALSE))))
pollsvot2 <- rbind(as.data.frame(do.call(rbind, lapply(pollsvot$V2, data.frame,
stringsAsFactors=FALSE))))
pollsvot1 <- cbind(polltype = rownames(pollsvot1), pollsvot1,
polltypeA = gsub('[0-9]+', '', rownames(pollsvot1)),
polltype1 = extract_numeric(rownames(pollsvot1)))
pollsvot1$polltype1 <- ifelse(is.na(pollsvot1$polltype1), 1, pollsvot1$polltype1 + 1)
pollsvot2 <- cbind(polltype = rownames(pollsvot2), pollsvot2,
polltypeA = gsub('[0-9]+', '', rownames(pollsvot2)),
polltype1 = extract_numeric(rownames(pollsvot2)))
pollsvot2$polltype1 <- ifelse(is.na(pollsvot2$polltype1), 1, pollsvot2$polltype1 + 1)
pollsdf <- pollsdf %>%
mutate(population = unlist(population),
sampleSize = as.numeric(unlist(sampleSize)),
pollster = unlist(pollster),
startDate = ymd(unlist(startDate)),
endDate = ymd(unlist(endDate)),
pollsterRating = unlist(pollsterRating)) %>%
select(population, sampleSize, pollster, startDate, endDate, pollsterRating,
wtpolls, wtplus, wtnow)
allpolldata <- cbind(rbind(pollsdf[rep(seq_len(nrow(pollsdf)), each=3),],
pollsdf[rep(seq_len(nrow(pollsdf)), each=3),]),
rbind(pollsvot1, pollsvot2))
allpolldata <- allpolldata %>%
arrange(polltype1, choice)