Category: R

library(tidyverse)
library(readxl)

# Original data source - https://www.nasdaq.com/market-activity/funds-and-etfs/weat/historical

# Download reformatted data (columns/headings) from github
# https://github.com/123blee/Stealth_Curves.io/blob/main/WEAT_nasdaq_com_data_reformatted.xlsx

# Insert your file path in the next line of code 

weat <- read_excel("... Place your file path Here ... /WEAT_nasdaq_com_data_reformatted.xlsx")
weat


# Convert 'Date and Time' to 'Date' column
weat[["Date"]] <- as.Date(weat[["Date"]])
weat

bars <- nrow(weat)

# Add bar indicator as first tibble column

weat <- weat %>%
     add_column(t = 1:nrow(weat), .before = "Date")
weat

# Interactive Pricing Chart

xmin <- 1              
ymin <- 0   
ymax_close <- ceiling(max(weat[["Close"]]))
ymax_low <- ceiling(max(weat[["Low"]]))
ymax_high <- ceiling(max(weat[["High"]]))

interactive <- hPlot(x = "t", y = "Close", data = weat, type = "line",
               
               ylim = c(ymin, ymax_close),
               
               xlim = c(xmin, bars),
               
               xaxt="n",   # suppress x-axis labels
               
               yaxt="n",   # suppress y-axis labels,
               
               ann=FALSE)  # x and y axis titles

interactive$set(height = 600)

interactive$set(width = 700)

interactive$plotOptions(line = list(color = "green"))

interactive$chart(zoomType = "x")   # Highlight range of chart to zoom in

interactive

Highlight any range to zoom data and view price on any bar number.

Interactive Chart
WEAT Daily Closing Prices (Zoomed)



Prior to plotting, add 400 additional rows to the tibble in preparation for extending the calculated Stealth Curve into future periods.

# Add 400 future days to the plot for projection of the Stealth Curve
 
 future <- 400
 
 weat <- weat %>%
   add_row(t = (bars+1):(bars+future))

 # Chart Closing WEAT prices
 
 plot.new()
 
 chart_title_close <- c("Teucrium Wheat ETF (Symbol = WEAT) \nDaily Closing Prices ($)")
 
 background <- c("azure1") 
 
 u <- par("usr") 
 
 rect(u[1], u[3], u[2], u[4], col = background) 
 
 par(new=TRUE)
 
 t <- weat[["t"]]
 Price <- weat[["Close"]]
 
 plot(x=t, y=Price, main = chart_title_close, type="l", col = "blue",        
      
      ylim = c(ymin, ymax_close) ,
      
      xlim = c(xmin, (bars+future )) ) 

The below chart represents 10 years of closing prices for the WEAT market since inception of the ETF on 9/19/2011.  The horizontal axis represents time (t) stated in bar numbers (t=1 = bar 1 = Date 9/19/2011).  This starting ‘t‘ value is entirely arbitrary and does not impact the position of a calculated Stealth Curve on a chart.

 # Add Stealth Curve to tibble
 
 # Stealth Curve parameters
 a <- 7231.88  
 b <-  1.18 
 c <- -7.77 
 
 weat <- weat %>%
   mutate(Stealth_Curve_Close = a/(t + c) + b)
 weat

 # Omit negative Stealth Curve values in charting, if any
 
 z1 <- weat[["Stealth_Curve_Close"]]
 
 weat[["Stealth_Curve_Close"]] <- ifelse(z1 < 0, NA, z1)
 weat

# Add Stealth Curve to chart
 
 lines(t, weat[["Stealth_Curve_Close"]])

# Market Pivot Lows using High Prices
 
 # Chart High WEAT prices
 
 plot.new()
 
 chart_title_high <- c("Teucrium Wheat ETF (Symbol = WEAT) \nDaily High Prices ($)")
 
 u <- par("usr") 
 
 rect(u[1], u[3], u[2], u[4], col = background) 
 
 par(ann=TRUE)
 
 par(new=TRUE)
 
 t <- weat[["t"]]
 Price <- weat[["High"]]
 
 plot(x=t, y=Price, main = chart_title_high, type="l", col = "blue", 
      
      ylim = c(ymin, ymax_high) ,
      
      xlim = c(xmin, (bars+future )) )  

The parameterized Stealth Curve equation is as follows:

