Merge pull request #5 from lsteinmann/functions

update on get.histogramscale()

Author: lsteinmann

R/get.histogramscale.R

@@ -1,42 +1,40 @@
 #' @title Scaling Factor for Combined Histogramm Plots
 #'
-#' @description Requires a dataframe as produced by datsteps().
-#' Meaning 6 columns in the following order:
-#' * ID,
-#' * group,
-#' * minimum/earliest date,
-#' * maximum/latest date,
-#' * weight,
-#' * 'DAT_Steps'
+#' @description Requires a dataframe as produced by datsteps() or a number as DAT_df_steps. Calculated the value with which the
+#' y-axis of a density graph should be multplied in order to be visible in the corresponding histogram.
 #'
-#' @param DAT_df a dataframe as returned by datsteps
-#' @param bw the bandwidth to use for the density function and histogram. Should be stepsize used to
-#' create the dataframe. If a df as returned by datsteps() is given, stepsize is automatically assigned
-#' using the corresponding attribute.
+#' @param DAT_df_steps a dataframe as returned by datsteps
+#' @param binwidth the bandwidth to use for the density function and histogram. Should be stepsize used to
+#' create the dataframe. If a df as returned by datsteps() is given, stepsize can be automatically assigned
+#' using the corresponding attribute (binwidth = "stepsize")
 #'
 #' @return the value with which to scale the density curve to a histogram plot so that both will be visible
 #'
 #' @examples
 #' DAT_df_steps <- datsteps(DAT_df[1:100,], stepsize = 25)
 #' get.histogramscale(DAT_df_steps)
 #'
+#' get.histogramscale(500, binwidth = 20)
+#'
 #' @export get.histogramscale
 
