My brand new Shiny App has one sidePanel with two dynamic SelectInput() functions. Depending on which Panel is active, the respective uiOutput("select") dynamic SelectInput should be use. I read this could be done with conditionalPanel() - but I cannot figure out how ... non of the examples I found combine uiOutput("select")/SelectInput(), all use SelectInput directly in the Pane...
Please, can anyone help me, how I have to change the code to include conditionalPanel()- if this is what's necessary. Thank a lot for any advice and help!!!!
ui.R
shinyUI(fluidPage(
titlePanel('Table Overviews'),
sidebarPanel(
uiOutput("select1"),
br(),
uiOutput("select2")
),
mainPanel(
tabsetPanel(
tabPanel("Panel 1",
fluidRow(
column(6, h4("Tablel"), tableOutput("Table1")),
column(6, div(style = "height:300px")),
fluidRow(
column(6,h4("Table2"), tableOutput("Table2")),
column(6,h4("Table3"), tableOutput("Table3")))
)),
tabPanel("Panel 2",
fluidRow(
column(6, h4("Table4"), tableOutput("Table4")),
column(6, div(style = "height:300px")),
fluidRow(
column(6,h4("Table5"), tableOutput("Table5")),
column(6,h4("Table6"), tableOutput("Table6")))
))
)
server.R
shinyServer(function(input,output){
## two different SelectInputs to select from two different lists
output$select1 <- renderUI({
selectInput("dataset1", "Overview1", as.list(files1))
})
output$select2 <- renderUI({
selectInput("dataset2", "Overview2", as.list(files2))
})
## Output of the first SelectInput
output$Table1 <- renderTable({
f1 <- function1(input$dataset1)
f1[[1]]
})
output$Table2 <- renderTable({
f1 <- function1(input$dataset1)
f1[[2]]
})
output$Table3 <- renderTable({
f1 <- function1(input$dataset1)
f1[[3]]
})
# Output of the second SelectInput
output$Table4<- renderTable({
f2 <- function2(input$dataset2)
f2[[3]]
})
output$Table5 <- renderTable({
f2 <- function2(input$dataset2)
f2[[2]]
})
output$Table6 <- renderTable({
f2 <- function2(input$dataset2)
f2[[1]]
})
})
Finally figured it out - it's really simple. Thanks to all comments for my various questions, thanks a lot to everyone!!!
All that's needed to be changed in the UI.R:
conditionalPanel(condition="input.conditionedPanels == Panel 1",
uiOutput("select_twb")),
br(),
conditionalPanel(condition="input.conditionedPanels == Panel 2",
uiOutput("select_twbx"))
Related
I have a question regarding tableGrob/grid.table from the gridExtra package. Is there a way to customize different colors for each column? So far and in this stackoverflow link, I have only found how to customize for different rows or cell specific.
Much obliged for any suggestion if possible!
you can pass a vector of colours (fills) for each individual cell,
fills <- rep(blues9, each=nrow(iris[1:4, 1:3]))
tt <- ttheme_default(core=list(bg_params=list(fill=fills)))
grid.table(iris[1:4, 1:3], theme=tt)
grid.table column color/fill: This example is gradient fill for a single column.
library(grid)
library(gridExtra)
library(scales)
library(dplyr)
# build a vector color/fill choice for the first two columns
blkz <- rep(c("NA", "NA"), times = c(4,4)) #NA is for transparent
# generate continuous color scales based off a vector of colors from https://themockup.blog/posts/2020-05-16-gt-a-grammer-of-tables/
red_color_generator <- scales::col_numeric(c("red", "white"), domain = NULL)
redz2 <-red_color_generator(seq(10, 60, by = 10))[1:4] #%>% scales::show_col()
# cmobine the two vectors
blkz_redz <- c(blkz, redz2)
tt <- ttheme_default(core=list(bg_params=list(fill= blkz_redz, col = "gray56")))
dev.off()
grid.table(iris[1:4, 1:3], theme=tt)
#~~~~~~
To make the color fill conditioned on the value in the variable. Follow this steps.
#conditional color mapper function
clrize <-
function(df, x) {
df %>%
mutate(cc =
ifelse(x == 1.3, "#FFB299",
ifelse(x == 1.4, "#FF8969",
ifelse(x == 1.5, "#FF5B3A",
"#FF0000"))))
}
#map this to the column build a vector
dt <- iris[1:4,1:3] %>% as.data.frame()
# apply color based on the value on petal.length variable
clrize(dt, dt$Petal.Length) -> redz3
# cmobine the two vectors
blkz_redz <- c(blkz, redz3$cc) # cc is var added inside the function
tt <- ttheme_default(core=list(bg_params=list(fill= blkz_redz, col = "gray56")))
dev.off()
grid.table(iris[1:4, 1:3], theme=tt)
I making an R Leaflet Map and I have 2 legend. how to combine them?
thanks
Understanding the structure of your map (str(mapObject))object in R can be a helpful starting point. This can be useful for making "aftermarket" edits to legends.
I tried this as a solution to your problem:
# Concatenate the vectors that define each set of colors and their corresponding values:
require(spData)
require(leaflet)
require(sf)
# loading shapes of countries from the package spData
data(world)
world <- st_read(system.file("shapes/world.gpkg", package="spData"))
africa <- world[world$continent == "Africa",]
asia <- world[world$continent == "Asia", ]
asiaPal <- colorNumeric("Reds", domain = asia$pop)
africaPal <- colorNumeric("Blues", domain = africa$pop)
map <- leaflet() %>%
addProviderTiles(providers$CartoDB.Positron) %>%
addPolygons(data = asia,
color = ~asiaPal(asia$pop)) %>%
addPolygons(data = africa,
color = ~africaPal(africa$pop)) %>%
addLegend("bottomright", pal = asiaPal, values = asia$pop, title = "Asian Population") %>%
addLegend("bottomright", pal = africaPal, values = africa$pop, title = "African Population")
# Colors
map$x$calls[[5]]$args[[1]]$colors <-
c(map$x$calls[[5]]$args[[1]]$colors, map$x$calls[[4]]$args[[1]]$colors)
# Labels
map$x$calls[[5]]$args[[1]]$labels <-
c(map$x$calls[[5]]$args[[1]]$labels, map$x$calls[[4]]$args[[1]]$labels)
# Get rid of Old Legend:
map$x$calls[[4]] <- NULL
where your legends result from elements 4 & 5 of map$x$calls.
This doesnt work very nicely. I suspect it's because these list elements are not the end result, and the elements of the map object are provided to javascript/html when rendering the map. That said, I dont know if it's easily possible to do what you are trying to achieve, without poking around in the actual HTML that results.
I want to import data of a similar category from multiple source files.
Every source has a short label.
How can I incorporate this into drake, without writing out every file as its own target?
I thought the following would work, but it does not. Ideally, I would like to have the targets raw_a and raw_b.
input_files <- list(
'a' = 'file_1.csv',
'b' = 'file_2.csv'
)
plan <-
drake::drake_plan(
raw = drake::target(
import_file(file),
transform = map(
file = file_in(!! input_files)
)
)
)
with
import_file <- function(file) {
readr::read_csv(file, skip = 2)
}
You are so close. file_in() needs to go literally in the command, not the transformation.
library(drake)
input_files <- c("file_1.csv", "file_2.csv")
plan <- drake_plan(
raw = target(
import_file(file_in(file)),
transform = map(file = !!input_files)
)
)
config <- drake_config(plan)
vis_drake_graph(config)
Created on 2019-10-19 by the reprex package (v0.3.0)
This is probably the idiomatic solution.
plan <-
drake::drake_plan(
raw = drake::target(
import_file(file),
transform = map(
file = file_in('file_1.csv', 'file_2.csv'),
label = c('a', 'b'),
.id = label
)
)
)
file_in needs to around the whole string
plan <-
drake::drake_plan(
raw = drake::target(
import_file(file),
transform = map(
file = list(
file_in('file_1.csv'),
file_in('file_2.csv')
)
)
)
)
I am attempting to create a table which has citations built into the table. Here is a visual of what I am trying to achieve.
As far as I know you can only add footnotes in rowvars or colvars in kableExtra (love that package).
# Create a dataframe called df
Component <- c('N2','P3')
Latency <- c('150 to 200ms', '625 to 800ms')
Location <- c('FCz, Fz, Cz', 'Pz, Oz')
df <- data.frame(Component, Latency, Location)
Below is my attempt after reading through kableExtra's Git page
# Trying some code taken from the kableExtra guide
row.names(df) <- df$Component
df[1] <- NULL
dt_footnote <- df
names(dt_footnote)[1] <- paste0(names(dt_footnote)[2],
footnote_marker_symbol(1))
row.names(dt_footnote)[2] <- paste0(row.names(dt_footnote)[2],
footnote_marker_alphabet(1))
kable(dt_footnote, align = "c",
# Remember this escape = F
escape = F, "latex", longtable = T, booktabs = T, caption = "My Table Name") %>%
kable_styling(full_width = F) %>%
footnote(alphabet = "Jones, 2013",
symbol = "Footnote Symbol 1; ",
footnote_as_chunk = T)
But this code only works on the headers. The ultimate goal would be if I could use a BibTex reference such as #JonesFunctionalMixedEffectModels2013 such that the final part of the code would look like
footnote(alphabet = #davidsonFunctionalMixedEffectModels2009,
symbol = "Footnote Symbol 1; ", footnote_as_chunk = T)
Anyone have any ideas?
Thanks
What I did at the end was to generate a temporary table with pander, then copy the references' number manually to my kable
pander(
df,
caption = "Temporal",
style = "simple",
justify = "left")
I wanted to use mselec function from drc package for selecting the best model of a dose-response dataset. However, mselect does not work if you use it inside a function.
The following code works:
library(drc)
ryegrass.m1 <- drm(rootl~conc, data = ryegrass, fct = LL.4())
mselect(ryegrass.m1,list(LL.5(), LN.4(), W1.4(), W2.4()))
But not this one:
best.fit=function(data){
model1=drm(rootl~conc, data=data, fct=LL.4())
M1=drc::mselect(model1, list(LL.5(), LN.4(), W1.4(), W2.4()))
return(M1)
}
best.fit(ryegrass)
I think the problem is related with the environments in R, but I don't know how to fix it. Someone could help me please?
I manage to solve the problem like this:
best.fit=function(data){
mf <- match.call(expand.dots = FALSE)
m <- match(c("data"), names(mf), 0L)
data.name=as.character(mf[m])
model1=eval(parse(text=paste0('drm(rootl~conc, data=',data.name, ',fct=LL.4())')))
M1=drc::mselect(model1, list(LL.5(), LN.4(), W1.4(), W2.4()))
return(M1)
}
best.fit(ryegrass)
There should be better ways to do it, but at least it works for me now.
It seems that the update function within mselect doesn't access the original dataframe when run from inside a function. My solution was to add a data argument at line 34.
[1] my_mselect <- function(...
...
[33] tempObj <- try(update(object, fct = fctList[[i]],
[34] data = object$origData), # <--- line added here
[35] silent = TRUE)
I also noticed that the reference to the model variables doens't work either if their relative positions are used instead of their original names, for instance when using drm(data[, 1] ~ data[, 2], fct = LL.4()). To avoid this you can use a temporary dataframe in your function, set the variable names as you want, and use these names in the drm call.
best.fit <- function(data){
tmp_data <- data
names(tmp_data) <- c("Var1", "Var2")
model1 <- drm(Var1 ~ Var2, data = tmp_data, fct = LL.4())
M1 <- my_mselect(model1, list(LL.5(), LN.4(), W1.4(), W2.4()))
return(M1)
}