From 93f34cf41718d5f1d920979d6a93d89ef0a5a136 Mon Sep 17 00:00:00 2001 From: Michael Enion Date: Wed, 8 Jul 2020 15:59:21 +0000 Subject: [PATCH 01/10] Work in progress. Basic framework for dealing with multiple repetitions. Use a list of tables, one for each dice set, to store rolls and related information. Can be broken down into three parts: 1. Initial rolls. e.g., 3d6. 2. Modifications. e.g. exploding or keep highest. 3. Successes. Use an S3 class for the list of tables structure, storing other relevant information, like the command, in attributes. R6 might be better for this (particularly for the re-rolling of tables), but then we have to deal with the fact that R6 modifies in place, which is a bit counterintuitive for general R users. Successes could be pulled out as a method, but that would break the use of command as the primary way to set up the dice rolling parameters. --- R/evaluate_roll_cmd.R | 43 +++++ R/roll_dice.R | 27 +-- R/roll_one.R | 414 +++++++++++++++++++++++++++++++----------- R/rolltable_class.R | 117 ++++++++++++ 4 files changed, 487 insertions(+), 114 deletions(-) create mode 100644 R/rolltable_class.R diff --git a/R/evaluate_roll_cmd.R b/R/evaluate_roll_cmd.R index 663e1ab..e5839ed 100644 --- a/R/evaluate_roll_cmd.R +++ b/R/evaluate_roll_cmd.R @@ -21,3 +21,46 @@ evaluate_roll_cmd <- function(parsed_cmd){ return(final_result) } + + + + + +roll_set <- function(parsed_cmd, repetitions) { + dice_tbls <- lapply(parsed_cmd$dices, construct_dice_table) + + calculated_dice_tbls <- lapply(dice_tbls, function(tbl, n) { do.call(rbind, replicate(n, calculate_dice_table(tbl), simplify = FALSE)) }, + n = repetitions) + names(calculated_dice_tbls) <- parsed_cmd$dices + + result <- parse_result(calculated_dice_tbls, operators = parsed_cmd$operators) + + return(list(calculated_dice_tbls = calculated_dice_tbls, + operators = parsed_cmd$operators, + result = result)) +} + +parse_result <- function(calculated_dice_tbls, operators = NULL, .summary_fn = identity) { + # result is a list one longer than operators + # Each result element is a table with 1 or more rows for a single set of dice rolls + # first choose either the calculated roll or success if available, and sum + out <- sapply(calculated_dice_tbls, function(tbl) { + out <- tbl$Calculated.Roll + out[!is.na(tbl$Success.Outcome)] <- tbl$Success.Outcome + return(sapply(out, sum, na.rm = TRUE)) + }) + + out <- apply(out, 2, .summary_fn) + if(is.null(dim(out))) dim(out) <- c(1, length(out)) + + if(!is.null(operators)) { + # now apply the operators to each + text <- paste(out[,1]) + for(i in 2:length(result)) { + text <- paste(text, operators[i-1], out[, i]) + } + out <- sapply(text, function(txt) { eval(parse(text = txt)) } ) + } + return(out) +} + diff --git a/R/roll_dice.R b/R/roll_dice.R index d95bc7e..5656b16 100644 --- a/R/roll_dice.R +++ b/R/roll_dice.R @@ -15,24 +15,25 @@ #' roll_dice("1d4 * 2") #' roll_dice("2d20h1") #' -roll_dice <- function(cmd, roll_history=FALSE) { - if (roll_history) { - message(paste0('Evaluating "', cmd,'" \n', - '==========')) +roll_dice <- function(cmd, roll_history=FALSE, repetitions = 1, verbose = FALSE) { + if(length(cmd) > 1) { + out <- lapply(cmd, roll_dice, roll_history = roll_history, repetitions = repetitions) + names(out) <- cmd + return(out) } - parsed_cmd <- parse_roll_cmd(cmd) - if (roll_history) { - result <- evaluate_roll_cmd(parsed_cmd) - } else { - result <- suppressMessages(evaluate_roll_cmd(parsed_cmd)) + tbl <- rolltable(cmd, repetitions = repetitions, verbose = verbose) + result <- calculate(tbl) + + if(verbose) { + message(paste('==========\n', + "Result is", result)) } - if (roll_history) { - message(paste('==========\n', - "Result is", result)) + if(roll_history) { + return(list(result = result, + roll_history = tbl)) } return(result) - } diff --git a/R/roll_one.R b/R/roll_one.R index cec679b..da2f755 100644 --- a/R/roll_one.R +++ b/R/roll_one.R @@ -17,107 +17,319 @@ roll_one <- function(roll){ warning("This roll command is not recognized") } +# die <- tolower(c("1d6", "10d6", "20d20", "10", "2d20h1", "3d10h2", "2d20l1", "1d20r1", "3d6!", "2d6>=5", "4d6=5", "4dF", "1d10!>9", "3d10!>=8", "1d10t10")) -no_dice = list(pattern = "^\\d+$", - compute = function(match) { - result = match[1] - return(result) + + +calculate_dice_table <- function(dice_tbl) { + dice_tbl <- roll_base_dice(dice_tbl) + dice_tbl <- calculate_types(dice_tbl) + dice_tbl <- calculate_successes(dice_tbl) + return(dice_tbl) +} + + +roll_base_dice <- function(dice_tbl) { + dice_tbl$Base.Roll <- NA + no_dice <- is.na(dice_tbl$N.Dice) + fate_dice <- dice_tbl$Sides == "f" & !no_dice + simple_dice <- !no_dice & !fate_dice + + if(any(no_dice)) dice_tbl$Base.Roll[no_dice] <- as.integer(dice_tbl$Dice.String[no_dice]) + if(any(simple_dice)) + dice_tbl$Base.Roll[simple_dice] <- mapply(sample.int, + n = as.integer(dice_tbl$Sides[simple_dice]), + size = as.integer(dice_tbl$N.Dice[simple_dice]), + replace = TRUE, + SIMPLIFY = FALSE) + if(any(fate_dice)) + dice_tbl$Base.Roll[fate_dice] <- mapply(sample, + size = as.integer(dice_tbl$N.Dice[fate_dice]), + replace = TRUE, + SIMPLIFY = FALSE, + MoreArgs = list(x = c(-1, 0, 1))) + + + + # message(sprintf("rolls: \n%s", + # sprintf("\t%001d") + # ) + # + # 'rolls: ', + # + # paste(rolls, collapse = ', ')) + + return(dice_tbl) +} + +calculate_types <- function(dice_tbl) { + dice_tbl$Calculated.Roll <- NA + + type.lst <- c(dice_modification_types, list(simple = simple, none = none)) + for(type in dice_tbl$Type) { + type_idx <- dice_tbl$Type == type + + if(any(type_idx)) { + calculation_fn <- type.lst[[type]]$calculate + dice_tbl$Calculated.Roll[type_idx] <- mapply(calculation_fn, + base_roll = dice_tbl$Base.Roll[type_idx], + match = dice_tbl$Type.Match[type_idx], + sides = dice_tbl$Sides[type_idx], + SIMPLIFY = FALSE) + } + } + return(dice_tbl) +} + +calculate_successes <- function(dice_tbl) { + dice_tbl$Success.Outcome <- NA + type.lst <- c(dice_modification_types, list(simple = simple, none = none)) + + for(success_type in success_types) { + type_idx <- dice_tbl$Success == success_type$name & !is.na(dice_tbl$Success) + + if(any(type_idx)) { + calculation_fn <- success_type$calculate + dice_tbl$Success.Outcome[type_idx] <- mapply(calculation_fn, + base_roll = dice_tbl$Calculated.Roll[type_idx], + match = dice_tbl$Success.Match[type_idx], + SIMPLIFY = FALSE) + } + } + return(dice_tbl) +} + +detect_dice <- function(die) { + pattern = SIMPLE_DIE_PATTERN + res <- stringr::str_match(die, pattern) + if(anyNA(res[,1])) stop("Dice pattern not recognized.") + + res <- as.data.frame(res, stringsAsFactors = FALSE) + colnames(res) <- c("Dice.String", "N.Dice", "Sides") + return(res) +} + + +detect_dice_type <- function(die) { + res <- data.frame(Die = die, stringsAsFactors = FALSE) + res$Type <- NA + res$Type.Match <- NA + + for(r in dice_modification_types) { + idx <- stringr::str_detect(die, pattern = r$pattern) + if(any(idx)) { + res$Type[idx] <- r$name + + # match, but lose the initial repetion of the full pattern + match_fn <- function(string, pattern) { + stringr::str_match(string = string, pattern = pattern)[, -1] + } + res$Type.Match[idx] <- mapply(match_fn, string = die[idx], pattern = r$pattern, SIMPLIFY = FALSE) + } + } + + # rest should be simple or none + idx <- stringr::str_detect(res$Die[is.na(res$Type)], simple$pattern) + res$Type[is.na(res$Type)][idx] <- simple$name + + idx <- stringr::str_detect(res$Die[is.na(res$Type)], none$pattern) + res$Type[is.na(res$Type)][idx] <- none$name + + stopifnot(!anyNA(res$Type)) + return(res[, -1, drop = FALSE]) +} + +detect_success_test <- function(die) { + res <- data.frame(Die = die, stringsAsFactors = FALSE) + res$Success <- NA + res$Success.Match <- NA + + for(s in success_types) { + idx <- stringr::str_detect(die, s$pattern) + if(any(idx)) { + res$Success[idx] <- s$name + match_fn <- function(string, pattern) { + stringr::str_match(string = string, pattern = pattern)[, -1] + } + + res$Success.Match[idx] <- mapply(match_fn, string = die[idx], pattern = s$pattern, SIMPLIFY = FALSE) + } + } + + return(res[, -1, drop = FALSE]) +} + +none <- list(name = "none", + pattern = "^\\d+$", + calculate = function(base_roll, ...) { base_roll } ) + +simple <- list(name = "simple", + pattern = "^(\\d+)d(\\d+|f)", + calculate = function(base_roll, ...) { base_roll } ) + +SIMPLE_DIE_PATTERN <- paste(simple$pattern, none$pattern, sep = "|") + +# don't use $ to close the pattern as the pattern may also contain success test +# dots in the calculate argument permit additional arguments to be passed to some of the functions; otherwise ignored. +keep_h <- list(name = "keep highest", + pattern = "^\\d+d\\d+h(\\d+)", + calculate = function(base_roll, match, ...) { sort(base_roll, decreasing = TRUE)[1:as.integer(match)] }) + +keep_l <- list(name = "keep lowest", + pattern = "^\\d+d\\d+l(\\d+)", + calculate = function(base_roll, match, ...) { sort(base_roll, decreasing = FALSE)[1:as.integer(match)] }) + +reroll <- list(name = "reroll", + pattern = "^\\d+d\\d+r(\\d+)", + calculate = function(base_roll, match, sides, ...) { + sides <- as.integer(sides) + match <- as.integer(match) + idx <- base_roll == match + if(any(idx)) { + base_roll[idx] <- sample.int(sides, size = sum(idx), replace = TRUE) + } + return(base_roll) + }) + +double <- list(name = "double", + pattern = "^\\d+d\\d+t(\\d+)", + calculate = function(base_roll, match, ...) { + match <- as.integer(match) + idx <- base_roll == match + if(any(idx)) { + base_roll <- c(base_roll, rep.int(match, times = sum(idx))) + } + return(base_roll) }) -simple = list(pattern = "^(\\d+)[dD](\\d+)$", - compute = function(match) { - n = match[2] - sides = match[3] - rolls = sample(1:sides, n, replace = TRUE) - message('rolls: ', paste(rolls, collapse = ', ')) - result = sum(rolls) - }) - -keep_h = list(pattern = "^(\\d+)[dD](\\d+)[Hh](\\d+)$", - compute = function(match) { - n = match[2] - sides = match[3] - kept = match[4] - rolls = sample(1:sides, n, replace = TRUE) - message('rolls: ', paste(rolls, collapse = ', ')) - kept_dice = sort(rolls, decreasing = T)[1:as.numeric(kept)] - message('keeping ',kept, " highest(s): ", paste(kept_dice, collapse = ', ')) - result = sum(kept_dice) - }) - -keep_l = list(pattern = "^(\\d+)[dD](\\d+)[Ll](\\d+)$", - compute = function(match) { - n = match[2] - sides = match[3] - kept = match[4] - rolls = sample(1:sides, n, replace = TRUE) - message('rolls: ', paste(rolls, collapse = ', ')) - kept_dice = sort(rolls)[1:as.numeric(kept)] - message('keeping ',kept, " lowest(s): ", paste(kept_dice, collapse = ', ')) - result = sum(kept_dice) - }) - -exploding = list(pattern ="^(\\d+)[dD](\\d+)\\!$", - compute = function(match) { - n = match[2] - sides = match[3] - rolls = sample(1:sides, n, replace = TRUE) - explode = rolls[rolls == sides] - message('rolls: ', paste(rolls, collapse = ', ')) - message("exploding ", length(explode),' dice...') - while (length(explode) != 0) { - new_rolls = sample(1:sides, length(explode), replace = TRUE) - message('new rolls : ', paste(new_rolls, collapse = ', ')) - rolls = c(rolls, new_rolls) - explode = new_rolls[new_rolls==sides] - if (length(explode) != 0) { message("exploding ", length(explode),' dice...') } - } - result = sum(rolls) - }) - -reroll = list(pattern = "^(\\d+)[dD](\\d+)[rR](\\d+)$", - compute = function(match) { - n = match[2] - sides = match[3] - to_reroll = match[4] - rolls = sample(1:sides, n, replace = TRUE) - message('rolls: ', paste(rolls, collapse = ', ')) - reroll = rolls[rolls == to_reroll] - message("rerolling ",length(reroll),' dice') - while (length(reroll) != 0) { - new_rolls = sample(1:sides, length(reroll), replace = TRUE) - message('new rolls : ', paste(new_rolls, collapse = ', ')) - rolls[rolls == to_reroll] = new_rolls - reroll = rolls[rolls == to_reroll] - if (length(reroll) != 0) { message("rerolling ",length(reroll),' dice')} - } - result = sum(rolls) - }) - -success = list(pattern = "^(\\d+)[dD](\\d+) ?([<>]?=?) ?(\\d+)$", - compute = function(match) { - n = match[2] - sides = match[3] - comparator = match[4] - if (comparator == "=") {comparator="=="} - threshold = match[5] - rolls = sample(1:sides, n, replace = TRUE) - message('rolls: ', paste(rolls, collapse = ', ')) - success = eval(parse(text = paste("rolls[rolls",comparator,"threshold]"))) - result = length(success) - message('number of success: ', - result , - ' (', paste(sort(success,decreasing = TRUE), collapse = ', '),')') - return(result) - }) - -roll_types = list( - no_dice, - simple, - keep_h, - keep_l, - exploding, - reroll, - success, - reroll -) +exploding <- list(name = "exploding", + pattern = "^\\d+[dD]\\d+\\!(?:[>](\\d+))?", + calculate = function(base_roll, match, sides, ...) { + match <- as.integer(match) + sides <- as.integer(sides) + explode_test <- ifelse(is.na(match), sides, match:sides) + num_exploded <- sum(base_roll %in% explode_test) + while(num_exploded > 0) { + new_roll <- sample.int(sides, size = num_exploded, replace = TRUE) + num_exploded <- sum(new_roll %in% explode_test) + base_roll <- c(base_roll, new_roll) + } + return(base_roll) + }) + +dice_modification_types <- list(keep_h, keep_l, reroll, double, exploding) +names(dice_modification_types) <- sapply(dice_modification_types, function(x) x$name) + + +ge_success <- list(name = "success ge", + pattern = "[>][=](\\d+)$", + calculate = function(base_roll, match, ...) { sum(base_roll >= as.integer(match)) }) +equal_success <- list(name = "success equal", + pattern = "[^>][=](\\d+)$", + calculate = function(base_roll, match, ...) { sum(base_roll == as.integer(match)) }) +success_types <- list(ge_success, equal_success) +names(success_types) <- sapply(success_types, function(x) x$name) + +# no_dice = list(pattern = "^\\d+$", +# compute = function(match) { +# result = match[1] +# return(result) +# }) +# +# simple = list(pattern = "^(\\d+)[dD](\\d+)$", +# compute = function(match) { +# n = match[2] +# sides = match[3] +# rolls = sample(1:sides, n, replace = TRUE) +# message('rolls: ', paste(rolls, collapse = ', ')) +# result = sum(rolls) +# }) +# +# keep_h = list(pattern = "^(\\d+)[dD](\\d+)[Hh](\\d+)$", +# compute = function(match) { +# n = match[2] +# sides = match[3] +# kept = match[4] +# rolls = sample(1:sides, n, replace = TRUE) +# message('rolls: ', paste(rolls, collapse = ', ')) +# kept_dice = sort(rolls, decreasing = T)[1:as.numeric(kept)] +# message('keeping ',kept, " highest(s): ", paste(kept_dice, collapse = ', ')) +# result = sum(kept_dice) +# }) +# +# keep_l = list(pattern = "^(\\d+)[dD](\\d+)[Ll](\\d+)$", +# compute = function(match) { +# n = match[2] +# sides = match[3] +# kept = match[4] +# rolls = sample(1:sides, n, replace = TRUE) +# message('rolls: ', paste(rolls, collapse = ', ')) +# kept_dice = sort(rolls)[1:as.numeric(kept)] +# message('keeping ',kept, " lowest(s): ", paste(kept_dice, collapse = ', ')) +# result = sum(kept_dice) +# }) +# +# exploding = list(pattern ="^(\\d+)[dD](\\d+)\\!$", +# compute = function(match) { +# n = match[2] +# sides = match[3] +# rolls = sample(1:sides, n, replace = TRUE) +# explode = rolls[rolls == sides] +# message('rolls: ', paste(rolls, collapse = ', ')) +# message("exploding ", length(explode),' dice...') +# while (length(explode) != 0) { +# new_rolls = sample(1:sides, length(explode), replace = TRUE) +# message('new rolls : ', paste(new_rolls, collapse = ', ')) +# rolls = c(rolls, new_rolls) +# explode = new_rolls[new_rolls==sides] +# if (length(explode) != 0) { message("exploding ", length(explode),' dice...') } +# } +# result = sum(rolls) +# }) +# +# reroll = list(pattern = "^(\\d+)[dD](\\d+)[rR](\\d+)$", +# compute = function(match) { +# n = match[2] +# sides = match[3] +# to_reroll = match[4] +# rolls = sample(1:sides, n, replace = TRUE) +# message('rolls: ', paste(rolls, collapse = ', ')) +# reroll = rolls[rolls == to_reroll] +# message("rerolling ",length(reroll),' dice') +# while (length(reroll) != 0) { +# new_rolls = sample(1:sides, length(reroll), replace = TRUE) +# message('new rolls : ', paste(new_rolls, collapse = ', ')) +# rolls[rolls == to_reroll] = new_rolls +# reroll = rolls[rolls == to_reroll] +# if (length(reroll) != 0) { message("rerolling ",length(reroll),' dice')} +# } +# result = sum(rolls) +# }) +# +# success = list(pattern = "^(\\d+)[dD](\\d+) ?([<>]?=?) ?(\\d+)$", +# compute = function(match) { +# n = match[2] +# sides = match[3] +# comparator = match[4] +# if (comparator == "=") {comparator="=="} +# threshold = match[5] +# rolls = sample(1:sides, n, replace = TRUE) +# message('rolls: ', paste(rolls, collapse = ', ')) +# success = eval(parse(text = paste("rolls[rolls",comparator,"threshold]"))) +# result = length(success) +# message('number of success: ', +# result , +# ' (', paste(sort(success,decreasing = TRUE), collapse = ', '),')') +# return(result) +# }) +# +# roll_types = list( +# no_dice = no_dice, +# simple = simple, +# keep_h = keep_h, +# keep_l = keep_l, +# exploding = exploding, +# reroll = reroll, +# success = success, +# reroll = reroll +# ) diff --git a/R/rolltable_class.R b/R/rolltable_class.R new file mode 100644 index 0000000..a18d782 --- /dev/null +++ b/R/rolltable_class.R @@ -0,0 +1,117 @@ +#' Rolltable class +#' +#' Class used to store multiple dice rolls for a roll command. +#' This function is the main helper, which sets up a new rolltable. +#' +#' @param cmd character string describing the dice roll to compute. +#' @param repetitions Number of times to roll the command. +#' @param verbose If TRUE, dice rolls details are visible in the console. +#' @export +rolltable <- function(cmd, repetitions = 1, verbose = FALSE) { + cmd <- tolower(cmd) # avoid needing to check for a bunch of capital letters + parsed_cmd <- rollr:::parse_roll_cmd(cmd) + dice_tbls <- lapply(parsed_cmd$dices, construct_dice_table) + tbl <- new_rolltable(lst = dice_tbls, + cmd = cmd, + dices = parsed_cmd$dices, + operators = parsed_cmd$operators) + roll(tbl, repetitions = repetitions, verbose = verbose) +} + +#' Constructor for rolltable +#' +#' Internal function to build the rolltable class structure. +#' Minimal checks for validity. +new_rolltable <- function(lst, cmd, dices, operators) { + stopifnot(is.list(lst)) + stopifnot(is.character(cmd), + length(cmd) == 1) + stopifnot(is.character(dices), + length(dices) == length(lst)) + stopifnot(is.character(operators), + length(operators) == (length(dices) - 1)) + + names(lst) <- dices + structure( + .Data = lst, + command = cmd, + dices = dices, + operators = operators, + class = "rolltable" + ) +} + +#' Method to roll one or more iterations of dice. +#' +#' Takes a rolltable and rolls to create a new set of results. +#' +#' @param tbl A rolltable class. +#' @param repetitions Number of times to roll the command. +#' @param verbose If TRUE, dice roll details are visible in the console. +#' @return An updated rolltable. +#' @export +roll <- function(tbl, ...) { UseMethod("roll") } +roll.rolltable <- function(tbl, repetitions = 1, verbose = FALSE) { + fn <- ifelse(verbose, lapply, function(...) suppressMessages(lapply(...))) + rollhist <- fn(tbl, function(tbl, n) { do.call(rbind, replicate(n, calculate_dice_table(tbl), simplify = FALSE)) }, + n = repetitions) + + # lapply strips class, so add back. + new_rolltable(rollhist, cmd = attr(tbl, "command"), dices = attr(tbl, "dices"), operators = attr(tbl, "operators")) +} + +#' Method to calculate the current value of a rolltable +#' +#' For each repetition in the rolltable, summarizes each dice set and +#' applies the operators in turn. +#' +#' @param tbl A rolltable class. +#' @param .summary_fn Function used to summarize results between repetitions. Default returns each repetition separately. +#' @return A numeric vector whose names are the individual sums for each dice set. +#' @export +calculate <- function(tbl, ...) { UseMethod("calculate") } +calculate.rolltable <- function(tbl, .summary_fn = "identity") { + out <- parse_result(tbl, operators = attr(tbl, "operators"), .summary_fn = get(.summary_fn)) + attr(out, "command") <- attr(tbl, "command") + attr(out, "parse_function") <- .summary_fn + out +} + +#' Determines the average over repetitions for the rolls. +#' Calculates the total by applying the operators to each average. +#' +#' @param tbl A rolltable class. +#' @return A numeric vector whose names are the individual means for each dice set. +mean.rolltable <- function(x) { + calculate(x, .summary_fn = "mean") +} + +#' Determines the median over repetitions for the rolls. +#' Calculates the total by applying the operators to each median value. +#' +#' @param tbl A rolltable class. +#' @return A numeric vector whose names are the individual means for each dice set. +median.rolltable <- function(x, na.rm = FALSE) { + calculate(x, .summary_fn = "median") +} + + + +#' Determines the minimum over repetitions for the rolls. +#' Calculates the total by applying the operators to each minimum. +#' +#' @param tbl A rolltable class. +#' @return A numeric vector whose names are the individual minimums for each dice set. +min.rolltable <- function(tbl, ..., na.rm = FALSE) { + calculate(tbl, .summary_fn = "min") +} + +#' Determines the maximum over repetitions for the rolls. +#' Calculates the total by applying the operators to each maximum. +#' +#' @param tbl A rolltable class. +#' @return A numeric vector whose names are the individual maximums for each dice set. +max.rolltable <- function(tbl, ..., na.rm = FALSE) { + calculate(tbl, .summary_fn = "max") +} + From 8285ffc6cc91693800bb50d4aa70f78602176376 Mon Sep 17 00:00:00 2001 From: Michael Enion Date: Wed, 8 Jul 2020 19:19:41 +0000 Subject: [PATCH 02/10] Create printing for rolltable class. --- R/roll_one.R | 1 + R/rolltable_class.R | 53 +++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 54 insertions(+) diff --git a/R/roll_one.R b/R/roll_one.R index da2f755..cc58a6d 100644 --- a/R/roll_one.R +++ b/R/roll_one.R @@ -159,6 +159,7 @@ detect_success_test <- function(die) { return(res[, -1, drop = FALSE]) } +# These should all probably be classes, or a single class with various values... none <- list(name = "none", pattern = "^\\d+$", calculate = function(base_roll, ...) { base_roll } ) diff --git a/R/rolltable_class.R b/R/rolltable_class.R index a18d782..f7ceb54 100644 --- a/R/rolltable_class.R +++ b/R/rolltable_class.R @@ -115,3 +115,56 @@ max.rolltable <- function(tbl, ..., na.rm = FALSE) { calculate(tbl, .summary_fn = "max") } +#' Print a rolltable +#' +#' @param tbl A rolltable class. +#' @param n Number of repetitions to print. +#' @param rolls If TRUE, print the base rolls and modifications to rolls, such as keep highest or exploding. +#' @param digits Round numbers to this number of digits when printing. +print.rolltable <- function(tbl, n = 10, rolls = FALSE, digits = 2, ...) { + res <- mean(tbl) + repetitions <- nrow(tbl[[1]]) + + cat(attr(tbl, "command"), "\n") + cat("======\n") + cat(sprintf("Number of repetitions: %d\n", repetitions)) + + if(rolls) { + # basic format: + # ---------- + # 1. 1d6 rolls: 3 + # 1. 2d10h1 rolls: 10, 4 + # 1. Keep Highest: 10, 4 + # 1. 8d6! rolls: 5, 2, 4, 5, 3, 1, 3, 4 + # 1. Exploding: 5, 2, 4, 5, 3, 1, 3, 4 + # ---------- + + total_i <- min(repetitions, n) + iteration_s <- paste0("%0", ceiling(total_i / 10), "d") + for(i in seq_len(total_i)) { + cat("----------\n") + i_str <- sprintf(iteration_s, i) + for(d in seq_len(length(tbl))) { + + cat(sprintf("%s. %s base rolls: %s\n", i_str, names(tbl)[[d]], paste(tbl[[d]]$Base.Roll[[i]], collapse = ", "))) + + if(tbl[[d]]$Type[[i]] != "none" & tbl[[d]]$Type[[i]] != "simple") { + cat(sprintf("%s. %s: %s\n", i_str, stringr::str_to_title(tbl[[d]]$Type[[i]]), paste(tbl[[d]]$Base.Roll[[i]], collapse = ", "))) + } + } + } + if(total_i < repetitions) cat("...\n") + + } + + cat("======\n") + s <- paste0("Mean result: %s = %.", digits, "f\n") + cat(sprintf(s, trim_numeric_string(names(res), digits), res)) + + +} + +trim_numeric_string <- function(str, digits = 2) { + p <- sprintf("([[:digit:]]+[.])([[:digit:]]{%d})[[:digit:]]+", digits) + stringr::str_replace_all(str, pattern = p, replacement = "\\1\\2") +} From 96df75caea8166c0725116165f216d05c47b0078 Mon Sep 17 00:00:00 2001 From: Michael Enion Date: Wed, 8 Jul 2020 21:42:29 +0000 Subject: [PATCH 03/10] Improve printing and add verbose messaging option. --- NAMESPACE | 8 +++ R/evaluate_roll_cmd.R | 14 +++-- R/roll_dice.R | 9 ++- R/roll_one.R | 116 +++++++++++++++++++++++-------------- R/rolltable_class.R | 15 +++-- man/calculate.Rd | 20 +++++++ man/max.rolltable.Rd | 19 ++++++ man/mean.rolltable.Rd | 19 ++++++ man/median.rolltable.Rd | 19 ++++++ man/min.rolltable.Rd | 19 ++++++ man/new_rolltable.Rd | 12 ++++ man/print.rolltable.Rd | 20 +++++++ man/roll.Rd | 21 +++++++ man/roll_dice.Rd | 2 +- man/rolltable.Rd | 19 ++++++ man/trim_numeric_string.Rd | 11 ++++ rollr.Rproj | 1 + 17 files changed, 288 insertions(+), 56 deletions(-) create mode 100644 man/calculate.Rd create mode 100644 man/max.rolltable.Rd create mode 100644 man/mean.rolltable.Rd create mode 100644 man/median.rolltable.Rd create mode 100644 man/min.rolltable.Rd create mode 100644 man/new_rolltable.Rd create mode 100644 man/print.rolltable.Rd create mode 100644 man/roll.Rd create mode 100644 man/rolltable.Rd create mode 100644 man/trim_numeric_string.Rd diff --git a/NAMESPACE b/NAMESPACE index e0457cf..af0e428 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,3 +1,11 @@ # Generated by roxygen2: do not edit by hand +S3method(max,rolltable) +S3method(mean,rolltable) +S3method(median,rolltable) +S3method(min,rolltable) +S3method(print,rolltable) +export(calculate) +export(roll) export(roll_dice) +export(rolltable) diff --git a/R/evaluate_roll_cmd.R b/R/evaluate_roll_cmd.R index e5839ed..f2c8e21 100644 --- a/R/evaluate_roll_cmd.R +++ b/R/evaluate_roll_cmd.R @@ -40,23 +40,27 @@ roll_set <- function(parsed_cmd, repetitions) { result = result)) } -parse_result <- function(calculated_dice_tbls, operators = NULL, .summary_fn = identity) { +parse_result <- function(calculated_dice_tbls, operators = character(0), .summary_fn = identity) { # result is a list one longer than operators # Each result element is a table with 1 or more rows for a single set of dice rolls # first choose either the calculated roll or success if available, and sum out <- sapply(calculated_dice_tbls, function(tbl) { out <- tbl$Calculated.Roll - out[!is.na(tbl$Success.Outcome)] <- tbl$Success.Outcome + + idx <- sapply(calculated_dice_tbls$Success.Outcome, is.null) + out[!idx] <- tbl$Success.Outcome[!idx] return(sapply(out, sum, na.rm = TRUE)) }) - out <- apply(out, 2, .summary_fn) if(is.null(dim(out))) dim(out) <- c(1, length(out)) + out <- apply(out, 2, .summary_fn) + - if(!is.null(operators)) { + if(length(operators) > 0) { + if(is.null(dim(out))) dim(out) <- c(1, length(out)) # now apply the operators to each text <- paste(out[,1]) - for(i in 2:length(result)) { + for(i in 2:ncol(out)) { text <- paste(text, operators[i-1], out[, i]) } out <- sapply(text, function(txt) { eval(parse(text = txt)) } ) diff --git a/R/roll_dice.R b/R/roll_dice.R index 5656b16..a4a498f 100644 --- a/R/roll_dice.R +++ b/R/roll_dice.R @@ -26,8 +26,13 @@ roll_dice <- function(cmd, roll_history=FALSE, repetitions = 1, verbose = FALSE) result <- calculate(tbl) if(verbose) { - message(paste('==========\n', - "Result is", result)) + message('==========') + iteration_s <- paste0("%0", ceiling(length(result) / 10), "d") + for(i in seq_along(result)) { + i_str <- sprintf(iteration_s, i) + message(sprintf("%s. Result is %d", i_str, result[[i]])) + } + } if(roll_history) { diff --git a/R/roll_one.R b/R/roll_one.R index cc58a6d..1e530ae 100644 --- a/R/roll_one.R +++ b/R/roll_one.R @@ -19,9 +19,14 @@ roll_one <- function(roll){ # die <- tolower(c("1d6", "10d6", "20d20", "10", "2d20h1", "3d10h2", "2d20l1", "1d20r1", "3d6!", "2d6>=5", "4d6=5", "4dF", "1d10!>9", "3d10!>=8", "1d10t10")) +construct_dice_table <- function(die) { + cbind(Die = die, + detect_dice(die), + detect_dice_type(die), + detect_success_test(die)) +} - -calculate_dice_table <- function(dice_tbl) { +calculate_dice_table <- function(dice_tbl, verbose = FALSE) { dice_tbl <- roll_base_dice(dice_tbl) dice_tbl <- calculate_types(dice_tbl) dice_tbl <- calculate_successes(dice_tbl) @@ -49,51 +54,46 @@ roll_base_dice <- function(dice_tbl) { SIMPLIFY = FALSE, MoreArgs = list(x = c(-1, 0, 1))) - - - # message(sprintf("rolls: \n%s", - # sprintf("\t%001d") - # ) - # - # 'rolls: ', - # - # paste(rolls, collapse = ', ')) + iteration_s <- paste0("%0", ceiling(nrow(dice_tbl) / 10), "d") + for(i in seq_len(nrow(dice_tbl))) { + i_str <- sprintf(iteration_s, i) + message(sprintf("%s. %s Base roll(s): %s", i_str, dice_tbl$Die[[i]], paste(dice_tbl$Base.Roll[[i]], collapse = ", "))) + } return(dice_tbl) } calculate_types <- function(dice_tbl) { - dice_tbl$Calculated.Roll <- NA - - type.lst <- c(dice_modification_types, list(simple = simple, none = none)) - for(type in dice_tbl$Type) { - type_idx <- dice_tbl$Type == type - - if(any(type_idx)) { - calculation_fn <- type.lst[[type]]$calculate - dice_tbl$Calculated.Roll[type_idx] <- mapply(calculation_fn, - base_roll = dice_tbl$Base.Roll[type_idx], - match = dice_tbl$Type.Match[type_idx], - sides = dice_tbl$Sides[type_idx], - SIMPLIFY = FALSE) + dice_tbl$Calculated.Roll <- vector("list", nrow(dice_tbl)) + + iteration_s <- paste0("%0", ceiling(nrow(dice_tbl) / 10), "d") + for(i in seq_len(nrow(dice_tbl))) { + type <- dice_tbl$Type[[i]] + if(type %in% names(dice_modification_types)) { + i_str <- sprintf(iteration_s, i) + calculation_fn <- dice_modification_types[[type]]$calculate + dice_tbl$Calculated.Roll[[i]] <- calculation_fn(base_roll = dice_tbl$Base.Roll[[i]], + match = dice_tbl$Type.Match[[i]], + sides = dice_tbl$Sides[[i]], + i_str = i_str) } } + return(dice_tbl) } calculate_successes <- function(dice_tbl) { - dice_tbl$Success.Outcome <- NA - type.lst <- c(dice_modification_types, list(simple = simple, none = none)) - - for(success_type in success_types) { - type_idx <- dice_tbl$Success == success_type$name & !is.na(dice_tbl$Success) - - if(any(type_idx)) { - calculation_fn <- success_type$calculate - dice_tbl$Success.Outcome[type_idx] <- mapply(calculation_fn, - base_roll = dice_tbl$Calculated.Roll[type_idx], - match = dice_tbl$Success.Match[type_idx], - SIMPLIFY = FALSE) + dice_tbl$Success.Outcome <- vector("list", nrow(dice_tbl)) + + iteration_s <- paste0("%0", ceiling(nrow(dice_tbl) / 10), "d") + for(i in seq_len(nrow(dice_tbl))) { + type <- dice_tbl$Success[[i]] + if(dice_tbl$Success[[i]] %in% names(success_types) & !is.na(dice_tbl$Success[[i]])) { + i_str <- sprintf(iteration_s, i) + calculation_fn <- success_type[[type]]$calculate + dice_tbl$Calculated.Roll[[i]] <- calculation_fn(base_roll = dice_tbl$Calculated.Roll[[i]], + match = dice_tbl$Success.Match[[i]], + i_str = i_str) } } return(dice_tbl) @@ -174,44 +174,64 @@ SIMPLE_DIE_PATTERN <- paste(simple$pattern, none$pattern, sep = "|") # dots in the calculate argument permit additional arguments to be passed to some of the functions; otherwise ignored. keep_h <- list(name = "keep highest", pattern = "^\\d+d\\d+h(\\d+)", - calculate = function(base_roll, match, ...) { sort(base_roll, decreasing = TRUE)[1:as.integer(match)] }) + calculate = function(base_roll, match, i_str = "1", ...) { + out <- sort(base_roll, decreasing = TRUE)[1:as.integer(match)] + message(i_str, '. keeping ', match, " highest(s): ", paste(out[1:as.integer(match)], collapse = ', ')) + return(out) + }) keep_l <- list(name = "keep lowest", pattern = "^\\d+d\\d+l(\\d+)", - calculate = function(base_roll, match, ...) { sort(base_roll, decreasing = FALSE)[1:as.integer(match)] }) + calculate = function(base_roll, match, i_str = "1", ...) { + out <- sort(base_roll, decreasing = FALSE)[1:as.integer(match)] + message(i_str, '. keeping ', match, " lowest(s): ", paste(out[1:as.integer(match)], collapse = ', ')) + return(out) + }) reroll <- list(name = "reroll", pattern = "^\\d+d\\d+r(\\d+)", - calculate = function(base_roll, match, sides, ...) { + calculate = function(base_roll, match, sides, i_str = "1", ...) { sides <- as.integer(sides) match <- as.integer(match) idx <- base_roll == match if(any(idx)) { base_roll[idx] <- sample.int(sides, size = sum(idx), replace = TRUE) + message(i_str, '. rerolling ', sum(idx), ' dice: ', paste(base_roll[idx], collapse = ', ')) + return(out) + } return(base_roll) }) double <- list(name = "double", pattern = "^\\d+d\\d+t(\\d+)", - calculate = function(base_roll, match, ...) { + calculate = function(base_roll, match, i_str = "1", ...) { match <- as.integer(match) idx <- base_roll == match if(any(idx)) { + message(i_str, '. doubling ', sum(idx), ' dice: ', paste(base_roll[idx], collapse = ', ')) base_roll <- c(base_roll, rep.int(match, times = sum(idx))) + } return(base_roll) }) exploding <- list(name = "exploding", pattern = "^\\d+[dD]\\d+\\!(?:[>](\\d+))?", - calculate = function(base_roll, match, sides, ...) { + calculate = function(base_roll, match, sides, i_str = "1", ...) { match <- as.integer(match) sides <- as.integer(sides) - explode_test <- ifelse(is.na(match), sides, match:sides) + if(is.na(match)) { + explode_test <- sides + } else { + explode_test <- match:sides + } + stopifnot(length(explode_test) < sides) # don't want an infinite loop where every die result explodes + num_exploded <- sum(base_roll %in% explode_test) while(num_exploded > 0) { new_roll <- sample.int(sides, size = num_exploded, replace = TRUE) + message(i_str, ". exploding ", num_exploded, " dice. New roll(s): ", paste(new_roll, collapse = ", ")) num_exploded <- sum(new_roll %in% explode_test) base_roll <- c(base_roll, new_roll) } @@ -224,10 +244,18 @@ names(dice_modification_types) <- sapply(dice_modification_types, function(x) x$ ge_success <- list(name = "success ge", pattern = "[>][=](\\d+)$", - calculate = function(base_roll, match, ...) { sum(base_roll >= as.integer(match)) }) + calculate = function(base_roll, match, i_str = "1", ...) { + out <- sum(base_roll >= as.integer(match)) + message(i_str, ". Number of successes: ", out) + out + }) equal_success <- list(name = "success equal", pattern = "[^>][=](\\d+)$", - calculate = function(base_roll, match, ...) { sum(base_roll == as.integer(match)) }) + calculate = function(base_roll, match, i_str = "1", ...) { + sum(base_roll == as.integer(match)) + message(i_str, ". Number of successes: ", out) + out + }) success_types <- list(ge_success, equal_success) names(success_types) <- sapply(success_types, function(x) x$name) diff --git a/R/rolltable_class.R b/R/rolltable_class.R index f7ceb54..90721e9 100644 --- a/R/rolltable_class.R +++ b/R/rolltable_class.R @@ -52,9 +52,10 @@ new_rolltable <- function(lst, cmd, dices, operators) { #' @export roll <- function(tbl, ...) { UseMethod("roll") } roll.rolltable <- function(tbl, repetitions = 1, verbose = FALSE) { - fn <- ifelse(verbose, lapply, function(...) suppressMessages(lapply(...))) - rollhist <- fn(tbl, function(tbl, n) { do.call(rbind, replicate(n, calculate_dice_table(tbl), simplify = FALSE)) }, - n = repetitions) + lapply_fn <- ifelse(verbose, lapply, function(...) suppressMessages(lapply(...))) + + rollhist <- lapply_fn(tbl, function(df, n) { df[rep(1, times = n), , drop = FALSE] }, n = repetitions) + rollhist <- lapply_fn(rollhist, rollr:::calculate_dice_table) # lapply strips class, so add back. new_rolltable(rollhist, cmd = attr(tbl, "command"), dices = attr(tbl, "dices"), operators = attr(tbl, "operators")) @@ -82,6 +83,7 @@ calculate.rolltable <- function(tbl, .summary_fn = "identity") { #' #' @param tbl A rolltable class. #' @return A numeric vector whose names are the individual means for each dice set. +#' @export mean.rolltable <- function(x) { calculate(x, .summary_fn = "mean") } @@ -91,6 +93,7 @@ mean.rolltable <- function(x) { #' #' @param tbl A rolltable class. #' @return A numeric vector whose names are the individual means for each dice set. +#' @export median.rolltable <- function(x, na.rm = FALSE) { calculate(x, .summary_fn = "median") } @@ -102,6 +105,7 @@ median.rolltable <- function(x, na.rm = FALSE) { #' #' @param tbl A rolltable class. #' @return A numeric vector whose names are the individual minimums for each dice set. +#' @export min.rolltable <- function(tbl, ..., na.rm = FALSE) { calculate(tbl, .summary_fn = "min") } @@ -111,6 +115,7 @@ min.rolltable <- function(tbl, ..., na.rm = FALSE) { #' #' @param tbl A rolltable class. #' @return A numeric vector whose names are the individual maximums for each dice set. +#' @export max.rolltable <- function(tbl, ..., na.rm = FALSE) { calculate(tbl, .summary_fn = "max") } @@ -121,6 +126,7 @@ max.rolltable <- function(tbl, ..., na.rm = FALSE) { #' @param n Number of repetitions to print. #' @param rolls If TRUE, print the base rolls and modifications to rolls, such as keep highest or exploding. #' @param digits Round numbers to this number of digits when printing. +#' @export print.rolltable <- function(tbl, n = 10, rolls = FALSE, digits = 2, ...) { res <- mean(tbl) repetitions <- nrow(tbl[[1]]) @@ -149,7 +155,7 @@ print.rolltable <- function(tbl, n = 10, rolls = FALSE, digits = 2, ...) { cat(sprintf("%s. %s base rolls: %s\n", i_str, names(tbl)[[d]], paste(tbl[[d]]$Base.Roll[[i]], collapse = ", "))) if(tbl[[d]]$Type[[i]] != "none" & tbl[[d]]$Type[[i]] != "simple") { - cat(sprintf("%s. %s: %s\n", i_str, stringr::str_to_title(tbl[[d]]$Type[[i]]), paste(tbl[[d]]$Base.Roll[[i]], collapse = ", "))) + cat(sprintf("%s. %s: %s\n", i_str, stringr::str_to_title(tbl[[d]]$Type[[i]]), paste(tbl[[d]]$Calculated.Roll[[i]], collapse = ", "))) } } } @@ -164,6 +170,7 @@ print.rolltable <- function(tbl, n = 10, rolls = FALSE, digits = 2, ...) { } +#' Helper function to change the number of digits for a string with numerals trim_numeric_string <- function(str, digits = 2) { p <- sprintf("([[:digit:]]+[.])([[:digit:]]{%d})[[:digit:]]+", digits) stringr::str_replace_all(str, pattern = p, replacement = "\\1\\2") diff --git a/man/calculate.Rd b/man/calculate.Rd new file mode 100644 index 0000000..4dfaab6 --- /dev/null +++ b/man/calculate.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rolltable_class.R +\name{calculate} +\alias{calculate} +\title{Method to calculate the current value of a rolltable} +\usage{ +calculate(tbl, ...) +} +\arguments{ +\item{tbl}{A rolltable class.} + +\item{.summary_fn}{Function used to summarize results between repetitions. Default returns each repetition separately.} +} +\value{ +A numeric vector whose names are the individual sums for each dice set. +} +\description{ +For each repetition in the rolltable, summarizes each dice set and +applies the operators in turn. +} diff --git a/man/max.rolltable.Rd b/man/max.rolltable.Rd new file mode 100644 index 0000000..d2fb355 --- /dev/null +++ b/man/max.rolltable.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rolltable_class.R +\name{max.rolltable} +\alias{max.rolltable} +\title{Determines the maximum over repetitions for the rolls. +Calculates the total by applying the operators to each maximum.} +\usage{ +\method{max}{rolltable}(tbl, ..., na.rm = FALSE) +} +\arguments{ +\item{tbl}{A rolltable class.} +} +\value{ +A numeric vector whose names are the individual maximums for each dice set. +} +\description{ +Determines the maximum over repetitions for the rolls. +Calculates the total by applying the operators to each maximum. +} diff --git a/man/mean.rolltable.Rd b/man/mean.rolltable.Rd new file mode 100644 index 0000000..52d3141 --- /dev/null +++ b/man/mean.rolltable.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rolltable_class.R +\name{mean.rolltable} +\alias{mean.rolltable} +\title{Determines the average over repetitions for the rolls. +Calculates the total by applying the operators to each average.} +\usage{ +\method{mean}{rolltable}(x) +} +\arguments{ +\item{tbl}{A rolltable class.} +} +\value{ +A numeric vector whose names are the individual means for each dice set. +} +\description{ +Determines the average over repetitions for the rolls. +Calculates the total by applying the operators to each average. +} diff --git a/man/median.rolltable.Rd b/man/median.rolltable.Rd new file mode 100644 index 0000000..7a781c4 --- /dev/null +++ b/man/median.rolltable.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rolltable_class.R +\name{median.rolltable} +\alias{median.rolltable} +\title{Determines the median over repetitions for the rolls. +Calculates the total by applying the operators to each median value.} +\usage{ +\method{median}{rolltable}(x, na.rm = FALSE) +} +\arguments{ +\item{tbl}{A rolltable class.} +} +\value{ +A numeric vector whose names are the individual means for each dice set. +} +\description{ +Determines the median over repetitions for the rolls. +Calculates the total by applying the operators to each median value. +} diff --git a/man/min.rolltable.Rd b/man/min.rolltable.Rd new file mode 100644 index 0000000..ed9bd81 --- /dev/null +++ b/man/min.rolltable.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rolltable_class.R +\name{min.rolltable} +\alias{min.rolltable} +\title{Determines the minimum over repetitions for the rolls. +Calculates the total by applying the operators to each minimum.} +\usage{ +\method{min}{rolltable}(tbl, ..., na.rm = FALSE) +} +\arguments{ +\item{tbl}{A rolltable class.} +} +\value{ +A numeric vector whose names are the individual minimums for each dice set. +} +\description{ +Determines the minimum over repetitions for the rolls. +Calculates the total by applying the operators to each minimum. +} diff --git a/man/new_rolltable.Rd b/man/new_rolltable.Rd new file mode 100644 index 0000000..ce042c5 --- /dev/null +++ b/man/new_rolltable.Rd @@ -0,0 +1,12 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rolltable_class.R +\name{new_rolltable} +\alias{new_rolltable} +\title{Constructor for rolltable} +\usage{ +new_rolltable(lst, cmd, dices, operators) +} +\description{ +Internal function to build the rolltable class structure. +Minimal checks for validity. +} diff --git a/man/print.rolltable.Rd b/man/print.rolltable.Rd new file mode 100644 index 0000000..e9fc464 --- /dev/null +++ b/man/print.rolltable.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rolltable_class.R +\name{print.rolltable} +\alias{print.rolltable} +\title{Print a rolltable} +\usage{ +\method{print}{rolltable}(tbl, n = 10, rolls = FALSE, digits = 2, ...) +} +\arguments{ +\item{tbl}{A rolltable class.} + +\item{n}{Number of repetitions to print.} + +\item{rolls}{If TRUE, print the base rolls and modifications to rolls, such as keep highest or exploding.} + +\item{digits}{Round numbers to this number of digits when printing.} +} +\description{ +Print a rolltable +} diff --git a/man/roll.Rd b/man/roll.Rd new file mode 100644 index 0000000..a608295 --- /dev/null +++ b/man/roll.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rolltable_class.R +\name{roll} +\alias{roll} +\title{Method to roll one or more iterations of dice.} +\usage{ +roll(tbl, ...) +} +\arguments{ +\item{tbl}{A rolltable class.} + +\item{repetitions}{Number of times to roll the command.} + +\item{verbose}{If TRUE, dice roll details are visible in the console.} +} +\value{ +An updated rolltable. +} +\description{ +Takes a rolltable and rolls to create a new set of results. +} diff --git a/man/roll_dice.Rd b/man/roll_dice.Rd index bb2ffdb..eebee6b 100644 --- a/man/roll_dice.Rd +++ b/man/roll_dice.Rd @@ -4,7 +4,7 @@ \alias{roll_dice} \title{Roll Dice} \usage{ -roll_dice(cmd, roll_history = FALSE) +roll_dice(cmd, roll_history = FALSE, repetitions = 1, verbose = FALSE) } \arguments{ \item{cmd}{character string describing the dice roll to compute.} diff --git a/man/rolltable.Rd b/man/rolltable.Rd new file mode 100644 index 0000000..3012fdc --- /dev/null +++ b/man/rolltable.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rolltable_class.R +\name{rolltable} +\alias{rolltable} +\title{Rolltable class} +\usage{ +rolltable(cmd, repetitions = 1, verbose = FALSE) +} +\arguments{ +\item{cmd}{character string describing the dice roll to compute.} + +\item{repetitions}{Number of times to roll the command.} + +\item{verbose}{If TRUE, dice rolls details are visible in the console.} +} +\description{ +Class used to store multiple dice rolls for a roll command. +This function is the main helper, which sets up a new rolltable. +} diff --git a/man/trim_numeric_string.Rd b/man/trim_numeric_string.Rd new file mode 100644 index 0000000..48c9d38 --- /dev/null +++ b/man/trim_numeric_string.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rolltable_class.R +\name{trim_numeric_string} +\alias{trim_numeric_string} +\title{Helper function to change the number of digits for a string with numerals} +\usage{ +trim_numeric_string(str, digits = 2) +} +\description{ +Helper function to change the number of digits for a string with numerals +} diff --git a/rollr.Rproj b/rollr.Rproj index 497f8bf..270314b 100644 --- a/rollr.Rproj +++ b/rollr.Rproj @@ -18,3 +18,4 @@ StripTrailingWhitespace: Yes BuildType: Package PackageUseDevtools: Yes PackageInstallArgs: --no-multiarch --with-keep.source +PackageRoxygenize: rd,collate,namespace From 04f1914c80d1bc45cd3e93882deba5e6d434f2eb Mon Sep 17 00:00:00 2001 From: Michael Enion Date: Wed, 8 Jul 2020 21:46:53 +0000 Subject: [PATCH 04/10] Add a few examples for class functions. --- R/rolltable_class.R | 33 +++++++++++++++++++++++++++++---- man/calculate.Rd | 6 ++++++ man/max.rolltable.Rd | 3 +-- man/mean.rolltable.Rd | 5 ++--- man/median.rolltable.Rd | 5 ++--- man/min.rolltable.Rd | 3 +-- man/roll.Rd | 10 ++++++++-- man/rolltable.Rd | 5 +++++ 8 files changed, 54 insertions(+), 16 deletions(-) diff --git a/R/rolltable_class.R b/R/rolltable_class.R index 90721e9..8bbeba0 100644 --- a/R/rolltable_class.R +++ b/R/rolltable_class.R @@ -7,6 +7,11 @@ #' @param repetitions Number of times to roll the command. #' @param verbose If TRUE, dice rolls details are visible in the console. #' @export +#' +#' @examples +#' rolltable("2d20h1 + 20") +#' rolltable("2d20h1 + 20", repetitions = 3) +#' rolltable("2d20h1 + 20", verbose = TRUE) rolltable <- function(cmd, repetitions = 1, verbose = FALSE) { cmd <- tolower(cmd) # avoid needing to check for a bunch of capital letters parsed_cmd <- rollr:::parse_roll_cmd(cmd) @@ -41,15 +46,21 @@ new_rolltable <- function(lst, cmd, dices, operators) { ) } -#' Method to roll one or more iterations of dice. +#' Roll Method #' -#' Takes a rolltable and rolls to create a new set of results. +#' Takes a rolltable and rolls to create a new set of results, using one or more repetitions. #' #' @param tbl A rolltable class. #' @param repetitions Number of times to roll the command. #' @param verbose If TRUE, dice roll details are visible in the console. #' @return An updated rolltable. #' @export +#' +#' @examples +#' +#' tbl <- rolltable("2d20h1 + 20"); tbl +#' roll(tbl, repetitions = 3) +#' roll(tbl, repetitions = 2, verbose = TRUE) roll <- function(tbl, ...) { UseMethod("roll") } roll.rolltable <- function(tbl, repetitions = 1, verbose = FALSE) { lapply_fn <- ifelse(verbose, lapply, function(...) suppressMessages(lapply(...))) @@ -70,6 +81,12 @@ roll.rolltable <- function(tbl, repetitions = 1, verbose = FALSE) { #' @param .summary_fn Function used to summarize results between repetitions. Default returns each repetition separately. #' @return A numeric vector whose names are the individual sums for each dice set. #' @export +#' +#' @examples +#' +#' tbl <- rolltable("2d20h1 + 20") +#' calculate(tbl) +#' calculate(tbl, .summary_fn = "median") calculate <- function(tbl, ...) { UseMethod("calculate") } calculate.rolltable <- function(tbl, .summary_fn = "identity") { out <- parse_result(tbl, operators = attr(tbl, "operators"), .summary_fn = get(.summary_fn)) @@ -78,20 +95,24 @@ calculate.rolltable <- function(tbl, .summary_fn = "identity") { out } +#' Mean rolltable +#' #' Determines the average over repetitions for the rolls. #' Calculates the total by applying the operators to each average. #' -#' @param tbl A rolltable class. +#' @param x A rolltable class. #' @return A numeric vector whose names are the individual means for each dice set. #' @export mean.rolltable <- function(x) { calculate(x, .summary_fn = "mean") } +#' Median rolltable +#' #' Determines the median over repetitions for the rolls. #' Calculates the total by applying the operators to each median value. #' -#' @param tbl A rolltable class. +#' @param x A rolltable class. #' @return A numeric vector whose names are the individual means for each dice set. #' @export median.rolltable <- function(x, na.rm = FALSE) { @@ -100,6 +121,8 @@ median.rolltable <- function(x, na.rm = FALSE) { +#' Min rolltable +#' #' Determines the minimum over repetitions for the rolls. #' Calculates the total by applying the operators to each minimum. #' @@ -110,6 +133,8 @@ min.rolltable <- function(tbl, ..., na.rm = FALSE) { calculate(tbl, .summary_fn = "min") } +#' Max rolltable +#' #' Determines the maximum over repetitions for the rolls. #' Calculates the total by applying the operators to each maximum. #' diff --git a/man/calculate.Rd b/man/calculate.Rd index 4dfaab6..cfc0528 100644 --- a/man/calculate.Rd +++ b/man/calculate.Rd @@ -18,3 +18,9 @@ A numeric vector whose names are the individual sums for each dice set. For each repetition in the rolltable, summarizes each dice set and applies the operators in turn. } +\examples{ + +tbl <- rolltable("2d20h1 + 20") +calculate(tbl) +calculate(tbl, .summary_fn = "median") +} diff --git a/man/max.rolltable.Rd b/man/max.rolltable.Rd index d2fb355..a2de2e8 100644 --- a/man/max.rolltable.Rd +++ b/man/max.rolltable.Rd @@ -2,8 +2,7 @@ % Please edit documentation in R/rolltable_class.R \name{max.rolltable} \alias{max.rolltable} -\title{Determines the maximum over repetitions for the rolls. -Calculates the total by applying the operators to each maximum.} +\title{Max rolltable} \usage{ \method{max}{rolltable}(tbl, ..., na.rm = FALSE) } diff --git a/man/mean.rolltable.Rd b/man/mean.rolltable.Rd index 52d3141..07bb065 100644 --- a/man/mean.rolltable.Rd +++ b/man/mean.rolltable.Rd @@ -2,13 +2,12 @@ % Please edit documentation in R/rolltable_class.R \name{mean.rolltable} \alias{mean.rolltable} -\title{Determines the average over repetitions for the rolls. -Calculates the total by applying the operators to each average.} +\title{Mean rolltable} \usage{ \method{mean}{rolltable}(x) } \arguments{ -\item{tbl}{A rolltable class.} +\item{x}{A rolltable class.} } \value{ A numeric vector whose names are the individual means for each dice set. diff --git a/man/median.rolltable.Rd b/man/median.rolltable.Rd index 7a781c4..576a254 100644 --- a/man/median.rolltable.Rd +++ b/man/median.rolltable.Rd @@ -2,13 +2,12 @@ % Please edit documentation in R/rolltable_class.R \name{median.rolltable} \alias{median.rolltable} -\title{Determines the median over repetitions for the rolls. -Calculates the total by applying the operators to each median value.} +\title{Median rolltable} \usage{ \method{median}{rolltable}(x, na.rm = FALSE) } \arguments{ -\item{tbl}{A rolltable class.} +\item{x}{A rolltable class.} } \value{ A numeric vector whose names are the individual means for each dice set. diff --git a/man/min.rolltable.Rd b/man/min.rolltable.Rd index ed9bd81..1ed8de1 100644 --- a/man/min.rolltable.Rd +++ b/man/min.rolltable.Rd @@ -2,8 +2,7 @@ % Please edit documentation in R/rolltable_class.R \name{min.rolltable} \alias{min.rolltable} -\title{Determines the minimum over repetitions for the rolls. -Calculates the total by applying the operators to each minimum.} +\title{Min rolltable} \usage{ \method{min}{rolltable}(tbl, ..., na.rm = FALSE) } diff --git a/man/roll.Rd b/man/roll.Rd index a608295..820753f 100644 --- a/man/roll.Rd +++ b/man/roll.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/rolltable_class.R \name{roll} \alias{roll} -\title{Method to roll one or more iterations of dice.} +\title{Roll Method} \usage{ roll(tbl, ...) } @@ -17,5 +17,11 @@ roll(tbl, ...) An updated rolltable. } \description{ -Takes a rolltable and rolls to create a new set of results. +Takes a rolltable and rolls to create a new set of results, using one or more repetitions. +} +\examples{ + +tbl <- rolltable("2d20h1 + 20"); tbl +roll(tbl, repetitions = 3) +roll(tbl, repetitions = 2, verbose = TRUE) } diff --git a/man/rolltable.Rd b/man/rolltable.Rd index 3012fdc..c83225b 100644 --- a/man/rolltable.Rd +++ b/man/rolltable.Rd @@ -17,3 +17,8 @@ rolltable(cmd, repetitions = 1, verbose = FALSE) Class used to store multiple dice rolls for a roll command. This function is the main helper, which sets up a new rolltable. } +\examples{ +rolltable("2d20h1 + 20") +rolltable("2d20h1 + 20", repetitions = 3) +rolltable("2d20h1 + 20", verbose = TRUE) +} From 55b258d1b70fb4ce0f48042e27b5ae1ec6f53459 Mon Sep 17 00:00:00 2001 From: Michael Enion Date: Thu, 9 Jul 2020 02:29:34 +0000 Subject: [PATCH 05/10] Initial branch commit: Test using a simplified class for the rolltable. Instead of storing a list, store a simple dataframe and use class methods to implement addition, subtraction, etc. The class dataframe will store all replications. Changed rolltable class and methods accordingly. --- NAMESPACE | 2 + R/evaluate_roll_cmd.R | 29 ++++-------- R/roll_one.R | 26 +++++++---- R/rolltable_class.R | 103 ++++++++++++++++++++++------------------- man/new_rolltable.Rd | 2 +- man/print.rolltable.Rd | 2 +- 6 files changed, 84 insertions(+), 80 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index af0e428..49d12b7 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,10 +1,12 @@ # Generated by roxygen2: do not edit by hand +S3method(calculate,rolltable) S3method(max,rolltable) S3method(mean,rolltable) S3method(median,rolltable) S3method(min,rolltable) S3method(print,rolltable) +S3method(roll,rolltable) export(calculate) export(roll) export(roll_dice) diff --git a/R/evaluate_roll_cmd.R b/R/evaluate_roll_cmd.R index f2c8e21..31406ad 100644 --- a/R/evaluate_roll_cmd.R +++ b/R/evaluate_roll_cmd.R @@ -40,31 +40,18 @@ roll_set <- function(parsed_cmd, repetitions) { result = result)) } -parse_result <- function(calculated_dice_tbls, operators = character(0), .summary_fn = identity) { +parse_result <- function(tbl, .summary_fn = identity) { # result is a list one longer than operators # Each result element is a table with 1 or more rows for a single set of dice rolls # first choose either the calculated roll or success if available, and sum - out <- sapply(calculated_dice_tbls, function(tbl) { - out <- tbl$Calculated.Roll + tbl$Result <- tbl$Calculated.Roll + success_idx <- !sapply(tbl$Success.Outcome, is.na) + tbl$Result[success_idx] <- tbl$Success.Outcome[success_idx] - idx <- sapply(calculated_dice_tbls$Success.Outcome, is.null) - out[!idx] <- tbl$Success.Outcome[!idx] - return(sapply(out, sum, na.rm = TRUE)) - }) + # sum each set of dice rolls or successes + tbl$Result <- sapply(tbl$Result, sum, na.rm = TRUE) - if(is.null(dim(out))) dim(out) <- c(1, length(out)) - out <- apply(out, 2, .summary_fn) - - - if(length(operators) > 0) { - if(is.null(dim(out))) dim(out) <- c(1, length(out)) - # now apply the operators to each - text <- paste(out[,1]) - for(i in 2:ncol(out)) { - text <- paste(text, operators[i-1], out[, i]) - } - out <- sapply(text, function(txt) { eval(parse(text = txt)) } ) - } - return(out) + # summarize by die type if more than one type + by(tbl$Result, INDICES = tbl$Die, FUN = .summary_fn) } diff --git a/R/roll_one.R b/R/roll_one.R index 1e530ae..c75648f 100644 --- a/R/roll_one.R +++ b/R/roll_one.R @@ -21,15 +21,17 @@ roll_one <- function(roll){ construct_dice_table <- function(die) { cbind(Die = die, - detect_dice(die), - detect_dice_type(die), - detect_success_test(die)) + Repetition = 1, + rollr:::detect_dice(die), + rollr:::detect_dice_type(die), + rollr:::detect_success_test(die), + stringsAsFactors = FALSE) } calculate_dice_table <- function(dice_tbl, verbose = FALSE) { - dice_tbl <- roll_base_dice(dice_tbl) - dice_tbl <- calculate_types(dice_tbl) - dice_tbl <- calculate_successes(dice_tbl) + dice_tbl <- rollr:::roll_base_dice(dice_tbl) + dice_tbl <- rollr:::calculate_types(dice_tbl) + dice_tbl <- rollr:::calculate_successes(dice_tbl) return(dice_tbl) } @@ -70,12 +72,16 @@ calculate_types <- function(dice_tbl) { for(i in seq_len(nrow(dice_tbl))) { type <- dice_tbl$Type[[i]] if(type %in% names(dice_modification_types)) { + # modify the base roll in some fashion i_str <- sprintf(iteration_s, i) calculation_fn <- dice_modification_types[[type]]$calculate dice_tbl$Calculated.Roll[[i]] <- calculation_fn(base_roll = dice_tbl$Base.Roll[[i]], match = dice_tbl$Type.Match[[i]], sides = dice_tbl$Sides[[i]], i_str = i_str) + } else { + # no modification required; use the base roll + dice_tbl$Calculated.Roll[[i]] <- dice_tbl$Base.Roll[[i]] } } @@ -83,15 +89,15 @@ calculate_types <- function(dice_tbl) { } calculate_successes <- function(dice_tbl) { - dice_tbl$Success.Outcome <- vector("list", nrow(dice_tbl)) + dice_tbl$Success.Outcome <- NA iteration_s <- paste0("%0", ceiling(nrow(dice_tbl) / 10), "d") for(i in seq_len(nrow(dice_tbl))) { type <- dice_tbl$Success[[i]] - if(dice_tbl$Success[[i]] %in% names(success_types) & !is.na(dice_tbl$Success[[i]])) { + if(dice_tbl$Success[[i]] %in% names(rollr:::success_types) & !is.na(dice_tbl$Success[[i]])) { i_str <- sprintf(iteration_s, i) - calculation_fn <- success_type[[type]]$calculate - dice_tbl$Calculated.Roll[[i]] <- calculation_fn(base_roll = dice_tbl$Calculated.Roll[[i]], + calculation_fn <- rollr:::success_types[[type]]$calculate + dice_tbl$Success.Outcome[[i]] <- calculation_fn(base_roll = dice_tbl$Calculated.Roll[[i]], match = dice_tbl$Success.Match[[i]], i_str = i_str) } diff --git a/R/rolltable_class.R b/R/rolltable_class.R index 8bbeba0..85fd8dc 100644 --- a/R/rolltable_class.R +++ b/R/rolltable_class.R @@ -14,12 +14,19 @@ #' rolltable("2d20h1 + 20", verbose = TRUE) rolltable <- function(cmd, repetitions = 1, verbose = FALSE) { cmd <- tolower(cmd) # avoid needing to check for a bunch of capital letters - parsed_cmd <- rollr:::parse_roll_cmd(cmd) - dice_tbls <- lapply(parsed_cmd$dices, construct_dice_table) - tbl <- new_rolltable(lst = dice_tbls, - cmd = cmd, - dices = parsed_cmd$dices, - operators = parsed_cmd$operators) + error_txt <- "Rolltable only accepts single dice set commands (e.g., '2d6!', not '2d6! + 20'. To add, subtract, or use other mathematical symbols either apply the symbol to rolltables directly or use roll_dice." + + if(length(cmd) > 1) { + parsed_cmd <- sapply(cmd, parse_roll_cmd) + ln <- sapply(parsed_cmd["dices",], length) + if(any(ln > 1)) stop(error_txt) + } else { + parsed_cmd <- rollr:::parse_roll_cmd(cmd) + if(length(parsed_cmd$dices) > 1) stop(error_txt) + } + + tbl <- rollr:::new_rolltable(tbl = rollr:::construct_dice_table(cmd), + cmd = cmd) roll(tbl, repetitions = repetitions, verbose = verbose) } @@ -27,22 +34,14 @@ rolltable <- function(cmd, repetitions = 1, verbose = FALSE) { #' #' Internal function to build the rolltable class structure. #' Minimal checks for validity. -new_rolltable <- function(lst, cmd, dices, operators) { - stopifnot(is.list(lst)) - stopifnot(is.character(cmd), - length(cmd) == 1) - stopifnot(is.character(dices), - length(dices) == length(lst)) - stopifnot(is.character(operators), - length(operators) == (length(dices) - 1)) - - names(lst) <- dices +new_rolltable <- function(cmd, tbl) { + stopifnot(is.data.frame(tbl)) + stopifnot(is.character(cmd)) + structure( - .Data = lst, + .Data = tbl, command = cmd, - dices = dices, - operators = operators, - class = "rolltable" + class = c("rolltable", "data.frame") ) } @@ -62,14 +61,16 @@ new_rolltable <- function(lst, cmd, dices, operators) { #' roll(tbl, repetitions = 3) #' roll(tbl, repetitions = 2, verbose = TRUE) roll <- function(tbl, ...) { UseMethod("roll") } -roll.rolltable <- function(tbl, repetitions = 1, verbose = FALSE) { - lapply_fn <- ifelse(verbose, lapply, function(...) suppressMessages(lapply(...))) - rollhist <- lapply_fn(tbl, function(df, n) { df[rep(1, times = n), , drop = FALSE] }, n = repetitions) - rollhist <- lapply_fn(rollhist, rollr:::calculate_dice_table) +#' @export +roll.rolltable <- function(tbl, repetitions = 1, verbose = FALSE) { + calc_fn <- ifelse(verbose, rollr:::calculate_dice_table, function(...) suppressMessages(rollr:::calculate_dice_table(...))) - # lapply strips class, so add back. - new_rolltable(rollhist, cmd = attr(tbl, "command"), dices = attr(tbl, "dices"), operators = attr(tbl, "operators")) + # add repetitions, if any + n_orig <- length(attr(tbl, "command")) + rollhist <- tbl[rep(1:n_orig, each = repetitions), , drop = FALSE] + rollhist$Repetition <- rep(1:repetitions, times = n_orig) + calc_fn(rollhist) } #' Method to calculate the current value of a rolltable @@ -88,11 +89,10 @@ roll.rolltable <- function(tbl, repetitions = 1, verbose = FALSE) { #' calculate(tbl) #' calculate(tbl, .summary_fn = "median") calculate <- function(tbl, ...) { UseMethod("calculate") } + +#' @export calculate.rolltable <- function(tbl, .summary_fn = "identity") { - out <- parse_result(tbl, operators = attr(tbl, "operators"), .summary_fn = get(.summary_fn)) - attr(out, "command") <- attr(tbl, "command") - attr(out, "parse_function") <- .summary_fn - out + parse_result(tbl, .summary_fn = get(.summary_fn)) } #' Mean rolltable @@ -152,11 +152,21 @@ max.rolltable <- function(tbl, ..., na.rm = FALSE) { #' @param rolls If TRUE, print the base rolls and modifications to rolls, such as keep highest or exploding. #' @param digits Round numbers to this number of digits when printing. #' @export -print.rolltable <- function(tbl, n = 10, rolls = FALSE, digits = 2, ...) { +print.rolltable <- function(tbl, n = 10, rolls = FALSE, digits = 1, ...) { res <- mean(tbl) - repetitions <- nrow(tbl[[1]]) + repetitions <- max(tbl$Repetition) + + # format so that the dice and means line up. + res <- round(res, digits = digits) + field_widths <- pmax(nchar(attr(tbl, "command")), + nchar(res)) + + field_s <- paste(paste0("%", field_widths, "s"), collapse = " ") + field_f <- paste(paste0("%", field_widths, ".", digits, "f"), collapse = " ") + + cat("Dice:", do.call(sprintf, args = c(list(fmt = field_s), as.list(attr(tbl, "command")))), "\n") + cat("Mean:", do.call(sprintf, args = c(list(fmt = field_f), as.list(res))), "\n") - cat(attr(tbl, "command"), "\n") cat("======\n") cat(sprintf("Number of repetitions: %d\n", repetitions)) @@ -170,29 +180,28 @@ print.rolltable <- function(tbl, n = 10, rolls = FALSE, digits = 2, ...) { # 1. Exploding: 5, 2, 4, 5, 3, 1, 3, 4 # ---------- - total_i <- min(repetitions, n) - iteration_s <- paste0("%0", ceiling(total_i / 10), "d") - for(i in seq_len(total_i)) { + max_repetition <- min(repetitions, n) + iteration_s <- paste0("%0", ceiling(max_repetition / 10), "d") + for(i in seq_len(nrow(tbl))) { + if(tbl$Repetition[[i]] > max_repetition) next; cat("----------\n") - i_str <- sprintf(iteration_s, i) - for(d in seq_len(length(tbl))) { + i_str <- sprintf(iteration_s, tbl$Repetition[[i]]) + cat(sprintf("%s. %s base rolls: %s\n", i_str, tbl$Die[[i]], paste(tbl$Base.Roll[[i]], collapse = ", "))) - cat(sprintf("%s. %s base rolls: %s\n", i_str, names(tbl)[[d]], paste(tbl[[d]]$Base.Roll[[i]], collapse = ", "))) + if(tbl$Type[[i]] != "none" & tbl$Type[[i]] != "simple") { + cat(sprintf("%s. %s: %s\n", i_str, stringr::str_to_title(tbl$Type[[i]]), paste(tbl$Calculated.Roll[[i]], collapse = ", "))) + } - if(tbl[[d]]$Type[[i]] != "none" & tbl[[d]]$Type[[i]] != "simple") { - cat(sprintf("%s. %s: %s\n", i_str, stringr::str_to_title(tbl[[d]]$Type[[i]]), paste(tbl[[d]]$Calculated.Roll[[i]], collapse = ", "))) + if(!is.na(tbl$Success[[i]])) { + cat(sprintf("%s. Number successes: %s\n", i_str, paste(tbl$Success.Outcome[[i]], collapse = ", "))) } - } } - if(total_i < repetitions) cat("...\n") + + if(max_repetition < repetitions) cat("...\n") } cat("======\n") - s <- paste0("Mean result: %s = %.", digits, "f\n") - cat(sprintf(s, trim_numeric_string(names(res), digits), res)) - - } #' Helper function to change the number of digits for a string with numerals diff --git a/man/new_rolltable.Rd b/man/new_rolltable.Rd index ce042c5..0da0c01 100644 --- a/man/new_rolltable.Rd +++ b/man/new_rolltable.Rd @@ -4,7 +4,7 @@ \alias{new_rolltable} \title{Constructor for rolltable} \usage{ -new_rolltable(lst, cmd, dices, operators) +new_rolltable(cmd, tbl) } \description{ Internal function to build the rolltable class structure. diff --git a/man/print.rolltable.Rd b/man/print.rolltable.Rd index e9fc464..9b22126 100644 --- a/man/print.rolltable.Rd +++ b/man/print.rolltable.Rd @@ -4,7 +4,7 @@ \alias{print.rolltable} \title{Print a rolltable} \usage{ -\method{print}{rolltable}(tbl, n = 10, rolls = FALSE, digits = 2, ...) +\method{print}{rolltable}(tbl, n = 10, rolls = FALSE, digits = 1, ...) } \arguments{ \item{tbl}{A rolltable class.} From fa9724244bad388722382f147fc39e0b3ae8d166 Mon Sep 17 00:00:00 2001 From: Michael Enion Date: Thu, 9 Jul 2020 04:33:02 +0000 Subject: [PATCH 06/10] Correct error with calculating success based on equality. (forget to assign the result) --- R/roll_one.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/roll_one.R b/R/roll_one.R index c75648f..e778c37 100644 --- a/R/roll_one.R +++ b/R/roll_one.R @@ -258,7 +258,7 @@ ge_success <- list(name = "success ge", equal_success <- list(name = "success equal", pattern = "[^>][=](\\d+)$", calculate = function(base_roll, match, i_str = "1", ...) { - sum(base_roll == as.integer(match)) + out <- sum(base_roll == as.integer(match)) message(i_str, ". Number of successes: ", out) out }) From 3e6e10e264cc6758c446d778609bac6015f4e8b9 Mon Sep 17 00:00:00 2001 From: Michael Enion Date: Fri, 10 Jul 2020 00:47:52 +0000 Subject: [PATCH 07/10] Re-worked roll_dice to use rolltable and calculate, and to parse infinitely long mathematical operations using anything from the Ops set of functions. Added documentation for roll_dice and rolltable. --- NAMESPACE | 5 ++ R/parse_roll_cmd.R | 19 ++++- R/roll_dice.R | 99 ++++++++++++++++++++---- R/roll_one.R | 4 +- R/rolltable_calculation_class.R | 125 +++++++++++++++++++++++++++++++ R/rolltable_class.R | 111 +++++++++++++++++++++++++-- man/Ops.rollr.Rd | 19 +++++ man/new_rolltable_calculation.Rd | 19 +++++ man/repetitions.Rd | 17 +++++ man/roll_dice.Rd | 82 ++++++++++++++++++-- man/rolltable.Rd | 24 ++++-- 11 files changed, 489 insertions(+), 35 deletions(-) create mode 100644 R/rolltable_calculation_class.R create mode 100644 man/Ops.rollr.Rd create mode 100644 man/new_rolltable_calculation.Rd create mode 100644 man/repetitions.Rd diff --git a/NAMESPACE b/NAMESPACE index 49d12b7..996cb3e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,13 +1,18 @@ # Generated by roxygen2: do not edit by hand +S3method(Ops,rollr) S3method(calculate,rolltable) S3method(max,rolltable) S3method(mean,rolltable) S3method(median,rolltable) S3method(min,rolltable) S3method(print,rolltable) +S3method(repetitions,rolltable) +S3method(repetitions,rolltable_calculation) S3method(roll,rolltable) export(calculate) +export(new_rolltable_calculation) +export(repetitions) export(roll) export(roll_dice) export(rolltable) diff --git a/R/parse_roll_cmd.R b/R/parse_roll_cmd.R index d09a9cf..e7304e1 100644 --- a/R/parse_roll_cmd.R +++ b/R/parse_roll_cmd.R @@ -7,11 +7,26 @@ #' #' @return a list containing dice to roll and mathematical operators. parse_roll_cmd <- function(roll_cmd) { - pattern = "[\\+-\\/\\*]" + # Group "Ops": + # "+", "-", "*", "/", "^", "%%", "%/%" + # "&", "|", "!" + # "==", "!=", "<", "<=", ">=", ">" + # lose any parentheticals, as we are not looking to capture exact mathematical sequence, + # just dice and operators + # replace with space to avoid inadvertently jamming together certain symbols + # roll_cmd <- "(!20d6!>5 + 20) * 3 >= (-2d20h1 + 1d4=4 + 2d4>=3)*2" + roll_cmd <- tolower(roll_cmd) + roll_cmd <- stringr::str_replace_all(roll_cmd, pattern = "[()]", replacement = " ") + + # add space at beginning and end to make it easier to capture certain patterns without needing anchors + roll_cmd <- paste0(" ", roll_cmd, " ") + + pattern = "([|/*+^&-])|( [><=] )|( [!+-])|( [>N. Reroll (explode) any N or higher. +#' Example: Modified critical: 1d20!>19. +#' \item Double: 2d20tN. If N is rolled, then count it twice. +#' } +#' +#' Success tests: +#' \itemize{ +#' \item Equality: 2d20=N. Only count a success if the roll equals N. +#' \item Difficulty check: 2d20>=N. Only count a success if the roll is greater or equal to N. +#' } +#' +#' To use a success test along with a modification, just add the success test after the modification. +#' +#' Spaces: Be careful in using spaces. Die sets should not contain spaces. +#' For example, '2d20h1>=10' is a difficulty success test; '2d20h1!>10' explodes everything 10 or higher; +#' '2d20h1 >= 10' is a mathematical operation, comparing the result of the 2d20h1 roll to 10. +#' +#' @section Operations and rollr classes: +#' Rollr introduces two types of classes to facilitate dice rolls and manipulations: rolltable and rolltable_calculation. +#' Rolltables store all the information needed to recreate the rolls for a dice set. See \code{\link{rolltable}}. +#' Rolltable calculations are the result of applying \code{\link{calculate}} on a rolltable, or applying a mathematical +#' operation. For example, \code{roll_dice("4d6 + 2")}. See \code{\link{calculate}} and \code{\link{new_rolltable_calculation}}. +#' +#' @section Repetitions: +#' Rollr can run multiple repetitions of a command, and can use mathematical operations across repetitions. +#' In rolltables, repetitions are stored in a dataframe. +#' In rolltable calculations, repetitions are represented by a vector. +#' #' @examples #' +#' roll_dice("4d6h3") #' roll_dice("1d10 + 20") -#' roll_dice("1d4 * 2") -#' roll_dice("2d20h1") +#' +#' # See the rolls as they happen +#' roll_dice("2d20h1", verbose = TRUE) +#' +#' # Examine roll history and run multiple repetitions +#' outcome <- roll_dice("4d6!>5 + 1d4", roll_history = TRUE, repetitions = 3) +#' print(outcome$roll_history, rolls = TRUE) #' roll_dice <- function(cmd, roll_history=FALSE, repetitions = 1, verbose = FALSE) { + stopifnot(repetitions > 0) + if(length(cmd) > 1) { out <- lapply(cmd, roll_dice, roll_history = roll_history, repetitions = repetitions) names(out) <- cmd return(out) } - tbl <- rolltable(cmd, repetitions = repetitions, verbose = verbose) - result <- calculate(tbl) + # parse the command and create a roll table for each dices. + parsed_cmd <- rollr:::parse_roll_cmd(cmd) - if(verbose) { - message('==========') - iteration_s <- paste0("%0", ceiling(length(result) / 10), "d") - for(i in seq_along(result)) { - i_str <- sprintf(iteration_s, i) - message(sprintf("%s. Result is %d", i_str, result[[i]])) - } + tbls <- lapply(parsed_cmd$dices, rolltable, repetitions = repetitions, verbose = verbose) + names(tbls) <- parsed_cmd$dices + cmd_to_eval <- cmd + for(i in seq_along(parsed_cmd$dices)) { + cmd_to_eval <- sub(pattern = parsed_cmd$dices[[i]], replacement = sprintf("tbls[[%d]]", i), x = cmd_to_eval, fixed = TRUE) } + result <- eval(parse(text = cmd_to_eval)) + + # if the command is simple, it might be left as a rolltable + if(inherits(result, "rolltable")) result <- calculate(result) + if(roll_history) { return(list(result = result, - roll_history = tbl)) + roll_history = tbls)) } return(result) diff --git a/R/roll_one.R b/R/roll_one.R index e778c37..632b269 100644 --- a/R/roll_one.R +++ b/R/roll_one.R @@ -126,7 +126,7 @@ detect_dice_type <- function(die) { if(any(idx)) { res$Type[idx] <- r$name - # match, but lose the initial repetion of the full pattern + # match, but lose the initial repetition of the full pattern match_fn <- function(string, pattern) { stringr::str_match(string = string, pattern = pattern)[, -1] } @@ -223,7 +223,7 @@ double <- list(name = "double", }) exploding <- list(name = "exploding", - pattern = "^\\d+[dD]\\d+\\!(?:[>](\\d+))?", + pattern = "^\\d+d\\d+\\!(?:[>](\\d+))?", calculate = function(base_roll, match, sides, i_str = "1", ...) { match <- as.integer(match) sides <- as.integer(sides) diff --git a/R/rolltable_calculation_class.R b/R/rolltable_calculation_class.R new file mode 100644 index 0000000..13baf8f --- /dev/null +++ b/R/rolltable_calculation_class.R @@ -0,0 +1,125 @@ +#' Rolltable calculation class +#' +#' Class returned when calculating a rolltable. +#' This inherits from the "by" class returned when using the \code{\link[base]{by}} function. +#' Typically, this function is not needed by the user, who instead should rely on \code{\link{calculate}}. +#' +#' @param lst A list object returned using the "by" function. +#' @return A rolltable_calculation classed object. +#' +#' @export +new_rolltable_calculation <- function(lst, n = names(lst)) { + # ignoring the call attribute as it is not useful for rolltables. + # these may be already set if lst is a "by" object. + force(n) # needed to avoid circular promise when reassigning names below + attr(lst, "dim") <- length(lst) + attr(lst, "dimnames") <- list("Die" = n) + class(lst) <- c("rolltable_calculation", "rollr", "by") # rollr virtual class needed for Ops methods. + return(lst) +} + +#' @export +repetitions.rolltable_calculation <- function(tbl, ...) { length(tbl[[1]]) } + + +#' S3 Group Generic Ops for rolltable_calculation and rolltable +#' +#' Permits mathemetical operations on rolltables or rolltable calculations in certain circumstances. +#' Namely, the number of repetitions must match between objects, or one object is a length-one vector. +#' +#' In all valid instances, the rolltable or rolltables are first calculated. +#' If there are multiple repetitions, these are all kept separate. +#' A rolltable can only be added, etc. to another rolltable with a comparable number of repetitions. +#' Repetitions will be increased to match, which will cause the rolltable to be rerolled. +#' If dies differ within a rolltable, each will be treated separately. +#' +#' @export +Ops.rollr <- function(e1, e2 = NULL) { + # The rollr class is used similarly to how POSIXt class is used, to permit operations on rolltables or rolltable calculations, or both. + # See, e.g., https://stackoverflow.com/questions/43066501/s3-operator-overloading-for-multiple-classes + # The end result of an operation will always be a rolltable_calculation. + + # mostly copied from Ops.data.frame + unary <- nargs() == 1L + lclass <- nzchar(.Method[1L]) + rclass <- !unary && (nzchar(.Method[2L])) + FUN <- get(.Generic, envir = parent.frame(), mode = "function") + # f <- if (unary) { quote(FUN(left)) } else { quote(FUN(left, right)) } + + if(lclass && rclass) { + # both objects are rolltables or rolltable calculations. + rep1 <- repetitions(e1) + rep2 <- repetitions(e2) + if(rep1 != rep2 && rep1 != 1 && rep2 != 1) { + # conform repetitions + if(inherits(e1, "rolltable") && inherits(e2, "rolltable")) { + warning("Number of repetitions do not match. They will be increased accordingly, which will cause the smaller table to be rerolled.") + n_reps <- max(rep1, rep2) + if(rep1 != n_reps) e1 <- roll(e1, repetitions = n_reps) + if(rep2 != n_reps) e2 <- roll(e2, repetitions = n_reps) + } else if(inherits(e1, "rolltable")) { + warning("Number of repetitions do not match. They will be increased accordingly, which will cause the rolltable to be rerolled.") + e1 <- roll(e1, repetitions = rep2) + } else if(inherits(e2, "rolltable")) { + e2 <- roll(e2, repetitions = rep1) + } else stop("Should not be here.") + } + + } else if(unary) { + # no adjustment to repetitions needed + + + } else if(lclass) { + # e1 is rolltable or rolltable_calculation; e2 is vector + if(length(e2) != 1 && repetitions(e1) != length(e2) && inherits(e1, "rolltable")) { + warning("Number of repetitions do not match length of the vector. They will be increased accordingly, which will cause the rolltable to be rerolled.") + e1 <- roll(e1, repetitions = length(e2)) + } + + } else if(rclass) { + # e2 is rolltable or rolltable_calculation; e1 is vector + if(length(e1) != 1 && repetitions(e2) != length(e1) && inherits(e2, "rolltable")) { + warning("Number of repetitions do not match length of the vector. They will be increased accordingly, which will cause the rolltable to be rerolled.") + e2 <- roll(e2, repetitions = length(e1)) + } + + } else stop("Should not be here.") + + # apply calculation so all that is left are either rolltable_calculations or vectors + if(inherits(e1, "rolltable")) e1 <- calculate(e1) + if(inherits(e2, "rolltable")) e2 <- calculate(e2) + + if(length(e1) != length(e2) && + length(e1) > 1 && + length(e2) > 1) stop("Rolltable calculations must have the same number of Dies or a single die.") + + if(unary) { + value <- lapply(e1, FUN) + new_labels <- paste0(.Generic, names(e1)) + + } else if(lclass && rclass) { + # both e1 and e2 are rolltable calculations + value <- mapply(FUN, e1, e2, SIMPLIFY = FALSE) + new_labels <- paste0("(", names(e1), " ", .Generic, " ", names(e2), ")") + + } else if(lclass) { + # e1 is a rolltable calculation. + # apply e2 to each grouping of e1 equally + # might throw an error if the e2 length is not compatible with the group length (repetitions) for e1 + # may also throw an error if the e2 vector is of a non-compatible class, such as character. + value <- lapply(e1, FUN, e2 = e2) + new_labels <- paste0("(", names(e1), " ", .Generic, " ", paste(as.character(e2), collapse = "|"), ")") + + } else if(rclass) { + # e2 is a rolltable calculation. Treated as mirror of lclass. + value <- lapply(e2, FUN, e1 = e1) + new_labels <- paste0("(", paste(as.character(e1), collapse = "|"), " ", .Generic, " ", names(e2), ")") + + } else stop("Should not be here.") + + new_rolltable_calculation(value, new_labels) + + # return(paste(class(e1), .Generic, class(e2))) +} + + diff --git a/R/rolltable_class.R b/R/rolltable_class.R index 85fd8dc..f55eaca 100644 --- a/R/rolltable_class.R +++ b/R/rolltable_class.R @@ -1,17 +1,31 @@ #' Rolltable class #' #' Class used to store multiple dice rolls for a roll command. -#' This function is the main helper, which sets up a new rolltable. +#' This function is the main helper, and sets up a new rolltable. #' #' @param cmd character string describing the dice roll to compute. +#' Can be of any length, but each character element can only represent a single dice set with no operators. #' @param repetitions Number of times to roll the command. #' @param verbose If TRUE, dice rolls details are visible in the console. #' @export #' +#' @details +#' Users interested in simulation may wish to use the rolltable class directly. +#' For example, the following simulates 1000 different D&D 5e ability rolls: +#' \code{rolltable("4d6h3", repetitions = 1000)} +#' +#' You can apply mathematical operations to one or more rolltables. For example: +#' \code{(rolltable("3d6") * 3) + rolltable("1d4r1")} +#' \code{median(rolltable("4d6h3", repetitions = 1000))} +#' #' @examples -#' rolltable("2d20h1 + 20") -#' rolltable("2d20h1 + 20", repetitions = 3) -#' rolltable("2d20h1 + 20", verbose = TRUE) +#' rolltable("2d20h1") +#' rolltable("2d20h1", repetitions = 5) + rolltable("10") +#' +#' # How often would advantage beat disadvantage in D&D 5e? +#' result <- rolltable("2d20h1", repetitions = 1000) > rolltable("2d20l1", repetitions = 1000) +#' summary(result[[1]]) +#' rolltable <- function(cmd, repetitions = 1, verbose = FALSE) { cmd <- tolower(cmd) # avoid needing to check for a bunch of capital letters error_txt <- "Rolltable only accepts single dice set commands (e.g., '2d6!', not '2d6! + 20'. To add, subtract, or use other mathematical symbols either apply the symbol to rolltables directly or use roll_dice." @@ -41,7 +55,7 @@ new_rolltable <- function(cmd, tbl) { structure( .Data = tbl, command = cmd, - class = c("rolltable", "data.frame") + class = c("rolltable", "rollr", "data.frame") # rollr virtual class needed for Ops methods. ) } @@ -92,9 +106,20 @@ calculate <- function(tbl, ...) { UseMethod("calculate") } #' @export calculate.rolltable <- function(tbl, .summary_fn = "identity") { - parse_result(tbl, .summary_fn = get(.summary_fn)) + out <- parse_result(tbl, .summary_fn = get(.summary_fn)) + new_rolltable_calculation(out) } +#' Number of repetitions in a rolltable +#' +#' @param tbl A rolltable class. +#' @return Integer value indicating the number of repetitions. +#' @export +repetitions <- function(tbl, ...) { UseMethod("repetitions") } + +#' @export +repetitions.rolltable <- function(tbl, ...) { max(tbl$Repetition) } + #' Mean rolltable #' #' Determines the average over repetitions for the rolls. @@ -209,3 +234,77 @@ trim_numeric_string <- function(str, digits = 2) { p <- sprintf("([[:digit:]]+[.])([[:digit:]]{%d})[[:digit:]]+", digits) stringr::str_replace_all(str, pattern = p, replacement = "\\1\\2") } + + + +# Ops.rolltable <- function(e1, e2 = NULL) { +# # mostly copied from Ops.data.frame +# unary <- nargs() == 1L +# lclass <- nzchar(.Method[1L]) +# rclass <- !unary && (nzchar(.Method[2L])) +# FUN <- get(.Generic, envir = parent.frame(), mode = "function") +# f <- if (unary) { quote(FUN(left)) } else { quote(FUN(left, right)) } +# +# if(lclass && rclass) { +# # both e1 and e2 are rolltables +# # conform repetitions +# if(repetitions(e1) != repetitions(e2)) { +# warning("Number of repetitions do not match. They will be increased accordingly, which will cause the smaller table to be rerolled.") +# n_reps <- max(repetitions(e1), repetitions(e2)) +# if(repetitions(e1) != n_reps) e1 <- roll(e1, repetitions = n_reps) +# if(repetitions(e2) != n_reps) e2 <- roll(e2, repetitions = n_reps) +# } +# } else if(lclass) { +# # e1 is a rolltable +# if(!unary) { +# if(!(is.numeric(e2) | is.logical(e2) | is.integer(e2))) stop("Operation is only defined for numeric vectors.") +# if(length(e2) > 1 & length(e2) != repetitions(e1)) { +# warning("Number of repetitions do not match the size of the numeric vector. Repetitions will be changed accordingly, which will cause the table to be rerolled.") +# e1 <- roll(e1, repetitions = length(e2)) +# } +# +# } +# +# } else if(rclass) { +# # e2 is a rolltable +# if(!unary) { +# if(!(is.numeric(e1) | is.logical(e1) | is.integer(e1))) stop("Operation is only defined for numeric vectors.") +# if(length(e1) > 1 & length(e1) != repetitions(e2)) { +# warning("Number of repetitions do not match the size of the numeric vector. Repetitions will be changed accordingly, which will cause the table to be rerolled.") +# e2 <- roll(e2, repetitions = length(e1)) +# } +# } +# +# } else stop("Should not be here.") +# +# # apply the function +# if(unary) { +# left <- calculate(e1) +# +# } else if(lclass && rclass) { +# # both e1 and e2 are rolltables +# left <- calculate(e1) +# right <- calculate(e2) +# +# } else if(lclass) { +# # e1 is a rolltable +# left <- calculate(e1) +# right <- e2 +# +# } else if(rclass) { +# # e2 is a rolltable +# left <- e1 +# right <- calculate(e2) +# } +# +# # value <- eval(f) +# # eval(f) +# # return(.Generic) +# +# return(paste(class(e1), .Generic, class(e2))) +# # return(list(method_one = .Method[1L], +# # method_two = .Method[2L])) +# +# } + + diff --git a/man/Ops.rollr.Rd b/man/Ops.rollr.Rd new file mode 100644 index 0000000..b3ccf17 --- /dev/null +++ b/man/Ops.rollr.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rolltable_calculation_class.R +\name{Ops.rollr} +\alias{Ops.rollr} +\title{S3 Group Generic Ops for rolltable_calculation and rolltable} +\usage{ +\method{Ops}{rollr}(e1, e2 = NULL) +} +\description{ +Permits mathemetical operations on rolltables or rolltable calculations in certain circumstances. +Namely, the number of repetitions must match between objects, or one object is a length-one vector. +} +\details{ +In all valid instances, the rolltable or rolltables are first calculated. +If there are multiple repetitions, these are all kept separate. +A rolltable can only be added, etc. to another rolltable with a comparable number of repetitions. +Repetitions will be increased to match, which will cause the rolltable to be rerolled. +If dies differ within a rolltable, each will be treated separately. +} diff --git a/man/new_rolltable_calculation.Rd b/man/new_rolltable_calculation.Rd new file mode 100644 index 0000000..c4d0b7e --- /dev/null +++ b/man/new_rolltable_calculation.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rolltable_calculation_class.R +\name{new_rolltable_calculation} +\alias{new_rolltable_calculation} +\title{Rolltable calculation class} +\usage{ +new_rolltable_calculation(lst, n = names(lst)) +} +\arguments{ +\item{lst}{A list object returned using the "by" function.} +} +\value{ +A rolltable_calculation classed object. +} +\description{ +Class returned when calculating a rolltable. +This inherits from the "by" class returned when using the \code{\link[base]{by}} function. +Typically, this function is not needed by the user, who instead should rely on \code{\link{calculate}}. +} diff --git a/man/repetitions.Rd b/man/repetitions.Rd new file mode 100644 index 0000000..6ea2d12 --- /dev/null +++ b/man/repetitions.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rolltable_class.R +\name{repetitions} +\alias{repetitions} +\title{Number of repetitions in a rolltable} +\usage{ +repetitions(tbl, ...) +} +\arguments{ +\item{tbl}{A rolltable class.} +} +\value{ +Integer value indicating the number of repetitions. +} +\description{ +Number of repetitions in a rolltable +} diff --git a/man/roll_dice.Rd b/man/roll_dice.Rd index eebee6b..1259f71 100644 --- a/man/roll_dice.Rd +++ b/man/roll_dice.Rd @@ -9,18 +9,90 @@ roll_dice(cmd, roll_history = FALSE, repetitions = 1, verbose = FALSE) \arguments{ \item{cmd}{character string describing the dice roll to compute.} -\item{roll_history}{boolean, if TRUE, dice rolls details are visible in the console.} +\item{roll_history}{boolean, if TRUE, a list of rolltables will be returned along with the result.} + +\item{repetitions}{integer value} + +\item{verbose}{boolean, if TRUE, dice rolls details are visible in the console.} } \value{ -result of the dice roll computation +result of the dice roll computation, as a rolltable_calculation. +If roll_history is TRUE, a list will be returned with two elements: the result and the roll_history. +The returned roll_history is a named list, with a single rolltable for each dice set. } \description{ -Main function to use the library. This function wraps all the computing functions of the library. let the user choose between print or hide all rolls details in the console. +Main function to use the library. User can provide one or more commands using character strings, and choose to see roll details in the console. +} +\details{ +The \code{roll_dice} function parses one or more commands, where each command can be any valid dice set or sets, +using one or more mathematical operations. See \code{\link[base]{Ops}}. Parentheticals are permitted for controlling +order of operations. The \code{roll_dice} function first creates a \code{\link{rolltable}} for each dice set, then +applies the command operations to the rolltable(s). The result is a rolltable_calculation. See \code{\link{calculate}}. +} +\section{Dice sets}{ + +Dice sets are commands for rolling one or more dice, possibly applying a modifier, +and possibly applying a test for success. The various dice set commands are described at +https://github.com/Felixmil/rollR. + +Basic dice sets are: +\itemize{ + \item Integer. A positive integer. Usually used as part of a formula, e.g. 1d20 + 5 + \item Dice: NdX. Roll N dice with sides X. Example: 3d6, 2d20, 1d10. + \item Fate: Ndf. Roll N Fudge/Fate dice. Typically 4df. +} + +Modifications to dice are: +\itemize{ + \item High/Low: 2d20hN or 2d20lN. Keep N highest or N lowest dice from the roll. + Examples: D&D 5e advantage: 2d20h1. Disadvantage: 2d20l1. Ability roll: 4d6h3. + \item Reroll: 2d20rN. Reroll whenever N appears, and keep the result. + Examples: Halflings are lucky and reroll on a 1: 1d20r1. + \item Exploding: 2d20!N. For each N rolled, roll again and add the result to the initial roll. + You continue adding rolls as long as N appears. + Variation: 2d20!>N. Reroll (explode) any N or higher. + Example: Modified critical: 1d20!>19. + \item Double: 2d20tN. If N is rolled, then count it twice. +} + +Success tests: +\itemize{ + \item Equality: 2d20=N. Only count a success if the roll equals N. + \item Difficulty check: 2d20>=N. Only count a success if the roll is greater or equal to N. +} + +To use a success test along with a modification, just add the success test after the modification. + +Spaces: Be careful in using spaces. Die sets should not contain spaces. +For example, '2d20h1>=10' is a difficulty success test; '2d20h1!>10' explodes everything 10 or higher; +'2d20h1 >= 10' is a mathematical operation, comparing the result of the 2d20h1 roll to 10. +} + +\section{Operations and rollr classes}{ + +Rollr introduces two types of classes to facilitate dice rolls and manipulations: rolltable and rolltable_calculation. +Rolltables store all the information needed to recreate the rolls for a dice set. See \code{\link{rolltable}}. +Rolltable calculations are the result of applying \code{\link{calculate}} on a rolltable, or applying a mathematical +operation. For example, \code{roll_dice("4d6 + 2")}. See \code{\link{calculate}} and \code{\link{new_rolltable_calculation}}. } + +\section{Repetitions}{ + +Rollr can run multiple repetitions of a command, and can use mathematical operations across repetitions. +In rolltables, repetitions are stored in a dataframe. +In rolltable calculations, repetitions are represented by a vector. +} + \examples{ +roll_dice("4d6h3") roll_dice("1d10 + 20") -roll_dice("1d4 * 2") -roll_dice("2d20h1") + +# See the rolls as they happen +roll_dice("2d20h1", verbose = TRUE) + +# Examine roll history and run multiple repetitions +outcome <- roll_dice("4d6!>5 + 1d4", roll_history = TRUE, repetitions = 3) +print(outcome$roll_history, rolls = TRUE) } diff --git a/man/rolltable.Rd b/man/rolltable.Rd index c83225b..6b946ea 100644 --- a/man/rolltable.Rd +++ b/man/rolltable.Rd @@ -7,7 +7,8 @@ rolltable(cmd, repetitions = 1, verbose = FALSE) } \arguments{ -\item{cmd}{character string describing the dice roll to compute.} +\item{cmd}{character string describing the dice roll to compute. +Can be of any length, but each character element can only represent a single dice set with no operators.} \item{repetitions}{Number of times to roll the command.} @@ -15,10 +16,23 @@ rolltable(cmd, repetitions = 1, verbose = FALSE) } \description{ Class used to store multiple dice rolls for a roll command. -This function is the main helper, which sets up a new rolltable. +This function is the main helper, and sets up a new rolltable. +} +\details{ +Users interested in simulation may wish to use the rolltable class directly. +For example, the following simulates 1000 different D&D 5e ability rolls: +\code{rolltable("4d6h3", repetitions = 1000)} + +You can apply mathematical operations to one or more rolltables. For example: +\code{(rolltable("3d6") * 3) + rolltable("1d4r1")} +\code{median(rolltable("4d6h3", repetitions = 1000))} } \examples{ -rolltable("2d20h1 + 20") -rolltable("2d20h1 + 20", repetitions = 3) -rolltable("2d20h1 + 20", verbose = TRUE) +rolltable("2d20h1") +rolltable("2d20h1", repetitions = 5) + rolltable("10") + +# How often would advantage beat disadvantage in D&D 5e? +result <- rolltable("2d20h1", repetitions = 1000) > rolltable("2d20l1", repetitions = 1000) +summary(result[[1]]) + } From 9af18606a521e03f820e681295a59f203dd33382 Mon Sep 17 00:00:00 2001 From: Michael Enion Date: Fri, 10 Jul 2020 08:20:50 +0000 Subject: [PATCH 08/10] Fix somewhat obscure parsing error when subbing tables. Avoid situation where 1d6+1 results in tbls[[tbls[[2]]]]+1 instead of tbs[[1]]+tbls[[2]] --- R/roll_dice.R | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/R/roll_dice.R b/R/roll_dice.R index dc37db5..130e56f 100644 --- a/R/roll_dice.R +++ b/R/roll_dice.R @@ -92,11 +92,12 @@ roll_dice <- function(cmd, roll_history=FALSE, repetitions = 1, verbose = FALSE) parsed_cmd <- rollr:::parse_roll_cmd(cmd) tbls <- lapply(parsed_cmd$dices, rolltable, repetitions = repetitions, verbose = verbose) - names(tbls) <- parsed_cmd$dices + # names(tbls) <- parsed_cmd$dices + names(tbls) <- infinite_letters(length(tbls)) # use letters to avoid subbing over numbers such as 1d6+1 -> tbl[[1]] + tbl[[2]] cmd_to_eval <- cmd for(i in seq_along(parsed_cmd$dices)) { - cmd_to_eval <- sub(pattern = parsed_cmd$dices[[i]], replacement = sprintf("tbls[[%d]]", i), x = cmd_to_eval, fixed = TRUE) + cmd_to_eval <- sub(pattern = parsed_cmd$dices[[i]], replacement = sprintf("tbls[['%s']]", names(tbls)[[i]]), x = cmd_to_eval, fixed = TRUE) } result <- eval(parse(text = cmd_to_eval)) @@ -105,9 +106,25 @@ roll_dice <- function(cmd, roll_history=FALSE, repetitions = 1, verbose = FALSE) if(roll_history) { + names(tbls) <- parsed_cmd$dices return(list(result = result, roll_history = tbls)) } return(result) } + +#' Helper function to create names using only letters, not numbers +#' So that a command can be substituted without accidentally overwriting the number. +#' For example, subbing "1d6 + 1" with tbls[[1]] and tbls[[2]] needs to result in tbls[[1]] + tbls[[2]] +#' But instead will result in tbls[[tbls[[2]]]] + 1 +infinite_letters <- function(n) { + max_n <- 0 + k <- 0 + while(max_n < n) { + k <- k + 1 + max_n <- choose(26, k) + } + values <- unlist(combn(letters, k, paste0, simplify = FALSE, collapse = "")) + values[1:n] +} From 87945e8024be1c0bcfed11b35397fe27bfe2f475 Mon Sep 17 00:00:00 2001 From: Michael Enion Date: Fri, 10 Jul 2020 15:23:54 +0000 Subject: [PATCH 09/10] Pass all tests. Adjust tests to account for changes in underlying functions regarding rolltables. Fix minor errors and simplify how matches for roll patterns are stored. --- R/roll_one.R | 221 +++++++++++--------------------- R/rolltable_class.R | 77 +---------- man/infinite_letters.Rd | 17 +++ tests/testthat/test-roll_dice.R | 25 +++- tests/testthat/test-roll_one.R | 53 -------- tests/testthat/test-rolltable.R | 64 +++++++++ 6 files changed, 178 insertions(+), 279 deletions(-) create mode 100644 man/infinite_letters.Rd delete mode 100644 tests/testthat/test-roll_one.R create mode 100644 tests/testthat/test-rolltable.R diff --git a/R/roll_one.R b/R/roll_one.R index 632b269..61f1feb 100644 --- a/R/roll_one.R +++ b/R/roll_one.R @@ -17,14 +17,15 @@ roll_one <- function(roll){ warning("This roll command is not recognized") } +# should be able to handle all of the following, in one go # die <- tolower(c("1d6", "10d6", "20d20", "10", "2d20h1", "3d10h2", "2d20l1", "1d20r1", "3d6!", "2d6>=5", "4d6=5", "4dF", "1d10!>9", "3d10!>=8", "1d10t10")) construct_dice_table <- function(die) { cbind(Die = die, Repetition = 1, rollr:::detect_dice(die), - rollr:::detect_dice_type(die), - rollr:::detect_success_test(die), + rollr:::detect_dice_type(die)[,-1], # lose the Die column + rollr:::detect_success_test(die)[,-1], # lose the Die column stringsAsFactors = FALSE) } @@ -119,65 +120,75 @@ detect_dice <- function(die) { detect_dice_type <- function(die) { res <- data.frame(Die = die, stringsAsFactors = FALSE) res$Type <- NA - res$Type.Match <- NA + res$Type.Match <- vector("list", length(die)) # to accommodate patterns that return multiple sub-matches - for(r in dice_modification_types) { + for(r in rollr:::dice_modification_types) { idx <- stringr::str_detect(die, pattern = r$pattern) - if(any(idx)) { - res$Type[idx] <- r$name - - # match, but lose the initial repetition of the full pattern - match_fn <- function(string, pattern) { - stringr::str_match(string = string, pattern = pattern)[, -1] - } - res$Type.Match[idx] <- mapply(match_fn, string = die[idx], pattern = r$pattern, SIMPLIFY = FALSE) - } + if(any(idx)) res$Type[idx] <- r$name } # rest should be simple or none - idx <- stringr::str_detect(res$Die[is.na(res$Type)], simple$pattern) - res$Type[is.na(res$Type)][idx] <- simple$name + idx <- stringr::str_detect(res$Die[is.na(res$Type)], rollr:::simple$pattern) + res$Type[is.na(res$Type)][idx] <- rollr:::simple$name - idx <- stringr::str_detect(res$Die[is.na(res$Type)], none$pattern) - res$Type[is.na(res$Type)][idx] <- none$name + idx <- stringr::str_detect(res$Die[is.na(res$Type)], rollr:::none$pattern) + res$Type[is.na(res$Type)][idx] <- rollr:::none$name stopifnot(!anyNA(res$Type)) - return(res[, -1, drop = FALSE]) + + # match the pattern + # Could probably do in the previous loop by modification type (and would be faster), but a bit easier to control here. + # pattern can return more than one item; should be converted to a character vector + for(i in seq_len(length(die))) { + mod_type <- res$Type[[i]] + if(mod_type %in% c(simple$name, none$name)) next; + # if(is.na(mod_type)) next; # should not actually occur, as simple or none should pick up everything else + + pattern <- rollr:::dice_modification_types[[mod_type]]$pattern + res$Type.Match[[i]] <- stringr::str_match(string = res$Die[[i]], pattern = pattern)[,-1] + } + + return(res) } detect_success_test <- function(die) { res <- data.frame(Die = die, stringsAsFactors = FALSE) res$Success <- NA - res$Success.Match <- NA + res$Success.Match <- vector("list", length(die)) # to accommodate patterns that return multiple sub-matches - for(s in success_types) { + for(s in rollr:::success_types) { idx <- stringr::str_detect(die, s$pattern) - if(any(idx)) { - res$Success[idx] <- s$name - match_fn <- function(string, pattern) { - stringr::str_match(string = string, pattern = pattern)[, -1] - } + if(any(idx)) res$Success[idx] <- s$name + } - res$Success.Match[idx] <- mapply(match_fn, string = die[idx], pattern = s$pattern, SIMPLIFY = FALSE) - } + for(i in seq_len(length(die))) { + s_type <- res$Success[[i]] + if(is.na(s_type)) next; + pattern <- rollr:::success_types[[s_type]]$pattern + res$Success.Match[[i]] <- stringr::str_match(string = res$Die[[i]], pattern = pattern)[, -1] } - return(res[, -1, drop = FALSE]) + return(res) } # These should all probably be classes, or a single class with various values... +# Simple die patterns #### +# • None #### none <- list(name = "none", pattern = "^\\d+$", calculate = function(base_roll, ...) { base_roll } ) +# • Simple #### simple <- list(name = "simple", pattern = "^(\\d+)d(\\d+|f)", calculate = function(base_roll, ...) { base_roll } ) SIMPLE_DIE_PATTERN <- paste(simple$pattern, none$pattern, sep = "|") +# Modification patterns #### # don't use $ to close the pattern as the pattern may also contain success test # dots in the calculate argument permit additional arguments to be passed to some of the functions; otherwise ignored. +# • Keep highest #### keep_h <- list(name = "keep highest", pattern = "^\\d+d\\d+h(\\d+)", calculate = function(base_roll, match, i_str = "1", ...) { @@ -186,6 +197,7 @@ keep_h <- list(name = "keep highest", return(out) }) +# • Keep lowest #### keep_l <- list(name = "keep lowest", pattern = "^\\d+d\\d+l(\\d+)", calculate = function(base_roll, match, i_str = "1", ...) { @@ -194,6 +206,7 @@ keep_l <- list(name = "keep lowest", return(out) }) +# • Reroll #### reroll <- list(name = "reroll", pattern = "^\\d+d\\d+r(\\d+)", calculate = function(base_roll, match, sides, i_str = "1", ...) { @@ -203,12 +216,11 @@ reroll <- list(name = "reroll", if(any(idx)) { base_roll[idx] <- sample.int(sides, size = sum(idx), replace = TRUE) message(i_str, '. rerolling ', sum(idx), ' dice: ', paste(base_roll[idx], collapse = ', ')) - return(out) - } return(base_roll) }) +# • Double #### double <- list(name = "double", pattern = "^\\d+d\\d+t(\\d+)", calculate = function(base_roll, match, i_str = "1", ...) { @@ -217,28 +229,40 @@ double <- list(name = "double", if(any(idx)) { message(i_str, '. doubling ', sum(idx), ' dice: ', paste(base_roll[idx], collapse = ', ')) base_roll <- c(base_roll, rep.int(match, times = sum(idx))) - } return(base_roll) }) +# • Exploding #### exploding <- list(name = "exploding", - pattern = "^\\d+d\\d+\\!(?:[>](\\d+))?", + #pattern = "^\\d+d\\d+\\!(?:((?:>=|<=|>|<|=)\\d+))?", + pattern = "^\\d+d\\d+\\!(?:(>=|<=|>|<|=)(\\d+))?", calculate = function(base_roll, match, sides, i_str = "1", ...) { - match <- as.integer(match) + stopifnot(length(match) == 2) + sym <- match[[1]] + test_num <- as.integer(match[[2]]) sides <- as.integer(sides) - if(is.na(match)) { - explode_test <- sides + + if(is.na(test_num)) { + # explode if the die equals the highest potential roll + test_num <- sides + FUN <- get("==", envir = parent.frame(), mode = "function") } else { - explode_test <- match:sides + # test could be >=, <=, >, <, or = + # = must be converted to == + stopifnot(sym %in% c(">=", "<=", ">", "<", "=")) + if(sym == "=") sym <- "==" + FUN <- get(sym, envir = parent.frame(), mode = "function") + + if(sym == ">=" && test_num == 1) stop("Exploding would cause an infinite loop.") + if(sym == "<=" && test_num == sides) stop("Exploding would cause an infinite loop.") } - stopifnot(length(explode_test) < sides) # don't want an infinite loop where every die result explodes - num_exploded <- sum(base_roll %in% explode_test) + num_exploded <- sum(FUN(base_roll, test_num)) while(num_exploded > 0) { new_roll <- sample.int(sides, size = num_exploded, replace = TRUE) message(i_str, ". exploding ", num_exploded, " dice. New roll(s): ", paste(new_roll, collapse = ", ")) - num_exploded <- sum(new_roll %in% explode_test) + num_exploded <- sum(FUN(new_roll, test_num)) base_roll <- c(base_roll, new_roll) } return(base_roll) @@ -247,16 +271,23 @@ exploding <- list(name = "exploding", dice_modification_types <- list(keep_h, keep_l, reroll, double, exploding) names(dice_modification_types) <- sapply(dice_modification_types, function(x) x$name) - +# Success patterns #### +# • Greater/Less Than #### ge_success <- list(name = "success ge", - pattern = "[>][=](\\d+)$", + pattern = "[^!]([><][=]?)(\\d+)$", calculate = function(base_roll, match, i_str = "1", ...) { - out <- sum(base_roll >= as.integer(match)) + stopifnot(length(match) == 2, + match[[1]] %in% c(">=", "<=", ">", "<")) + test_num <- as.integer(match[[2]]) + FUN <- get(match[[1]], envir = parent.frame(), mode = "function") + out <- sum(FUN(base_roll, test_num)) message(i_str, ". Number of successes: ", out) out }) + +# • Equality #### equal_success <- list(name = "success equal", - pattern = "[^>][=](\\d+)$", + pattern = "[^!><][=](\\d+)$", calculate = function(base_roll, match, i_str = "1", ...) { out <- sum(base_roll == as.integer(match)) message(i_str, ". Number of successes: ", out) @@ -264,107 +295,3 @@ equal_success <- list(name = "success equal", }) success_types <- list(ge_success, equal_success) names(success_types) <- sapply(success_types, function(x) x$name) - -# no_dice = list(pattern = "^\\d+$", -# compute = function(match) { -# result = match[1] -# return(result) -# }) -# -# simple = list(pattern = "^(\\d+)[dD](\\d+)$", -# compute = function(match) { -# n = match[2] -# sides = match[3] -# rolls = sample(1:sides, n, replace = TRUE) -# message('rolls: ', paste(rolls, collapse = ', ')) -# result = sum(rolls) -# }) -# -# keep_h = list(pattern = "^(\\d+)[dD](\\d+)[Hh](\\d+)$", -# compute = function(match) { -# n = match[2] -# sides = match[3] -# kept = match[4] -# rolls = sample(1:sides, n, replace = TRUE) -# message('rolls: ', paste(rolls, collapse = ', ')) -# kept_dice = sort(rolls, decreasing = T)[1:as.numeric(kept)] -# message('keeping ',kept, " highest(s): ", paste(kept_dice, collapse = ', ')) -# result = sum(kept_dice) -# }) -# -# keep_l = list(pattern = "^(\\d+)[dD](\\d+)[Ll](\\d+)$", -# compute = function(match) { -# n = match[2] -# sides = match[3] -# kept = match[4] -# rolls = sample(1:sides, n, replace = TRUE) -# message('rolls: ', paste(rolls, collapse = ', ')) -# kept_dice = sort(rolls)[1:as.numeric(kept)] -# message('keeping ',kept, " lowest(s): ", paste(kept_dice, collapse = ', ')) -# result = sum(kept_dice) -# }) -# -# exploding = list(pattern ="^(\\d+)[dD](\\d+)\\!$", -# compute = function(match) { -# n = match[2] -# sides = match[3] -# rolls = sample(1:sides, n, replace = TRUE) -# explode = rolls[rolls == sides] -# message('rolls: ', paste(rolls, collapse = ', ')) -# message("exploding ", length(explode),' dice...') -# while (length(explode) != 0) { -# new_rolls = sample(1:sides, length(explode), replace = TRUE) -# message('new rolls : ', paste(new_rolls, collapse = ', ')) -# rolls = c(rolls, new_rolls) -# explode = new_rolls[new_rolls==sides] -# if (length(explode) != 0) { message("exploding ", length(explode),' dice...') } -# } -# result = sum(rolls) -# }) -# -# reroll = list(pattern = "^(\\d+)[dD](\\d+)[rR](\\d+)$", -# compute = function(match) { -# n = match[2] -# sides = match[3] -# to_reroll = match[4] -# rolls = sample(1:sides, n, replace = TRUE) -# message('rolls: ', paste(rolls, collapse = ', ')) -# reroll = rolls[rolls == to_reroll] -# message("rerolling ",length(reroll),' dice') -# while (length(reroll) != 0) { -# new_rolls = sample(1:sides, length(reroll), replace = TRUE) -# message('new rolls : ', paste(new_rolls, collapse = ', ')) -# rolls[rolls == to_reroll] = new_rolls -# reroll = rolls[rolls == to_reroll] -# if (length(reroll) != 0) { message("rerolling ",length(reroll),' dice')} -# } -# result = sum(rolls) -# }) -# -# success = list(pattern = "^(\\d+)[dD](\\d+) ?([<>]?=?) ?(\\d+)$", -# compute = function(match) { -# n = match[2] -# sides = match[3] -# comparator = match[4] -# if (comparator == "=") {comparator="=="} -# threshold = match[5] -# rolls = sample(1:sides, n, replace = TRUE) -# message('rolls: ', paste(rolls, collapse = ', ')) -# success = eval(parse(text = paste("rolls[rolls",comparator,"threshold]"))) -# result = length(success) -# message('number of success: ', -# result , -# ' (', paste(sort(success,decreasing = TRUE), collapse = ', '),')') -# return(result) -# }) -# -# roll_types = list( -# no_dice = no_dice, -# simple = simple, -# keep_h = keep_h, -# keep_l = keep_l, -# exploding = exploding, -# reroll = reroll, -# success = success, -# reroll = reroll -# ) diff --git a/R/rolltable_class.R b/R/rolltable_class.R index f55eaca..80509ad 100644 --- a/R/rolltable_class.R +++ b/R/rolltable_class.R @@ -26,6 +26,10 @@ #' result <- rolltable("2d20h1", repetitions = 1000) > rolltable("2d20l1", repetitions = 1000) #' summary(result[[1]]) #' +#' # convert to dataframe +#' as.data.frame(rolltable("2d20h1", repetitions = 10)) +#' as.data.frame(rolltable(c("1d6", "2d6", "3d6", "4d6"), repetitions = 2)) +#' rolltable <- function(cmd, repetitions = 1, verbose = FALSE) { cmd <- tolower(cmd) # avoid needing to check for a bunch of capital letters error_txt <- "Rolltable only accepts single dice set commands (e.g., '2d6!', not '2d6! + 20'. To add, subtract, or use other mathematical symbols either apply the symbol to rolltables directly or use roll_dice." @@ -235,76 +239,3 @@ trim_numeric_string <- function(str, digits = 2) { stringr::str_replace_all(str, pattern = p, replacement = "\\1\\2") } - - -# Ops.rolltable <- function(e1, e2 = NULL) { -# # mostly copied from Ops.data.frame -# unary <- nargs() == 1L -# lclass <- nzchar(.Method[1L]) -# rclass <- !unary && (nzchar(.Method[2L])) -# FUN <- get(.Generic, envir = parent.frame(), mode = "function") -# f <- if (unary) { quote(FUN(left)) } else { quote(FUN(left, right)) } -# -# if(lclass && rclass) { -# # both e1 and e2 are rolltables -# # conform repetitions -# if(repetitions(e1) != repetitions(e2)) { -# warning("Number of repetitions do not match. They will be increased accordingly, which will cause the smaller table to be rerolled.") -# n_reps <- max(repetitions(e1), repetitions(e2)) -# if(repetitions(e1) != n_reps) e1 <- roll(e1, repetitions = n_reps) -# if(repetitions(e2) != n_reps) e2 <- roll(e2, repetitions = n_reps) -# } -# } else if(lclass) { -# # e1 is a rolltable -# if(!unary) { -# if(!(is.numeric(e2) | is.logical(e2) | is.integer(e2))) stop("Operation is only defined for numeric vectors.") -# if(length(e2) > 1 & length(e2) != repetitions(e1)) { -# warning("Number of repetitions do not match the size of the numeric vector. Repetitions will be changed accordingly, which will cause the table to be rerolled.") -# e1 <- roll(e1, repetitions = length(e2)) -# } -# -# } -# -# } else if(rclass) { -# # e2 is a rolltable -# if(!unary) { -# if(!(is.numeric(e1) | is.logical(e1) | is.integer(e1))) stop("Operation is only defined for numeric vectors.") -# if(length(e1) > 1 & length(e1) != repetitions(e2)) { -# warning("Number of repetitions do not match the size of the numeric vector. Repetitions will be changed accordingly, which will cause the table to be rerolled.") -# e2 <- roll(e2, repetitions = length(e1)) -# } -# } -# -# } else stop("Should not be here.") -# -# # apply the function -# if(unary) { -# left <- calculate(e1) -# -# } else if(lclass && rclass) { -# # both e1 and e2 are rolltables -# left <- calculate(e1) -# right <- calculate(e2) -# -# } else if(lclass) { -# # e1 is a rolltable -# left <- calculate(e1) -# right <- e2 -# -# } else if(rclass) { -# # e2 is a rolltable -# left <- e1 -# right <- calculate(e2) -# } -# -# # value <- eval(f) -# # eval(f) -# # return(.Generic) -# -# return(paste(class(e1), .Generic, class(e2))) -# # return(list(method_one = .Method[1L], -# # method_two = .Method[2L])) -# -# } - - diff --git a/man/infinite_letters.Rd b/man/infinite_letters.Rd new file mode 100644 index 0000000..9e1e9d5 --- /dev/null +++ b/man/infinite_letters.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/roll_dice.R +\name{infinite_letters} +\alias{infinite_letters} +\title{Helper function to create names using only letters, not numbers +So that a command can be substituted without accidentally overwriting the number. +For example, subbing "1d6 + 1" with tbls[[1]] and tbls[[2]] needs to result in tbls[[1]] + tbls[[2]] +But instead will result in tbls[[tbls[[2]]]] + 1} +\usage{ +infinite_letters(n) +} +\description{ +Helper function to create names using only letters, not numbers +So that a command can be substituted without accidentally overwriting the number. +For example, subbing "1d6 + 1" with tbls[[1]] and tbls[[2]] needs to result in tbls[[1]] + tbls[[2]] +But instead will result in tbls[[tbls[[2]]]] + 1 +} diff --git a/tests/testthat/test-roll_dice.R b/tests/testthat/test-roll_dice.R index 929ec2f..e1b0f38 100644 --- a/tests/testthat/test-roll_dice.R +++ b/tests/testthat/test-roll_dice.R @@ -2,30 +2,43 @@ test_that("roll dice with addition works", { set.seed(42) roll = roll_dice("1d6+1") - expect_true(roll == 2) + expect_true(as.numeric(roll) == 2) }) test_that("roll with substraction", { set.seed(42) roll = roll_dice("1d100-20") - expect_true(roll == 29) + expect_true(as.numeric(roll) == 29) }) test_that("addition of rolls works", { set.seed(42) roll = roll_dice("1d4+1d6+1d8+1d10") - expect_true(roll == 16) + expect_true(as.numeric(roll) == 16) }) test_that("substraction of rolls works", { set.seed(42) roll = roll_dice("1d100-1d20") - expect_true(roll == 44) + expect_true(as.numeric(roll) == 44) }) -test_that("print history works",{ +test_that("parentheticals work", { set.seed(42) - expect_message(roll_dice("1d100",roll_history = TRUE)) + roll = roll_dice("(1d4+1d6)*20+(1d8+1d10)/2") + expect_true(as.numeric(roll) == 125) +}) + +test_that("verbose works",{ + set.seed(42) + expect_message(roll_dice("1d100",verbose = TRUE)) +}) + +test_that("roll history works", { + set.seed(42) + roll = roll_dice("8d6!", roll_history = TRUE) + expect_named(roll, c("result", "roll_history")) + expect_equal(roll$result, calculate(roll$roll_history$`8d6!`)) }) diff --git a/tests/testthat/test-roll_one.R b/tests/testthat/test-roll_one.R deleted file mode 100644 index 2658c7d..0000000 --- a/tests/testthat/test-roll_one.R +++ /dev/null @@ -1,53 +0,0 @@ -test_that("simple roll works", { - set.seed(42) - roll1 = roll_one("1d6") - roll2 = roll_one("1d6") - - expect_true(roll1 == 1) - expect_true(roll2 == 5) -}) - -test_that("keep highest works",{ - set.seed(42) - roll = roll_one("10d10h2") - expect_equal(roll, 20) - }) - -test_that("keep lowest works",{ - set.seed(42) - roll = roll_one("10d10l2") - expect_equal(roll, 2) -}) - -test_that("exploding dice works", { - set.seed(42) - roll = roll_one("5d10!") - expect_equal(roll,30) -}) - -test_that("reroll dice works",{ - set.seed(42) - roll = roll_one("10d6r1") - expect_equal(roll,36) -}) - - -test_that("sucess dice works",{ - set.seed(42) - roll = roll_one("6d6>4") - expect_equal(roll,1) - roll = roll_one("6d6>=4") - expect_equal(roll, 2) - roll = roll_one("6d6<3") - expect_equal(roll, 3) - roll = roll_one("6d6<=2") - expect_equal(roll, 1) - roll = roll_one("6d6=4") - expect_equal(roll, 2) -}) - -test_that("warning works",{ - set.seed(42) - expect_warning(roll_one("wrong_syntax")) -}) - diff --git a/tests/testthat/test-rolltable.R b/tests/testthat/test-rolltable.R new file mode 100644 index 0000000..83cf71a --- /dev/null +++ b/tests/testthat/test-rolltable.R @@ -0,0 +1,64 @@ +test_that("simple roll works", { + set.seed(42) + roll1 = as.numeric(calculate(rolltable("1d6"))) + roll2 = as.numeric(calculate(rolltable("1d6"))) + + expect_true(roll1 == 1) + expect_true(roll2 == 5) +}) + +test_that("keep highest works",{ + set.seed(42) + roll = as.numeric(calculate(rolltable(("10d10h2")))) + expect_equal(roll, 20) + }) + +test_that("keep lowest works",{ + set.seed(42) + roll = as.numeric(calculate(rolltable("10d10l2"))) + expect_equal(roll, 2) +}) + +test_that("exploding dice works", { + set.seed(42) + roll = as.numeric(calculate(rolltable("5d10!"))) + expect_equal(roll,30) + roll = as.numeric(calculate(rolltable("10d10!>8"))) + expect_equal(roll, 87) +}) + +test_that("reroll dice works",{ + set.seed(42) + roll = as.numeric(calculate(rolltable("10d6r1"))) + expect_equal(roll,35) +}) + +test_that("doubling dice works",{ + set.seed(42) + roll = as.numeric(calculate(rolltable("10d6t1"))) + expect_equal(roll,27) +}) + + + +test_that("success dice works",{ + set.seed(42) + roll = as.numeric(calculate(rolltable("6d6>4"))) + expect_equal(roll,1) + roll = as.numeric(calculate(rolltable("6d6>=4"))) + expect_equal(roll, 2) + roll = as.numeric(calculate(rolltable("6d6<3"))) + expect_equal(roll, 3) + roll = as.numeric(calculate(rolltable("6d6<=2"))) + expect_equal(roll, 1) + roll = as.numeric(calculate(rolltable("6d6=4"))) + expect_equal(roll, 2) + roll = as.numeric(calculate(rolltable("6d6!>5=6"))) + expect_equal(roll, 3) +}) + +test_that("error works",{ + set.seed(42) + expect_error(rolltable("wrong_syntax")) +}) + From e05f78ac75ca423674835df5b9d05d0899456da6 Mon Sep 17 00:00:00 2001 From: Michael Enion Date: Fri, 10 Jul 2020 16:32:26 +0000 Subject: [PATCH 10/10] Updates to pass check package tests. Mostly improvements to documentation of parameters; conform inherited methods. --- NAMESPACE | 2 + R/evaluate_roll_cmd.R | 57 --------- R/roll_dice.R | 5 +- R/roll_one.R | 51 +++----- R/rolltable_calculation_class.R | 2 + R/rolltable_class.R | 147 ++++++++++++++++-------- man/Ops.rollr.Rd | 5 + man/calculate.Rd | 11 +- man/calculate.rolltable.Rd | 21 ++++ man/evaluate_roll_cmd.Rd | 18 --- man/infinite_letters.Rd | 6 + man/max.rolltable.Rd | 6 +- man/mean.rolltable.Rd | 4 +- man/median.rolltable.Rd | 6 +- man/min.rolltable.Rd | 6 +- man/new_rolltable.Rd | 8 ++ man/new_rolltable_calculation.Rd | 2 + man/parse_result.Rd | 19 +++ man/print.rolltable.Rd | 6 +- man/repetitions.Rd | 2 + man/roll.Rd | 16 +-- man/roll.rolltable.Rd | 27 +++++ man/roll_one.Rd | 17 --- man/rolltable.Rd | 4 + man/trim_numeric_string.Rd | 11 -- tests/testthat/test-evaluate_roll_cmd.R | 3 - 26 files changed, 245 insertions(+), 217 deletions(-) delete mode 100644 R/evaluate_roll_cmd.R create mode 100644 man/calculate.rolltable.Rd delete mode 100644 man/evaluate_roll_cmd.Rd create mode 100644 man/parse_result.Rd create mode 100644 man/roll.rolltable.Rd delete mode 100644 man/roll_one.Rd delete mode 100644 man/trim_numeric_string.Rd delete mode 100644 tests/testthat/test-evaluate_roll_cmd.R diff --git a/NAMESPACE b/NAMESPACE index 996cb3e..9a85136 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -16,3 +16,5 @@ export(repetitions) export(roll) export(roll_dice) export(rolltable) +importFrom(stats,median) +importFrom(utils,combn) diff --git a/R/evaluate_roll_cmd.R b/R/evaluate_roll_cmd.R deleted file mode 100644 index 31406ad..0000000 --- a/R/evaluate_roll_cmd.R +++ /dev/null @@ -1,57 +0,0 @@ -#' A complex roll resolution -#' -#' @description The complex roll resolution function evaluates each elements of a complex -#' roll command and compute their total result -#' -#' @param parsed_cmd a list of dice and operators as returned by parse_roll_cmd. -#' -#' @return roll result. -#' -evaluate_roll_cmd <- function(parsed_cmd){ - final_result <- NA - - for (i in 1:length(parsed_cmd$dice)) { - result <- roll_one(parsed_cmd$dice[i]) - if (is.na(final_result)) { - final_result = result - } else { - final_result = eval(parse(text = paste(final_result, parsed_cmd$operators[i-1], result))) - } - } - - return(final_result) -} - - - - - -roll_set <- function(parsed_cmd, repetitions) { - dice_tbls <- lapply(parsed_cmd$dices, construct_dice_table) - - calculated_dice_tbls <- lapply(dice_tbls, function(tbl, n) { do.call(rbind, replicate(n, calculate_dice_table(tbl), simplify = FALSE)) }, - n = repetitions) - names(calculated_dice_tbls) <- parsed_cmd$dices - - result <- parse_result(calculated_dice_tbls, operators = parsed_cmd$operators) - - return(list(calculated_dice_tbls = calculated_dice_tbls, - operators = parsed_cmd$operators, - result = result)) -} - -parse_result <- function(tbl, .summary_fn = identity) { - # result is a list one longer than operators - # Each result element is a table with 1 or more rows for a single set of dice rolls - # first choose either the calculated roll or success if available, and sum - tbl$Result <- tbl$Calculated.Roll - success_idx <- !sapply(tbl$Success.Outcome, is.na) - tbl$Result[success_idx] <- tbl$Success.Outcome[success_idx] - - # sum each set of dice rolls or successes - tbl$Result <- sapply(tbl$Result, sum, na.rm = TRUE) - - # summarize by die type if more than one type - by(tbl$Result, INDICES = tbl$Die, FUN = .summary_fn) -} - diff --git a/R/roll_dice.R b/R/roll_dice.R index 130e56f..818ebc2 100644 --- a/R/roll_dice.R +++ b/R/roll_dice.R @@ -89,7 +89,7 @@ roll_dice <- function(cmd, roll_history=FALSE, repetitions = 1, verbose = FALSE) } # parse the command and create a roll table for each dices. - parsed_cmd <- rollr:::parse_roll_cmd(cmd) + parsed_cmd <- parse_roll_cmd(cmd) tbls <- lapply(parsed_cmd$dices, rolltable, repetitions = repetitions, verbose = verbose) # names(tbls) <- parsed_cmd$dices @@ -118,6 +118,9 @@ roll_dice <- function(cmd, roll_history=FALSE, repetitions = 1, verbose = FALSE) #' So that a command can be substituted without accidentally overwriting the number. #' For example, subbing "1d6 + 1" with tbls[[1]] and tbls[[2]] needs to result in tbls[[1]] + tbls[[2]] #' But instead will result in tbls[[tbls[[2]]]] + 1 +#' @param n Number of distinct names required +#' @return a character vector of unique names +#' @importFrom utils combn infinite_letters <- function(n) { max_n <- 0 k <- 0 diff --git a/R/roll_one.R b/R/roll_one.R index 61f1feb..73b48f5 100644 --- a/R/roll_one.R +++ b/R/roll_one.R @@ -1,38 +1,19 @@ -#' Roll One -#' -#' @description Roll one die from string command. -#' -#' @param roll a string corresponding to a roll command. -#' -#' @return result of the roll -roll_one <- function(roll){ - for (r in roll_types) { # we try rolls patterns one by one - detected = stringr::str_detect(roll,r$pattern) - if (detected) { # when a pattern matches - match = stringr::str_match(roll, r$pattern) - result = r$compute(match) # it is possible to make the roll and apply its rules - return(result) - } - } - warning("This roll command is not recognized") -} - # should be able to handle all of the following, in one go # die <- tolower(c("1d6", "10d6", "20d20", "10", "2d20h1", "3d10h2", "2d20l1", "1d20r1", "3d6!", "2d6>=5", "4d6=5", "4dF", "1d10!>9", "3d10!>=8", "1d10t10")) construct_dice_table <- function(die) { cbind(Die = die, Repetition = 1, - rollr:::detect_dice(die), - rollr:::detect_dice_type(die)[,-1], # lose the Die column - rollr:::detect_success_test(die)[,-1], # lose the Die column + detect_dice(die), + detect_dice_type(die)[,-1], # lose the Die column + detect_success_test(die)[,-1], # lose the Die column stringsAsFactors = FALSE) } calculate_dice_table <- function(dice_tbl, verbose = FALSE) { - dice_tbl <- rollr:::roll_base_dice(dice_tbl) - dice_tbl <- rollr:::calculate_types(dice_tbl) - dice_tbl <- rollr:::calculate_successes(dice_tbl) + dice_tbl <- roll_base_dice(dice_tbl) + dice_tbl <- calculate_types(dice_tbl) + dice_tbl <- calculate_successes(dice_tbl) return(dice_tbl) } @@ -95,9 +76,9 @@ calculate_successes <- function(dice_tbl) { iteration_s <- paste0("%0", ceiling(nrow(dice_tbl) / 10), "d") for(i in seq_len(nrow(dice_tbl))) { type <- dice_tbl$Success[[i]] - if(dice_tbl$Success[[i]] %in% names(rollr:::success_types) & !is.na(dice_tbl$Success[[i]])) { + if(dice_tbl$Success[[i]] %in% names(success_types) & !is.na(dice_tbl$Success[[i]])) { i_str <- sprintf(iteration_s, i) - calculation_fn <- rollr:::success_types[[type]]$calculate + calculation_fn <- success_types[[type]]$calculate dice_tbl$Success.Outcome[[i]] <- calculation_fn(base_roll = dice_tbl$Calculated.Roll[[i]], match = dice_tbl$Success.Match[[i]], i_str = i_str) @@ -122,17 +103,17 @@ detect_dice_type <- function(die) { res$Type <- NA res$Type.Match <- vector("list", length(die)) # to accommodate patterns that return multiple sub-matches - for(r in rollr:::dice_modification_types) { + for(r in dice_modification_types) { idx <- stringr::str_detect(die, pattern = r$pattern) if(any(idx)) res$Type[idx] <- r$name } # rest should be simple or none - idx <- stringr::str_detect(res$Die[is.na(res$Type)], rollr:::simple$pattern) - res$Type[is.na(res$Type)][idx] <- rollr:::simple$name + idx <- stringr::str_detect(res$Die[is.na(res$Type)], simple$pattern) + res$Type[is.na(res$Type)][idx] <- simple$name - idx <- stringr::str_detect(res$Die[is.na(res$Type)], rollr:::none$pattern) - res$Type[is.na(res$Type)][idx] <- rollr:::none$name + idx <- stringr::str_detect(res$Die[is.na(res$Type)], none$pattern) + res$Type[is.na(res$Type)][idx] <- none$name stopifnot(!anyNA(res$Type)) @@ -144,7 +125,7 @@ detect_dice_type <- function(die) { if(mod_type %in% c(simple$name, none$name)) next; # if(is.na(mod_type)) next; # should not actually occur, as simple or none should pick up everything else - pattern <- rollr:::dice_modification_types[[mod_type]]$pattern + pattern <- dice_modification_types[[mod_type]]$pattern res$Type.Match[[i]] <- stringr::str_match(string = res$Die[[i]], pattern = pattern)[,-1] } @@ -156,7 +137,7 @@ detect_success_test <- function(die) { res$Success <- NA res$Success.Match <- vector("list", length(die)) # to accommodate patterns that return multiple sub-matches - for(s in rollr:::success_types) { + for(s in success_types) { idx <- stringr::str_detect(die, s$pattern) if(any(idx)) res$Success[idx] <- s$name } @@ -164,7 +145,7 @@ detect_success_test <- function(die) { for(i in seq_len(length(die))) { s_type <- res$Success[[i]] if(is.na(s_type)) next; - pattern <- rollr:::success_types[[s_type]]$pattern + pattern <- success_types[[s_type]]$pattern res$Success.Match[[i]] <- stringr::str_match(string = res$Die[[i]], pattern = pattern)[, -1] } diff --git a/R/rolltable_calculation_class.R b/R/rolltable_calculation_class.R index 13baf8f..d16dab7 100644 --- a/R/rolltable_calculation_class.R +++ b/R/rolltable_calculation_class.R @@ -5,6 +5,7 @@ #' Typically, this function is not needed by the user, who instead should rely on \code{\link{calculate}}. #' #' @param lst A list object returned using the "by" function. +#' @param n Names to use for the returned object, if the lst is not already named. #' @return A rolltable_calculation classed object. #' #' @export @@ -33,6 +34,7 @@ repetitions.rolltable_calculation <- function(tbl, ...) { length(tbl[[1]]) } #' Repetitions will be increased to match, which will cause the rolltable to be rerolled. #' If dies differ within a rolltable, each will be treated separately. #' +#' @inheritParams base::groupGeneric #' @export Ops.rollr <- function(e1, e2 = NULL) { # The rollr class is used similarly to how POSIXt class is used, to permit operations on rolltables or rolltable calculations, or both. diff --git a/R/rolltable_class.R b/R/rolltable_class.R index 80509ad..3935b84 100644 --- a/R/rolltable_class.R +++ b/R/rolltable_class.R @@ -39,11 +39,11 @@ rolltable <- function(cmd, repetitions = 1, verbose = FALSE) { ln <- sapply(parsed_cmd["dices",], length) if(any(ln > 1)) stop(error_txt) } else { - parsed_cmd <- rollr:::parse_roll_cmd(cmd) + parsed_cmd <- parse_roll_cmd(cmd) if(length(parsed_cmd$dices) > 1) stop(error_txt) } - tbl <- rollr:::new_rolltable(tbl = rollr:::construct_dice_table(cmd), + tbl <- new_rolltable(tbl = construct_dice_table(cmd), cmd = cmd) roll(tbl, repetitions = repetitions, verbose = verbose) } @@ -52,6 +52,10 @@ rolltable <- function(cmd, repetitions = 1, verbose = FALSE) { #' #' Internal function to build the rolltable class structure. #' Minimal checks for validity. +#' +#' @param cmd Character vetor. Intended to be one or more dice set commands. +#' @param tbl Dataframe to convert to rolltable. +#' @return Rolltable class object. new_rolltable <- function(cmd, tbl) { stopifnot(is.data.frame(tbl)) stopifnot(is.character(cmd)) @@ -65,58 +69,97 @@ new_rolltable <- function(cmd, tbl) { #' Roll Method #' -#' Takes a rolltable and rolls to create a new set of results, using one or more repetitions. +#' Method for rolling dice. #' -#' @param tbl A rolltable class. +#' @param obj Object to roll +#' @param ... For use by class methods +#' @return An updated rolltable. +#' @export +#' + +roll <- function(obj, ...) { UseMethod("roll") } + + +#' Roll or reroll a rolltable +#' +#' Any existing repetitions will be removed and all rolls re-done. +#' @param obj A rolltable. #' @param repetitions Number of times to roll the command. #' @param verbose If TRUE, dice roll details are visible in the console. -#' @return An updated rolltable. +#' @param ... Unused. #' @export #' #' @examples #' -#' tbl <- rolltable("2d20h1 + 20"); tbl +#' tbl <- rolltable("2d20h1"); tbl #' roll(tbl, repetitions = 3) #' roll(tbl, repetitions = 2, verbose = TRUE) -roll <- function(tbl, ...) { UseMethod("roll") } - -#' @export -roll.rolltable <- function(tbl, repetitions = 1, verbose = FALSE) { - calc_fn <- ifelse(verbose, rollr:::calculate_dice_table, function(...) suppressMessages(rollr:::calculate_dice_table(...))) +#' +roll.rolltable <- function(obj, repetitions = 1, verbose = FALSE, ...) { + calc_fn <- ifelse(verbose, calculate_dice_table, function(...) suppressMessages(calculate_dice_table(...))) # add repetitions, if any - n_orig <- length(attr(tbl, "command")) - rollhist <- tbl[rep(1:n_orig, each = repetitions), , drop = FALSE] + n_orig <- length(attr(obj, "command")) + rollhist <- obj[rep(1:n_orig, each = repetitions), , drop = FALSE] rollhist$Repetition <- rep(1:repetitions, times = n_orig) calc_fn(rollhist) } #' Method to calculate the current value of a rolltable #' -#' For each repetition in the rolltable, summarizes each dice set and -#' applies the operators in turn. -#' -#' @param tbl A rolltable class. -#' @param .summary_fn Function used to summarize results between repetitions. Default returns each repetition separately. +#' @param obj Table to calculate, such as a rolltable. +#' @param ... For use by class methods #' @return A numeric vector whose names are the individual sums for each dice set. #' @export #' #' @examples #' -#' tbl <- rolltable("2d20h1 + 20") +#' tbl <- rolltable("2d20h1") #' calculate(tbl) #' calculate(tbl, .summary_fn = "median") -calculate <- function(tbl, ...) { UseMethod("calculate") } +calculate <- function(obj, ...) { UseMethod("calculate") } +#' Calculate a rolltable +#' +#' Summarizes the provided summary function over repetitions, groups by Die if more than one in the table. +#' +#' @param obj A rolltable. +#' @param .summary_fn A character string providing the name of a summary function, such as mean or median, or the function itself. +#' @param ... Unused. +#' @return A rolltable_calculation. #' @export -calculate.rolltable <- function(tbl, .summary_fn = "identity") { - out <- parse_result(tbl, .summary_fn = get(.summary_fn)) +calculate.rolltable <- function(obj, .summary_fn = "identity", ...) { + if(is.character(.summary_fn)) .summary_fn <- get(.summary_fn, envir = parent.frame(), mode = "function") + + out <- parse_result(obj, .summary_fn = .summary_fn) new_rolltable_calculation(out) } +#' Helper function for calculate to apply a summary function to a rolltable. +#' @param tbl Rolltable +#' @param .summary_fn A summary function to apply +#' @return A summarized result generated using the by function. +parse_result <- function(tbl, .summary_fn = identity) { + stopifnot(inherits(tbl, "rolltable")) + # result is a list one longer than operators + # Each result element is a table with 1 or more rows for a single set of dice rolls + # first choose either the calculated roll or success if available, and sum + tbl$Result <- tbl$Calculated.Roll + success_idx <- !sapply(tbl$Success.Outcome, is.na) + tbl$Result[success_idx] <- tbl$Success.Outcome[success_idx] + + # sum each set of dice rolls or successes + tbl$Result <- sapply(tbl$Result, sum, na.rm = TRUE) + + # summarize by die type if more than one type + by(tbl$Result, INDICES = tbl$Die, FUN = .summary_fn) +} + + #' Number of repetitions in a rolltable #' #' @param tbl A rolltable class. +#' @param ... For use by class methods. #' @return Integer value indicating the number of repetitions. #' @export repetitions <- function(tbl, ...) { UseMethod("repetitions") } @@ -130,9 +173,10 @@ repetitions.rolltable <- function(tbl, ...) { max(tbl$Repetition) } #' Calculates the total by applying the operators to each average. #' #' @param x A rolltable class. +#' @param ... Unused. #' @return A numeric vector whose names are the individual means for each dice set. #' @export -mean.rolltable <- function(x) { +mean.rolltable <- function(x, ...) { calculate(x, .summary_fn = "mean") } @@ -142,9 +186,12 @@ mean.rolltable <- function(x) { #' Calculates the total by applying the operators to each median value. #' #' @param x A rolltable class. +#' @param na.rm Unused. For consistency with \code{\link[stats]{median}}. +#' @param ... Unused. For consistency with \code{\link[stats]{median}}. #' @return A numeric vector whose names are the individual means for each dice set. #' @export -median.rolltable <- function(x, na.rm = FALSE) { +#' @importFrom stats median +median.rolltable <- function(x, na.rm = FALSE, ...) { calculate(x, .summary_fn = "median") } @@ -155,11 +202,14 @@ median.rolltable <- function(x, na.rm = FALSE) { #' Determines the minimum over repetitions for the rolls. #' Calculates the total by applying the operators to each minimum. #' -#' @param tbl A rolltable class. +#' @param ... A rolltable class. +#' @param na.rm Unused. For consistency with \code{\link[base]{min}}. #' @return A numeric vector whose names are the individual minimums for each dice set. #' @export -min.rolltable <- function(tbl, ..., na.rm = FALSE) { - calculate(tbl, .summary_fn = "min") +min.rolltable <- function(..., na.rm = FALSE) { + args <- list(...) + if(length(args) > 1) stop("Min for rolltables currently does not handle multiple arguments.") + calculate(args[[1]], .summary_fn = "min") } #' Max rolltable @@ -167,33 +217,37 @@ min.rolltable <- function(tbl, ..., na.rm = FALSE) { #' Determines the maximum over repetitions for the rolls. #' Calculates the total by applying the operators to each maximum. #' -#' @param tbl A rolltable class. +#' @param ... A rolltable class. +#' @param na.rm Unused. For consistency with \code{\link[base]{min}}. #' @return A numeric vector whose names are the individual maximums for each dice set. #' @export -max.rolltable <- function(tbl, ..., na.rm = FALSE) { - calculate(tbl, .summary_fn = "max") +max.rolltable <- function(..., na.rm = FALSE) { + args <- list(...) + if(length(args) > 1) stop("Max for rolltables currently does not handle multiple arguments.") + calculate(args[[1]], .summary_fn = "max") } #' Print a rolltable #' -#' @param tbl A rolltable class. +#' @param x A rolltable class. #' @param n Number of repetitions to print. #' @param rolls If TRUE, print the base rolls and modifications to rolls, such as keep highest or exploding. #' @param digits Round numbers to this number of digits when printing. +#' @param ... Unused. #' @export -print.rolltable <- function(tbl, n = 10, rolls = FALSE, digits = 1, ...) { - res <- mean(tbl) - repetitions <- max(tbl$Repetition) +print.rolltable <- function(x, n = 10, rolls = FALSE, digits = 1, ...) { + res <- mean(x) + repetitions <- max(x$Repetition) # format so that the dice and means line up. res <- round(res, digits = digits) - field_widths <- pmax(nchar(attr(tbl, "command")), + field_widths <- pmax(nchar(attr(x, "command")), nchar(res)) field_s <- paste(paste0("%", field_widths, "s"), collapse = " ") field_f <- paste(paste0("%", field_widths, ".", digits, "f"), collapse = " ") - cat("Dice:", do.call(sprintf, args = c(list(fmt = field_s), as.list(attr(tbl, "command")))), "\n") + cat("Dice:", do.call(sprintf, args = c(list(fmt = field_s), as.list(attr(x, "command")))), "\n") cat("Mean:", do.call(sprintf, args = c(list(fmt = field_f), as.list(res))), "\n") cat("======\n") @@ -211,18 +265,18 @@ print.rolltable <- function(tbl, n = 10, rolls = FALSE, digits = 1, ...) { max_repetition <- min(repetitions, n) iteration_s <- paste0("%0", ceiling(max_repetition / 10), "d") - for(i in seq_len(nrow(tbl))) { - if(tbl$Repetition[[i]] > max_repetition) next; + for(i in seq_len(nrow(x))) { + if(x$Repetition[[i]] > max_repetition) next; cat("----------\n") - i_str <- sprintf(iteration_s, tbl$Repetition[[i]]) - cat(sprintf("%s. %s base rolls: %s\n", i_str, tbl$Die[[i]], paste(tbl$Base.Roll[[i]], collapse = ", "))) + i_str <- sprintf(iteration_s, x$Repetition[[i]]) + cat(sprintf("%s. %s base rolls: %s\n", i_str, x$Die[[i]], paste(x$Base.Roll[[i]], collapse = ", "))) - if(tbl$Type[[i]] != "none" & tbl$Type[[i]] != "simple") { - cat(sprintf("%s. %s: %s\n", i_str, stringr::str_to_title(tbl$Type[[i]]), paste(tbl$Calculated.Roll[[i]], collapse = ", "))) + if(x$Type[[i]] != "none" & x$Type[[i]] != "simple") { + cat(sprintf("%s. %s: %s\n", i_str, stringr::str_to_title(x$Type[[i]]), paste(x$Calculated.Roll[[i]], collapse = ", "))) } - if(!is.na(tbl$Success[[i]])) { - cat(sprintf("%s. Number successes: %s\n", i_str, paste(tbl$Success.Outcome[[i]], collapse = ", "))) + if(!is.na(x$Success[[i]])) { + cat(sprintf("%s. Number successes: %s\n", i_str, paste(x$Success.Outcome[[i]], collapse = ", "))) } } @@ -233,9 +287,4 @@ print.rolltable <- function(tbl, n = 10, rolls = FALSE, digits = 1, ...) { cat("======\n") } -#' Helper function to change the number of digits for a string with numerals -trim_numeric_string <- function(str, digits = 2) { - p <- sprintf("([[:digit:]]+[.])([[:digit:]]{%d})[[:digit:]]+", digits) - stringr::str_replace_all(str, pattern = p, replacement = "\\1\\2") -} diff --git a/man/Ops.rollr.Rd b/man/Ops.rollr.Rd index b3ccf17..d5c1067 100644 --- a/man/Ops.rollr.Rd +++ b/man/Ops.rollr.Rd @@ -6,6 +6,11 @@ \usage{ \method{Ops}{rollr}(e1, e2 = NULL) } +\arguments{ +\item{e1}{objects.} + +\item{e2}{objects.} +} \description{ Permits mathemetical operations on rolltables or rolltable calculations in certain circumstances. Namely, the number of repetitions must match between objects, or one object is a length-one vector. diff --git a/man/calculate.Rd b/man/calculate.Rd index cfc0528..6022fff 100644 --- a/man/calculate.Rd +++ b/man/calculate.Rd @@ -4,23 +4,22 @@ \alias{calculate} \title{Method to calculate the current value of a rolltable} \usage{ -calculate(tbl, ...) +calculate(obj, ...) } \arguments{ -\item{tbl}{A rolltable class.} +\item{obj}{Table to calculate, such as a rolltable.} -\item{.summary_fn}{Function used to summarize results between repetitions. Default returns each repetition separately.} +\item{...}{For use by class methods} } \value{ A numeric vector whose names are the individual sums for each dice set. } \description{ -For each repetition in the rolltable, summarizes each dice set and -applies the operators in turn. +Method to calculate the current value of a rolltable } \examples{ -tbl <- rolltable("2d20h1 + 20") +tbl <- rolltable("2d20h1") calculate(tbl) calculate(tbl, .summary_fn = "median") } diff --git a/man/calculate.rolltable.Rd b/man/calculate.rolltable.Rd new file mode 100644 index 0000000..f8d7ae6 --- /dev/null +++ b/man/calculate.rolltable.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rolltable_class.R +\name{calculate.rolltable} +\alias{calculate.rolltable} +\title{Calculate a rolltable} +\usage{ +\method{calculate}{rolltable}(obj, .summary_fn = "identity", ...) +} +\arguments{ +\item{obj}{A rolltable.} + +\item{.summary_fn}{A character string providing the name of a summary function, such as mean or median, or the function itself.} + +\item{...}{Unused.} +} +\value{ +A rolltable_calculation. +} +\description{ +Summarizes the provided summary function over repetitions, groups by Die if more than one in the table. +} diff --git a/man/evaluate_roll_cmd.Rd b/man/evaluate_roll_cmd.Rd deleted file mode 100644 index 4508bd5..0000000 --- a/man/evaluate_roll_cmd.Rd +++ /dev/null @@ -1,18 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/evaluate_roll_cmd.R -\name{evaluate_roll_cmd} -\alias{evaluate_roll_cmd} -\title{A complex roll resolution} -\usage{ -evaluate_roll_cmd(parsed_cmd) -} -\arguments{ -\item{parsed_cmd}{a list of dice and operators as returned by parse_roll_cmd.} -} -\value{ -roll result. -} -\description{ -@description The complex roll resolution function evaluates each elements of a complex - roll command and compute their total result -} diff --git a/man/infinite_letters.Rd b/man/infinite_letters.Rd index 9e1e9d5..8a50370 100644 --- a/man/infinite_letters.Rd +++ b/man/infinite_letters.Rd @@ -9,6 +9,12 @@ But instead will result in tbls[[tbls[[2]]]] + 1} \usage{ infinite_letters(n) } +\arguments{ +\item{n}{Number of distinct names required} +} +\value{ +a character vector of unique names +} \description{ Helper function to create names using only letters, not numbers So that a command can be substituted without accidentally overwriting the number. diff --git a/man/max.rolltable.Rd b/man/max.rolltable.Rd index a2de2e8..e5cac91 100644 --- a/man/max.rolltable.Rd +++ b/man/max.rolltable.Rd @@ -4,10 +4,12 @@ \alias{max.rolltable} \title{Max rolltable} \usage{ -\method{max}{rolltable}(tbl, ..., na.rm = FALSE) +\method{max}{rolltable}(..., na.rm = FALSE) } \arguments{ -\item{tbl}{A rolltable class.} +\item{...}{A rolltable class.} + +\item{na.rm}{Unused. For consistency with \code{\link[base]{min}}.} } \value{ A numeric vector whose names are the individual maximums for each dice set. diff --git a/man/mean.rolltable.Rd b/man/mean.rolltable.Rd index 07bb065..e0b3cf7 100644 --- a/man/mean.rolltable.Rd +++ b/man/mean.rolltable.Rd @@ -4,10 +4,12 @@ \alias{mean.rolltable} \title{Mean rolltable} \usage{ -\method{mean}{rolltable}(x) +\method{mean}{rolltable}(x, ...) } \arguments{ \item{x}{A rolltable class.} + +\item{...}{Unused.} } \value{ A numeric vector whose names are the individual means for each dice set. diff --git a/man/median.rolltable.Rd b/man/median.rolltable.Rd index 576a254..68324f9 100644 --- a/man/median.rolltable.Rd +++ b/man/median.rolltable.Rd @@ -4,10 +4,14 @@ \alias{median.rolltable} \title{Median rolltable} \usage{ -\method{median}{rolltable}(x, na.rm = FALSE) +\method{median}{rolltable}(x, na.rm = FALSE, ...) } \arguments{ \item{x}{A rolltable class.} + +\item{na.rm}{Unused. For consistency with \code{\link[stats]{median}}.} + +\item{...}{Unused. For consistency with \code{\link[stats]{median}}.} } \value{ A numeric vector whose names are the individual means for each dice set. diff --git a/man/min.rolltable.Rd b/man/min.rolltable.Rd index 1ed8de1..d5d447f 100644 --- a/man/min.rolltable.Rd +++ b/man/min.rolltable.Rd @@ -4,10 +4,12 @@ \alias{min.rolltable} \title{Min rolltable} \usage{ -\method{min}{rolltable}(tbl, ..., na.rm = FALSE) +\method{min}{rolltable}(..., na.rm = FALSE) } \arguments{ -\item{tbl}{A rolltable class.} +\item{...}{A rolltable class.} + +\item{na.rm}{Unused. For consistency with \code{\link[base]{min}}.} } \value{ A numeric vector whose names are the individual minimums for each dice set. diff --git a/man/new_rolltable.Rd b/man/new_rolltable.Rd index 0da0c01..c51ee5b 100644 --- a/man/new_rolltable.Rd +++ b/man/new_rolltable.Rd @@ -6,6 +6,14 @@ \usage{ new_rolltable(cmd, tbl) } +\arguments{ +\item{cmd}{Character vetor. Intended to be one or more dice set commands.} + +\item{tbl}{Dataframe to convert to rolltable.} +} +\value{ +Rolltable class object. +} \description{ Internal function to build the rolltable class structure. Minimal checks for validity. diff --git a/man/new_rolltable_calculation.Rd b/man/new_rolltable_calculation.Rd index c4d0b7e..9a0ef92 100644 --- a/man/new_rolltable_calculation.Rd +++ b/man/new_rolltable_calculation.Rd @@ -8,6 +8,8 @@ new_rolltable_calculation(lst, n = names(lst)) } \arguments{ \item{lst}{A list object returned using the "by" function.} + +\item{n}{Names to use for the returned object, if the lst is not already named.} } \value{ A rolltable_calculation classed object. diff --git a/man/parse_result.Rd b/man/parse_result.Rd new file mode 100644 index 0000000..8ab4b39 --- /dev/null +++ b/man/parse_result.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rolltable_class.R +\name{parse_result} +\alias{parse_result} +\title{Helper function for calculate to apply a summary function to a rolltable.} +\usage{ +parse_result(tbl, .summary_fn = identity) +} +\arguments{ +\item{tbl}{Rolltable} + +\item{.summary_fn}{A summary function to apply} +} +\value{ +A summarized result generated using the by function. +} +\description{ +Helper function for calculate to apply a summary function to a rolltable. +} diff --git a/man/print.rolltable.Rd b/man/print.rolltable.Rd index 9b22126..ae74712 100644 --- a/man/print.rolltable.Rd +++ b/man/print.rolltable.Rd @@ -4,16 +4,18 @@ \alias{print.rolltable} \title{Print a rolltable} \usage{ -\method{print}{rolltable}(tbl, n = 10, rolls = FALSE, digits = 1, ...) +\method{print}{rolltable}(x, n = 10, rolls = FALSE, digits = 1, ...) } \arguments{ -\item{tbl}{A rolltable class.} +\item{x}{A rolltable class.} \item{n}{Number of repetitions to print.} \item{rolls}{If TRUE, print the base rolls and modifications to rolls, such as keep highest or exploding.} \item{digits}{Round numbers to this number of digits when printing.} + +\item{...}{Unused.} } \description{ Print a rolltable diff --git a/man/repetitions.Rd b/man/repetitions.Rd index 6ea2d12..4918749 100644 --- a/man/repetitions.Rd +++ b/man/repetitions.Rd @@ -8,6 +8,8 @@ repetitions(tbl, ...) } \arguments{ \item{tbl}{A rolltable class.} + +\item{...}{For use by class methods.} } \value{ Integer value indicating the number of repetitions. diff --git a/man/roll.Rd b/man/roll.Rd index 820753f..1f7fab2 100644 --- a/man/roll.Rd +++ b/man/roll.Rd @@ -4,24 +4,16 @@ \alias{roll} \title{Roll Method} \usage{ -roll(tbl, ...) +roll(obj, ...) } \arguments{ -\item{tbl}{A rolltable class.} +\item{obj}{Object to roll} -\item{repetitions}{Number of times to roll the command.} - -\item{verbose}{If TRUE, dice roll details are visible in the console.} +\item{...}{For use by class methods} } \value{ An updated rolltable. } \description{ -Takes a rolltable and rolls to create a new set of results, using one or more repetitions. -} -\examples{ - -tbl <- rolltable("2d20h1 + 20"); tbl -roll(tbl, repetitions = 3) -roll(tbl, repetitions = 2, verbose = TRUE) +Method for rolling dice. } diff --git a/man/roll.rolltable.Rd b/man/roll.rolltable.Rd new file mode 100644 index 0000000..4a58643 --- /dev/null +++ b/man/roll.rolltable.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rolltable_class.R +\name{roll.rolltable} +\alias{roll.rolltable} +\title{Roll or reroll a rolltable} +\usage{ +\method{roll}{rolltable}(obj, repetitions = 1, verbose = FALSE, ...) +} +\arguments{ +\item{obj}{A rolltable.} + +\item{repetitions}{Number of times to roll the command.} + +\item{verbose}{If TRUE, dice roll details are visible in the console.} + +\item{...}{Unused.} +} +\description{ +Any existing repetitions will be removed and all rolls re-done. +} +\examples{ + +tbl <- rolltable("2d20h1"); tbl +roll(tbl, repetitions = 3) +roll(tbl, repetitions = 2, verbose = TRUE) + +} diff --git a/man/roll_one.Rd b/man/roll_one.Rd deleted file mode 100644 index e0a78ff..0000000 --- a/man/roll_one.Rd +++ /dev/null @@ -1,17 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/roll_one.R -\name{roll_one} -\alias{roll_one} -\title{Roll One} -\usage{ -roll_one(roll) -} -\arguments{ -\item{roll}{a string corresponding to a roll command.} -} -\value{ -result of the roll -} -\description{ -Roll one die from string command. -} diff --git a/man/rolltable.Rd b/man/rolltable.Rd index 6b946ea..b5b018a 100644 --- a/man/rolltable.Rd +++ b/man/rolltable.Rd @@ -35,4 +35,8 @@ rolltable("2d20h1", repetitions = 5) + rolltable("10") result <- rolltable("2d20h1", repetitions = 1000) > rolltable("2d20l1", repetitions = 1000) summary(result[[1]]) +# convert to dataframe +as.data.frame(rolltable("2d20h1", repetitions = 10)) +as.data.frame(rolltable(c("1d6", "2d6", "3d6", "4d6"), repetitions = 2)) + } diff --git a/man/trim_numeric_string.Rd b/man/trim_numeric_string.Rd deleted file mode 100644 index 48c9d38..0000000 --- a/man/trim_numeric_string.Rd +++ /dev/null @@ -1,11 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/rolltable_class.R -\name{trim_numeric_string} -\alias{trim_numeric_string} -\title{Helper function to change the number of digits for a string with numerals} -\usage{ -trim_numeric_string(str, digits = 2) -} -\description{ -Helper function to change the number of digits for a string with numerals -} diff --git a/tests/testthat/test-evaluate_roll_cmd.R b/tests/testthat/test-evaluate_roll_cmd.R deleted file mode 100644 index 8849056..0000000 --- a/tests/testthat/test-evaluate_roll_cmd.R +++ /dev/null @@ -1,3 +0,0 @@ -test_that("multiplication works", { - expect_equal(2 * 2, 4) -})