# Add Stealth Curve to tibble
 
 # Stealth Curve parameters
 a <- 7815.16  
 b <-    1.01 
 c <-   37.35 
 
 weat <- weat %>%
   mutate(Stealth_Curve_High = a/(t + c) + b)
 
 # Omit negative Stealth Curve values in charting, if any
 
 z2 <- weat[["Stealth_Curve_High"]]
 
 weat[["Stealth_Curve_High"]] <- ifelse(z2 < 0, NA, z2)
 weat

 # Add Stealth Curve to chart
 
 lines(t, weat[["Stealth_Curve_High"]])

 # Natural Log High Prices 
 
 # Chart High WEAT prices
 
 plot.new()
 
 chart_title_high <- c("Teucrium Wheat ETF (Symbol = WEAT) \nDaily High Prices ($)")
 
 u <- par("usr") 
 
 rect(u[1], u[3], u[2], u[4], col = background) 
 
 par(ann=TRUE)
 
 par(new=TRUE)
 
 chart_title_log_high <- c("Teucrium Wheat ETF (Symbol = WEAT) \nNatural Log of Daily High Prices ($)")
 
 t <- weat[["t"]]
 Log_Price <- log(weat[["High"]])
 
 plot(x=t, y=Log_Price, main = chart_title_log_high, type="l", col = "blue", 
      
      ylim = c(log(7), log(ymax_high)) ,
      
      xlim = c(xmin, 800) ) # (bars+future )) )  
 
 # Add Log(Stealth Curve) to chart
 
 lines(t, log(weat[["Stealth_Curve_High"]]))

Zoomed Sectional
Log(High Prices) and Log(Stealth Curve)
WEAT



There are 11 successful tests of Stealth Resistance including the all-time market high of the ETF.

# Market Pivot Lows using Low Prices
 
 # Chart Low WEAT prices
 
 plot.new()
 
 u <- par("usr") 
 
 rect(u[1], u[3], u[2], u[4], col = background) 
 
 par(ann=TRUE)
 
 par(new=TRUE)
 
 chart_title_low <- c("Teucrium Wheat ETF (Symbol = WEAT) \nDaily Low Prices ($)")
 
 t <- weat[["t"]]
 Price <- weat[["Low"]]
 
 
 plot(x=t, y=Price, main = chart_title_low, type="l", col = "blue", 
      
      ylim = c(ymin, ymax_low) ,
      
      xlim = c(xmin, (bars+future )) )  

Chart the low prices.

equation based on 3 pivot lows is given below.

 # Add Stealth Curve to tibble
 
 # Stealth Curve parameters
 a <- 9022.37  
 b <-    0.48 
 c <-  125.72 
 
 weat <- weat %>%
   mutate(Stealth_Curve_Low = a/(t + c) + b)

 # Omit negative Stealth Curve values in charting, if any
 
 z3 <- weat[["Stealth_Curve_Low"]]
 
 weat[["Stealth_Curve_Low"]] <- ifelse(z3 < 0, NA, z3)
 weat

Add the Stealth Curve to the chart. 

# Add Stealth Curve to chart
 
 lines(t, weat[["Stealth_Curve_Low"]])
 

Chart 1 of 2




Chart 2 of 2

By Xiaotong Ding (Claire), With Greg Page

A practical tool that enables a modeler to remove non-informative data points during the variable selection process of data modeling

In this article, we will introduce a powerful function called ‘nearZeroVar()’. This function, which comes from the caret package, is a practical tool that enables a modeler to remove non-informative data points during the variable selection process of data modeling.

For starters, the nearZeroVar() function identifies constants, and predictors with one unique value across samples. In addition, nearZeroVar() diagnoses predictors as having “near-zero variance” when they possess very few unique values relative to the number of samples, and for which the ratio of the frequency of the most common value to the frequency of the second most common value is large.

Regardless of the modeling process being used, or of the specific purpose for a particular model, the removal of non-informative predictors is a good idea. Leaving such variables in a model only adds extra complexity, without any corresponding payoff in model accuracy or quality.

For this analysis, we will use the dataset hawaii.csv , which contains information about Airbnb rentals from Hawaii. In the code cell below, the dataset is read into R, and blank cells are converted to NA values

library(dplyr) 

library(caret)

options(scipen=999)  #display decimal values, rather than scientific notation
data = read.csv("/Users/xiaotongding/Desktop/Page BA-WritingProject/hawaii.csv")
dim(data)

## [1] 21523    74

data[data==""] <- NA

nzv_vals <- nearZeroVar(data, saveMetrics = TRUE)
dim(nzv_vals)

## [1] 74  4

• The code chunk shown above generates a dataframe with 74 rows (one for each variable in the dataset) and four columns. If saveMetrics is set to FALSE, the positions of the zero or near-zero predictors are returned instead.

nzv_sorted <- arrange(nzv_vals, desc(freqRatio))
head(nzv_sorted)

The first column, freqRatio, tells us the ratio of frequencies for the most common value over the second most common value for that variable. To see how this is calculated, let’s look at the freqRatio for host_has_profile_pic (282.184):

table(sort(data$host_has_profile_pic, decreasing=TRUE))

## 
##     f     t 
##    76 21446

length(unique(data$license))

## [1] 9768

length(unique(data$license)) / nrow(data) * 100

## [1] 45.38401

head(nzv_sorted, 10)

nzv_vals2 <- nearZeroVar(data, saveMetrics = TRUE, uniqueCut = 0.04)
nzv_sorted2 <- arrange(nzv_vals2, desc(freqRatio))
head(nzv_sorted2, 10)

