#' Get names of available tests
#'
#' Get names of available tests
#'
#' @export
test_names <- function() {
names(available_tests())
}
#' List of available test
#'
#' Return the list of available tests.
#'
#' @keywords internal
available_tests <- function() {
list("review" = test_review,
"choose" = test_choose,
"answer" = test_answer)
}
#' Review a card
#'
#' Review a card by flipping it over until moving to the next test.
#'
#' @param card The index of the card to use
#' @param deck The table containing the deck information.
#' @param progress The progress table for the user
#' @param max_score Each time this test is selected, a distribution between 1
#' and 0 is sampled that simulates a guess at how well the user knows a card.
#' 0 means does not know and 1 means does know. Cards that get a score higher
#' than this option value will not be used for this test and a diffent test
#' will be tried.
#'
#' @keywords internal
test_review <- function(card, deck, progress, max_score = 0.5) {
# Only allow this test for cards that are not well known
is_prog_record <- progress$front_hash == deck$front_hash[card] & progress$back_hash == deck$back_hash[card]
if (sum(is_prog_record) == 0) { # If no matches in progress table
card_score <- sample_learn_dist(0, 0)
} else {
card_score <- sample_learn_dist(progress$right[is_prog_record], progress$wrong[is_prog_record])
}
if (card_score > max_score) {
return(NA)
}
# Flip card until user types "c"
deck_path <- deck$deck_path[card]
front <- deck$front[card]
back <- deck$back[card]
my_print("Press [Enter] to flip card. Press [c] to finish.")
input = ""
count = 0
while (input != "c") {
graphics::plot(plot_card_side(c(front, back)[count %% 2 + 1], deck_path = deck_path))
input <- readline()
count <- count + 1
}
# Return results
data.frame(front = deck$front[card],
back = deck$back[card],
front_hash = deck$front_hash[card],
back_hash = deck$back_hash[card],
right = 0.1,
wrong = 0,
updated = date(),
deck_name = basename(deck_path),
test_name = "review")
}
#' Multiple choice test
#'
#' Display one side of multiple cards and ask which matches the other side of
#' another card shown.
#'
#' @param card The index of the card to use
#' @param deck The table containing the deck information.
#' @param progress The progress table for the user
#' @param max_choices The maximum number of cards to show.
#' @param pick_multiple If \code{TRUE}, allow multiple correct answers
#'
#' @keywords internal
test_choose <- function(card, deck, progress, max_choices = 4, pick_multiple = TRUE) {
# Internal parameters
diff_deck_penalty <- 0.1 # How likly, relative to 1, that a card from a different deck will be chosen as an option
# Pick side and card to test
sides <- c("front", "back")[sample.int(2)]
side_hashes <- paste0(sides, "_hash")
answer_side <- deck[[sides[1]]]
answer_hashes <- deck[[side_hashes[1]]]
option_side <- deck[[sides[2]]]
option_hashes <- deck[[side_hashes[2]]]
answer_card <- answer_side[card]
# Pick some choices
wrong_indexes <- sample.int(nrow(deck),
prob = ifelse(deck$deck_path[card] == deck$deck_path, 1, diff_deck_penalty))
wrong_indexes <- wrong_indexes[! duplicated(option_side[wrong_indexes])]
wrong_indexes <- wrong_indexes[option_side[wrong_indexes] != option_side[card]]
if (length(wrong_indexes) > max_choices - 1) {
wrong_indexes <- wrong_indexes[sample.int(max_choices - 1)]
}
option_indexes <- c(card, wrong_indexes)
option_indexes <- option_indexes[sample.int(length(option_indexes))]
test_cards <- option_side[option_indexes]
# Present test
option_plots <- lapply(option_indexes,
function(i) plot_card_side(option_side[i], deck_path = deck$deck_path[i]))
options <- cowplot::plot_grid(plotlist = option_plots,
scale = 0.9,
labels = seq_along(option_plots),
label_size = 30,
label_colour = "#777777")
answer_plot <- plot_card_side(answer_card, deck_path = deck$deck_path[card])
print(cowplot::plot_grid(answer_plot, options, ncol = 1, rel_heights = c(1, 1.62)))
# Get user input
if (pick_multiple) {
my_print("Enter the numbers that apply to the card on top, separated by commas:")
input = ""
count = 0
while (length(input) == 0 || ! all(input %in% seq_along(test_cards))) {
if (count != 0) {
play_sound("partial.wav")
my_print("Invalid input. Must be one or more numbes between 1 and ", length(test_cards), " separated by commas.")
}
input <- strsplit(readline(), ", *")[[1]]
count <- count + 1
}
} else {
my_print("Enter the number that applies to the card on top:")
input = ""
count = 0
while (length(input) != 1 || ! input %in% seq_along(test_cards)) {
if (count != 0) {
play_sound("partial.wav")
my_print("Invalid input. Must be a number between 1 and ", length(test_cards), ".")
}
input <- readline()
count <- count + 1
}
}
input <- as.numeric(input)
# Score test
answer_indexes <- option_indexes[input]
correct_option_hashes <- option_hashes[answer_hashes == answer_hashes[card]]
output <- lapply(seq_along(option_indexes),
function(i) {
option_index <- option_indexes[i]
if (option_hashes[option_index] %in% correct_option_hashes) { # Correct option
if (option_index %in% answer_indexes) { # Right!
right <- 1
wrong <- 0
} else { # Missing answer
right <- 0
wrong <- 0.5
}
} else {
if (option_index %in% answer_indexes) { # Wrong!
right <- 0
wrong <- 1
} else { # Missing wrong answer
right <- 0.05
wrong <- 0
}
}
return(data.frame(front = deck$front[option_index],
back = deck$back[option_index],
front_hash = deck$front_hash[option_index],
back_hash = deck$back_hash[option_index],
right = right,
wrong = wrong,
updated = date(),
deck_name = basename(deck$deck_path[option_index]),
test_name = "choice"))
})
# Report right answers
is_right <- option_hashes[option_indexes[input]] %in% correct_option_hashes
if (sum(is_right) == 1) {
my_print(input[is_right], " is right!")
} else if (sum(is_right) == 2) {
my_print(paste0(input[is_right], collapse = " and "), " are right!")
} else if (sum(is_right) > 2) {
my_print(paste0(input[is_right], collapse = ", "), " are right!")
}
# Report wrong answers
if (sum(! is_right) == 1) {
my_print(input[! is_right], " is WRONG!")
} else if (sum(! is_right) == 2) {
my_print(paste0(input[! is_right], collapse = " and "), " are WRONG!")
} else if (sum(! is_right) > 2) {
my_print(paste0(input[! is_right], collapse = ", "), " are WRONG!")
}
# Report missing answers
is_missing <- option_hashes[option_indexes] %in% correct_option_hashes & ! seq_along(option_indexes) %in% input
missing_indexes <- seq_along(option_indexes)[is_missing]
if (length(missing_indexes) == 1) {
my_print(missing_indexes, " is a correct answer!")
} else if (length(missing_indexes) == 2) {
my_print(paste0(missing_indexes, collapse = " and "), " are correct answers!")
} else if (length(missing_indexes) > 2) {
my_print(paste0(missing_indexes, collapse = ", "), " are correct answers!")
}
# Play sound
if (all(is_right) && length(missing_indexes) == 0) {
play_sound("correct.wav")
} else if (all(!is_right)) {
play_sound("wrong.wav")
} else {
play_sound("partial.wav")
}
return(do.call(rbind, output))
}
#' Plot an image
#'
#' Plot an image from a file path
#'
#' @param path The path to the image to plot
#'
#' @keywords internal
plot_image <- function(path) {
if (endsWith(tolower(path), "png")) {
image <- png::readPNG(path)
} else if (endsWith(tolower(path), "jpg") || endsWith(tolower(path), "jpeg")) {
image <- jpeg::readJPEG(path)
} else {
stop(paste0('Not an accepted file format: "', path, '".'))
}
y_max <- dim(image)[1] / dim(image)[2]
ggplot2::ggplot() +
ggplot2::annotation_raster(image, ymin = 0, xmin = 0, xmax = 1, ymax = y_max) +
ggplot2::ylim(0, y_max) +
ggplot2::xlim(0, 1) +
ggplot2::coord_fixed() +
ggplot2::theme_void()
}
#' Plot text
#'
#' Plot text
#'
#' @param text The text to plot
#'
#' @keywords internal
plot_text <- function(text) {
ggplot2::ggplot(data = data.frame(label = text, xmin = 0, xmax = 1, ymin = 0, ymax = 1)) +
ggfittext::geom_fit_text(ggplot2::aes(label = label, xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax), grow = TRUE, reflow = TRUE) +
ggplot2::xlim(0, 1) +
ggplot2::ylim(0, 1) +
ggplot2::theme_void()
}
#' Plot a card
#'
#' Plot a card. If it is a image file path, the contents of file is plotted.
#'
#' @param card The content of the side of a card
#'
#' @keywords internal
plot_card_side <- function(card, deck_path) {
img_path <- file.path(deck_path, "images", card)
if (file.exists(img_path)) {
return(plot_image(img_path))
} else {
return(plot_text(card))
}
}
#' Typing test
#'
#' Display one side of a card and ask which matches the other side of another
#' card shown. The user must type in the other side of the card.
#'
#' @param card The index of the card to use
#' @param deck The table containing the deck information.
#' @param progress The progress table for the user
#' @param max_chars The maximum number of characters the answer side of a card
#' can have.
#' @param max_dist The maximum proportion of differences the answer can be to
#' the correct answer while still being considered correct.
#' @param ignore_case If \code{FALSE}, capitalization needs to be correct.
#'
#' @keywords internal
test_answer <- function(card, deck, progress, max_chars = 20, max_dist = 0.2, ignore_case = TRUE) {
is_image <- function(side_content) {
file.exists(file.path(deck$deck_path[card], "images", side_content))
}
unique_answer <- function(side) {
opposite_hash <- list(front = deck$back_hash, back = deck$front_hash)
other_hash <- opposite_hash[[side]]
sum(other_hash == other_hash[card]) == 1
}
# Get the side(s) of the card that can be used
sides <- c(front = deck$front[card], back = deck$back[card])
answer_options <- sides[! is_image(sides)] # Answer cant be an image
answer_options <- answer_options[nchar(answer_options) <= max_chars] # Answer cannot be too long
answer_options <- answer_options[vapply(names(answer_options), unique_answer, logical(1))] # Answer must be unique
# Check that one of the sides can be used
if (length(answer_options) == 0) {
return(NA)
}
# Pick a side to present
if (length(answer_options) == 2) {
side_order <- c("front", "back")[sample.int(2)]
query <- answer_options[sides[2]]
answer <- answer_options[sides[1]]
} else {
answer <- answer_options[1]
query <- sides[! names(sides) %in% names(answer_options)]
}
# Present card
graphics::plot(plot_card_side(query, deck_path = deck$deck_path[card]))
# Get user input
my_print("Type the other side of the card:")
input = ""
count = 0
while (nchar(input) == 0) {
if (count != 0) {
play_sound("partial.wav")
my_print("Invalid input.\nType the other side of the card:")
}
input <- readline()
count <- count + 1
}
# Score test
answer_dist <- utils::adist(tolower(input), tolower(answer), ignore.case = ignore_case)[1, 1] / max(nchar(c(input, answer)))
if (answer_dist == 0) { # Right!
right <- 2
wrong <- 0
play_sound("correct.wav")
my_print("Perfect!")
} else if (answer_dist <= max_dist) { # Almost right
right <- 2 * (1 - answer_dist)
wrong <- 2 * answer_dist
play_sound("partial.wav")
my_print("Almost right. The correct answer is:\n", answer)
} else { # Wrong!
right <- 0
wrong <- 1
play_sound("wrong.wav")
my_print("Wrong! The correct answer is:\n", answer)
}
result <- data.frame(front = deck$front[card],
back = deck$back[card],
front_hash = deck$front_hash[card],
back_hash = deck$back_hash[card],
right = right,
wrong = wrong,
updated = date(),
deck_name = basename(deck$deck_path[card]),
test_name = "answer")
return(result)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.