-get.histogramscale <- function(DAT_df, bw = "auto") {
-  if (bw == "auto") {
-    if (!is.null(attributes(DAT_df)$stepsize)) {
-      bw <- attributes(DAT_df)$stepsize
-    } else {
-      stop("Either specify stepsize/bandwidth (bw = ) or use a data.frame as returned by datsteps()")
+get.histogramscale <- function(DAT_df_steps, binwidth = "stepsize") {
+  if (check.number(DAT_df_steps)) {
+    nrow <- DAT_df_steps
+    if (binwidth == "stepsize") {
+      stop("'binwidth == stepsize' cannot be used with a number, supply either a dataframe as returned by datsteps or a numerical bindwidth")
+    }
+  } else {
+    nrow <- nrow(DAT_df_steps)
+    if (binwidth == "stepsize") {
+      binwidth <- attributes(DAT_df_steps)$stepsize
+      if (is.null(binwidth)) {
+        stop("Supply numerical binwidth or dataframe as returned by datsteps")
+      }
+    } else if (!check.number(binwidth)) {
+      stop('Supply numerical binwidth or use binwidth = "stepsize".')
     }
-  } else if (!is.numeric(bw)) {
-    stop("Either specify stepsize/bandwidth (bw = ) or use a data.frame as returned by datsteps()")
   }
-  density <- density(DAT_df$DAT_step, weights = DAT_df$weight, bw = bw)
-  breaks <- range(DAT_df$DAT_step)
-  breaks <- breaks[2] - breaks [1]
-  breaks <- round(breaks / bw, digits = 0)
-  hist <- hist(DAT_df$DAT_step, breaks = breaks)
-  histogramscale <- max(hist$counts) / max(density$y)
+  histogramscale <- nrow * binwidth
   return(histogramscale)
 }

R/scaleweights.R

@@ -1,29 +1,29 @@
-#' @title Scales the content of the weight columns according to group membership
+#' @title Scales the content of a column according to group membership
 #'
-#' @description Requires a dataframe as produced by datsteps(). (Meaning 6 columns in the following order: ID, group, minimum/earliest date, maximum/latest date, weight, 'DAT_Steps')
+#' @description Requires a dataframe with one variable and one value column.
 #'
-#' @param DAT_df a dataframe as returned by datsteps
-#' @param var the index of the column of said dataframe that should be used as the group variable, OR "all" (note: all non-numeric values will result in the weight being scaled accross all objects)
+#' @param DAT_df a dataframe
+#' @param var the index of the column that should be used as the group variable, OR "all"
+#' (note: all non-numeric values will result in the weight being scaled accross all objects)
+#' @param val the column that should be scaled (value / sum(values))
 #'
-#' @return the same dataframe, with scaled 'weight'-values
+#' @return the same dataframe, with scaled values in the specifies column
 #'
 #' @export scaleweight
 
-scaleweight <- function(DAT_df, var = c("all", 2) ) {
-  res_DAT_df <- data.frame(NULL)
-  if (is.numeric(var)) {
-    uvar <- unique(DAT_df[,var])
-    for (row in 1:length(uvar)) {
-      wip <- DAT_df[which(DAT_df[,var] == uvar[row]),]
-      wip$weight <- wip$weight / sum(wip$weight)
-      res_DAT_df <- rbind(res_DAT_df, wip)
-    }
-    attr(DAT_df$weight, "descr") <- "weight (scaled to sum of objects grouped by variable)"
-  } else {
-    DAT_df$weight <- DAT_df$weight / sum(DAT_df$weight)
-    attr(DAT_df$weight, "descr") <- "weight (scaled to sum of all objects)"
-    res_DAT_df <- DAT_df
+scaleweight <- function(DAT_df, var = c("all", 2), val = 5 ) {
+  if (check.number(var)) {
+    if (check.number(val)) {
+      uvar <- unique(DAT_df[,var])
+      for (row in 1:length(uvar)) {
+        index <- which(DAT_df[,var] == uvar[row])
+        DAT_df[index,val] <-  DAT_df[index,val] / sum(DAT_df[index,val])
+      }
+      attr(DAT_df[,val], "descr") <- "weight (scaled to sum of objects grouped by variable)"
+      } else { stop("val needs to be of a number (the index of the column that should be scaled)")}
+    } else {
+    DAT_df[,val] <- DAT_df[,val] / sum(DAT_df[,val])
+    attr(DAT_df[,val], "descr") <- "weight (scaled to sum of all objects)"
   }
-
-  return(res_DAT_df)
+return(DAT_df)
 }

README.md

@@ -1,8 +1,8 @@
 <!-- README.md is generated from README.Rmd. Please edit that file -->
  <!-- badges: start -->
   [![R build status](https://github.com/lsteinmann/datplot/workflows/R-CMD-check/badge.svg)](https://github.com/lsteinmann/datplot/actions)
-  [![Codecov test coverage](https://codecov.io/gh/lsteinmann/datplot/branch/master/graph/badge.svg)](https://codecov.io/gh/lsteinmann/datplot?branch=master)
   [![Travis build status](https://travis-ci.com/lsteinmann/datplot.svg?branch=master)](https://travis-ci.com/lsteinmann/datplot)
+  [![Codecov test coverage](https://codecov.io/gh/lsteinmann/datplot/branch/master/graph/badge.svg)](https://codecov.io/gh/lsteinmann/datplot?branch=master)
   <!-- badges: end -->
 
 datplot

man/get.histogramscale.Rd

@@ -55,6 +55,7 @@ test_that("check.number returns true for numbers false for other", {
   expect_false(check.number(testdf_wrong[3,3]))
   expect_true(check.number(testdf_wrong[3,4]))
   expect_false(check.number(testdf_wrong_two[3,4]))
+  expect_false(check.number(testdf))
 })
 
 
@@ -68,3 +69,7 @@ test_that("check.structure works", {
 
 
 
+test_that("check.structure issues warning", {
+  expect_warning(check.structure(testdf), regexp = "recommended")
+})
+

man/scaleweight.Rd

@@ -2,6 +2,15 @@ source(file = "../create_testing_df.R")
 testdf <- create.testing.df()
 
 test_that("error for wrong value of stepsize", {
-  expect_error(datsteps(testdf, stepsize = "test"))
+  expect_error(datsteps(testdf, stepsize = "test"), "stepsize has to be")
   expect_warning(datsteps(testdf, stepsize = 25))
 })
+
+data("DAT_df")
+
+str(DAT_df)
+
+test_that("error for wrong value of stepsize", {
+  expect_warning(datsteps(DAT_df), regexp = "wrong order")
+
+})

tests/testthat/test-datplot_utility.R

@@ -9,7 +9,16 @@ attributes(teststeps_wrong)$stepsize <- NULL
 #str(teststeps_wrong)
 
 
-test_that("multiplication works", {
-  #expect_type(get.histogramscale(teststeps), c("numeric", "double", "integer"))
-  expect_error(get.histogramscale(teststeps_wrong))
+
+test_that("right errors are returned", {
+  expect_error(get.histogramscale(teststeps_wrong, binwidth = "stepsize"), regexp = "dataframe as returned by datsteps")
+  expect_error(get.histogramscale(teststeps_wrong), regexp = "dataframe as returned by datsteps")
+  expect_error(get.histogramscale(testdfsteps, binwidth = "börek"), regexp = "or use")
+  expect_error(get.histogramscale(20), regexp = "cannot be used with a number")
+})
+
+
+test_that("returns number", {
+  expect_true(check.number(get.histogramscale(testdfsteps)))
+  expect_true(check.number(get.histogramscale(20, binwidth = 5)))
 })

tests/testthat/test-datsteps.R

@@ -0,0 +1,20 @@
+source(file = "../create_testing_df.R")
+
+
+testdf <- create.testing.df()
+
+testdf_steps <- datsteps(testdf)
+
+
+test_that("scaleweight appends attribute", {
+  expect_equal(2 * 2, 4)
+  expect_match(as.character(attributes(scaleweight(testdf_steps, var = "all")$weight)), regexp = "all objects")
+  expect_match(as.character(attributes(scaleweight(testdf_steps, var = 2)$weight)), regexp = "by variable")
+})
+
+
+test_that("val accepts only numbers", {
+  expect_error(scaleweight(testdf_steps, val = "no"))
+  expect_error(scaleweight(testdf_steps, val = 8))
+})
+