data <- data %>%
  mutate(Rf = rep(0.03, 6),
         MRP = rep(0.04, 6),
         Bd = rep(0.2, 6),
         Bu = rep(1.1, 6),
         Kd = Rf + Bd * MRP,
         Ku = Rf + Bu * MRP,
         N = np + cpltd + LTD,   # All interest bearing debt
         CFd = ie - (N - lag(N, default=0)),
         ECF3 = ni - ii*(1-T_) - ( Ebv - lag(Ebv, default=0) ) + ( MS  - lag(MS, default=0)) ) 

rotate(data)

valuation <- function(a) {
  
  library(tidyverse)
  
  n <- length(a$bd) - 1
  
  Rf  <- a$Rf
  MRP <- a$MRP
  Ku  <- a$Ku
  Kd  <- a$Kd
  T_   <- a$T_
  
  # Flow values
  
  CFd <- a$CFd
  ECF <- a$ECF3
  
  # Initialize valuation vectors to zero by Year
  
  d <- rep(0, n+1 )  # Initialize debt value to zero each Year
  e <- rep(0, n+1 )  # Initialize equity value to zero each Year
  
  # Calculate debt and equity value by period in reverse order using discount rates 'Kd' and 'Ku', repsectively
  
  for (t in (n+1):2)    # reverse step through loop from period 'n+1' to 2
  {
    
    # Debt Valuation discounting 1-period at the forward discount rate, Kd[t]
    
    d[t-1] <- ( d[t] + CFd[t] ) / (1 + Kd[t] )
    
     # Equity Valuation discounting 1-period at the forward discount rate, Ku[t]
    
    e[t-1] <- ( e[t] + ECF[t] - (d[t-1])*(Ku[t]-Kd[t])*(1-T_[t]) ) / (1 + Ku[t] )
    
  }
  
  # Asset valuation by Year (Using Value Additivity Equation)
  v = d + e
  
  npv_0 <- round(e[1],0) + round(ECF[1],0)
  npv_0 <- c(npv_0, rep(NaN,n) )
  
  valuation <- as_tibble( cbind(a$Year, T_, Rf, MRP, Ku, Kd, Ku-Kd, ECF,
                                   -lag(d, default=0)*(1-T_)*(Ku-Kd), ECF - lag(d, default=0)*(1-T_)*(Ku-Kd), 
                                    d, e, v, d/e, c( ECF[1], rep(NaN,n)), npv_0 ) )  
  
  names(valuation) <- c("Year", "T", "Rf", "MRP", "Ku", "Kd", "Ku_Kd", "ECF",
                           "ECF_adj", "ADJ_ECF", "D", "E", "V", "D_E_Ratio", "ECF_0", "NPV_0")
  
  return(rotate(valuation))
}

valuation <- valuation( data )

round(valuation, 5)

data <- data %>%
mutate(Ebv = c(250000, 295204.551, 429491.869, 678425.4966, 988024.52, 0 ))

ECF3 <- function(a, b) {
  
  library(tibble)
  
  ECF3 <- a$ni -a$ii*(1-a$T_) - ( a$Ebv -lag(a$Ebv, default=0) ) + ( a$MS  - lag(a$MS, default=0) )  
  
  ECF_3 <-     tibble(T              = a$T_,
                      ii             = a$ii,
                      ni             = a$ni,
                      Year           = c(0:(length(ii)-1)),
                      ii_AT          = -ii*(1-T),
                      ni_less_ii_AT   = ni + ii_AT,
                      Ebv            = a$Ebv,
                      MS             = -a$MS,
                      Ebv_less_MS    = Ebv + MS,
                      chg_Ebv_less_MS  = - (Ebv_less_MS - lag(Ebv_less_MS, default=0) ) ,
                      ECF_3          = ni_less_ii_AT + chg_Ebv_less_MS )
  
  ECF_3 <- rotate(ECF_3)
  
  return(ECF_3)
  
}

R Output formatted in Excel

library(tidyverse)


data <- tibble(Year = c(0:5),
              div  = c(0, 2379, 7068, 13102, 16295, 1249876),
              MS   = c(0, 0, 7226, 350948, 698648, 0),
              ii   = c(0, 0, 0, 253, 12283, 24453),
              pic  = c(250000, 250000, 250000, 250000, 250000, 0), 
              T_   = c(0.25, 0.40, 0.40, 0.40, 0.40, 0.40))

data

rotate <- function(r) {
  
  p <- t(as.matrix(as_tibble(r)))
  
  return(p)
  
}

rotate(data)

ECF_1 <- function(a) {
  
  ECF1 <-     tibble( T_             = a$T_,
                      pic            = a$pic,
                      chg_pic        = pic - lag(pic, default=0),
                      MS             = a$MS,
                      ii             = a$ii,
                      Year           = c(0:(length(T_)-1)),
                      div            = a$div,
                      net_new_equity = -chg_pic,   
                      chg_MS         = MS - lag(MS, default=0),
                      ii_AT          = -ii*(1-T_),
                      ECF1           = div + net_new_equity 
                                       + chg_MS + ii_AT )
  
  ECF1 <- rotate(ECF1)
  
  return(ECF1)
  
}

ECF_method_1 <- ECF_1( data)
ECF_method_1