From 264c9f935005409e4b6cfebd9de498a49ff32b6f Mon Sep 17 00:00:00 2001 From: Ross Armstrong <52817125+rossarmstrong@users.noreply.github.com> Date: Thu, 19 Jan 2023 22:09:55 +1100 Subject: [PATCH] Initial commit --- DESCRIPTION | 7 +- NAMESPACE | 5 + R/golem_utils_server.R | 63 ++++ R/golem_utils_ui.R | 405 +++++++++++++++++++++++ dev/01_start.R | 8 +- inst/WORDLIST | 3 + inst/app/www/favicon.ico | Bin 3774 -> 15086 bytes man/run_app.Rd | 2 +- tests/spelling.R | 3 + tests/testthat.R | 12 + tests/testthat/test-golem-recommended.R | 74 +++++ tests/testthat/test-golem_utils_server.R | 54 +++ tests/testthat/test-golem_utils_ui.R | 177 ++++++++++ 13 files changed, 807 insertions(+), 6 deletions(-) create mode 100644 R/golem_utils_server.R create mode 100644 R/golem_utils_ui.R create mode 100644 inst/WORDLIST create mode 100644 tests/spelling.R create mode 100644 tests/testthat.R create mode 100644 tests/testthat/test-golem-recommended.R create mode 100644 tests/testthat/test-golem_utils_server.R create mode 100644 tests/testthat/test-golem_utils_ui.R diff --git a/DESCRIPTION b/DESCRIPTION index ea53f49..765aa62 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,4 +14,9 @@ Imports: shiny (>= 1.7.4) Encoding: UTF-8 LazyData: true -RoxygenNote: 7.1.1 +RoxygenNote: 7.2.3 +Suggests: + spelling, + testthat (>= 3.0.0) +Config/testthat/edition: 3 +Language: en-US diff --git a/NAMESPACE b/NAMESPACE index 2b8d54c..8218a94 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -7,4 +7,9 @@ importFrom(golem,add_resource_path) importFrom(golem,bundle_resources) importFrom(golem,favicon) importFrom(golem,with_golem_options) +importFrom(shiny,HTML) +importFrom(shiny,column) importFrom(shiny,shinyApp) +importFrom(shiny,tagAppendAttributes) +importFrom(shiny,tagList) +importFrom(shiny,tags) diff --git a/R/golem_utils_server.R b/R/golem_utils_server.R new file mode 100644 index 0000000..0099c19 --- /dev/null +++ b/R/golem_utils_server.R @@ -0,0 +1,63 @@ +#' Inverted versions of in, is.null and is.na +#' +#' @noRd +#' +#' @examples +#' 1 %not_in% 1:10 +#' not_null(NULL) +`%not_in%` <- Negate(`%in%`) + +not_null <- Negate(is.null) + +not_na <- Negate(is.na) + +#' Removes the null from a vector +#' +#' @noRd +#' +#' @example +#' drop_nulls(list(1, NULL, 2)) +drop_nulls <- function(x) { + x[!sapply(x, is.null)] +} + +#' If x is `NULL`, return y, otherwise return x +#' +#' @param x,y Two elements to test, one potentially `NULL` +#' +#' @noRd +#' +#' @examples +#' NULL %||% 1 +"%||%" <- function(x, y) { + if (is.null(x)) { + y + } else { + x + } +} + +#' If x is `NA`, return y, otherwise return x +#' +#' @param x,y Two elements to test, one potentially `NA` +#' +#' @noRd +#' +#' @examples +#' NA %|NA|% 1 +"%|NA|%" <- function(x, y) { + if (is.na(x)) { + y + } else { + x + } +} + +#' Typing reactiveValues is too long +#' +#' @inheritParams reactiveValues +#' @inheritParams reactiveValuesToList +#' +#' @noRd +rv <- function(...) shiny::reactiveValues(...) +rvtl <- function(...) shiny::reactiveValuesToList(...) diff --git a/R/golem_utils_ui.R b/R/golem_utils_ui.R new file mode 100644 index 0000000..5a9ee8d --- /dev/null +++ b/R/golem_utils_ui.R @@ -0,0 +1,405 @@ +#' Turn an R list into an HTML list +#' +#' @param list An R list +#' @param class a class for the list +#' +#' @return an HTML list +#' @noRd +#' +#' @examples +#' list_to_li(c("a", "b")) +#' @importFrom shiny tags tagAppendAttributes tagList +list_to_li <- function(list, class = NULL) { + if (is.null(class)) { + tagList( + lapply( + list, + tags$li + ) + ) + } else { + res <- lapply( + list, + tags$li + ) + res <- lapply( + res, + function(x) { + tagAppendAttributes( + x, + class = class + ) + } + ) + tagList(res) + } +} +#' Turn an R list into corresponding HTML paragraph tags +#' +#' @param list an R list +#' @param class a class for the paragraph tags +#' +#' @return An HTML tag +#' @noRd +#' +#' @examples +#' list_to_p(c("This is the first paragraph", "this is the second paragraph")) +#' @importFrom shiny tags tagAppendAttributes tagList +#' +list_to_p <- function(list, class = NULL) { + if (is.null(class)) { + tagList( + lapply( + list, + tags$p + ) + ) + } else { + res <- lapply( + list, + tags$p + ) + res <- lapply( + res, + function(x) { + tagAppendAttributes( + x, + class = class + ) + } + ) + tagList(res) + } +} + +#' @importFrom shiny tags tagAppendAttributes tagList +named_to_li <- function(list, class = NULL) { + if (is.null(class)) { + res <- mapply( + function(x, y) { + tags$li( + HTML( + sprintf("%s: %s", y, x) + ) + ) + }, + list, + names(list), + SIMPLIFY = FALSE + ) + tagList(res) + } else { + res <- mapply( + function(x, y) { + tags$li( + HTML( + sprintf("%s: %s", y, x) + ) + ) + }, + list, + names(list), + SIMPLIFY = FALSE + ) + res <- lapply( + res, + function(x) { + tagAppendAttributes( + x, + class = class + ) + } + ) + tagList(res) + } +} + +#' Remove a tag attribute +#' +#' @param tag the tag +#' @param ... the attributes to remove +#' +#' @return a new tag +#' @noRd +#' +#' @examples +#' a <- shiny::tags$p(src = "plop", "pouet") +#' tagRemoveAttributes(a, "src") +tagRemoveAttributes <- function(tag, ...) { + attrs <- as.character(list(...)) + for (i in seq_along(attrs)) { + tag$attribs[[attrs[i]]] <- NULL + } + tag +} + +#' Hide or display a tag +#' +#' @param tag the tag +#' +#' @return a tag +#' @noRd +#' +#' @examples +#' ## Hide +#' a <- shiny::tags$p(src = "plop", "pouet") +#' undisplay(a) +#' b <- shiny::actionButton("go_filter", "go") +#' undisplay(b) +#' @importFrom shiny tagList +undisplay <- function(tag) { + # if not already hidden + if ( + !is.null(tag$attribs$style) && + !grepl("display:\\s+none", tag$attribs$style) + ) { + tag$attribs$style <- paste( + "display: none;", + tag$attribs$style + ) + } else { + tag$attribs$style <- "display: none;" + } + tag +} + +#' @importFrom shiny tagList +display <- function(tag) { + if ( + !is.null(tag$attribs$style) && + grepl("display:\\s+none", tag$attribs$style) + ) { + tag$attribs$style <- gsub( + "(\\s)*display:(\\s)*none(\\s)*(;)*(\\s)*", + "", + tag$attribs$style + ) + } + tag +} + +#' Hide an elements by calling jquery hide on it +#' +#' @param id the id of the element to hide +#' +#' @noRd +#' +#' @importFrom shiny tags +jq_hide <- function(id) { + tags$script(sprintf("$('#%s').hide()", id)) +} + +#' Add a red star at the end of the text +#' +#' Adds a red star at the end of the text +#' (for example for indicating mandatory fields). +#' +#' @param text the HTLM text to put before the red star +#' +#' @return an html element +#' @noRd +#' +#' @examples +#' with_red_star("Enter your name here") +#' @importFrom shiny tags HTML +with_red_star <- function(text) { + shiny::tags$span( + HTML( + paste0( + text, + shiny::tags$span( + style = "color:red", + "*" + ) + ) + ) + ) +} + + + +#' Repeat tags$br +#' +#' @param times the number of br to return +#' +#' @return the number of br specified in times +#' @noRd +#' +#' @examples +#' rep_br(5) +#' @importFrom shiny HTML +rep_br <- function(times = 1) { + HTML(rep("
", times = times)) +} + +#' Create an url +#' +#' @param url the URL +#' @param text the text to display +#' +#' @return an a tag +#' @noRd +#' +#' @examples +#' enurl("https://www.thinkr.fr", "ThinkR") +#' @importFrom shiny tags +enurl <- function(url, text) { + tags$a(href = url, text) +} + +#' Columns wrappers +#' +#' These are convenient wrappers around +#' `column(12, ...)`, `column(6, ...)`, `column(4, ...)`... +#' +#' @noRd +#' +#' @importFrom shiny column +col_12 <- function(...) { + column(12, ...) +} + +#' @importFrom shiny column +col_10 <- function(...) { + column(10, ...) +} + +#' @importFrom shiny column +col_8 <- function(...) { + column(8, ...) +} + +#' @importFrom shiny column +col_6 <- function(...) { + column(6, ...) +} + + +#' @importFrom shiny column +col_4 <- function(...) { + column(4, ...) +} + + +#' @importFrom shiny column +col_3 <- function(...) { + column(3, ...) +} + + +#' @importFrom shiny column +col_2 <- function(...) { + column(2, ...) +} + + +#' @importFrom shiny column +col_1 <- function(...) { + column(1, ...) +} + + + +#' Make the current tag behave like an action button +#' +#' Only works with compatible tags like button or links +#' +#' @param tag Any compatible tag. +#' @param inputId Unique id. This will host the input value to be used +#' on the server side. +#' +#' @return The modified tag with an extra id and the action button class. +#' @noRd +#' +#' @examples +#' if (interactive()) { +#' library(shiny) +#' +#' link <- a(href = "#", "My super link", style = "color: lightblue;") +#' +#' ui <- fluidPage( +#' make_action_button(link, inputId = "mylink") +#' ) +#' +#' server <- function(input, output, session) { +#' observeEvent(input$mylink, { +#' showNotification("Pouic!") +#' }) +#' } +#' +#' shinyApp(ui, server) +#' } +make_action_button <- function(tag, inputId = NULL) { + # some obvious checks + if (!inherits(tag, "shiny.tag")) stop("Must provide a shiny tag.") + if (!is.null(tag$attribs$class)) { + if (grep("action-button", tag$attribs$class)) { + stop("tag is already an action button") + } + } + if (is.null(inputId) && is.null(tag$attribs$id)) { + stop("tag does not have any id. Please use inputId to be able to + access it on the server side.") + } + + # handle id + if (!is.null(inputId)) { + if (!is.null(tag$attribs$id)) { + warning( + paste( + "tag already has an id. Please use input$", + tag$attribs$id, + "to access it from the server side. inputId will be ignored." + ) + ) + } else { + tag$attribs$id <- inputId + } + } + + # handle class + if (is.null(tag$attribs$class)) { + tag$attribs$class <- "action-button" + } else { + tag$attribs$class <- paste(tag$attribs$class, "action-button") + } + # return tag + tag +} + + +# UNCOMMENT AND USE +# +# attachment::att_amend_desc() +# +# To use this part of the UI +# +#' #' Include Content From a File +#' #' +#' #' Load rendered RMarkdown from a file and turn into HTML. +#' #' +#' #' @rdname includeRMarkdown +#' #' @export +#' #' +#' #' @importFrom rmarkdown render +#' #' @importFrom markdown markdownToHTML +#' #' @importFrom shiny HTML +#' includeRMarkdown <- function(path){ +#' +#' md <- tempfile(fileext = '.md') +#' +#' on.exit(unlink(md),add = TRUE) +#' +#' rmarkdown::render( +#' path, +#' output_format = 'md_document', +#' output_dir = tempdir(), +#' output_file = md,quiet = TRUE +#' ) +#' +#' html <- markdown::markdownToHTML(md, fragment.only = TRUE) +#' +#' Encoding(html) <- "UTF-8" +#' +#' return(HTML(html)) +#' } diff --git a/dev/01_start.R b/dev/01_start.R index 3249c84..cb8444a 100644 --- a/dev/01_start.R +++ b/dev/01_start.R @@ -22,10 +22,10 @@ golem::fill_desc( pkg_name = "chatgptimages", # The Name of the package containing the App pkg_title = "A 'Shiny' App for creating images with ChatGPT", # The Title of the package containing the App pkg_description = "A system for accessing the ChatGPT Image Generation tool, and easily creating pictures based on user description.", # The Description of the package containing the App - author_first_name = "AUTHOR_FIRST", # Your First Name - author_last_name = "AUTHOR_LAST", # Your Last Name + author_first_name = "Ross", # Your First Name + author_last_name = "Armstrong", # Your Last Name author_email = "ross.armstrong@analyticsinmotion.com", # Your Email - repo_url = NULL # The URL of the GitHub Repo (optional) + repo_url = "https://github.com/analyticsinmotion/chatgpt-images-r-shiny" # The URL of the GitHub Repo (optional) ) ## Set {golem} options ---- @@ -50,7 +50,7 @@ golem::use_recommended_tests() ## Favicon ---- # If you want to change the favicon (default is golem's one) -golem::use_favicon() # path = "path/to/ico". Can be an online file. +golem::use_favicon("https://www.analyticsinmotion.com/favicon.ico") # path = "path/to/ico". Can be an online file. # golem::remove_favicon() # Uncomment to remove the default favicon ## Add helper functions ---- diff --git a/inst/WORDLIST b/inst/WORDLIST new file mode 100644 index 0000000..8db7151 --- /dev/null +++ b/inst/WORDLIST @@ -0,0 +1,3 @@ +ChatGPT +chatgpt +golem diff --git a/inst/app/www/favicon.ico b/inst/app/www/favicon.ico index 4c0982c026551c9cf45043e2a9ce56f58ef9a817..433f78ad8267a28eaa107e3de07e314cd8e5e172 100644 GIT binary patch literal 15086 zcmeHNdvH|M8NaxYd(XXhcg0$)j~cYr>69{JbxYiF1u0|Dgy zNQ`1yB#0dpAtgcqAqwFoMxKEJn<(1S4zyDcHVI^4H`(lFv)SEb+0);-cTe_a_ufq! z^`E+TIQh;!`F`j7oge3J?w;=xgdu`W7&AtI9Vu-6rXY+J1YzXJO&mu_-Da|+}X$SIIhAg4f1ft&(gW(ArG)!#Q4*~@ura@l7! z71|$f9OoSVdFev&3f5Xo#$KJF%=XS!%Dr=x^40}tOO*1q67}c(#kpE6-RUbBda zg;uj)c}}{+J6+x3Emjg5b{?<`(U#~~|4Z^h`lMiMDzcw7;jgW!vC#hS=J5`^;r{QJ zZG|1#v8F|dpS95HLG`)Iv!ZR1#jvvmoL)_fiQfdOMSwMe{%f1@8KKmR+ zug+2)ZJncBYfaOe@%H}#++UFstrdiQ709?Q&m>>>KCiU;GWBM>Y5Q`9C(}8Q?N9JL zm3+Sk2QqPkuLTpQLzKfcq-Bg=^2}Xm&Y% zke$Ch-Z(-1HuukFTbHO)`TkDl9e7Qqfz@bhUbyNzG>a{H+4*{Rh_P0Ur zByZZW9&6tqKbt~i_L>Xrd;3|#(M*&+LRSkap36&Yf2Z^Ar~>zmgm!KsTdeSbSLFTe zmb?k=*hDUzsTT6A@NB$!yfPa6uVr6@W1`s{{#TW`R=h)-!F?NvhpO{TpCSJ$GLG-> zzIqd?VYk9olV6y{O&`PGt*zPl+fU;&<~k#eX^-d9%l8S_o5${a7yP%&RYr`l5A1$3 z-XZYrd!dW?1PI^E1QuH+KFpbp-wwo2Om?xQz&$4;QR5x?F-dwhQ3nLf>)jb5y-x5it;x~00oYR~z9`p9r6 z__rF@&~U#@pRrv>_f5%5#b*0N*IVNqs|Wvjse_(YNAS6fHu4^M%8GXqOM5<)3XGV+ z_VHdcm-GMl0fjy%*=WW0hSIM6seQur=CPBu%q(W8Hg8nq0BJMs6Q;Kj8-?~}*ujjo zOu9ur?^0WKjF#w&qlVJj>CpX$WhbRNhX4bJnUM%fGupx`w^5Fg zDL}PL5WXn8lF|Te6oe8=ODIkeN|sU~0b5s)7!tR^=EsLbVLkbATNH229%s}RfDJgK zV!#P221E}myYuA3+C0uW*tpG;Ux#m(@ga5jC9sJhB?To*VFld5QUO2l1OJw2wgfKh zz77!0BCKX@b(-~v9+BNgoq>F269oxS{lawNdb2vMk!UWo-a4(%l(EA^xhtnYPJ#a` z1sV$-rOkzoYSx-u>dM9m&PVa_giq3eT~}rcimzCn;+v&x@y%6hS{JD`{!-=nbTslR zLs4t+OXT}Ea6i-;tZFV)f5y+?Qda$7AaxQ~ij~or@1k#xp8szvLH-|kY+sq`GRAM4 zMs9=O$C}@QWR1a#3T%X4<(yM-wH#vbb>(TJpJ|S`$o`*G_X)#{eyrb7V!shOhqQIDydvVV92fGxyN$l| zO<@>vzUPwb)#JVazqQDDrRCY0iyUL2K_WwkA~hqY?O#ro^Yv=!siXIlyAm*y9{w@Xba}7CVg_> z6!}#6HTH?ia-G%W6P!nxK3`dKtP6Pj;2Pys6de^JR zP3Cdr$N5}lwyDVRwuuG-jhwqWshqg*<`o#SJIkdx45AtAlb3C)1ZhC`iQ;4 z0I8XSH_(SL%VfmguemEO8`VFM-d0M{t!pl*f0f5;NT=xJr2nXW#MUJgKvMw{*4J zO&;L>(Ietr$S3|Q-4FMnn4A2R`whm1HVPv`mC9!1fj?y}h<@i5<)-wx=s7{`u9u#{ z+4bgFy|^8AQTUX3els1LyU!_*Q{c;~fPP+J{nJU^fifx{Elr4}N8`@2y13KkiRO!* zdAEy!8RMOSG2@(3VNrfmn3o?Hq6KjwfD;&;#@Om8eK}-3aq>6poPr%oj6~}_r!cJo zgu|EkO1_uKE|c zq>j~5*+#c-^474=pv`Uu8=)5g}5 z7#}mf<72Kj**M;hKVh|Ls28H_y^)OtRx8_B%^9nG3UBZGHw^K2B{}rCAC$k#aHw}- zIqHiH%PtLv+BDP#g!GZrPyUYWMy<-_N)prRs8CbGYfrh_od_bJ^Mb?a93a#c7X+#W!dKiG!!9-K;-=tQB24B zjCRt*m|)Ua)YO>z3>9P*6txqRm>Lrwkkqj?lGd6A&{ie}em&`PU%m*_j3tXjwR`&S-$5?iV3ruH0Kv-77nWteuL2Tvk3J369Jwf8iNx?pg_C@Un11n zg#g12#6@X_9j2)Bj>JXbQ(;Rwo-<6^9}w@0DREHU3ECgZgw41bagC{=eChg;Ch9`4U4EoO_qa5%z9u#X7=ovt; z`!ht^Phg(w27=swC(e5^-g^ji-$Crs_mG?SD})Pw7Waa(zJkC06{w>#usA;M4q-2| z8nv^Sm10PDnzWsX20Q!>yPAHz4!<7_se`}5#7Tb%M zn>j-9agBz=dW8|b%JXkAW)Bf@?XD)%4?%iGYhaT^i~KE-_d#j&&Z z;rMwT!tHn-+jHF@t|3oyEDo2ifZMqPb3MZ%HrFOl7(l3-&PTXEu49>F=erZ=`4V9c zsu{%=MDl{H+febo>l&^3Zu#!j6ZX5v^=!kj%3`>aV@GJ9v%VbF*^T&#K;bA`C*4w203P-icl^A%BMKR?@F5UF1erR9CmhT~INE~0s9B~H|p zGvC+D*HK@I_UdAkJ60e(PL=*fq-t`vW$tr*X*y^i?nt8lup3P;M8p{KEe za<0OuRn>Sd+l}zVRW{O}SP5 zFCTGsjPdf!!`o1WSMqZ(KdK5!C-=f2l(tVOr@zv<_L0o@e+d4L&!LVg#IcGMV%(BH z=OAJd)^T5cqkNw2wS2xl4#`%UPc@W5tI3AH{Wby|x3DCC6;g6`BeV1{QkT2{WyTEz zIB&xhFW?NFkK`wx8C%9Tdi)#sdYWpH^kghlj(*Ht`~l{~?t;Jh43w#7@I>tEP}y%G z$kmSmQv%haW`=wf)8^ORSc_*8^$1RA_4Nk#2j5|FaIetc7~K|Z6dYo`<#|c6FTYB@ zFMOVq-}HQZm(H%K!+Jr0()uy=*n@FCCCNdlJ!r|x#_83yQ|88;%*Qq3+I<_J6k~T| zC5r5&2uVGKS;?32gL;bls+0Qq@6p%MhQ9VTeDM0K_|)5h58r6T<^6Bq>d}KZy?z}&errG8Yk3Km_O;^Nw$11u z-*Fs~&le--N8b+jURs`ucB-LQ&dGdRHsIoGE%@loeYke?FnVZx{p}-^?_R?GEqaf) zp=Z;2TyHxja&Zi7Bj;mGzW+N5bNPLApWcD?Omkd!jmL_;D+_Uw&PK}LySk2Y+&~z= zME5V&im{)2ZWG?$^)kBFHR1gBt>W4K@%e2yw|$EkpSP*rcgB<#W9@mS5H)Tq1aq91 zxNQ86PccNzvYB+tvdsEBP1z3W70Q)s!uN$_F!+U@=akpt+hpcqU&bJ;9fbLPIfo?Eo+K*LjoNT) z!ost~HuG@n%H?9L(iu<1$9tU597-e{XEtbZ={xeBwb{j+3+yu$mZY0%mUB{VXPe^G<+&E)_2wl`94IeA*Qy$Eyj4+xXP3IL z%wp^#n@XzDcmAH2_?c7AYu0O2RQJ_+X{Lu8as+J3%|w2hX_R!$v=<=x@hta~>t`a% zed(L^QL4YvnHY0``u32`qz$kd7k;Pz$8fWG0H@;zp!ngysN#DA!-_`+ZYmTN>lBI~ W%_N?g*f7>j!engbU@no9xc>v_w5JCE diff --git a/man/run_app.Rd b/man/run_app.Rd index 6be75ea..c6c36f7 100644 --- a/man/run_app.Rd +++ b/man/run_app.Rd @@ -33,7 +33,7 @@ request to determine whether the \code{ui} should be used to handle the request. Note that the entire request path must match the regular expression in order for the match to be considered successful.} -\item{...}{arguments to pass to golem_opts. +\item{...}{arguments to pass to golem_opts. See `?golem::get_golem_options` for more details.} } \description{ diff --git a/tests/spelling.R b/tests/spelling.R new file mode 100644 index 0000000..6713838 --- /dev/null +++ b/tests/spelling.R @@ -0,0 +1,3 @@ +if(requireNamespace('spelling', quietly = TRUE)) + spelling::spell_check_test(vignettes = TRUE, error = FALSE, + skip_on_cran = TRUE) diff --git a/tests/testthat.R b/tests/testthat.R new file mode 100644 index 0000000..531684a --- /dev/null +++ b/tests/testthat.R @@ -0,0 +1,12 @@ +# This file is part of the standard setup for testthat. +# It is recommended that you do not modify it. +# +# Where should you do additional test configuration? +# Learn more about the roles of various files in: +# * https://r-pkgs.org/tests.html +# * https://testthat.r-lib.org/reference/test_package.html#special-files + +library(testthat) +library(chatgptimages) + +test_check("chatgptimages") diff --git a/tests/testthat/test-golem-recommended.R b/tests/testthat/test-golem-recommended.R new file mode 100644 index 0000000..b314130 --- /dev/null +++ b/tests/testthat/test-golem-recommended.R @@ -0,0 +1,74 @@ +test_that("app ui", { + ui <- app_ui() + golem::expect_shinytaglist(ui) + # Check that formals have not been removed + fmls <- formals(app_ui) + for (i in c("request")) { + expect_true(i %in% names(fmls)) + } +}) + +test_that("app server", { + server <- app_server + expect_type(server, "closure") + # Check that formals have not been removed + fmls <- formals(app_server) + for (i in c("input", "output", "session")) { + expect_true(i %in% names(fmls)) + } +}) + +test_that( + "app_sys works", + { + expect_true( + app_sys("golem-config.yml") != "" + ) + } +) + +test_that( + "golem-config works", + { + config_file <- app_sys("golem-config.yml") + skip_if(config_file == "") + + expect_true( + get_golem_config( + "app_prod", + config = "production", + file = config_file + ) + ) + expect_false( + get_golem_config( + "app_prod", + config = "dev", + file = config_file + ) + ) + } +) + +# Configure this test to fit your need. +# testServer() function makes it possible to test code in server functions and modules, without needing to run the full Shiny application +testServer(app_server, { + + # Set and test an input + session$setInputs(x = 2) + expect_equal(input$x, 2) + + # Example of tests you can do on the server: + # - Checking reactiveValues + # expect_equal(r$lg, 'EN') + # - Checking output + # expect_equal(output$txt, "Text") +}) + +# Configure this test to fit your need +test_that( + "app launches", + { + golem::expect_running(sleep = 5) + } +) diff --git a/tests/testthat/test-golem_utils_server.R b/tests/testthat/test-golem_utils_server.R new file mode 100644 index 0000000..770d387 --- /dev/null +++ b/tests/testthat/test-golem_utils_server.R @@ -0,0 +1,54 @@ +test_that("not_in works", { + expect_true(1 %not_in% 2:10) + expect_false(1 %not_in% 1:10) +}) + +test_that("not_null works", { + expect_true(not_null(1)) + expect_false(not_null(NULL)) +}) + +test_that("not_na works", { + expect_true(not_na(1)) + expect_false(not_na(NA)) +}) + +test_that("drop_nulls works", { + expect_equal( + drop_nulls( + list(x = NULL, y = 2) + ), + list(y = 2) + ) +}) + +test_that("%||% works", { + expect_equal( + NULL %||% 1, + 1 + ) + expect_equal( + 2 %||% 1, + 2 + ) +}) + +test_that("%|NA|% works", { + expect_equal( + NA %|NA|% 1, + 1 + ) + expect_equal( + 2 %|NA|% 1, + 2 + ) +}) + +test_that("rv and rvtl work", { + expect_true( + inherits(rv, "function") + ) + expect_true( + inherits(rvtl, "function") + ) +}) diff --git a/tests/testthat/test-golem_utils_ui.R b/tests/testthat/test-golem_utils_ui.R new file mode 100644 index 0000000..a33935c --- /dev/null +++ b/tests/testthat/test-golem_utils_ui.R @@ -0,0 +1,177 @@ +test_that("Test with_red_star works", { + expect_s3_class(with_red_star("golem"), "shiny.tag") + expect_equal( + as.character(with_red_star("Enter your name here")), + 'Enter your name here*' + ) +}) + +test_that("Test list_to_li works", { + expect_s3_class(list_to_li(c("a", "b")), "shiny.tag.list") + expect_equal( + as.character(list_to_li(c("a", "b"))), + "
  • a
    • \n
  • b
    • " + ) + expect_equal( + as.character(list_to_li(c("a", "b"), class = "my_li")), + '
  • a
    • \n
  • b
    • ' + ) +}) + +test_that("Test list_to_p works", { + expect_s3_class( + list_to_p(c( + "This is the first paragraph", + "this is the second paragraph" + )), + "shiny.tag.list" + ) + expect_equal( + as.character( + list_to_p(c( + "This is the first paragraph", + "this is the second paragraph" + )) + ), + "

    This is the first paragraph

    \n

    this is the second paragraph

    " + ) + expect_equal( + as.character( + list_to_p( + c( + "This is the first paragraph", + "this is the second paragraph" + ), + class = "my_li" + ) + ), + '

    This is the first paragraph

    \n

    this is the second paragraph

    ' + ) +}) + +test_that("Test named_to_li works", { + expect_s3_class(named_to_li(list(a = "a", b = "b")), "shiny.tag.list") + expect_equal( + as.character(named_to_li(list(a = "a", b = "b"))), + "
  • a: a
    • \n
  • b: b
    • " + ) + expect_equal( + as.character(named_to_li(list(a = "a", b = "b"), class = "mylist")), + '
  • a: a
    • \n
  • b: b
    • ' + ) +}) + +test_that("Test tagRemoveAttributes works", { + a_with_tag <- shiny::tags$p(src = "plop", "pouet") + expect_s3_class(a_with_tag, "shiny.tag") + expect_equal( + as.character(a_with_tag), + '

    pouet

    ' + ) + + a_without_tag <- tagRemoveAttributes(a_with_tag, "src") + expect_s3_class(a_without_tag, "shiny.tag") + expect_equal( + as.character(a_without_tag), + "

    pouet

    " + ) +}) + +test_that("Test undisplay works", { + a <- shiny::tags$p(src = "plop", "pouet") + expect_s3_class(a, "shiny.tag") + expect_equal( + as.character(a), + '

    pouet

    ' + ) + a_undisplay <- undisplay(a) + expect_s3_class(a_undisplay, "shiny.tag") + expect_equal( + as.character(a_undisplay), + '

    pouet

    ' + ) + + b <- shiny::actionButton("go_filter", "go") + expect_s3_class(b, "shiny.tag") + expect_equal( + as.character(b), + '' + ) + b_undisplay <- undisplay(b) + expect_s3_class(b, "shiny.tag") + expect_equal( + as.character(b_undisplay), + '' + ) +}) + +test_that("Test display works", { + a_undisplay <- shiny::tags$p(src = "plop", "pouet", style = "display: none;") + expect_s3_class(a_undisplay, "shiny.tag") + expect_equal( + as.character(a_undisplay), + '

    pouet

    ' + ) + a_display <- display(a_undisplay) + expect_s3_class(a_display, "shiny.tag") + expect_equal( + as.character(a_display), + '

    pouet

    ' + ) +}) + +test_that("Test jq_hide works", { + expect_s3_class(jq_hide("golem"), "shiny.tag") + expect_equal( + as.character(jq_hide("golem")), + "" + ) +}) + +test_that("Test rep_br works", { + expect_s3_class(rep_br(5), "html") + expect_equal( + as.character(rep_br(5)), + "




    " + ) +}) + +test_that("Test enurl works", { + expect_s3_class(enurl("https://www.thinkr.fr", "ThinkR"), "shiny.tag") + expect_equal( + as.character(enurl("https://www.thinkr.fr", "ThinkR")), + 'ThinkR' + ) +}) + +test_that("Test columns wrappers works", { + expect_s3_class(col_12(), "shiny.tag") + expect_s3_class(col_10(), "shiny.tag") + expect_s3_class(col_8(), "shiny.tag") + expect_s3_class(col_6(), "shiny.tag") + expect_s3_class(col_4(), "shiny.tag") + expect_s3_class(col_3(), "shiny.tag") + expect_s3_class(col_2(), "shiny.tag") + expect_s3_class(col_1(), "shiny.tag") + + expect_equal(as.character(col_12()), '
    ') + expect_equal(as.character(col_10()), '
    ') + expect_equal(as.character(col_8()), '
    ') + expect_equal(as.character(col_6()), '
    ') + expect_equal(as.character(col_4()), '
    ') + expect_equal(as.character(col_3()), '
    ') + expect_equal(as.character(col_2()), '
    ') + expect_equal(as.character(col_1()), '
    ') +}) + +test_that("Test make_action_button works", { + button <- make_action_button( + a(href = "#", "My super link", style = "color: lightblue;"), + inputId = "mylink" + ) + expect_s3_class(button, "shiny.tag") + expect_equal( + as.character(button), + 'My super link' + ) +})