Running ‘testthat.R’
Running the tests in ‘tests/testthat.R’ failed.
Complete output:
  > library(testthat)
  > library(pricesensitivitymeter)
  > 
  > test_check("pricesensitivitymeter")
   ----------- FAILURE REPORT -------------- 
   --- srcref --- 
  : 
   --- package (from environment) --- 
  pricesensitivitymeter
   --- call from context --- 
  psm_analysis(data = data.psm.test, toocheap = "tch", cheap = "ch", 
      expensive = "ex", tooexpensive = "tex", pi_cheap = rep.int(2, 
          nrow(data.psm.test)), pi_expensive = rep.int(1, nrow(data.psm.test)))
   --- call from argument --- 
  if (is.na(col_pi_cheap) | is.na(col_pi_expensive)) {
      stop("Could not find all variable names of the purchase intent variables (pi_cheap, pi_expensive) in the data object")
  }
   --- R stacktrace ---
  where 1: psm_analysis(data = data.psm.test, toocheap = "tch", cheap = "ch", 
      expensive = "ex", tooexpensive = "tex", pi_cheap = rep.int(2, 
          nrow(data.psm.test)), pi_expensive = rep.int(1, nrow(data.psm.test)))
  where 2: eval_bare(get_expr(quo), get_env(quo))
  where 3: doTryCatch(return(expr), name, parentenv, handler)
  where 4: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 5: tryCatchList(expr, classes, parentenv, handlers)
  where 6: tryCatch({
      code
      NULL
  }, error = function(e) e)
  where 7: capture(act$val <- eval_bare(get_expr(quo), get_env(quo)))
  where 8: quasi_capture(enquo(object), capture_error, label = label)
  where 9 at testthat/test_data_input.R#110: expect_error(psm_analysis(data = data.psm.test, toocheap = "tch", 
      cheap = "ch", expensive = "ex", tooexpensive = "tex", pi_cheap = rep.int(2, 
          nrow(data.psm.test)), pi_expensive = rep.int(1, nrow(data.psm.test))))
  where 10: eval(code, test_env)
  where 11: eval(code, test_env)
  where 12: withCallingHandlers({
      eval(code, test_env)
      if (!handled && !is.null(test)) {
          skip_empty()
      }
  }, expectation = handle_expectation, skip = handle_skip, warning = handle_warning, 
      message = handle_message, error = handle_error)
  where 13: doTryCatch(return(expr), name, parentenv, handler)
  where 14: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 15: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 16: doTryCatch(return(expr), name, parentenv, handler)
  where 17: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 18: tryCatchList(expr, classes, parentenv, handlers)
  where 19: tryCatch(withCallingHandlers({
      eval(code, test_env)
      if (!handled && !is.null(test)) {
          skip_empty()
      }
  }, expectation = handle_expectation, skip = handle_skip, warning = handle_warning, 
      message = handle_message, error = handle_error), error = handle_fatal, 
      skip = function(e) {
      })
  where 20: test_code(desc, code, env = parent.frame())
  where 21 at testthat/test_data_input.R#109: test_that("Data Input: NMS using dataframe", {
      expect_error(psm_analysis(data = data.psm.test, toocheap = "tch", 
          cheap = "ch", expensive = "ex", tooexpensive = "tex", 
          pi_cheap = rep.int(2, nrow(data.psm.test)), pi_expensive = rep.int(1, 
              nrow(data.psm.test))))
      expect_error(psm_analysis(data = data.psm.test, toocheap = "tch", 
          cheap = "ch", expensive = "ex", tooexpensive = "tex", 
          pi_cheap = "foo", pi_expensive = "bar"))
      expect_error(psm_analysis(data = data.psm.test, toocheap = "tch", 
          cheap = "ch", expensive = "ex", tooexpensive = "tex", 
          pi_cheap = "pi_cheap2", pi_expensive = "pi_expensive"))
      expect_error(psm_analysis(data = data.psm.test, toocheap = "tch", 
          cheap = "ch", expensive = "ex", tooexpensive = "tex", 
          pi_cheap = "pi_cheap", pi_expensive = "pi_expensive2"))
      expect_error(psm_analysis(data = data.psm.test, toocheap = "tch", 
          cheap = "ch", expensive = "ex", tooexpensive = "tex", 
          pi_cheap = "pi_cheap3", pi_expensive = "pi_expensive"))
      expect_error(psm_analysis(data = data.psm.test, toocheap = "tch", 
          cheap = "ch", expensive = "ex", tooexpensive = "tex", 
          pi_cheap = "pi_cheap", pi_expensive = "pi_expensive3"))
      expect_silent(psm_analysis(data = data.psm.test, toocheap = "tch", 
          cheap = "ch", expensive = "ex", tooexpensive = "tex", 
          pi_cheap = "pi_cheap", pi_expensive = "pi_expensive"))
  })
  where 22: eval(code, test_env)
  where 23: eval(code, test_env)
  where 24: withCallingHandlers({
      eval(code, test_env)
      if (!handled && !is.null(test)) {
          skip_empty()
      }
  }, expectation = handle_expectation, skip = handle_skip, warning = handle_warning, 
      message = handle_message, error = handle_error)
  where 25: doTryCatch(return(expr), name, parentenv, handler)
  where 26: tryCatchOne(expr, names, parentenv, handlers[[1L]])
  where 27: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
  where 28: doTryCatch(return(expr), name, parentenv, handler)
  where 29: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]), 
      names[nh], parentenv, handlers[[nh]])
  where 30: tryCatchList(expr, classes, parentenv, handlers)
  where 31: tryCatch(withCallingHandlers({
      eval(code, test_env)
      if (!handled && !is.null(test)) {
          skip_empty()
      }
  }, expectation = handle_expectation, skip = handle_skip, warning = handle_warning, 
      message = handle_message, error = handle_error), error = handle_fatal, 
      skip = function(e) {
      })
  where 32: test_code(NULL, exprs, env)
  where 33: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
  where 34: force(code)
  where 35: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter, 
      {
          lister$start_file(basename(path))
          source_file(path, new.env(parent = env), chdir = TRUE, 
              wrap = wrap)
          end_context()
      })
  where 36: FUN(X[[i]], ...)
  where 37: lapply(paths, test_file, env = env, reporter = current_reporter, 
      start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
  where 38: force(code)
  where 39: with_reporter(reporter = current_reporter, results <- lapply(paths, 
      test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE, 
      load_helpers = FALSE, wrap = wrap))
  where 40: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 41: test_dir(path = test_path, reporter = reporter, env = env, filter = filter, 
      ..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning, 
      wrap = wrap)
  where 42: test_package_dir(package = package, test_path = test_path, filter = filter, 
      reporter = reporter, ..., stop_on_failure = stop_on_failure, 
      stop_on_warning = stop_on_warning, wrap = wrap)
  where 43: test_check("pricesensitivitymeter")
  
   --- value of length: 20 type: logical ---
   [1] TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE
  [16] TRUE TRUE TRUE TRUE TRUE
   --- function from context --- 
  function (toocheap, cheap, expensive, tooexpensive, data = NA, 
      validate = TRUE, interpolate = FALSE, pi_cheap = NA, pi_expensive = NA, 
      pi_scale = 5:1, pi_calibrated = c(0.7, 0.5, 0.3, 0.1, 0)) 
  {
      if (any(is.na(validate)) | !is.logical(validate) | length(validate) != 
          1) {
          stop("validate requires one logical value")
      }
      if (any(is.na(interpolate)) | !is.logical(interpolate) | 
          length(interpolate) != 1) {
          stop("interpolate requires one logical value")
      }
      if (!is.data.frame(data) & !is.matrix(data) & !all(is.na(data))) {
          stop("If the data argument is used, it must provide a data frame (or matrix) object")
          if (!is.character(toocheap) | !is.character(cheap) | 
              !is.character(expensive) | !is.character(tooexpensive) | 
              length(toocheap) != 1 | length(cheap) != 1 | length(expensive) != 
              1 | length(tooexpensive) != 1) {
              stop("If the data argument is used, all price arguments (toocheap, cheap, expensive, tooexpensive) must be character values that contain the name of the respective price variable in the data object")
          }
      }
      if (is.data.frame(data) | is.matrix(data)) {
          if (length(toocheap) == 1 & length(cheap) == 1 & length(expensive) == 
              1 & length(tooexpensive) == 1) {
              col_toocheap <- match(toocheap, colnames(data))
              col_cheap <- match(cheap, colnames(data))
              col_expensive <- match(expensive, colnames(data))
              col_tooexpensive <- match(tooexpensive, colnames(data))
          }
          if (is.na(col_toocheap) | is.na(col_cheap) | is.na(col_expensive) | 
              is.na(col_tooexpensive)) {
              stop("Could not find all variable names of the price variables (toocheap, cheap, expensive, tooexpensive) in the data object")
          }
          if (ifelse(!is.numeric(data[, col_toocheap]), !all(is.na(data[, 
              col_toocheap])), FALSE) | !is.numeric(data[, col_cheap]) | 
              !is.numeric(data[, col_expensive]) | !is.numeric(data[, 
              col_tooexpensive])) {
              stop("All price variables (toocheap, cheap, expensive, tooexpensive) must contain only numeric values\n(toocheap is also tolerated if all values are NA)")
          }
          psmdata <- data.frame(toocheap = data[, col_toocheap], 
              cheap = data[, col_cheap], expensive = data[, col_expensive], 
              tooexpensive = data[, col_tooexpensive])
      }
      if (!is.data.frame(data) & !is.matrix(data) & all(is.na(data))) {
          if (!is.vector(toocheap) | !is.vector(cheap) | !is.vector(expensive) | 
              !is.vector(tooexpensive) | ifelse(!all(is.na(toocheap)), 
              !is.numeric(toocheap), FALSE) | !is.numeric(cheap) | 
              !is.numeric(expensive) | !is.numeric(tooexpensive)) {
              stop("If the data argument is not provided, all price variables (toocheap, cheap, expensive, tooexpensive) must be numeric vectors\n(toocheap is also tolerated if all values are NA)")
          }
          if (!(length(toocheap) == length(cheap)) | !(length(toocheap) == 
              length(expensive)) | !(length(toocheap) == length(tooexpensive))) {
              stop("All price arguments must have the same length")
          }
          psmdata <- data.frame(toocheap, cheap, expensive, tooexpensive)
      }
      NMS <- !all(is.na(pi_cheap)) & !all(is.na(pi_expensive))
      if (length(pi_cheap) != length(pi_expensive)) {
          stop("If purchase intent data is provided, this data must have the same number of respondents for the cheap and for the expensive price")
      }
      if (all(is.na(data)) & isTRUE(NMS)) {
          if (length(cheap) != length(pi_cheap)) {
              stop("Unequal number of respondents for PSM data and for purchase intent variables")
          }
          if (!is.vector(pi_cheap) | !is.vector(pi_expensive)) {
              stop("If the data argument is not provided, both purchase intent variables (pi_cheap, pi_expensive) must be vectors")
          }
          psmdata$pi_cheap <- pi_cheap
          psmdata$pi_expensive <- pi_expensive
      }
      if (!all(is.na(data)) & isTRUE(NMS)) {
          col_pi_cheap <- match(pi_cheap, colnames(data))
          col_pi_expensive <- match(pi_expensive, colnames(data))
          if (is.na(col_pi_cheap) | is.na(col_pi_expensive)) {
              stop("Could not find all variable names of the purchase intent variables (pi_cheap, pi_expensive) in the data object")
          }
          psmdata$pi_cheap <- data[, col_pi_cheap]
          psmdata$pi_expensive <- data[, col_pi_expensive]
      }
      stopifnot(length(pi_scale) == length(pi_calibrated))
      if (isTRUE(NMS)) {
          if (!identical(x = class(psmdata$pi_cheap), y = class(pi_scale)) & 
              !(is.numeric(psmdata$pi_cheap) & is.numeric(pi_scale))) {
              stop("pi_cheap and pi_scale must have the same class")
          }
          if (!identical(x = class(psmdata$pi_expensive), y = class(pi_scale)) & 
              !(is.numeric(psmdata$pi_expensive) & is.numeric(pi_scale))) {
              stop("pi_expensive and pi_scale must have the same class")
          }
          if (!all(unique(psmdata$pi_cheap) %in% unique(pi_scale))) {
              stop("pi_cheap contains values which are not defined in the pi_scale variable")
          }
          if (!all(unique(psmdata$pi_expensive) %in% unique(pi_scale))) {
              stop("pi_expensive contains values which are not defined in the pi_scale variable")
          }
          if (any(!is.numeric(pi_calibrated))) {
              stop("All calibrated purchase intent values must be numeric")
          }
          if (any(pi_calibrated < 0)) {
              warning("Some of the purchase intent calibration values are smaller than 0. It seems that this is not a probability between 0 and 1. The interpretation of the trial/revenue values is not recommended.")
          }
          if (any(pi_calibrated > 1)) {
              warning("Some of the purchase intent calibration values are larger than 1. It seems that this is not a probability between 0 and 1. The interpretation of the trial/revenue values is not recommended.")
          }
          if (any(is.nan(pi_calibrated))) {
              stop("Some of the purchase intent calibration values are not a number (NaN)")
          }
          if (any(is.infinite(pi_calibrated))) {
              stop("Some of the purchase intent calibration values are infinite (-Inf, Inf).")
          }
      }
      if (all(is.na(psmdata$toocheap))) {
          psmdata$valid <- psmdata$tooexpensive > psmdata$expensive & 
              psmdata$expensive > psmdata$cheap
          psmdata$valid[which(is.na(psmdata$tooexpensive) | is.na(psmdata$expensive) | 
              is.na(psmdata$cheap))] <- FALSE
      }
      else {
          psmdata$valid <- psmdata$tooexpensive > psmdata$expensive & 
              psmdata$expensive > psmdata$cheap & psmdata$cheap > 
              psmdata$toocheap
          psmdata$valid[which(is.na(psmdata$tooexpensive) | is.na(psmdata$expensive) | 
              is.na(psmdata$cheap) | is.na(psmdata$toocheap))] <- FALSE
      }
      if (any(psmdata$valid == FALSE) & !isTRUE(validate)) {
          warning("Some respondents' price structures might not be consistent (i.e. different from too cheap < cheap < expensive < too expensive). Consider running this function with the additional option 'validate == TRUE' to analyse only the subset of respondents with consistent price structure.")
      }
      invalid_cases <- nrow(psmdata) - sum(psmdata$valid)
      total_sample <- nrow(psmdata)
      if (total_sample == invalid_cases) {
          stop("All respondents have intransitive preference structures (i.e. different from too cheap < cheap < expensive < too expensive).")
      }
      if (isTRUE(validate) & !isTRUE(NMS)) {
          psmdata <- subset(psmdata, psmdata$valid, select = c("toocheap", 
              "cheap", "expensive", "tooexpensive"))
      }
      if (isTRUE(validate) & isTRUE(NMS)) {
          psmdata <- subset(psmdata, psmdata$valid, select = c("toocheap", 
              "cheap", "expensive", "tooexpensive", "pi_cheap", 
              "pi_expensive"))
      }
      data_ecdf <- data.frame(price = sort(unique(c(psmdata$toocheap, 
          psmdata$cheap, psmdata$expensive, psmdata$tooexpensive))))
      if (!all(is.na(psmdata$toocheap))) {
          ecdf_psm <- ecdf(psmdata$toocheap)
          data_ecdf$ecdf_toocheap <- 1 - ecdf_psm(data_ecdf$price)
      }
      else {
          data_ecdf$ecdf_toocheap <- NA
      }
      ecdf_psm <- ecdf(psmdata$cheap)
      data_ecdf$ecdf_cheap <- 1 - ecdf_psm(data_ecdf$price)
      ecdf_psm <- ecdf(psmdata$expensive)
      data_ecdf$ecdf_expensive <- ecdf_psm(data_ecdf$price)
      ecdf_psm <- ecdf(psmdata$tooexpensive)
      data_ecdf$ecdf_tooexpensive <- ecdf_psm(data_ecdf$price)
      if (isTRUE(interpolate)) {
          data_ecdf_smooth <- data.frame(price = seq(from = min(data_ecdf$price), 
              to = max(data_ecdf$price), by = 0.01))
          data_ecdf_smooth <- merge(x = data_ecdf_smooth, y = data_ecdf, 
              by = "price", all.x = TRUE)
          data_ecdf_smooth$ecdf_toocheap <- approx(x = data_ecdf$price, 
              y = data_ecdf$ecdf_toocheap, xout = data_ecdf_smooth$price, 
              method = "linear")$y
          data_ecdf_smooth$ecdf_cheap <- approx(x = data_ecdf$price, 
              y = data_ecdf$ecdf_cheap, xout = data_ecdf_smooth$price, 
              method = "linear")$y
          data_ecdf_smooth$ecdf_expensive <- approx(x = data_ecdf$price, 
              y = data_ecdf$ecdf_expensive, xout = data_ecdf_smooth$price, 
              method = "linear")$y
          data_ecdf_smooth$ecdf_tooexpensive <- approx(x = data_ecdf$price, 
              y = data_ecdf$ecdf_tooexpensive, xout = data_ecdf_smooth$price, 
              method = "linear")$y
          data_ecdf <- data_ecdf_smooth
      }
      pricerange_lower <- data_ecdf$price[which(data_ecdf$ecdf_expensive >= 
          data_ecdf$ecdf_toocheap)[1]]
      pricerange_upper <- data_ecdf$price[which(data_ecdf$ecdf_tooexpensive >= 
          data_ecdf$ecdf_cheap)[1]]
      idp <- data_ecdf$price[which(data_ecdf$ecdf_expensive >= 
          data_ecdf$ecdf_cheap)[1]]
      opp <- data_ecdf$price[which(data_ecdf$ecdf_tooexpensive >= 
          data_ecdf$ecdf_toocheap)[1]]
      if (!all(is.na(pi_cheap)) & !all(is.na(pi_expensive))) {
          psmdata$pi_cheap_cal <- NA
          psmdata$pi_expensive_cal <- NA
          for (i in 1:length(pi_scale)) {
              psmdata$pi_cheap_cal[which(psmdata$pi_cheap == pi_scale[i])] <- pi_calibrated[i]
              psmdata$pi_expensive_cal[which(psmdata$pi_expensive == 
                  pi_scale[i])] <- pi_calibrated[i]
          }
          nms_prices <- data_ecdf$price
          nms_matrix <- matrix(nrow = nrow(psmdata), ncol = length(nms_prices), 
              dimnames = list(rownames(psmdata), nms_prices))
          pos_toocheap <- sapply(as.character(psmdata$toocheap), 
              FUN = function(x) which(colnames(nms_matrix) == x))
          nms_matrix[cbind(1:nrow(nms_matrix), as.numeric(pos_toocheap))] <- 0
          pos_tooexpensive <- sapply(as.character(psmdata$tooexpensive), 
              FUN = function(x) which(colnames(nms_matrix) == x))
          nms_matrix[cbind(1:nrow(nms_matrix), as.numeric(pos_tooexpensive))] <- 0
          pos_cheap <- sapply(as.character(psmdata$cheap), FUN = function(x) which(colnames(nms_matrix) == 
              x))
          nms_matrix[cbind(1:nrow(nms_matrix), as.numeric(pos_cheap))] <- psmdata$pi_cheap_cal
          pos_expensive <- sapply(as.character(psmdata$expensive), 
              FUN = function(x) which(colnames(nms_matrix) == x))
          nms_matrix[cbind(1:nrow(nms_matrix), as.numeric(pos_expensive))] <- psmdata$pi_expensive_cal
          table(nms_matrix[1, ])
          if (all(is.na(psmdata$toocheap))) {
              for (i in 1:nrow(nms_matrix)) {
                  nms_matrix[i, min(which(!is.na(nms_matrix[i, 
                    ]))):max(which(!is.na(nms_matrix[i, ])))] <- c(seq.int(from = nms_matrix[i, 
                    which(!is.na(nms_matrix[i, ]))[1]], to = nms_matrix[i, 
                    which(!is.na(nms_matrix[i, ]))[2]], length.out = which(!is.na(nms_matrix[i, 
                    ]))[2] - which(!is.na(nms_matrix[i, ]))[1] + 
                    1), seq.int(from = nms_matrix[i, which(!is.na(nms_matrix[i, 
                    ]))[2]], to = nms_matrix[i, which(!is.na(nms_matrix[i, 
                    ]))[3]], length.out = which(!is.na(nms_matrix[i, 
                    ]))[3] - which(!is.na(nms_matrix[i, ]))[2] + 
                    1)[-1])
              }
          }
          else {
              for (i in 1:nrow(nms_matrix)) {
                  nms_matrix[i, min(which(!is.na(nms_matrix[i, 
                    ]))):max(which(!is.na(nms_matrix[i, ])))] <- c(seq.int(from = nms_matrix[i, 
                    which(!is.na(nms_matrix[i, ]))[1]], to = nms_matrix[i, 
                    which(!is.na(nms_matrix[i, ]))[2]], length.out = which(!is.na(nms_matrix[i, 
                    ]))[2] - which(!is.na(nms_matrix[i, ]))[1] + 
                    1), seq.int(from = nms_matrix[i, which(!is.na(nms_matrix[i, 
                    ]))[2]], to = nms_matrix[i, which(!is.na(nms_matrix[i, 
                    ]))[3]], length.out = which(!is.na(nms_matrix[i, 
                    ]))[3] - which(!is.na(nms_matrix[i, ]))[2] + 
                    1)[-1], seq.int(from = nms_matrix[i, which(!is.na(nms_matrix[i, 
                    ]))[3]], to = nms_matrix[i, which(!is.na(nms_matrix[i, 
                    ]))[4]], length.out = which(!is.na(nms_matrix[i, 
                    ]))[4] - which(!is.na(nms_matrix[i, ]))[3] + 
                    1)[-1])
              }
          }
          nms_matrix[is.na(nms_matrix)] <- 0
          data_nms <- data.frame(price = nms_prices, trial = apply(nms_matrix, 
              2, mean), row.names = 1:length(nms_prices))
          data_nms$revenue <- data_nms$price * data_nms$trial
          price_optimal_trial <- data_nms$price[which.max(data_nms$trial)]
          price_optimal_revenue <- data_nms$price[which.max(data_nms$revenue)]
      }
      output_psm <- list(data_input = psmdata, validated = validate, 
          invalid_cases = invalid_cases, total_sample = total_sample, 
          data_vanwestendorp = data_ecdf, pricerange_lower = pricerange_lower, 
          pricerange_upper = pricerange_upper, idp = idp, opp = opp, 
          NMS = NMS)
      if (NMS == TRUE) {
          output_psm$data_nms <- data_nms
          output_psm$pi_scale <- data.frame(pi_scale, pi_calibrated)
          output_psm$price_optimal_trial <- price_optimal_trial
          output_psm$price_optimal_revenue <- price_optimal_revenue
      }
      class(output_psm) <- "psm"
      return(output_psm)
  }
  <bytecode: 0x406fd70>
  <environment: namespace:pricesensitivitymeter>
   --- function search by body ---
  Function psm_analysis in namespace pricesensitivitymeter has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1