How to create custom questions in learnr?

[dmenne]

Looks like my posts on community.rstudio do not find an audience there, so I repost the question here with a somewhat different title.

I want to use my own Shiny app to let the user make a selection. Creating the Shiny app in the document is no problem, but how do I channel the response and correct/wrong handling into learnr?

Self-contained example highly simplified example see community link above to avoid cross-posting. A more realistic example would be the integration of Mine's ShinyEd apps into learnr.

[dmenne]

I found https://rdrr.io/cran/learnr/man/question_methods.html and the item in the code (quiz_question.Rmd), but could not locate it in the local docs.

There is also a mentioning of learnr::run_tutorial("question_type", "learnr") which does not exist.

[gadenbuie]

I fixed the problem with the incorrect tutorial name in #721. The mentioned documentation should be found in the Custom Question Types section of quiz_question tutorial:

run_tutorial("quiz_question", "learnr")

[dmenne]

Thanks for the fix. Still looking for an example of a Shiny app creating question items. Looks like the tools are there, but using it has a few traps.

[dmenne]

See also #722

[dmenne]

My desperate cry for an example was because of #722 which was a show-stopper even for the most simple home-made apps.

After this has been resolved, Chapter "sortable" in quiz_question.Rmd should give a starter.

[dmenne]

I still have not been able to use a shiny app as input. Below the code, in the end I want that a click near any point should be "correct", but could not get the plot to display.

Superseded code, see next message

````

---

title: "How to use shiny with learnr"
output: learnr::tutorial
runtime: shiny_prerendered

library(learnr)
library(shiny)
library(ggplot2)

mtcars2 <- mtcars[, c("mpg", "wt")]

Topic 1

question_ui_initialize.clickme = function(question, value, ...) {
  plotOutput("plot1", click = "plot1_click")
  verbatimTextOutput("click_info")
}

question_ui_completed.clickme = function(question, ...) {
  actionButton("clicked", "Clicked")  
}

question_is_valid.clickme = function(question, value, ...) {
    TRUE # Not "correct"
}

question_is_correct.clickme = function(question, value, ...) {
    correct("Correct Nice click")
}

.S3method("question_ui_initialize", "clickme")
.S3method("question_ui_completed", "clickme")
.S3method("question_is_valid", "clickme")
.S3method("question_is_correct", "clickme")

question("Click Me", 
         answer("answer", correct = TRUE),
         type = "clickme")

  output$plot1 <- renderPlot({
    ggplot(mtcars2, aes(wt, mpg)) + geom_point(size = 4)
  })
  output$click_info <- renderPrint({
    nearPoints(mtcars2, input$plot1_click, addDist = TRUE)
  })

[dmenne]

Hello, anybody at home? Feeling a bit monologic here.

Here is a version that comes a bit closer. It shows 'Correct/Incorrect' on the first start as expected, but when I do a "Start over", the response is no longer displayed.

---
title: "How to use shiny with learnr"
output: learnr::tutorial
runtime: shiny_prerendered
---

```{r context="setup", include=FALSE}
library(learnr)
library(shiny)
library(ggplot2)
```

## Click close to a point

```{r  clickme, echo=FALSE}
question("Click me", 
         answer("ihaveclicked", correct = TRUE),
         type = "clickme")
```

```{r  context="server"}
  dist = reactiveVal(4711)

  mtcars2 <- mtcars[, c("mpg", "wt")]
  question_ui_initialize.clickme = function(question, value, ...) {
    tagList(
      plotOutput("plot1", click = "plot1_click"),
      verbatimTextOutput("click_info")
    )
  }

  question_is_valid.clickme = function(question, value, ...) {
    isTRUE(dist() < 4)
  }
  
  question_is_correct.clickme = function(question, value, ...) {
    mark_as(isTRUE(dist() < 4))
  }
  
  .S3method("question_ui_initialize", "clickme")
  .S3method("question_is_correct", "clickme")
  .S3method("question_is_valid", "clickme")

  output$plot1 <- renderPlot({
    ggplot(mtcars2, aes(wt, mpg)) + geom_point(size = 4)
  })
  
  output$click_info <- renderPrint({
    r = nearPoints(mtcars2, input$plot1_click, addDist = TRUE)
    dist(r$dist_)
    r    
  })

```


## Do something

```{r radio, echo = FALSE}
question_radio(
  "Is this a good question?",
  answer("yes", correct = TRUE),
  answer("no", message = 'This is a good question.')
)
```

[gadenbuie]

Hi @dmenne

I'm not sure how much I'll be able to help you very much since I'm not intimately familiar with the custom question feature. My best suggestion, after reading the existing documentation, would be to explore other packages that provide custom learnr questions, of which I only know about sortable.

I can kind of get your example working by lining up the input ID of the plot click with the input ID expected by the question methods. In other words, I think that if you use question$ids$answer as the ID of the click on the plot, learnr will automatically use that input as value in the question methods. This helps line everything up and it means that you don't need to maintain a separate reactive value for dist.

Here's what I came up with

---
title: "How to use shiny with learnr"
output: learnr::tutorial
runtime: shiny_prerendered
---

```{r context="setup", include=FALSE}
library(learnr)
library(shiny)
library(ggplot2)
```

## Click close to a point

```{r  clickme, echo=FALSE}
question(
  "Click me",
  answer("ihaveclicked", correct = TRUE),
  type = "clickme",
  try_again = TRUE
)
```

```{r  context="server"}
dist <- function(value) {
  tryCatch(
    nearPoints(mtcars2, value, addDist = TRUE)$dist_,
    error = function(err) Inf
  )
}

mtcars2 <- mtcars[, c("mpg", "wt")]

question_ui_initialize.clickme <- function(question, value, ...) {
  question_id <- question$ids$answer
  tagList(
    plotOutput(paste0(question_id, "_plot"), click = question_id),
    verbatimTextOutput("click_info")
  )
}

question_is_valid.clickme <- function(question, value, ...) {
  message("value is: ", value)
  isTRUE(dist(value) < 4)
}

question_is_correct.clickme <- function(question, value, ...) {
  message("value is: ", value)
  is_correct <- isTRUE(isolate(dist(value)) < 4)
  message("question is ", c("wrong", "correct")[is_correct + 1])
  mark_as(is_correct)
}

.S3method("question_ui_initialize", "clickme")
.S3method("question_is_correct", "clickme")
.S3method("question_is_valid", "clickme")

output$`clickme-answer_plot` <- renderPlot({
  ggplot(mtcars2, aes(wt, mpg)) +
    geom_point(size = 4)
})

output$click_info <- renderPrint({
  req(input[["clickme-answer"]])
  str(input[["clickme-answer"]][c("x", "y")])
})
```


## Do something

```{r radio, echo = FALSE}
question_radio(
  "Is this a good question?",
  answer("yes", correct = TRUE),
  answer("no", message = "This is a good question.")
)
```