R/spsUIcollections.R
In lz100/spsComps: 'systemPipeShiny' UI and Server Components
Defines functions
hexPanel
hexLogo
renderDesc
hrefTable
hrefTab
gallery
Documented in
gallery
hexLogo
hexPanel
hrefTab
hrefTable
renderDesc
################## A Collections of HTML components#############################
# can be used outside SPS framework, like other shiny projects
## use on top of shiny
#' A shiny gallery component
#' @description Create a gallery to display images or photos
#'
#' `texts`, `hrefs`, `images` Must have the same length
#'
#' If there is any image that you do not want to add links, use `""` to occupy the space, e.g
#'
#' `hrefs = c("https://xxx.com", "", "https://xxx.com")`
#'
#' If the link is empty, there will be no hover effect on that image, and you cannot click it.
#'
#' Similar to `hrefs`, for the `texts`, use `""` to occupy space
#'
#' @importFrom assertthat assert_that
#'
#' @param Id ID of this gallery
#' @param title Title of gallery
#' @param title_color Title color
#' @param texts vector of labels under each image
#' @param hrefs vector of links when each image is clicked
#' @param image_frame_size integer, 1-12, this controls width. How large is each
#' image. 12 is the whole width of the parent container and 1 is 1/12 of the container. Consider
#' numbers that can be fully divided by 12, like 1 (12 per row), 2 (6 per row),
#' 3 (4 per row), 4 (3 per row), 6 (1 per row)or 12 (if you want only 1 image per row).
#' @param images a vector of image sources, can be online URLs or local resource paths.
#' @param enlarge bool, when click on the image, enlarge
#' it? If enlarge is enabled, click the photo will enlarge instead of jump to the link.
#' Only the title below contains the link if enlarge is enabled.
#' @param enlarge_method how the photo is enlarged on click,
#' one of "inline" -- within the gallery change the size of photo to 12, "modal" --
#' display photo in a pop-up modal.
#' @param target_blank bool, whether to add `target="_blank"` to the link?
#' @param obj_fit string, the CSS property "object-fit" of images. This is helpful
#' to deal with stretched images. Read more on
#' [CSS documents](https://developer.mozilla.org/en-US/docs/Web/CSS/object-fit).
#' Default is `"fill"`, and other options are `"contain"`, `"cover"`, `"none"`, `"scale-down"`.
#' @param style additional CSS style you want to add to the most outside component "div"
#' @details
#' #### `modal` enlarge
#' When view the `modal` enlarged images, click the "X" button or anywhere outside the
#' image to close the full screen view.
#' @export
#' @return a gallery component
#'
#' @examples
#' if(interactive()){
#' texts <- c("p1", "p2", "", "p4", "p5")
#' hrefs <- c("https://github.com/lz100/spsComps/blob/master/img/1.jpg?raw=true",
#' "https://github.com/lz100/spsComps/blob/master/img/2.jpg?raw=true",
#' "",
#' "https://github.com/lz100/spsComps/blob/master/img/4.jpg?raw=true",
#' "https://github.com/lz100/spsComps/blob/master/img/5.jpg?raw=true")
#' images <- c("https://github.com/lz100/spsComps/blob/master/img/1.jpg?raw=true",
#' "https://github.com/lz100/spsComps/blob/master/img/2.jpg?raw=true",
#' "https://github.com/lz100/spsComps/blob/master/img/3.jpg?raw=true",
#' "https://github.com/lz100/spsComps/blob/master/img/4.jpg?raw=true",
#' "https://github.com/lz100/spsComps/blob/master/img/5.jpg?raw=true")
#' library(shiny)
#'
#' ui <- fluidPage(
#' column(
#' 6,
#' gallery(texts = texts, hrefs = hrefs, images = images, title = "Default gallery"),
#' spsHr(),
#' gallery(texts = texts, hrefs = hrefs, images = images,
#' image_frame_size = 2, title = "Photo size"),
#' spsHr(),
#' gallery(texts = texts, hrefs = hrefs, images = images,
#' enlarge = TRUE, title = "Inline enlarge"),
#' spsHr(),
#' gallery(
#' texts = texts, hrefs = hrefs, images = images,
#' enlarge = TRUE, title = "Modal enlarge",
#' enlarge_method = "modal", obj_fit = "cover"
#' )
#' )
#' )
#'
#' server <- function(input, output, session) {
#'
#' }
#'
#' shinyApp(ui, server)
#' }
gallery <- function(texts,
hrefs,
images,
Id = NULL,
title = "Gallery",
title_color = "#0275d8",
image_frame_size = 4,
enlarge = FALSE,
enlarge_method = c("inline", "modal"),
target_blank = FALSE,
obj_fit = "fill",
style = ""){
if (is.null(Id)) Id <- glue("gallery{sample(1000000:9999999, 1)}")
assertthat::assert_that(is.character(texts))
assertthat::assert_that(is.character(hrefs))
assertthat::assert_that(is.character(images))
stopifnot(is.logical(target_blank) && length(target_blank) == 1)
stopifnot(is.character(obj_fit) && length(obj_fit) == 1)
image_frame_size <- as.integer(image_frame_size)
stopifnot(image_frame_size > 0 && image_frame_size <=12)
stopifnot(is.logical(enlarge))
assertthat::assert_that(
length(texts) == length(hrefs) & length(hrefs) == length(images),
msg = "texts, hrefs and images must have the same length")
enlarge_method <- match.arg(enlarge_method, c("inline", "modal"))
texts[texts == ""] <- " "
hrefs_clean <- hrefs
img_ids <- paste0(Id, "-", seq_len(length(hrefs)))
hrefs[hrefs != ""] <- glue('href="{hrefs[hrefs != ""]}"')
href_hover <- rep("", length(hrefs))
href_hover[hrefs == ""] <- "gallery-nohover"
target_text <- if (target_blank) 'target="_blank"' else ''
gallery_div <- if(enlarge && enlarge_method == "inline") {
HTML(glue('
<div class="col-sm-{image_frame_size} sps-tab-link inline-enlarge" style="right: 1px;">
<img src="{images}" class="img-gallery" height=300 width=400 style="width: 100%; object-fit: {obj_fit};">
<a {hrefs} {target_text}><p class="text-center h4 {href_hover}">{texts}</p></a>
</div>
'))
} else if (enlarge) {
HTML(glue('
<div id={img_ids} class="col-sm-{image_frame_size} sps-tab-link" style="right: 1px;">
<img
src="{images}" class="img-gallery"
height=300 width=400
style="width: 100%; ; object-fit: {obj_fit};"
onclick=galEnlarge("#{img_ids}")
>
<a {hrefs} {target_text}><p class="text-center h4 {href_hover}">{texts}</p></a>
</div>
'))
} else {
HTML(glue('
<a {hrefs} {target_text} class="col-sm-{image_frame_size} sps-tab-link" style="right: 1px;">
<img src="{images}" class="img-gallery {href_hover}" height=300 width=400 style="width: 100%;">
<p class="text-center h4 {href_hover}">{texts}</p>
</a>
'))
}
div(
id = Id, class = "col sps-gallery",
style = style,
p(class = "text-center h2",
style = glue("color: {title_color};"),
title),
div(
class = "row", style = " margin: 10px;",
gallery_div
),
if(enlarge && enlarge_method == "modal") {
tags$script(HTML(
"
(function(){
if ($('#sps-gallery-modal').length) return ;
const gal_modal =
`<div id='sps-gallery-modal' class='gallery-modal' onclick='galModalClose()' style='display: none;'>
<span class='gallery-modal-close'>X</span>
<img id='sps-gallery-modal-content' class='gallery-modal-content'/>
<div class='gallery-caption'></div>
</div>`;
$(document.body).append(gal_modal);
})()
"
))
} else "",
tags$script(glue('fixGalHeight("{Id}")')),
spsDepend("basic")
)
}
#' Display a list of links in a row of buttons
#' @description `hrefTab` creates a small section of link buttons
#' @importFrom assertthat assert_that
#'
#' @param Id optional element ID
#' @param title element title
#' @param title_color title color
#' @param label_texts individual tab labels
#' @param hrefs individual tab links
#' @param bg_colors individual tab button background color, either 1 value to apply for all of
#' them or specify for each of them in a vector
#' @param text_colors individual tab button text color, either 1 value to apply for all of
#' them or specify for each of them in a vector
#' @param target_blank bool, whether to add `target="_blank"` to the link?
#' @param ... other arguments to be passed to the html element
#'
#' @return a Shiny component
#' @details
#' 1. `label_texts`, `hrefs` must be the same length
#' 2. If more than one value is provided for `bg_colors` or/and `text_colors`,
#' the length of these 2 vectors must be the same as `label_texts`
#' 3. Use `""` to occupy the space if you do not want a label contains a link,
#' e.g `hrefs = c("https://google.com/", "", "")`
#' 4. If a label does not have a link, you cannot click it and there is no hovering
#' effects.
#' @export
#' @examples
#' if(interactive()){
#' ui <- fluidPage(
#' hrefTab(
#' title = "Default",
#' label_texts = c("Bar Plot", "PCA Plot", "Scatter Plot"),
#' hrefs = c("https://google.com/", "", "")
#' ),
#' hrefTab(
#' title = "Different background",
#' label_texts = c("Bar Plot", "PCA Plot", "Scatter Plot"),
#' hrefs = c("https://google.com/", "", ""),
#' bg_colors = c("#eee", "orange", "green")
#' ),
#' hrefTab(
#' title = "Different background and text colors",
#' label_texts = c("Bar Plot", "Disabled", "Scatter Plot"),
#' hrefs = c("https://google.com/", "", ""),
#' bg_colors = c("green", "#eee", "orange"),
#' text_colors = c("#caffc1", "black", "blue")
#' )
#' )
#'
#' server <- function(input, output, session) {
#'
#' }
#' shinyApp(ui, server)
#' }
hrefTab <- function(label_texts,
hrefs,
Id = NULL,
title = "A list of tabs",
title_color = "#0275d8",
bg_colors = "#337ab7",
text_colors = "white",
target_blank = FALSE,
...
){
if (is.null(Id)) Id <- glue("list-tab{sample(1000000:9999999, 1)}")
assert_that(is.character(bg_colors) && length(bg_colors) > 0)
assert_that(is.character(text_colors) && length(text_colors) > 0)
assert_that(length(label_texts) == length(hrefs),
msg = "texts and hrefs must have the same length")
if (length(bg_colors) > 1) assert_that(length(label_texts) == length(bg_colors))
if (length(text_colors) > 1) assert_that(length(label_texts) == length(text_colors))
stopifnot(is.logical(target_blank) && length(target_blank) == 1)
href_hover <- rep("", length(hrefs))
href_hover[hrefs == ""] <- "nohover"
hrefs[hrefs == ""] <- "javascript:null;"
target_text <- if (target_blank) 'target="_blank"' else ''
div(
id = Id, class = "col", ... ,
p(class = "h4",
style = glue("color: {title_color}; text-align: left;"),
title),
div(
HTML(glue('
<a
href="{hrefs}" {target_text}
class="href-button sps-tab-link {href_hover}"
style="background-color: {bg_colors}; color: {text_colors};"
>
{label_texts}
</a>\n
'))
),
spsDepend("basic")
)
}
#' A table of hyper reference buttons
#' @description creates a table in Shiny which the cells are hyper reference (links)
#' buttons. This function is similar to [hrefTab], but that function only creates
#' a single row of link buttons, and this function creates a table of rows.
#'
#' The table has two columns, the first column is row names, second column is different
#' link buttons.
#' @details
#' 1. `item_titles`, `item_labels`, `item_hrefs` must have the same
#' length. Each vector in `item_labels`, `item_hrefs` must also have the same
#' length. For example, if we want to make a table of two rows, the first row
#' has 1 cell and the second row has 2 cells:
#'
#' ```
#' hrefTable(
#' item_titles = c("row 1", "row 2"),
#' item_labels = list(c("cell 1"), c("cell 1", "cell 2")),
#' item_hrefs = list(c("link1"), c("link1", "link2")
#' )
#' ```
#'
#' 2. If `item_title_colors`, `item_text_colors` are given more than one value,
#' the list must have the same length as `item_titles`, and length of each vector
#' in the list must match the vector in `item_labels` in the same order.
#' 3. If `item_title_colors` is given more than one value, the vector must have
#' the same length as `item_titles`.
#' 4. Use `""` to occupy the space if you do not want a label contains a link,
#' e.g `item_hrefs = list(c("https://www.google.com/"), c("", ""))`
#' 5. If a label does not have a link, you cannot click it and there is no hovering
#' effects.
#' @importFrom assertthat assert_that
#'
#' @param Id optional ID
#' @param title title of this table
#' @param item_titles vector of strings, a vector of titles for table row names
#' @param item_labels list, a list of character vectors to specify button
#' labels in each table row, one vector per row
#' @param item_hrefs list, a list of character vectors to specify button hrefs
#' links in each table row, one vector per row
#' @param item_bg_colors a single character value or a list, a list of character
#' vectors to specify button background colors in each table row, one vector per row
#' @param item_text_colors a single character value or a list, a list of character
#' vectors to specify button text colors in each table row, one vector per row
#' @param first_col_name first column name
#' @param second_col_name second column name
#' @param title_color table title color
#' @param item_title_colors a single character value or a character vector to
#' specify button title text colors of each row name
#' @param target_blank bool, whether to add `target="_blank"` to the link?
#' @param ... other HTML param you want to pass to the table
#'
#' @export
#' @return HTML elements
#' @examples
#' if(interactive()){
#' ui <- fluidPage(
#' hrefTable(
#' title = "default",
#' item_titles = c("workflow 1", "unclickable"),
#' item_labels = list(c("tab 1"), c("tab 3", "tab 4")),
#' item_hrefs = list(c("https://www.google.com/"), c("", ""))
#' ),
#' hrefTable(
#' title = "Change button color and text color",
#' item_titles = c("workflow 1", "No links"),
#' item_labels = list(c("tab 1"), c("tab 3", "tab 4")),
#' item_hrefs = list(c("https://www.google.com/"), c("", "")),
#' item_bg_colors = list(c("blue"), c("red", "orange")),
#' item_text_colors = list(c("black"), c("yellow", "green"))
#' ),
#' hrefTable(
#' title = "Change row name colors and width",
#' item_titles = c("Green", "Red", "Orange"),
#' item_labels = list(c("tab 1"), c("tab 3", "tab 4"), c("tab 5", "tab 6", "tab 7")),
#' item_hrefs = list(
#' c("https://www.google.com/"),
#' c("", ""),
#' c("https://www.google.com/", "https://www.google.com/", "")
#' ),
#' item_title_colors = c("green", "red", "orange"),
#' style = "width: 50%"
#' )
#'
#' )
#'
#' server <- function(input, output, session) {
#'
#' }
#'
#' shinyApp(ui, server)
#' }
hrefTable <- function(item_titles,
item_labels,
item_hrefs,
item_title_colors = "#0275d8",
item_bg_colors = "#337ab7",
item_text_colors = "white",
Id = NULL,
first_col_name = "Category",
second_col_name = "Options",
title = "A Table buttons with links",
title_color = "#0275d8",
target_blank = FALSE,
...) {
if (is.null(Id)) Id <- glue("list-table{sample(1000000:9999999, 1)}")
assert_that(is.character(item_title_colors) && length(item_title_colors) > 0)
if(length(item_title_colors) > 1) assert_that(length(item_title_colors) == length(item_titles))
assert_that(length(item_bg_colors) > 0)
stopifnot(is.logical(target_blank) && length(target_blank) == 1)
item_length <- lapply(item_labels, length)
if(length(item_bg_colors) > 1) {
assert_that(is.list(item_bg_colors))
mapply(function(len, color){
assert_that(is.character(color))
assert_that(
length(color) == len,
msg = "vectors in item_bg_colors has different length than vectors in item_labels"
)
},
item_length, item_bg_colors
)
}
assert_that(length(item_text_colors) > 0)
if(length(item_text_colors) > 1) {
assert_that(is.list(item_text_colors))
mapply(function(len, color){
assert_that(is.character(color))
assert_that(
length(color) == len,
msg = "vectors in item_text_colors has different length than vectors in item_labels"
)
},
item_length, item_text_colors
)
}
assert_that(is.list(item_labels)); assert_that(is.list(item_hrefs))
assert_that(length(item_titles) == length(item_labels) &
length(item_labels) == length(item_hrefs),
msg = glue("item_titles, item_labels and ",
"item_hrefs must have the same length"))
mapply(
function(label, href) {
assert_that(length(href) == length(label),
msg = paste0("'", paste0(label, collapse = ", "),
"' must have the same length as '",
paste0(href, collapse = ", "), "'")
)
},
item_labels, item_hrefs
)
target_text <- if (target_blank) 'target="_blank"' else ''
btns <- mapply(
function(label, href, bg_color, text_color) {
href_hover <- rep("", length(href))
href_hover[href == ""] <- "nohover"
href[href == ""] <- "javascript:null;"
glue('
<a
href="{href}" {target_text}
class="href-button {href_hover} sps-tab-link"
style="background-color: {bg_color}; color: {text_color};"
>
{label}
</a>'
) %>% glue::glue_collapse()
},
item_labels, item_hrefs, item_bg_colors,item_text_colors
)
tags$table(
id = Id, class = "table table-hover table-href table-striped",
...,
tags$caption(class = "text-center h2",
style = glue("color: {title_color};"),
title),
HTML(glue('<thead>
<tr class="info">
<th>{first_col_name}</th>
<th>{second_col_name}</th>
</tr>
</thead>')),
tags$tbody(HTML(glue(
'
<tr>
<td class="h4" style="color: {item_title_colors};">{item_titles}</td>
<td>{btns}</td>
</tr>\n
'
))),
spsDepend("basic")
)
}
#' Render some collapsible markdown text
#' @description write some text in markdown format and it will help you
#' render to markdown, use [shiny::markdown] but it is collapsible.
#' @param desc one character string in markdown format
#' @param id element ID
#' @export
#' @return HTML elements
#' @examples
#' if(interactive()){
#' desc <-
#' "
#' # Some desc
#' - xxxx
#' - bbbb
#'
#' This is a [link](https://www.google.com/).
#'
#' `Some other things`
#' > other markdown things
#'
#' 1. aaa
#' 2. bbb
#' 3. ccc
#' "
#' ui <- fluidPage(
#' renderDesc(id = "desc", desc),
#' )
#'
#' server <- function(input, output, session) {
#'
#' }
#'
#' shinyApp(ui, server)
#' }
renderDesc <- function(id, desc) {
div(
HTML(glue('
<div class="desc">
<div class="collapse desc-body" id="{id}" aria-expanded="false">
{HTML(markdown(glue(desc, .open = "@{", .close = "}@")))}
</div>
<a role="button" class="collapsed" data-toggle="collapse"
href="#{id}" aria-expanded="false" aria-controls="{id}">
</a>
</div>
')),
spsDepend("basic")
)
}
#' @rdname hexPanel
#' @param hex_img single value of `hex_imgs`
#' @param hex_link single value of `hex_links`
#' @param footer single value of `footers`
#' @param footer_link single value of `footer_links`
#' @param x number, X offset, e.g. "-10" instead of -10L
#' @param y number, Y offset
#' @param target_blank bool, whether to add `target="_blank"` to the link?
#' @export
hexLogo <- function(
id,
title = "",
hex_img,
hex_link = "" ,
footer = "",
footer_link = "",
x = "-10",
y = "-20",
target_blank = FALSE
) {
stopifnot(is.logical(target_blank) && length(target_blank) == 1)
target_text <- if (target_blank) 'target="_blank"' else ''
title_text <- if(!emptyIsFalse(title)) ''
else glue('<span class="text-info">{title}</span><br>')
hex <- if(!emptyIsFalse(hex_link)) {
glue('<polygon points="50 1 95 25 95 75 50 99 5 75 5 25"',
'fill="url(#{id}-hex)" stroke="var(--primary)"',
'stroke-width="2"/>')
} else {
glue('<a href="{hex_link}" {target_text}>',
'<polygon class="hex" points="50 1 95 25 95 75 50 99 5 75 5 25"',
'fill="url(#{id}-hex)" stroke="var(--primary)"',
'stroke-width="2"/></a>')
}
footer_link <- if(!emptyIsFalse(footer_link)) '' else glue('href="{footer_link}"')
footer_class <- if(emptyIsFalse(footer_link)) 'powerby-link' else 'powerby-link nohover'
footer_text <- if(!emptyIsFalse(footer)) ''
else glue('<text x=10 y=115><a class="{footer_class}"',
'{footer_link} target="_blank">{footer}</a></text>')
tagList(
HTML(glue('
<div id="{id}" class="hex-container">
{title_text}
<svg class="hex-box" viewBox="0 0 100 115" version="1.1" xmlns="http://www.w3.org/2000/svg">
<defs>
<pattern id="{id}-hex" patternUnits="userSpaceOnUse" height="100%" width="100%">
<image href="{hex_img}" x="{x}" y="{y}" height="125%" width="125%" />
</pattern>
</defs>
{hex}
{footer_text}
</svg>
</div>
')),
spsDepend("basic")
)
}
#' Hexagon logo and logo panel
#' @description Shiny UI widgets to generate hexagon logo(s).
#' [hexLogo()] generates a single hexagon, and [hexPanel()]
#' generates a panel of hex logos
#' @param id input ID
#' @param title title of the logo, display on top of logo or title of logo panel
#' displayed on the left
#' @param hex_imgs a character vector of logo image source, can be online or
#' local, see details
#' @param hex_links a character vector of links attached to each logo, if not
#' `NULL`, must be the same length as `hex_imgs`
#' @param hex_titles similar to `hex_links`, titles of each logo
#' @param footers a character vector of footer attached to each logo
#' @param footer_links a character vector of footer links, if not `NULL`,
#' must be the same length as `footers`
#' @param xs a character vector X coordinate offset value for each logo image,
#' default -10, mist be the same length as `hex_imgs`
#' @param ys Y coordinates offset, must be the same length as `xs`, default -20
#' @param target_blank bool, whether to add `target="_blank"` to the link?
#' @details
#' The image in each hexagon is resized to the same size as the hex border
#' and then enlarged 125%. You may want to use x, y offset value to change
#' the image position.
#'
#' If your image source is local, you need to add your local directory to the
#' shiny server, e.g. `addResourcePath("sps", "www")`. This example add `www`
#' folder under my current working directory as `sps` to the server. Then you
#' can access my images by `hex_imgs = "sps/my_img.png"`.
#'
#' some args in `hexPanel` are character vectors, use `NULL` for the default
#' value. If you want to change value but not all of your logos, use `""` to
#' occupy space in the vector. e.g. I have 3 logos, but I only want to add
#' 2 footer and only 1 footer has a link:
#' `footers = c("footer1", "footer2", "")`,
#' `footer_links = c("", "https://mylink", "")`. By doing so `footers` and
#' `footer_links` has the same required length.
#'
#' @export
#' @return HTML elements, tagList
#' @importFrom assertthat not_empty assert_that
#' @examples
#' if(interactive()){
#' ui <- fluidPage(
#' hexLogo(
#' "logo", "Logo",
#' hex_img = "https://live.staticflickr.com/7875/46106952034_954b8775fa_b.jpg",
#' hex_link = "https://www.google.com",
#' footer = "Footer",
#' footer_link = "https://www.google.com"
#' ),
#' hexLogo(
#' "x", "Change X offset",
#' hex_img = "https://live.staticflickr.com/7875/46106952034_954b8775fa_b.jpg",
#' x = "40"
#' ),
#' hexLogo(
#' "y", "Change Y offset",
#' hex_img = "https://live.staticflickr.com/7875/46106952034_954b8775fa_b.jpg",
#' y = "-60"
#' ),
#' hexPanel(
#' "demo1", "basic panel:" ,
#' rep("https://live.staticflickr.com/7875/46106952034_954b8775fa_b.jpg", 2)
#'
#' ),
#' hexPanel(
#' "demo2", "panel with links:" ,
#' c(paste0("https://d33wubrfki0l68.cloudfront.net/",
#' "2c6239d311be6d037c251c71c3902792f8c4ddd2/12f67/css/images/hex/ggplot2.png"),
#' paste0("https://d33wubrfki0l68.cloudfront.net/",
#' "621a9c8c5d7b47c4b6d72e8f01f28d14310e8370/193fc/css/images/hex/dplyr.png")
#' ),
#' c("https://ggplot2.tidyverse.org/", "https://dplyr.tidyverse.org/"),
#' c("ggplot2", "dplyr")
#' ),
#' hexPanel(
#' "demo3", "footer with links:" ,
#' rep("https://live.staticflickr.com/7875/46106952034_954b8775fa_b.jpg", 2),
#' footers = c("hex1", "hex2"),
#' footer_links = rep("https://www.google.com", 2)
#' ),
#' hexPanel(
#' "demo4", "panel offsets" ,
#' hex_imgs = rep("https://live.staticflickr.com/7875/46106952034_954b8775fa_b.jpg", 4),
#' footers = paste0("hex", 1:4),
#' ys = seq(-20, -50, by = -10),
#' xs = seq(20, 50, by = 10)
#' )
#' )
#' server <- function(input, output, session) {
#' }
#' shinyApp(ui, server)
#' }
hexPanel <-function(
id,
title,
hex_imgs,
hex_links = NULL,
hex_titles = NULL,
footers = NULL,
footer_links = NULL,
xs = NULL,
ys = NULL,
target_blank = FALSE) {
if(not_empty(hex_titles)) assert_that(length(hex_titles) == length(hex_imgs))
if(not_empty(hex_links)) assert_that(length(hex_imgs) == length(hex_links))
if(not_empty(footers)) assert_that(length(footers) == length(hex_imgs))
if(not_empty(footer_links)) assert_that(length(footers) == length(footer_links))
if(not_empty(xs)) assert_that(length(hex_imgs) == length(xs))
if(not_empty(ys)) assert_that(length(hex_imgs) == length(ys))
stopifnot(is.logical(target_blank) && length(target_blank) == 1)
if(is.null(xs)) xs <- rep("-10", length(hex_imgs))
if(is.null(ys)) ys <- rep("-20", length(hex_imgs))
lapply(seq_along(hex_imgs), function(i){
div(class="hex-item",
hexLogo(id = paste0(id, i), title = hex_titles[i],
hex_img = hex_imgs[i], hex_link = hex_links[i],
footer = footers[i], footer_link = footer_links[i],
x = xs[i], y=ys[i], target_blank = target_blank)
)
}) %>% {
fluidRow(class = "hex-panel",
h5(class = "text-primary", title),
tagList(.)
)
}
}
#' Match height of one element to the other element
#' @description Match the height of one element to the second element.
#' If the height of second element change, the height of first element will change
#' automatically
#' @param div1 element ID, or jquery selector if `isID = FALSE`. The first element
#' that you want to match the height to the other element
#' @param div2 matched element ID or selector, the other element
#' @param isID bool, if `TRUE`, `div1` and `div2` will be treated as ID, otherwise
#' you can use complex jquery selector
#'
#' @return tagList containing javascript
#' @export
#'
#' @examples
#' if(interactive()){
#' library(shiny)
#' library(shinyjqui)
#' ui <- fluidPage(
#' column(
#' 3, id = "a",
#' style = "border: 1px black solid; background-color: gray;",
#' p("This block's height is matched with orange one")
#' ),
#' shinyjqui::jqui_resizable(column(
#' 2, id ="b",
#' style = "border: 1px black solid; background-color: orange;",
#' p("drag the bottom-right corner")
#' )),
#' column(
#' 3, id = "c",
#' style = "border: 1px black solid; background-color: red;",
#' p("This block's is not matched with others")
#' ),
#' heightMatcher("a", "b")
#' )
#'
#' server <- function(input, output, session) {
#'
#' }
#' # Try to drag `b` from bottom right corner and see what happens to `a`
#' shinyApp(ui, server)
#' }
heightMatcher <- function(div1, div2, isID=TRUE){
if(isID) {
div1 <- paste0("#", div1)
div2 <- paste0("#", div2)
}
tagList(
tags$script(paste0(
'heightMatcher("', div1, '",', ' "', div2, '")'
)),
spsDepend("basic", css = FALSE)
)
}
#' Go top button
#' @description add a go top button on your shiny app. When the user clicks the
#' button, scroll the window all the way to the top. Just add this function anywhere
#' in you UI.
#'
#' @details The button hides if you are on very top of the page. If you scroll
#' down 50px, this button will appear.
#' @param id element ID
#' @param icon [shiny::icon] if you do not want to use the default rocket image
#' @param right character string, css style, the button's position to window right
#' @param bottom character string, css style, the button's position to window bottom
#' @param color color of the icon.
#'
#' @return a shiny component
#' @export
#' @examples
#' if(interactive()){
#' library(shiny)
#'
#' ui <- fluidPage(
#' h1("Scroll the page..."),
#' lapply(1: 100, function(x) br()),
#' spsGoTop("default"),
#' spsGoTop("mid", right = "50%", bottom= "50%", icon = icon("house"), color = "red"),
#' spsGoTop("up", right = "95%", bottom= "95%", icon = icon("arrow-up"), color = "green")
#' )
#'
#' server <- function(input, output, session) {
#'
#' }
#'
#' shinyApp(ui, server)
#' }
spsGoTop <- function(
id = "gotop",
icon = NULL,
right = "1rem",
bottom = "10rem",
color = "#337ab7"
){
inner <-
if (inherits(icon, "shiny.tag")) icon
else HTML('
<svg viewBox="0 0 1024 1024" version="1.1" xmlns="http://www.w3.org/2000/svg">
<path d="M526.60727968 10.90185116
a27.675 27.675 0 0 0-29.21455937 0
c-131.36607665 82.28402758-218.69155461 228.01873535-218.69155402
394.07834331a462.20625001 462.20625001 0 0 0 5.36959153 69.94390903
c1.00431239 6.55289093-0.34802892 13.13561351-3.76865779 18.80351572-32.63518765
54.11355614-51.75690182 118.55860487-51.7569018 187.94566865a371.06718723 371.06718723 0 0 0 11.50484808 91.98906777
c6.53300375 25.50556257 41.68394495 28.14064038 52.69160883 4.22606766 17.37162448-37.73630017
42.14135425-72.50938081 72.80769204-103.21549295 2.18761121 3.04276886 4.15646224 6.24463696
6.40373557 9.22774369a1871.4375 1871.4375 0 0 0 140.04691725 5.34970492 1866.36093723 1866.36093723 0 0 0 140.04691723-5.34970492
c2.24727335-2.98310674 4.21612437-6.18497483 6.3937923-9.2178004 30.66633723 30.70611158
55.4360664 65.4791928 72.80769147 103.21549355 11.00766384 23.91457269 46.15860503 21.27949489
52.69160879-4.22606768a371.15156223 371.15156223 0 0 0
11.514792-91.99901164c0-69.36717486-19.13165746-133.82216804-51.75690182-187.92578088-3.42062944-5.66790279-4.76302748-12.26056868-3.76865837-18.80351632a462.20625001
462.20625001 0 0 0 5.36959269-69.943909c-0.00994388-166.08943902-87.32547796-311.81420293-218.6915546-394.09823051zM605.93803103
357.87693858a93.93749974 93.93749974 0 1 1-187.89594924 6.1e-7 93.93749974 93.93749974 0 0 1 187.89594924-6.1e-7z">
</path>
<path d="M429.50777625 765.63860547C429.50777625 803.39355007 466.44236686
1000.39046097 512.00932183 1000.39046097c45.56695499 0 82.4922232-197.00623328
82.5015456-234.7518555 0-37.75494459-36.9345906-68.35043303-82.4922232-68.34111062-45.57627738-0.00932239-82.52019037
30.59548842-82.51086798 68.34111062z">
</path>
</svg>
')
div(
class="sps-gotop",
id=id,
style = glue(
.open = "@{", .close = "}@",
'
right: @{right}@;
bottom: @{bottom}@;
@{if(inherits(icon, "shiny.tag")) "color:" else "fill:"}@ @{color}@;
'),
`data-toggle`="tooltip",
`data-placement`="left",
title="Go Top",
onclick="goTop()",
inner,
spsDepend("basic", js = FALSE),
spsDepend("gotop")
)
}
#' Display your code in a bootstrap modal or collapse
#' @description Developers often wants to show their code in a shiny app.
#' This function creates a button that when clicked, a modal or collapse
#' hidden element will show up to display your code.
#'
#' @param id element ID
#' @param code code you want to display, in a character string or vector.
#' @param label string, label to display on the button
#' @param title string, title of the modal or collapse
#' @param tool_tip string, what tooltip to display when hover on the button
#' @param show_span bool, use the `<span>` tag to show a little label of the
#' left of the button? The span text will use text from `tool_tip`
#' @param placement string, where to display the tooltip
#' @param btn_icon icon, [shiny::icon()], icon of the button
#' @param size string, one of "large", "medium", "small", only works for modal
#' @param language string, what programming language is the code, use [shinyAce::getAceModes()]
#' to see options
#' @param display string, one of "modal", "collapse"
#' @param color string, color of the button
#' @param shape string, shape of the button, one of "rect", "circular",
#' @param ... other args pass to the [shiny::actionButton]
#'
#' @details
#' 1. The modal or collapse has an ID, the ID is your button ID + "-modal" or "-collapse",
#' like "my_button-modal"
#' 2. You could update the code inside the collapse use [shinyAce::updateAceEditor]
#' on server, the code block ID is button ID + "-ace", like "my_button-ace" . See
#' examples.
#' @return a shiny tagList
#' @export
#'
#' @examples
#' if(interactive()){
#' library(shiny)
#' my_code <-
#' '
#' # load package and data
#' library(ggplot2)
#' data(mpg, package="ggplot2")
#' # mpg <- read.csv("http://goo.gl/uEeRGu")
#'
#' # Scatterplot
#' theme_set(theme_bw()) # pre-set the bw theme.
#' g <- ggplot(mpg, aes(cty, hwy))
#' g + geom_jitter(width = .5, size=1) +
#' labs(subtitle="mpg: city vs highway mileage",
#' y="hwy",
#' x="cty",
#' title="Jittered Points")
#' '
#' html_code <-
#' '
#' <!DOCTYPE html>
#' <html>
#' <body>
#'
#' <h2>ABC</h2>
#'
#' <p id="demo">Some HTML</p>
#'
#' </body>
#' </html>
#' '
#' ui <- fluidPage(
#' fluidRow(
#' column(
#' 6,
#' h3("Display by modal"),
#' column(
#' 6, h4("default"),
#' spsCodeBtn(id = "a", my_code)
#' ),
#' column(
#' 6, h4("change color and shape"),
#' spsCodeBtn(
#' id = "b", c(my_code, my_code),
#' color = "red", shape = "circular")
#' )
#' ),
#' column(
#' 6,
#' h3("Display by collapse"),
#' column(
#' 6, h4("collapse"),
#' spsCodeBtn(id = "c", my_code, display = "collapse")
#' ),
#' column(
#' 6, h4("different programming language"),
#' spsCodeBtn(
#' id = "d", html_code,
#' language = "html", display = "collapse")
#' )
#' )
#' ),
#' fluidRow(
#' column(
#' 6,
#' h3("Update code"),
#' spsCodeBtn(
#' "update-code",
#' "# No code here",
#' display = "collapse"
#' ),
#' actionButton("update", "change code in the left `spsCodeBtn`"),
#' actionButton("changeback", "change it back")
#' )
#' )
#' )
#'
#' server <- function(input, output, session) {
#' observeEvent(input$update, {
#' shinyAce::updateAceEditor(
#' session, editorId = "update-code-ace",
#' value = "# code has changed!\n 1+1"
#' )
#' })
#' observeEvent(input$changeback, {
#' shinyAce::updateAceEditor(
#' session, editorId = "update-code-ace",
#' value = "# No code here"
#' )
#' })
#' }
#'
#' shinyApp(ui, server)
#' }
spsCodeBtn <- function(
id,
code,
language = "r",
label = "",
title="Code to Reproduce",
show_span = FALSE,
tool_tip = "Show Code",
placement = "bottom",
btn_icon = icon("code"),
display = c("modal", "collapse"),
size = c("large", "medium", "small"),
color = "black",
shape = c("rect", "circular"),
...
){
shape <- match.arg(shape, c("rect", "circular"))
size <- match.arg(size, c("large", "medium", "small"))
display <- match.arg(display, c("modal", "collapse"))
stopifnot(is.logical(show_span))
b_radius <- if (shape == "rect"){
btn_style <- glue(
.open = '@{', .close = '}@',
'
color: @{color}@;
'
)
} else {
btn_style <- glue(
.open = '@{', .close = '}@',
'
border-radius: 50%;
width: 35px;
height: 35px;
padding: 0;
color: @{color}@;
'
)
}
btn <- div(
style = "display: inline-block",
if (show_span) tags$span(tool_tip, class = "text-bold", style = "padding-right: 5px;") else "",
actionButton(
inputId = id,
label = label,
icon = btn_icon,
style = btn_style,
...
)
) %>% bsTooltip(title = tool_tip, placement = placement)
if (display == "modal") {
display_el <- bsModal(
id = id,
title = title,
size = size,
shinyAce::aceEditor(
outputId = paste0(id, "-ace"),
value = glue(.open = '@{', .close = '}@', glue_collapse(code)),
mode = language,
readOnly = TRUE,
fontSize = "14"
)
)
btn <- btn %>% htmltools::tagAppendAttributes(
`data-toggle`="modal",
`data-target`= paste0('#', id, '-modal')
)
} else {
display_el <- bsCollapse(
id = id,
div(
h4(class="modal-title", title),
shinyAce::aceEditor(
outputId = paste0(id, "-ace"),
value = glue(.open = '@{', .close = '}@', glue_collapse(code)),
mode = language,
readOnly = TRUE,
fontSize = "14"
)
)
)
btn <- btn %>% htmltools::tagAppendAttributes(
`data-toggle`="collapse",
`aria-expanded`="false",
`aria-controls`= paste0(id, '-collapse'),
`data-target`= paste0('#', id, '-collapse')
)
}
tagList(
btn,
display_el,
spsDepend("basic"),
spsDepend("pop-tip")
)
}
bsModal <- function(id, ..., title="title",
size=c('normal', 'large', 'small'),
confirmbtn = FALSE,
confirmbtn_id = paste0(id, "-confirm"),
confirmbtn_text = "confirm"
){
size <- switch(size[1],
'large' = 'modal-lg',
'small' = 'modal-sm',
''
)
div(
class="modal fade", id= paste0(id, "-modal"), tabindex="-1", role="dialog",
`aria-labelledby`=paste0(id, "-modal-title"),
div(
class=paste("modal-dialog", size), role="document",
div(
class="modal-content",
div(
class="modal-header",
HTML('<button type="button" class="close" data-dismiss="modal" aria-label="Close">
<span aria-hidden="true">×</span>
</button>
'),
h4(class="modal-title", id=paste0(id, "-modal-title"), title)
),
div(
class="modal-body", ...
),
div(
class="modal-footer",
tags$button(type="button", class="btn btn-default", `data-dismiss`="modal", "Close"),
if(confirmbtn){
tags$button(
class = "btn btn-default action-button btn-primary",
id = confirmbtn_id,
type = "button",
confirmbtn_text
)
} else
{div()}
)
)
)
)
}
bsCollapse <- function(id, ..., collapsed = FALSE) {
div(
class = if (collapsed) "collapse in" else "collapse",
id = paste0(id, "-collapse"),
`aria-expanded` = if (collapsed) "true" else "false",
...
)
}
lz100/spsComps documentation built on Oct. 13, 2023, 3:09 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions hexPanel hexLogo renderDesc hrefTable hrefTab gallery
Documented in gallery hexLogo hexPanel hrefTab hrefTable renderDesc
################## A Collections of HTML components#############################
# can be used outside SPS framework, like other shiny projects
## use on top of shiny
#' A shiny gallery component
#' @description Create a gallery to display images or photos
#'
#' `texts`, `hrefs`, `images` Must have the same length
#'
#' If there is any image that you do not want to add links, use `""` to occupy the space, e.g
#'
#' `hrefs = c("https://xxx.com", "", "https://xxx.com")`
#'
#' If the link is empty, there will be no hover effect on that image, and you cannot click it.
#'
#' Similar to `hrefs`, for the `texts`, use `""` to occupy space
#'
#' @importFrom assertthat assert_that
#'
#' @param Id ID of this gallery
#' @param title Title of gallery
#' @param title_color Title color
#' @param texts vector of labels under each image
#' @param hrefs vector of links when each image is clicked
#' @param image_frame_size integer, 1-12, this controls width. How large is each
#' image. 12 is the whole width of the parent container and 1 is 1/12 of the container. Consider
#' numbers that can be fully divided by 12, like 1 (12 per row), 2 (6 per row),
#' 3 (4 per row), 4 (3 per row), 6 (1 per row)or 12 (if you want only 1 image per row).
#' @param images a vector of image sources, can be online URLs or local resource paths.
#' @param enlarge bool, when click on the image, enlarge
#' it? If enlarge is enabled, click the photo will enlarge instead of jump to the link.
#' Only the title below contains the link if enlarge is enabled.
#' @param enlarge_method how the photo is enlarged on click,
#' one of "inline" -- within the gallery change the size of photo to 12, "modal" --
#' display photo in a pop-up modal.
#' @param target_blank bool, whether to add `target="_blank"` to the link?
#' @param obj_fit string, the CSS property "object-fit" of images. This is helpful
#' to deal with stretched images. Read more on
#' [CSS documents](https://developer.mozilla.org/en-US/docs/Web/CSS/object-fit).
#' Default is `"fill"`, and other options are `"contain"`, `"cover"`, `"none"`, `"scale-down"`.
#' @param style additional CSS style you want to add to the most outside component "div"
#' @details
#' #### `modal` enlarge
#' When view the `modal` enlarged images, click the "X" button or anywhere outside the
#' image to close the full screen view.
#' @export
#' @return a gallery component
#'
#' @examples
#' if(interactive()){
#' texts <- c("p1", "p2", "", "p4", "p5")
#' hrefs <- c("https://github.com/lz100/spsComps/blob/master/img/1.jpg?raw=true",
#' "https://github.com/lz100/spsComps/blob/master/img/2.jpg?raw=true",
#' "",
#' "https://github.com/lz100/spsComps/blob/master/img/4.jpg?raw=true",
#' "https://github.com/lz100/spsComps/blob/master/img/5.jpg?raw=true")
#' images <- c("https://github.com/lz100/spsComps/blob/master/img/1.jpg?raw=true",
#' "https://github.com/lz100/spsComps/blob/master/img/2.jpg?raw=true",
#' "https://github.com/lz100/spsComps/blob/master/img/3.jpg?raw=true",
#' "https://github.com/lz100/spsComps/blob/master/img/4.jpg?raw=true",
#' "https://github.com/lz100/spsComps/blob/master/img/5.jpg?raw=true")
#' library(shiny)
#'
#' ui <- fluidPage(
#' column(
#' 6,
#' gallery(texts = texts, hrefs = hrefs, images = images, title = "Default gallery"),
#' spsHr(),
#' gallery(texts = texts, hrefs = hrefs, images = images,
#' image_frame_size = 2, title = "Photo size"),
#' spsHr(),
#' gallery(texts = texts, hrefs = hrefs, images = images,
#' enlarge = TRUE, title = "Inline enlarge"),
#' spsHr(),
#' gallery(
#' texts = texts, hrefs = hrefs, images = images,
#' enlarge = TRUE, title = "Modal enlarge",
#' enlarge_method = "modal", obj_fit = "cover"
#' )
#' )
#' )
#'
#' server <- function(input, output, session) {
#'
#' }
#'
#' shinyApp(ui, server)
#' }
gallery <- function(texts,
hrefs,
images,
Id = NULL,
title = "Gallery",
title_color = "#0275d8",
image_frame_size = 4,
enlarge = FALSE,
enlarge_method = c("inline", "modal"),
target_blank = FALSE,
obj_fit = "fill",
style = ""){
if (is.null(Id)) Id <- glue("gallery{sample(1000000:9999999, 1)}")
assertthat::assert_that(is.character(texts))
assertthat::assert_that(is.character(hrefs))
assertthat::assert_that(is.character(images))
stopifnot(is.logical(target_blank) && length(target_blank) == 1)
stopifnot(is.character(obj_fit) && length(obj_fit) == 1)
image_frame_size <- as.integer(image_frame_size)
stopifnot(image_frame_size > 0 && image_frame_size <=12)
stopifnot(is.logical(enlarge))
assertthat::assert_that(
length(texts) == length(hrefs) & length(hrefs) == length(images),
msg = "texts, hrefs and images must have the same length")
enlarge_method <- match.arg(enlarge_method, c("inline", "modal"))
texts[texts == ""] <- " "
hrefs_clean <- hrefs
img_ids <- paste0(Id, "-", seq_len(length(hrefs)))
hrefs[hrefs != ""] <- glue('href="{hrefs[hrefs != ""]}"')
href_hover <- rep("", length(hrefs))
href_hover[hrefs == ""] <- "gallery-nohover"
target_text <- if (target_blank) 'target="_blank"' else ''
gallery_div <- if(enlarge && enlarge_method == "inline") {
HTML(glue('
<div class="col-sm-{image_frame_size} sps-tab-link inline-enlarge" style="right: 1px;">
<img src="{images}" class="img-gallery" height=300 width=400 style="width: 100%; object-fit: {obj_fit};">
<a {hrefs} {target_text}><p class="text-center h4 {href_hover}">{texts}</p></a>
</div>
'))
} else if (enlarge) {
HTML(glue('
<div id={img_ids} class="col-sm-{image_frame_size} sps-tab-link" style="right: 1px;">
<img
src="{images}" class="img-gallery"
height=300 width=400
style="width: 100%; ; object-fit: {obj_fit};"
onclick=galEnlarge("#{img_ids}")
>
<a {hrefs} {target_text}><p class="text-center h4 {href_hover}">{texts}</p></a>
</div>
'))
} else {
HTML(glue('
<a {hrefs} {target_text} class="col-sm-{image_frame_size} sps-tab-link" style="right: 1px;">
<img src="{images}" class="img-gallery {href_hover}" height=300 width=400 style="width: 100%;">
<p class="text-center h4 {href_hover}">{texts}</p>
</a>
'))
}
div(
id = Id, class = "col sps-gallery",
style = style,
p(class = "text-center h2",
style = glue("color: {title_color};"),
title),
div(
class = "row", style = " margin: 10px;",
gallery_div
),
if(enlarge && enlarge_method == "modal") {
tags$script(HTML(
"
(function(){
if ($('#sps-gallery-modal').length) return ;
const gal_modal =
`<div id='sps-gallery-modal' class='gallery-modal' onclick='galModalClose()' style='display: none;'>
<span class='gallery-modal-close'>X</span>
<img id='sps-gallery-modal-content' class='gallery-modal-content'/>
<div class='gallery-caption'></div>
</div>`;
$(document.body).append(gal_modal);
})()
"
))
} else "",
tags$script(glue('fixGalHeight("{Id}")')),
spsDepend("basic")
)
}
#' Display a list of links in a row of buttons
#' @description `hrefTab` creates a small section of link buttons
#' @importFrom assertthat assert_that
#'
#' @param Id optional element ID
#' @param title element title
#' @param title_color title color
#' @param label_texts individual tab labels
#' @param hrefs individual tab links
#' @param bg_colors individual tab button background color, either 1 value to apply for all of
#' them or specify for each of them in a vector
#' @param text_colors individual tab button text color, either 1 value to apply for all of
#' them or specify for each of them in a vector
#' @param target_blank bool, whether to add `target="_blank"` to the link?
#' @param ... other arguments to be passed to the html element
#'
#' @return a Shiny component
#' @details
#' 1. `label_texts`, `hrefs` must be the same length
#' 2. If more than one value is provided for `bg_colors` or/and `text_colors`,
#' the length of these 2 vectors must be the same as `label_texts`
#' 3. Use `""` to occupy the space if you do not want a label contains a link,
#' e.g `hrefs = c("https://google.com/", "", "")`
#' 4. If a label does not have a link, you cannot click it and there is no hovering
#' effects.
#' @export
#' @examples
#' if(interactive()){
#' ui <- fluidPage(
#' hrefTab(
#' title = "Default",
#' label_texts = c("Bar Plot", "PCA Plot", "Scatter Plot"),
#' hrefs = c("https://google.com/", "", "")
#' ),
#' hrefTab(
#' title = "Different background",
#' label_texts = c("Bar Plot", "PCA Plot", "Scatter Plot"),
#' hrefs = c("https://google.com/", "", ""),
#' bg_colors = c("#eee", "orange", "green")
#' ),
#' hrefTab(
#' title = "Different background and text colors",
#' label_texts = c("Bar Plot", "Disabled", "Scatter Plot"),
#' hrefs = c("https://google.com/", "", ""),
#' bg_colors = c("green", "#eee", "orange"),
#' text_colors = c("#caffc1", "black", "blue")
#' )
#' )
#'
#' server <- function(input, output, session) {
#'
#' }
#' shinyApp(ui, server)
#' }
hrefTab <- function(label_texts,
hrefs,
Id = NULL,
title = "A list of tabs",
title_color = "#0275d8",
bg_colors = "#337ab7",
text_colors = "white",
target_blank = FALSE,
...
){
if (is.null(Id)) Id <- glue("list-tab{sample(1000000:9999999, 1)}")
assert_that(is.character(bg_colors) && length(bg_colors) > 0)
assert_that(is.character(text_colors) && length(text_colors) > 0)
assert_that(length(label_texts) == length(hrefs),
msg = "texts and hrefs must have the same length")
if (length(bg_colors) > 1) assert_that(length(label_texts) == length(bg_colors))
if (length(text_colors) > 1) assert_that(length(label_texts) == length(text_colors))
stopifnot(is.logical(target_blank) && length(target_blank) == 1)
href_hover <- rep("", length(hrefs))
href_hover[hrefs == ""] <- "nohover"
hrefs[hrefs == ""] <- "javascript:null;"
target_text <- if (target_blank) 'target="_blank"' else ''
div(
id = Id, class = "col", ... ,
p(class = "h4",
style = glue("color: {title_color}; text-align: left;"),
title),
div(
HTML(glue('
<a
href="{hrefs}" {target_text}
class="href-button sps-tab-link {href_hover}"
style="background-color: {bg_colors}; color: {text_colors};"
>
{label_texts}
</a>\n
'))
),
spsDepend("basic")
)
}
#' A table of hyper reference buttons
#' @description creates a table in Shiny which the cells are hyper reference (links)
#' buttons. This function is similar to [hrefTab], but that function only creates
#' a single row of link buttons, and this function creates a table of rows.
#'
#' The table has two columns, the first column is row names, second column is different
#' link buttons.
#' @details
#' 1. `item_titles`, `item_labels`, `item_hrefs` must have the same
#' length. Each vector in `item_labels`, `item_hrefs` must also have the same
#' length. For example, if we want to make a table of two rows, the first row
#' has 1 cell and the second row has 2 cells:
#'
#' ```
#' hrefTable(
#' item_titles = c("row 1", "row 2"),
#' item_labels = list(c("cell 1"), c("cell 1", "cell 2")),
#' item_hrefs = list(c("link1"), c("link1", "link2")
#' )
#' ```
#'
#' 2. If `item_title_colors`, `item_text_colors` are given more than one value,
#' the list must have the same length as `item_titles`, and length of each vector
#' in the list must match the vector in `item_labels` in the same order.
#' 3. If `item_title_colors` is given more than one value, the vector must have
#' the same length as `item_titles`.
#' 4. Use `""` to occupy the space if you do not want a label contains a link,
#' e.g `item_hrefs = list(c("https://www.google.com/"), c("", ""))`
#' 5. If a label does not have a link, you cannot click it and there is no hovering
#' effects.
#' @importFrom assertthat assert_that
#'
#' @param Id optional ID
#' @param title title of this table
#' @param item_titles vector of strings, a vector of titles for table row names
#' @param item_labels list, a list of character vectors to specify button
#' labels in each table row, one vector per row
#' @param item_hrefs list, a list of character vectors to specify button hrefs
#' links in each table row, one vector per row
#' @param item_bg_colors a single character value or a list, a list of character
#' vectors to specify button background colors in each table row, one vector per row
#' @param item_text_colors a single character value or a list, a list of character
#' vectors to specify button text colors in each table row, one vector per row
#' @param first_col_name first column name
#' @param second_col_name second column name
#' @param title_color table title color
#' @param item_title_colors a single character value or a character vector to
#' specify button title text colors of each row name
#' @param target_blank bool, whether to add `target="_blank"` to the link?
#' @param ... other HTML param you want to pass to the table
#'
#' @export
#' @return HTML elements
#' @examples
#' if(interactive()){
#' ui <- fluidPage(
#' hrefTable(
#' title = "default",
#' item_titles = c("workflow 1", "unclickable"),
#' item_labels = list(c("tab 1"), c("tab 3", "tab 4")),
#' item_hrefs = list(c("https://www.google.com/"), c("", ""))
#' ),
#' hrefTable(
#' title = "Change button color and text color",
#' item_titles = c("workflow 1", "No links"),
#' item_labels = list(c("tab 1"), c("tab 3", "tab 4")),
#' item_hrefs = list(c("https://www.google.com/"), c("", "")),
#' item_bg_colors = list(c("blue"), c("red", "orange")),
#' item_text_colors = list(c("black"), c("yellow", "green"))
#' ),
#' hrefTable(
#' title = "Change row name colors and width",
#' item_titles = c("Green", "Red", "Orange"),
#' item_labels = list(c("tab 1"), c("tab 3", "tab 4"), c("tab 5", "tab 6", "tab 7")),
#' item_hrefs = list(
#' c("https://www.google.com/"),
#' c("", ""),
#' c("https://www.google.com/", "https://www.google.com/", "")
#' ),
#' item_title_colors = c("green", "red", "orange"),
#' style = "width: 50%"
#' )
#'
#' )
#'
#' server <- function(input, output, session) {
#'
#' }
#'
#' shinyApp(ui, server)
#' }
hrefTable <- function(item_titles,
item_labels,
item_hrefs,
item_title_colors = "#0275d8",
item_bg_colors = "#337ab7",
item_text_colors = "white",
Id = NULL,
first_col_name = "Category",
second_col_name = "Options",
title = "A Table buttons with links",
title_color = "#0275d8",
target_blank = FALSE,
...) {
if (is.null(Id)) Id <- glue("list-table{sample(1000000:9999999, 1)}")
assert_that(is.character(item_title_colors) && length(item_title_colors) > 0)
if(length(item_title_colors) > 1) assert_that(length(item_title_colors) == length(item_titles))
assert_that(length(item_bg_colors) > 0)
stopifnot(is.logical(target_blank) && length(target_blank) == 1)
item_length <- lapply(item_labels, length)
if(length(item_bg_colors) > 1) {
assert_that(is.list(item_bg_colors))
mapply(function(len, color){
assert_that(is.character(color))
assert_that(
length(color) == len,
msg = "vectors in item_bg_colors has different length than vectors in item_labels"
)
},
item_length, item_bg_colors
)
}
assert_that(length(item_text_colors) > 0)
if(length(item_text_colors) > 1) {
assert_that(is.list(item_text_colors))
mapply(function(len, color){
assert_that(is.character(color))
assert_that(
length(color) == len,
msg = "vectors in item_text_colors has different length than vectors in item_labels"
)
},
item_length, item_text_colors
)
}
assert_that(is.list(item_labels)); assert_that(is.list(item_hrefs))
assert_that(length(item_titles) == length(item_labels) &
length(item_labels) == length(item_hrefs),
msg = glue("item_titles, item_labels and ",
"item_hrefs must have the same length"))
mapply(
function(label, href) {
assert_that(length(href) == length(label),
msg = paste0("'", paste0(label, collapse = ", "),
"' must have the same length as '",
paste0(href, collapse = ", "), "'")
)
},
item_labels, item_hrefs
)
target_text <- if (target_blank) 'target="_blank"' else ''
btns <- mapply(
function(label, href, bg_color, text_color) {
href_hover <- rep("", length(href))
href_hover[href == ""] <- "nohover"
href[href == ""] <- "javascript:null;"
glue('
<a
href="{href}" {target_text}
class="href-button {href_hover} sps-tab-link"
style="background-color: {bg_color}; color: {text_color};"
>
{label}
</a>'
) %>% glue::glue_collapse()
},
item_labels, item_hrefs, item_bg_colors,item_text_colors
)
tags$table(
id = Id, class = "table table-hover table-href table-striped",
...,
tags$caption(class = "text-center h2",
style = glue("color: {title_color};"),
title),
HTML(glue('<thead>
<tr class="info">
<th>{first_col_name}</th>
<th>{second_col_name}</th>
</tr>
</thead>')),
tags$tbody(HTML(glue(
'
<tr>
<td class="h4" style="color: {item_title_colors};">{item_titles}</td>
<td>{btns}</td>
</tr>\n
'
))),
spsDepend("basic")
)
}
#' Render some collapsible markdown text
#' @description write some text in markdown format and it will help you
#' render to markdown, use [shiny::markdown] but it is collapsible.
#' @param desc one character string in markdown format
#' @param id element ID
#' @export
#' @return HTML elements
#' @examples
#' if(interactive()){
#' desc <-
#' "
#' # Some desc
#' - xxxx
#' - bbbb
#'
#' This is a [link](https://www.google.com/).
#'
#' `Some other things`
#' > other markdown things
#'
#' 1. aaa
#' 2. bbb
#' 3. ccc
#' "
#' ui <- fluidPage(
#' renderDesc(id = "desc", desc),
#' )
#'
#' server <- function(input, output, session) {
#'
#' }
#'
#' shinyApp(ui, server)
#' }
renderDesc <- function(id, desc) {
div(
HTML(glue('
<div class="desc">
<div class="collapse desc-body" id="{id}" aria-expanded="false">
{HTML(markdown(glue(desc, .open = "@{", .close = "}@")))}
</div>
<a role="button" class="collapsed" data-toggle="collapse"
href="#{id}" aria-expanded="false" aria-controls="{id}">
</a>
</div>
')),
spsDepend("basic")
)
}
#' @rdname hexPanel
#' @param hex_img single value of `hex_imgs`
#' @param hex_link single value of `hex_links`
#' @param footer single value of `footers`
#' @param footer_link single value of `footer_links`
#' @param x number, X offset, e.g. "-10" instead of -10L
#' @param y number, Y offset
#' @param target_blank bool, whether to add `target="_blank"` to the link?
#' @export
hexLogo <- function(
id,
title = "",
hex_img,
hex_link = "" ,
footer = "",
footer_link = "",
x = "-10",
y = "-20",
target_blank = FALSE
) {
stopifnot(is.logical(target_blank) && length(target_blank) == 1)
target_text <- if (target_blank) 'target="_blank"' else ''
title_text <- if(!emptyIsFalse(title)) ''
else glue('<span class="text-info">{title}</span><br>')
hex <- if(!emptyIsFalse(hex_link)) {
glue('<polygon points="50 1 95 25 95 75 50 99 5 75 5 25"',
'fill="url(#{id}-hex)" stroke="var(--primary)"',
'stroke-width="2"/>')
} else {
glue('<a href="{hex_link}" {target_text}>',
'<polygon class="hex" points="50 1 95 25 95 75 50 99 5 75 5 25"',
'fill="url(#{id}-hex)" stroke="var(--primary)"',
'stroke-width="2"/></a>')
}
footer_link <- if(!emptyIsFalse(footer_link)) '' else glue('href="{footer_link}"')
footer_class <- if(emptyIsFalse(footer_link)) 'powerby-link' else 'powerby-link nohover'
footer_text <- if(!emptyIsFalse(footer)) ''
else glue('<text x=10 y=115><a class="{footer_class}"',
'{footer_link} target="_blank">{footer}</a></text>')
tagList(
HTML(glue('
<div id="{id}" class="hex-container">
{title_text}
<svg class="hex-box" viewBox="0 0 100 115" version="1.1" xmlns="http://www.w3.org/2000/svg">
<defs>
<pattern id="{id}-hex" patternUnits="userSpaceOnUse" height="100%" width="100%">
<image href="{hex_img}" x="{x}" y="{y}" height="125%" width="125%" />
</pattern>
</defs>
{hex}
{footer_text}
</svg>
</div>
')),
spsDepend("basic")
)
}
#' Hexagon logo and logo panel
#' @description Shiny UI widgets to generate hexagon logo(s).
#' [hexLogo()] generates a single hexagon, and [hexPanel()]
#' generates a panel of hex logos
#' @param id input ID
#' @param title title of the logo, display on top of logo or title of logo panel
#' displayed on the left
#' @param hex_imgs a character vector of logo image source, can be online or
#' local, see details
#' @param hex_links a character vector of links attached to each logo, if not
#' `NULL`, must be the same length as `hex_imgs`
#' @param hex_titles similar to `hex_links`, titles of each logo
#' @param footers a character vector of footer attached to each logo
#' @param footer_links a character vector of footer links, if not `NULL`,
#' must be the same length as `footers`
#' @param xs a character vector X coordinate offset value for each logo image,
#' default -10, mist be the same length as `hex_imgs`
#' @param ys Y coordinates offset, must be the same length as `xs`, default -20
#' @param target_blank bool, whether to add `target="_blank"` to the link?
#' @details
#' The image in each hexagon is resized to the same size as the hex border
#' and then enlarged 125%. You may want to use x, y offset value to change
#' the image position.
#'
#' If your image source is local, you need to add your local directory to the
#' shiny server, e.g. `addResourcePath("sps", "www")`. This example add `www`
#' folder under my current working directory as `sps` to the server. Then you
#' can access my images by `hex_imgs = "sps/my_img.png"`.
#'
#' some args in `hexPanel` are character vectors, use `NULL` for the default
#' value. If you want to change value but not all of your logos, use `""` to
#' occupy space in the vector. e.g. I have 3 logos, but I only want to add
#' 2 footer and only 1 footer has a link:
#' `footers = c("footer1", "footer2", "")`,
#' `footer_links = c("", "https://mylink", "")`. By doing so `footers` and
#' `footer_links` has the same required length.
#'
#' @export
#' @return HTML elements, tagList
#' @importFrom assertthat not_empty assert_that
#' @examples
#' if(interactive()){
#' ui <- fluidPage(
#' hexLogo(
#' "logo", "Logo",
#' hex_img = "https://live.staticflickr.com/7875/46106952034_954b8775fa_b.jpg",
#' hex_link = "https://www.google.com",
#' footer = "Footer",
#' footer_link = "https://www.google.com"
#' ),
#' hexLogo(
#' "x", "Change X offset",
#' hex_img = "https://live.staticflickr.com/7875/46106952034_954b8775fa_b.jpg",
#' x = "40"
#' ),
#' hexLogo(
#' "y", "Change Y offset",
#' hex_img = "https://live.staticflickr.com/7875/46106952034_954b8775fa_b.jpg",
#' y = "-60"
#' ),
#' hexPanel(
#' "demo1", "basic panel:" ,
#' rep("https://live.staticflickr.com/7875/46106952034_954b8775fa_b.jpg", 2)
#'
#' ),
#' hexPanel(
#' "demo2", "panel with links:" ,
#' c(paste0("https://d33wubrfki0l68.cloudfront.net/",
#' "2c6239d311be6d037c251c71c3902792f8c4ddd2/12f67/css/images/hex/ggplot2.png"),
#' paste0("https://d33wubrfki0l68.cloudfront.net/",
#' "621a9c8c5d7b47c4b6d72e8f01f28d14310e8370/193fc/css/images/hex/dplyr.png")
#' ),
#' c("https://ggplot2.tidyverse.org/", "https://dplyr.tidyverse.org/"),
#' c("ggplot2", "dplyr")
#' ),
#' hexPanel(
#' "demo3", "footer with links:" ,
#' rep("https://live.staticflickr.com/7875/46106952034_954b8775fa_b.jpg", 2),
#' footers = c("hex1", "hex2"),
#' footer_links = rep("https://www.google.com", 2)
#' ),
#' hexPanel(
#' "demo4", "panel offsets" ,
#' hex_imgs = rep("https://live.staticflickr.com/7875/46106952034_954b8775fa_b.jpg", 4),
#' footers = paste0("hex", 1:4),
#' ys = seq(-20, -50, by = -10),
#' xs = seq(20, 50, by = 10)
#' )
#' )
#' server <- function(input, output, session) {
#' }
#' shinyApp(ui, server)
#' }
hexPanel <-function(
id,
title,
hex_imgs,
hex_links = NULL,
hex_titles = NULL,
footers = NULL,
footer_links = NULL,
xs = NULL,
ys = NULL,
target_blank = FALSE) {
if(not_empty(hex_titles)) assert_that(length(hex_titles) == length(hex_imgs))
if(not_empty(hex_links)) assert_that(length(hex_imgs) == length(hex_links))
if(not_empty(footers)) assert_that(length(footers) == length(hex_imgs))
if(not_empty(footer_links)) assert_that(length(footers) == length(footer_links))
if(not_empty(xs)) assert_that(length(hex_imgs) == length(xs))
if(not_empty(ys)) assert_that(length(hex_imgs) == length(ys))
stopifnot(is.logical(target_blank) && length(target_blank) == 1)
if(is.null(xs)) xs <- rep("-10", length(hex_imgs))
if(is.null(ys)) ys <- rep("-20", length(hex_imgs))
lapply(seq_along(hex_imgs), function(i){
div(class="hex-item",
hexLogo(id = paste0(id, i), title = hex_titles[i],
hex_img = hex_imgs[i], hex_link = hex_links[i],
footer = footers[i], footer_link = footer_links[i],
x = xs[i], y=ys[i], target_blank = target_blank)
)
}) %>% {
fluidRow(class = "hex-panel",
h5(class = "text-primary", title),
tagList(.)
)
}
}
#' Match height of one element to the other element
#' @description Match the height of one element to the second element.
#' If the height of second element change, the height of first element will change
#' automatically
#' @param div1 element ID, or jquery selector if `isID = FALSE`. The first element
#' that you want to match the height to the other element
#' @param div2 matched element ID or selector, the other element
#' @param isID bool, if `TRUE`, `div1` and `div2` will be treated as ID, otherwise
#' you can use complex jquery selector
#'
#' @return tagList containing javascript
#' @export
#'
#' @examples
#' if(interactive()){
#' library(shiny)
#' library(shinyjqui)
#' ui <- fluidPage(
#' column(
#' 3, id = "a",
#' style = "border: 1px black solid; background-color: gray;",
#' p("This block's height is matched with orange one")
#' ),
#' shinyjqui::jqui_resizable(column(
#' 2, id ="b",
#' style = "border: 1px black solid; background-color: orange;",
#' p("drag the bottom-right corner")
#' )),
#' column(
#' 3, id = "c",
#' style = "border: 1px black solid; background-color: red;",
#' p("This block's is not matched with others")
#' ),
#' heightMatcher("a", "b")
#' )
#'
#' server <- function(input, output, session) {
#'
#' }
#' # Try to drag `b` from bottom right corner and see what happens to `a`
#' shinyApp(ui, server)
#' }
heightMatcher <- function(div1, div2, isID=TRUE){
if(isID) {
div1 <- paste0("#", div1)
div2 <- paste0("#", div2)
}
tagList(
tags$script(paste0(
'heightMatcher("', div1, '",', ' "', div2, '")'
)),
spsDepend("basic", css = FALSE)
)
}
#' Go top button
#' @description add a go top button on your shiny app. When the user clicks the
#' button, scroll the window all the way to the top. Just add this function anywhere
#' in you UI.
#'
#' @details The button hides if you are on very top of the page. If you scroll
#' down 50px, this button will appear.
#' @param id element ID
#' @param icon [shiny::icon] if you do not want to use the default rocket image
#' @param right character string, css style, the button's position to window right
#' @param bottom character string, css style, the button's position to window bottom
#' @param color color of the icon.
#'
#' @return a shiny component
#' @export
#' @examples
#' if(interactive()){
#' library(shiny)
#'
#' ui <- fluidPage(
#' h1("Scroll the page..."),
#' lapply(1: 100, function(x) br()),
#' spsGoTop("default"),
#' spsGoTop("mid", right = "50%", bottom= "50%", icon = icon("house"), color = "red"),
#' spsGoTop("up", right = "95%", bottom= "95%", icon = icon("arrow-up"), color = "green")
#' )
#'
#' server <- function(input, output, session) {
#'
#' }
#'
#' shinyApp(ui, server)
#' }
spsGoTop <- function(
id = "gotop",
icon = NULL,
right = "1rem",
bottom = "10rem",
color = "#337ab7"
){
inner <-
if (inherits(icon, "shiny.tag")) icon
else HTML('
<svg viewBox="0 0 1024 1024" version="1.1" xmlns="http://www.w3.org/2000/svg">
<path d="M526.60727968 10.90185116
a27.675 27.675 0 0 0-29.21455937 0
c-131.36607665 82.28402758-218.69155461 228.01873535-218.69155402
394.07834331a462.20625001 462.20625001 0 0 0 5.36959153 69.94390903
c1.00431239 6.55289093-0.34802892 13.13561351-3.76865779 18.80351572-32.63518765
54.11355614-51.75690182 118.55860487-51.7569018 187.94566865a371.06718723 371.06718723 0 0 0 11.50484808 91.98906777
c6.53300375 25.50556257 41.68394495 28.14064038 52.69160883 4.22606766 17.37162448-37.73630017
42.14135425-72.50938081 72.80769204-103.21549295 2.18761121 3.04276886 4.15646224 6.24463696
6.40373557 9.22774369a1871.4375 1871.4375 0 0 0 140.04691725 5.34970492 1866.36093723 1866.36093723 0 0 0 140.04691723-5.34970492
c2.24727335-2.98310674 4.21612437-6.18497483 6.3937923-9.2178004 30.66633723 30.70611158
55.4360664 65.4791928 72.80769147 103.21549355 11.00766384 23.91457269 46.15860503 21.27949489
52.69160879-4.22606768a371.15156223 371.15156223 0 0 0
11.514792-91.99901164c0-69.36717486-19.13165746-133.82216804-51.75690182-187.92578088-3.42062944-5.66790279-4.76302748-12.26056868-3.76865837-18.80351632a462.20625001
462.20625001 0 0 0 5.36959269-69.943909c-0.00994388-166.08943902-87.32547796-311.81420293-218.6915546-394.09823051zM605.93803103
357.87693858a93.93749974 93.93749974 0 1 1-187.89594924 6.1e-7 93.93749974 93.93749974 0 0 1 187.89594924-6.1e-7z">
</path>
<path d="M429.50777625 765.63860547C429.50777625 803.39355007 466.44236686
1000.39046097 512.00932183 1000.39046097c45.56695499 0 82.4922232-197.00623328
82.5015456-234.7518555 0-37.75494459-36.9345906-68.35043303-82.4922232-68.34111062-45.57627738-0.00932239-82.52019037
30.59548842-82.51086798 68.34111062z">
</path>
</svg>
')
div(
class="sps-gotop",
id=id,
style = glue(
.open = "@{", .close = "}@",
'
right: @{right}@;
bottom: @{bottom}@;
@{if(inherits(icon, "shiny.tag")) "color:" else "fill:"}@ @{color}@;
'),
`data-toggle`="tooltip",
`data-placement`="left",
title="Go Top",
onclick="goTop()",
inner,
spsDepend("basic", js = FALSE),
spsDepend("gotop")
)
}
#' Display your code in a bootstrap modal or collapse
#' @description Developers often wants to show their code in a shiny app.
#' This function creates a button that when clicked, a modal or collapse
#' hidden element will show up to display your code.
#'
#' @param id element ID
#' @param code code you want to display, in a character string or vector.
#' @param label string, label to display on the button
#' @param title string, title of the modal or collapse
#' @param tool_tip string, what tooltip to display when hover on the button
#' @param show_span bool, use the `<span>` tag to show a little label of the
#' left of the button? The span text will use text from `tool_tip`
#' @param placement string, where to display the tooltip
#' @param btn_icon icon, [shiny::icon()], icon of the button
#' @param size string, one of "large", "medium", "small", only works for modal
#' @param language string, what programming language is the code, use [shinyAce::getAceModes()]
#' to see options
#' @param display string, one of "modal", "collapse"
#' @param color string, color of the button
#' @param shape string, shape of the button, one of "rect", "circular",
#' @param ... other args pass to the [shiny::actionButton]
#'
#' @details
#' 1. The modal or collapse has an ID, the ID is your button ID + "-modal" or "-collapse",
#' like "my_button-modal"
#' 2. You could update the code inside the collapse use [shinyAce::updateAceEditor]
#' on server, the code block ID is button ID + "-ace", like "my_button-ace" . See
#' examples.
#' @return a shiny tagList
#' @export
#'
#' @examples
#' if(interactive()){
#' library(shiny)
#' my_code <-
#' '
#' # load package and data
#' library(ggplot2)
#' data(mpg, package="ggplot2")
#' # mpg <- read.csv("http://goo.gl/uEeRGu")
#'
#' # Scatterplot
#' theme_set(theme_bw()) # pre-set the bw theme.
#' g <- ggplot(mpg, aes(cty, hwy))
#' g + geom_jitter(width = .5, size=1) +
#' labs(subtitle="mpg: city vs highway mileage",
#' y="hwy",
#' x="cty",
#' title="Jittered Points")
#' '
#' html_code <-
#' '
#' <!DOCTYPE html>
#' <html>
#' <body>
#'
#' <h2>ABC</h2>
#'
#' <p id="demo">Some HTML</p>
#'
#' </body>
#' </html>
#' '
#' ui <- fluidPage(
#' fluidRow(
#' column(
#' 6,
#' h3("Display by modal"),
#' column(
#' 6, h4("default"),
#' spsCodeBtn(id = "a", my_code)
#' ),
#' column(
#' 6, h4("change color and shape"),
#' spsCodeBtn(
#' id = "b", c(my_code, my_code),
#' color = "red", shape = "circular")
#' )
#' ),
#' column(
#' 6,
#' h3("Display by collapse"),
#' column(
#' 6, h4("collapse"),
#' spsCodeBtn(id = "c", my_code, display = "collapse")
#' ),
#' column(
#' 6, h4("different programming language"),
#' spsCodeBtn(
#' id = "d", html_code,
#' language = "html", display = "collapse")
#' )
#' )
#' ),
#' fluidRow(
#' column(
#' 6,
#' h3("Update code"),
#' spsCodeBtn(
#' "update-code",
#' "# No code here",
#' display = "collapse"
#' ),
#' actionButton("update", "change code in the left `spsCodeBtn`"),
#' actionButton("changeback", "change it back")
#' )
#' )
#' )
#'
#' server <- function(input, output, session) {
#' observeEvent(input$update, {
#' shinyAce::updateAceEditor(
#' session, editorId = "update-code-ace",
#' value = "# code has changed!\n 1+1"
#' )
#' })
#' observeEvent(input$changeback, {
#' shinyAce::updateAceEditor(
#' session, editorId = "update-code-ace",
#' value = "# No code here"
#' )
#' })
#' }
#'
#' shinyApp(ui, server)
#' }
spsCodeBtn <- function(
id,
code,
language = "r",
label = "",
title="Code to Reproduce",
show_span = FALSE,
tool_tip = "Show Code",
placement = "bottom",
btn_icon = icon("code"),
display = c("modal", "collapse"),
size = c("large", "medium", "small"),
color = "black",
shape = c("rect", "circular"),
...
){
shape <- match.arg(shape, c("rect", "circular"))
size <- match.arg(size, c("large", "medium", "small"))
display <- match.arg(display, c("modal", "collapse"))
stopifnot(is.logical(show_span))
b_radius <- if (shape == "rect"){
btn_style <- glue(
.open = '@{', .close = '}@',
'
color: @{color}@;
'
)
} else {
btn_style <- glue(
.open = '@{', .close = '}@',
'
border-radius: 50%;
width: 35px;
height: 35px;
padding: 0;
color: @{color}@;
'
)
}
btn <- div(
style = "display: inline-block",
if (show_span) tags$span(tool_tip, class = "text-bold", style = "padding-right: 5px;") else "",
actionButton(
inputId = id,
label = label,
icon = btn_icon,
style = btn_style,
...
)
) %>% bsTooltip(title = tool_tip, placement = placement)
if (display == "modal") {
display_el <- bsModal(
id = id,
title = title,
size = size,
shinyAce::aceEditor(
outputId = paste0(id, "-ace"),
value = glue(.open = '@{', .close = '}@', glue_collapse(code)),
mode = language,
readOnly = TRUE,
fontSize = "14"
)
)
btn <- btn %>% htmltools::tagAppendAttributes(
`data-toggle`="modal",
`data-target`= paste0('#', id, '-modal')
)
} else {
display_el <- bsCollapse(
id = id,
div(
h4(class="modal-title", title),
shinyAce::aceEditor(
outputId = paste0(id, "-ace"),
value = glue(.open = '@{', .close = '}@', glue_collapse(code)),
mode = language,
readOnly = TRUE,
fontSize = "14"
)
)
)
btn <- btn %>% htmltools::tagAppendAttributes(
`data-toggle`="collapse",
`aria-expanded`="false",
`aria-controls`= paste0(id, '-collapse'),
`data-target`= paste0('#', id, '-collapse')
)
}
tagList(
btn,
display_el,
spsDepend("basic"),
spsDepend("pop-tip")
)
}
bsModal <- function(id, ..., title="title",
size=c('normal', 'large', 'small'),
confirmbtn = FALSE,
confirmbtn_id = paste0(id, "-confirm"),
confirmbtn_text = "confirm"
){
size <- switch(size[1],
'large' = 'modal-lg',
'small' = 'modal-sm',
''
)
div(
class="modal fade", id= paste0(id, "-modal"), tabindex="-1", role="dialog",
`aria-labelledby`=paste0(id, "-modal-title"),
div(
class=paste("modal-dialog", size), role="document",
div(
class="modal-content",
div(
class="modal-header",
HTML('<button type="button" class="close" data-dismiss="modal" aria-label="Close">
<span aria-hidden="true">×</span>
</button>
'),
h4(class="modal-title", id=paste0(id, "-modal-title"), title)
),
div(
class="modal-body", ...
),
div(
class="modal-footer",
tags$button(type="button", class="btn btn-default", `data-dismiss`="modal", "Close"),
if(confirmbtn){
tags$button(
class = "btn btn-default action-button btn-primary",
id = confirmbtn_id,
type = "button",
confirmbtn_text
)
} else
{div()}
)
)
)
)
}
bsCollapse <- function(id, ..., collapsed = FALSE) {
div(
class = if (collapsed) "collapse in" else "collapse",
id = paste0(id, "-collapse"),
`aria-expanded` = if (collapsed) "true" else "false",
...
)
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.