Badge Generator

#| '!! shinylive warning !!': |
#|   shinylive does not work in self-contained HTML documents.
#|   Please set `embed-resources: false` in your metadata.
#| standalone: true
#| viewerHeight: 720

suppressPackageStartupMessages({
    library(magrittr)
    library(shiny)
})

rsspdc_url <- "https://rsspdc.org"
types <- c("Specific Record", "Pipeline", "Software Package", "Web Service")
type_colours <- c("bf2649", "7d26bf", "2686bf", "bfba26")
names(type_colours) <- types 
badges <- c(
    none = "", bronze = "🥉", silver = "🥈", gold = "🥇", platinum = "🏆"
)
assessor <- c("self" = "👤", "third party" = "👥")
assessor_colour <- c("565656", "22aa39") #  "26bf40")
names(assessor_colour) <- names(assessor)

ui <- fluidPage(
    # see: https://stackoverflow.com/questions/78448126/copying-output-to-clipboard-in-r-shiny
    tags$script("
        Shiny.addCustomMessageHandler('txt', function (txt) {
            navigator.clipboard.writeText(txt);
        });
    "), # this is new
    fluidRow(
        column(
            width = 6,
            selectInput(
                inputId = "type", choices = types,
                selected = types[1], label = "Type"
            ),
            selectInput(
                inputId = "assessor", choices = names(assessor),
                selected = names(assessor)[1],
                label = "assessor"
            ),
            selectInput(
                inputId = "tier", choices = names(badges),
                selected = names(badges)[1],
                label = "Medal"
            ),
            numericInput(
                inputId = "total_score", label = "Total Score",
                value = 0,
                min = 0, max = 44, step = 1
            )
        ),
        column(
            width = 6,
            h2("Preview"),
            p(),
            htmlOutput(outputId = "html_preview"),
            p(),
            htmlOutput(outputId = "score_badge_mismatch")
        )
    ),
    fluidRow(
        tabsetPanel(
            id = "active_tab",
            tabPanel("URL", verbatimTextOutput(outputId = "url")),
            tabPanel("Markdown", verbatimTextOutput(outputId = "Markdown")),
            tabPanel("rSt", verbatimTextOutput(outputId = "rSt")),
            tabPanel("AsciiDoc", verbatimTextOutput(outputId = "AsciiDoc")),
            tabPanel("HTML", verbatimTextOutput(outputId = "html_raw"))
        ),
        actionButton("copy_link", "Copy to clipboard")
    )
)

server <- function(input, output, session) {

    score_badge_mismatch <- reactive({
        text <- ""
        if(input$tier == "bronze" && input$total_score < 11) {
            text <- "⚠️Cannot get Bronze with a score of less than 11"
        } else if(input$tier == "silver" && input$total_score < 22) {
            text <- "⚠️Cannot get Silver with a score of less than 22"
        } else if(input$tier == "gold" && input$total_score < 33) {
            text <- "⚠️Cannot get Gold with a score of less than 33"
        } else if(input$tier == "platinum" && input$total_score < 44) {
            text <- "⚠️Cannot get Platinum with a score of less than 44"
        }
    })
    output$score_badge_mismatch <- renderText({score_badge_mismatch()}) 

    encoded_url <- reactive({
        URLencode(paste0(
            "https://img.shields.io/badge/RSSPDC_",
            ifelse(
                input$assessor == "third party",
                paste0(" ", assessor[input$assessor], " "),
                paste0(" ", assessor[input$assessor], " ")
            ),
            badges[input$tier], "_(", input$total_score, ")_-",
            input$type, "-", type_colours[input$type],
            "?style=for-the-badge",
            "&link=", rsspdc_url,
            ifelse(
                input$assessor == "third party",
                paste0(
                    "&labelColor=",
                    assessor_colour[input$assessor]
                ),
                ""
            ),
            "&link=", rsspdc_url, "/checklists/",
            tolower(gsub(" ","-", input$type)), ".html"
        ))
    })
    output$url <- renderText({ encoded_url() })
    alt_text <- reactive({paste(
        "RSSPDC Badge", input$assessor, "assessed", input$tier,
        input$total_score, input$type
    )})
    html_text <- reactive({
        paste0(
            '<img alt="', alt_text(), '" src="',
            encoded_url()
            ,'">'
        )
    })
    output$html_preview <- renderText({ html_text() })
    Markdown <- reactive({paste0(
        "[![", alt_text(), "](", encoded_url(), ")](", rsspdc_url, ")"
    )})
    rSt <- reactive({paste0(
        ".. image:: ", encoded_url(), "\n   :alt:", alt_text(),
        "\n   :target: ", rsspdc_url
    )})
    AsciiDoc <- reactive({paste0(
        "image:", encoded_url(), "[", alt_text(), ",link=", rsspdc_url, "]"
    )})
    output$Markdown <- renderText({ Markdown() })
    output$rSt <- renderText({ rSt() })
    output$AsciiDoc <- renderText({ AsciiDoc() })
    output$html_raw <- renderText({ html_text() })

    clipboard_text <- reactive({switch(
        input$active_tab,
        "URL" = encoded_url(), "Markdown" = Markdown(), "rSt" = rSt(),
        "AsciiDoc" = AsciiDoc(), "HTML" = html_text()
    )})
    
    observeEvent(input$copy_link, {
        session$sendCustomMessage("txt", clipboard_text())
    })
}

shinyApp(ui, server)