Related
A simulation model I created with Simmer returns a meaningful data-frame with get_mon_attributes(), however only a data-frame with 2 rows with get_mon_arrivals(). (My original code only returns a data-frame with no rows at this point). I use both data-frames to create a new data-frame to display queue and activity durations (of which there are three each) as well as throughput time for each arrival, which is then further analysed for output with Shiny (not shown in reproducible example below).
A previous version of this code worked well without issues, in spite of a more complex calculation of activity times.
I kept the reproducible example as small as possible - much of it is data. I realize it is quite large, not sure how to reduce it further, without changing it too much with regards to the original code.
I didn't find a similar problem on google or stackoverflow.com.
library(simmer)
library(dplyr)
arrivalsAtHatchV <- c(33.05, 59.65, 133.15, 187.683333333333,
190.916666666667, 191.316666666667,
191.733333333333, 192.2, 225.283333333333, 226.15,
232.483333333333,
250.983333333333, 294.616666666667, 295.05,
342.083333333333,
370.283333333333, 376.35, 381.816666666667,
392.716666666667,
393.866666666667, 398.666666666667,
399.116666666667, 400.8,
415.85, 429.65, 433.35, 436.466666666667,
437.883333333333, 439,
440.2, 440.633333333333, 441.216666666667,
443.066666666667,
457.25, 461.933333333333, 479.783333333333,
523.083333333333,
524.45)
arrivalsFromWardV <- c(18.3666666666667, 18.3666666666667, 46.15,
72.4333333333333,
72.45, 72.45, 72.4666666666667, 76.75, 80.6,
88.3833333333333,
99, 100.383333333333, 103.366666666667, 117.6,
117.683333333333,
125.466666666667, 136.633333333333,
136.633333333333, 150.033333333333,
156.6, 156.6, 158.833333333333, 158.833333333333,
158.833333333333,
158.85, 161.283333333333, 171.366666666667,
171.366666666667,
175.283333333333, 177.733333333333, 180.85,
193.366666666667,
193.383333333333, 208.266666666667,
208.683333333333, 209.166666666667,
209.266666666667, 209.366666666667, 218.55,
220.3, 232.733333333333,
235.683333333333, 237.95, 237.95,
240.383333333333, 254.083333333333,
254.75, 262.066666666667, 263.933333333333,
263.95, 275.05, 282.25,
291.45, 293.8, 309.25, 324.633333333333,
335.816666666667, 341,
342.316666666667, 343.15, 360.7, 364.5,
388.383333333333, 388.383333333333,
396.183333333333, 402.016666666667,
414.833333333333, 434.716666666667,
434.716666666667, 449.116666666667,
453.266666666667, 461.8,
469.75, 471.9, 476.116666666667, 476.2,
478.683333333333, 480.033333333333,
494.266666666667, 495.983333333333, 507.25)
defaultShiftMatrix <- structure(c(0, 0, 2, 0, 1, 2, 4, 1, 1, 2, 4, 1, 1,
2, 4, 1, 1,
2, 4, 1, 1, 0, 2, 1), .Dim = c(4L,
6L), .Dimnames = list(c("disp. pharmacist",
"ward pharmacist", "pharm. tech.", "checking tech."), c("8-9 a.m.",
"9-11 a.m.", "11 a.m.-1 p.m.", "1-3 p.m.", "3-5 p.m.", "5-6:30 p.m."
)))
outPatDurForChosenDate <- structure(list(RxID = c(108323, 108326,
108340, 108356, 108357,
108358, 108359, 108360, 108370, 108371, 108372, 108381, 108391,
108392, 108399, 108404, 108405, 108407, 108410, 108411, 108414,
108415, 108416, 108420, 108421, 108422, 108425, 108426, 108427,
108428, 108429, 108431, 108432, 108436, 108438, 108447, 108455,
108456), verifActivity = c(65, 1046, 1884, 82, 3, 6, 3, 4, 6,
663, 103, 4, 6, 5, 125, 9, 3, 13, 5, 6, 3, 6, 3, 3, 29, 5, 202,
7, 3, 3, 5, 7, 5, 4, 5, 2, 132, 5), dispActivity = c(602, 8,
702, 1032, 399, 172, 250, 301, 745, 303, 59, 4, 1278, 173, 728,
102, 356, 112, 4, 561, 1165, 383, 560, 433, 568, 604, 630, 378,
486, 3, 305, 378, 822, 257, 674, 1656, 413, 2), finCheckActivity = c(284,
162, 305, 3, 290, 163, 386, 282, 90, 56, 28, 72, 202, 67, 45,
163, 67, 59, 48, 3, 54, 2, 1, 3, 4, 263, 92, 7, 56, 2, 4, 2332,
718, 77, 7, 2, 3, 2)), row.names = c(NA, -38L), class = "data.frame")
inPatDurForChosenDate <- structure(list(RxID = c(108318, 108319, 108324, 108327, 108328,
108329, 108330, 108331, 108332, 108333, 108334, 108335, 108336,
108337, 108338, 108339, 108341, 108342, 108343, 108344, 108345,
108346, 108347, 108348, 108349, 108350, 108351, 108352, 108353,
108354, 108355, 108361, 108362, 108363, 108364, 108365, 108366,
108367, 108368, 108369, 108373, 108374, 108375, 108376, 108377,
108382, 108383, 108384, 108385, 108386, 108387, 108388, 108389,
108390, 108394, 108396, 108397, 108398, 108400, 108401, 108402,
108403, 108408, 108409, 108413, 108417, 108419, 108423, 108424,
108434, 108435, 108437, 108440, 108441, 108443, 108444, 108446,
108448, 108450, 108451, 108454), verifActivity = c(514, 224,
205, 1370, 9, 4751, 390, 5, 1057, 3699, 240, 30, 46147, 796,
753, 1020, 39, 713, 703, 401, 13517, 128, 507, 6391, 160, 6,
136, 293, 596, 196, 287, 863, 1770, 4, 548, 4, 462, 99, 118,
217, 7031, 10, 4504, 599, 44, 143, 127, 1239, 164, 94, 926, 77,
172, 4, 982, 760, 456, 44, 164, 3, 466, 2672, 710, 635, 445,
820, 2575, 8, 7, 92, 1283, 36, 4, 13, 7, 51, 131, 3, 15, 2, 4
), dispActivity = c(3, 1202, 4482, 100, 2611, 9600, 667, 1169,
596, 1124, 3, 8, 1673, 673, 977, 145, 592, 892, 300, 4004, 435,
728, 969, 1695, 1308, 8, 382, 470, 880, 366, 589, 1113, 1456,
606, 3256, 2135, 964, 145, 499, 3690, 4473, 622, 399, 878, 1687,
547, 1610, 3698, 966, 745, 127, 72, 658, 404, 15, 4103, 5827,
1175, 508, 127, 792, 2723, 33411, 617, 5037, 855, 607, 1093,
169, 3608, 925, 78, 1151, 53, 733, 1755, 579, 2014, 7953, 273,
999), finCheckActivity = c(422, 4, 3, 8, 273, 2257, 149, 579,
247, 316, 783, 2, 1, 175, 1978, 67, 545, 209, 4, 635, 4, 178,
424, 4, 2, 3, 2, 328, 163, 71, 116, 598, 1, 2, 1430, 150, 343,
22, 304, 758, 36, 201, 3, 1, 324, 157, 108, 874, 108, 94, 4,
3, 4, 31, 4, 3, 863, 6, 1, 118, 3, 64, 806, 4, 4, 215, 3, 131,
504, 1, 63, 3, 4, 278, 116, 5, 76, 1, 382, 1, 2)), row.names = c(NA,
-81L), class = "data.frame")
#The simulation model below is a function that requires a shift pattern for
#four roles, a vector outlining arrivals at the hatch and a vector outlining arrivals
#from the ward, both over 1 working day, i.e. the simulator
#runs over 1 working day. It returns a data-frame of the arrivals and one for
#their attributes:
simulationResults <- function(shiftMatrix, arrivalsAtHatchVect,
arrivalsFromWardVect, outPatDurs, inPatDurs, repeatNumber){
#outPatDurs is a data-frame containing the activity durations for outpatients
#for a chosen date
#inPatDurs is a the equivalent data-frame for inpatient wards
arrivalsAtHatchV <- arrivalsAtHatchVect
arrivalsFromWardV <- arrivalsFromWardVect
outpatientDurations <- outPatDurs
inpatientDurations <- inPatDurs
#Data input of average durations of main activities per arrival
#and duration of run.I will assume that time-units are minutes.
runDuration <- 630 #630 min. would be 10.5 hours, e.g. from 8:00 a.m. to 6:30 p.m.
arrivalFromHatch <- "hatch" #The name used for arrivals at the hatch in the model.
arrivalFromWard <- "wards" #The name used for arrivals from the wards in the model.
#Schedules (i.e. shifts for resources):
shiftTimes <- c(0, 60, 180, 300, 420, 540) # this corresponds to 8 a.m.,
#9 a.m., 11 a.m., 1 p.m., 3 p.m., and 5 p.m. - this is when number of resources
#change
disp.pharmacist.sched <- schedule(shiftTimes,
shiftMatrix["disp. pharmacist",], period = 630)
ward.pharmacist.sched <- schedule(shiftTimes,
shiftMatrix["ward pharmacist",], period = 630)
pharm.tech.sched <- schedule(shiftTimes,
shiftMatrix["pharm. tech.",], period = 630)
fin.check.sched <- schedule(shiftTimes,
shiftMatrix["checking tech.",], period = 630)
arrivalDataFrame <- NULL
for (counter in (1:repeatNumber)){
#since I want to keep the activity durations of a particular prescription
#together, I will just create a vector of randomly selected RxIDs from
#the outpatient or inpatient prescription data for the chosen day -
#these prescription numbers will be used to access the activity data
#later prescription by prescription
outpatientRxIDs <- sample(x = outpatientDurations %>% pull(RxID),
size = outpatientDurations %>% nrow(),
replace = F)
inpatientRxIDs <- sample(x = inpatientDurations %>% pull(RxID),
size = inpatientDurations %>% nrow(),
replace = F)
##############################################################
#Defining Simmer environment:
pharmacy <- simmer("Dispensing Process")
#Defining trajectory with 2 activities, the distribution of their durations
#and their required resources:
dispProcess <- trajectory("dispensing & final checking") %>%
set_attribute(keys = "progress", values = function(){5}) %>% # 5 ... waiting for dispensing
seize("dispenser", 1) %>%
set_attribute(keys = "progress", values = function(){6}) %>% # 6 ... start of dispensing
timeout(function() {durationCalculator(get_name(pharmacy),
get_attribute(pharmacy,"progress"),
outpatientRxIDs,
inpatientRxIDs,
outpatientDurations,
inpatientDurations)}) %>% #********
release("dispenser", 1) %>%
set_attribute(keys = "progress", values = function(){7}) %>% # 7 ... waiting for final checking
simmer::select(resources = c("final checker","disp_pharmacist"), policy = 'shortest-queue') %>%
seize_selected(amount = 1) %>%
set_attribute(keys = "progress", values = function(){8}) %>% # 8 ... start of final checking
timeout(function() {durationCalculator(get_name(pharmacy),
get_attribute(pharmacy,"progress"),
outpatientRxIDs,
inpatientRxIDs,
outpatientDurations,
inpatientDurations)}) %>% #********
release_selected(amount = 1) %>%
set_attribute(keys = "progress", values = function(){9}) # 9 ... finish of final checking and process
#Part of the trajectory that covers the verifying of prescriptions from the ward:
verifyingOnWards <- trajectory("verifying on wards") %>%
#Attribute keeping track of progress of Rx in process:
set_attribute(keys = "progress", values = function(){1}) %>% # 1 ... waiting for verifying
seize("ward pharmacist", 1) %>%
set_attribute(keys = "progress", values = function(){2}) %>% # 2 ... start of verifying
timeout(function() {durationCalculator(get_name(pharmacy),
get_attribute(pharmacy,"progress"),
outpatientRxIDs,
inpatientRxIDs,
outpatientDurations,
inpatientDurations)}) %>%
release("ward pharmacist", 1)
#Part of the trajectory that covers the verifying of prescriptions from the hatch (mainly
#outpatient Rxs):
verifyingOutpatients <- trajectory("verifying in dispensary") %>%
set_attribute(keys = "progress", values = function(){1}) %>% # 1 ... waiting for verifying
seize("disp_pharmacist", 1) %>%
set_attribute(keys = "progress", values = function(){2}) %>% # 2 ... start of verifying
timeout(function() {durationCalculator(get_name(pharmacy),
get_attribute(pharmacy,"progress"),
outpatientRxIDs,
inpatientRxIDs,
outpatientDurations,
inpatientDurations)}) %>%
release("disp_pharmacist", 1)
prescriptFromWard <- join(verifyingOnWards, dispProcess)
prescriptFromHatch <- join(verifyingOutpatients, dispProcess)
#Defining number of resources (i.e. staff) available:
pharmacy %>%
add_resource("disp_pharmacist", disp.pharmacist.sched) %>%
add_resource("ward pharmacist", ward.pharmacist.sched) %>%
add_resource("dispenser", pharm.tech.sched) %>%
add_resource("final checker", fin.check.sched) %>%
add_generator(arrivalFromHatch, prescriptFromHatch, at(arrivalsAtHatchV), mon = 2) %>%
add_generator(arrivalFromWard, prescriptFromWard, at(arrivalsFromWardV), mon = 2)
#Defining length of simulation run:
pharmacy %>% run(until = runDuration)
#Output of data to data-frame:
arrivals.df <- pharmacy %>% get_mon_arrivals() %>% .[order(.$start_time),]
attributes.df <- pharmacy %>% get_mon_attributes() %>% .[order(.$time),]
arrivalDataFrame <- arrivalDataFrame %>%
rbind(arrivals.df %>% cbind(trial = counter))
}
return(arrivalDataFrame)
}
#This function returns a duration dependend on attributes in the trajectory below;
durationCalculator <- function(arrivName, activity, outpatRxIDs,
inpatRxIDs, outpatDurs, inpatDurs){
#arrivName is the name of the arrival, e.g. "wards11", or "hatch5" -
#the last digits are to count the arrivals
#activity is an integer from 1 to 9
#depending on these two parameters an activity duration is picked from a
#data-frame, i.e. outpatientDurations or inpatientDurations
kounter <- substr(arrivName, start = 6, stop = nchar(arrivName)) %>% #both arrival names have 5 letters
as.integer() %>% "+" (1) #this is to extract the number of the arrival
currActivity <- switch(activity %>% as.character(), "2" ="verifActivity",
"6" = "dispActivity", "8" = "finCheckActivity")
if (grepl("hatch",arrivName)){ #this expression would be true for an inpatient Rx
r <- outpatDurs[
outpatDurs$RxID == outpatRxIDs[kounter],
currActivity]
}else{
r <- inpatDurs[
inpatDurs$RxID == inpatRxIDs[kounter],
currActivity]
}
return(r)
}
simulationResults(defaultShiftMatrix, arrivalsAtHatchV, arrivalsFromWardV,
outPatDurForChosenDate, inPatDurForChosenDate, 1) %>% #the last digit is the number of
print()
I would have expected the Simmer simulation to take account of all arrivals as per arrivalsAtHatchV and arrivalsFromWardV. This does not happen, however.
Any help would be greatly appreciated.
See comment above. Need to watch what I feed my functions in the future.
I have some missing data that I am trying to impute to the mean of each column. My code,
apply(train_new, 2, function(x)
mutate(
ifelse(is.na(x) | x < 0, mean(x), x)
)
)
is meant to impute all 17 columns to the mean of each column in one fell swoop, but this returns Error during wrapup: no applicable method for 'mutate_' applied to an object of class "c('double', 'numeric')", and leads me to a debug screen. I'm sure this is just a syntactical issue, but I'm at a loss as to where it is.
Sample data:
structure(list(INDEX = c(1, 2, 3, 4, 5, 6), TARGET_WINS = c(39,
70, 86, 70, 82, 75), TEAM_BATTING_H = c(1445, 1339, 1377, 1387,
1297, 1279), TEAM_BATTING_2B = c(194, 219, 232, 209, 186, 200
), TEAM_BATTING_3B = c(39, 22, 35, 38, 27, 36), TEAM_BATTING_HR = c(13,
190, 137, 96, 102, 92), TEAM_BATTING_BB = c(457.7607, 685, 602,
451, 472, 443), TEAM_BATTING_SO = c(842, 1075, 917, 922, 920,
973), TEAM_BASERUN_SB = c(97.288, 37, 46, 43, 49, 107), TEAM_BASERUN_CS = c(NA,
28, 27, 30, 39, 59), TEAM_PITCHING_H = c(NA, 1347, 1377, 1396,
1297, 1279), TEAM_PITCHING_HR = c(84, 191, 137, 97, 102, 92),
TEAM_PITCHING_BB = c(530.9595, 689, 602, 454, 472, 443),
TEAM_PITCHING_SO = c(737.105, 1082, 917, 928, 920, 973),
TEAM_FIELDING_E = c(NA, 193, 175, 164, 138, 123), TEAM_FIELDING_DP = c(146.234708045,
155, 153, 156, 168, 149), TEAM_BATTING_1B = c(1199, 908,
973, 1044, 982, 951)), row.names = c(NA, -6L), class = c("tbl_df",
"tbl", "data.frame"))
You could try:
library(dplyr)
train_new %>%
mutate_all(funs(ifelse(is.na(.) | . < 0, mean(., na.rm = T), .)))
Here is one option with na.aggregate (from zoo)
library(zoo)
na.aggregate(replace(train_new, train_new < 0, NA))
Im creating a ggplot with geom_vline at a specific location on the x axis. i would like the x axis to show that specific value
Following is my data + code:
dput(agg_data)
structure(list(latency = structure(c(0, 1, 2, 3, 4, 5, 6, 7,
8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 24, 26, 28,
29, 32, 36, 37, 40, 43, 46, 47, 48, 49, 54, 64, 71, 72, 75, 87,
88, 89, 93, 134, 151), class = "difftime", units = "days"), count = c(362,
11, 8, 5, 4, 2, 8, 6, 4, 2, 2, 1, 5, 1, 2, 2, 2, 1, 1, 1, 2,
1, 2, 1, 1, 1, 1, 1, 1, 1, 2, 2, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1,
1, 1, 1), cum_sum = c(362, 373, 381, 386, 390, 392, 400, 406,
410, 412, 414, 415, 420, 421, 423, 425, 427, 428, 429, 430, 432,
433, 435, 436, 437, 438, 439, 440, 441, 442, 444, 446, 447, 448,
449, 451, 452, 453, 454, 455, 456, 457, 458, 459, 460), cum_dist = c(0.78695652173913,
0.810869565217391, 0.828260869565217, 0.839130434782609, 0.847826086956522,
0.852173913043478, 0.869565217391304, 0.882608695652174, 0.891304347826087,
0.895652173913044, 0.9, 0.902173913043478, 0.91304347826087,
0.915217391304348, 0.919565217391304, 0.923913043478261, 0.928260869565217,
0.930434782608696, 0.932608695652174, 0.934782608695652, 0.939130434782609,
0.941304347826087, 0.945652173913043, 0.947826086956522, 0.95,
0.952173913043478, 0.954347826086957, 0.956521739130435, 0.958695652173913,
0.960869565217391, 0.965217391304348, 0.969565217391304, 0.971739130434783,
0.973913043478261, 0.976086956521739, 0.980434782608696, 0.982608695652174,
0.984782608695652, 0.98695652173913, 0.989130434782609, 0.991304347826087,
0.993478260869565, 0.995652173913044, 0.997826086956522, 1)), .Names = c("latency",
"count", "cum_sum", "cum_dist"), row.names = c(NA, -45L), class = "data.frame")
and code:
library(ggplot2)
library(ggthemes)
russ<-ggplot(data=agg_data,aes(x=as.numeric(latency),y=cum_dist))+geom_line(size=2)
russ<-russ+ggtitle("Latency from first click to Qualified Demo:") + xlab("in Days")+ ylab("Proportion of maturity")+theme_economist()
russ<-russ+geom_vline(aes(xintercept=10), color="black", linetype="dashed")
russ
which creates the following plot:
I want the plot show the value '10' (same location as the vline) on the x-axis
I looked for some other similar answers, like in Customize axis labels
but this one re creates the x axis labels (with scale_x_discrete), and does not add a new number to the current scale, which is more of what im looking for.
thanks in advance!
In your case x scale is continuous, so you can use function scale_x_continuous() and provide breaks at positions you need.
russ + scale_x_continuous(breaks=c(0,10,50,100,150))
I have the following 3 tables:
AggData <- structure(list(Path = c("NonBrand", "Brand", "NonBrand,NonBrand",
"Brand,Brand", "NonBrand,NonBrand,NonBrand", "Brand,Brand,Brand",
"Brand,NonBrand", "NonBrand,Brand", "NonBrand,NonBrand,NonBrand,NonBrand",
"Brand,Brand,Brand,Brand", "NonBrand,NonBrand,NonBrand,NonBrand,NonBrand",
"Brand,Brand,Brand,Brand,Brand", "Brand,Brand,NonBrand", "NonBrand,Brand,Brand",
"Brand,NonBrand,NonBrand", "NonBrand,NonBrand,NonBrand,NonBrand,NonBrand,NonBrand",
"NonBrand,NonBrand,Brand", "Brand,NonBrand,Brand", "NonBrand,Brand,NonBrand",
"NonBrand,NonBrand,NonBrand,NonBrand,NonBrand,NonBrand,NonBrand",
"Brand,Brand,Brand,Brand,Brand,Brand", "NonBrand,NonBrand,NonBrand,NonBrand,NonBrand,NonBrand,NonBrand,NonBrand",
"NonBrand,Brand,Brand,Brand", "NonBrand,NonBrand,NonBrand,Brand",
"Brand,Brand,Brand,NonBrand", "Brand,Brand,Brand,Brand,Brand,Brand,Brand",
"Brand,NonBrand,NonBrand,NonBrand", "NonBrand,NonBrand,Brand,Brand",
"Brand,Brand,NonBrand,NonBrand", "Brand,NonBrand,Brand,Brand",
"NonBrand,NonBrand,NonBrand,NonBrand,NonBrand,NonBrand,NonBrand,NonBrand,NonBrand",
"Brand,Brand,NonBrand,Brand", "NonBrand,Brand,NonBrand,NonBrand",
"Brand,Brand,Brand,Brand,Brand,Brand,Brand,Brand", "NonBrand,NonBrand,NonBrand,NonBrand,NonBrand,NonBrand,NonBrand,NonBrand,NonBrand,NonBrand",
"NonBrand,NonBrand,Brand,NonBrand", "Brand,NonBrand,NonBrand,Brand",
"NonBrand,Brand,Brand,Brand,Brand", "NonBrand,NonBrand,NonBrand,NonBrand,Brand",
"Brand,NonBrand,Brand,NonBrand", "NonBrand,Brand,Brand,NonBrand",
"Brand,Brand,Brand,Brand,NonBrand", "Brand,NonBrand,NonBrand,NonBrand,NonBrand",
"Brand,Brand,Brand,Brand,Brand,Brand,Brand,Brand,Brand", "NonBrand,NonBrand,NonBrand,NonBrand,NonBrand,NonBrand,NonBrand,NonBrand,NonBrand,NonBrand,NonBrand",
"Brand,NonBrand,Brand,Brand,Brand", "NonBrand,Brand,NonBrand,Brand",
"Brand,Brand,Brand,NonBrand,Brand", "NonBrand,NonBrand,Brand,Brand,Brand",
"NonBrand,NonBrand,NonBrand,Brand,Brand", "Brand,Brand,NonBrand,Brand,Brand",
"Brand,Brand,Brand,NonBrand,NonBrand", "Brand,Brand,Brand,Brand,Brand,Brand,Brand,Brand,Brand,Brand",
"NonBrand,NonBrand,NonBrand,Brand,NonBrand", "Brand,Brand,NonBrand,NonBrand,NonBrand",
"NonBrand,Brand,Brand,Brand,Brand,Brand", "NonBrand,Brand,NonBrand,NonBrand,NonBrand",
"NonBrand,NonBrand,Brand,NonBrand,NonBrand", "NonBrand,NonBrand,NonBrand,NonBrand,NonBrand,Brand",
"Brand,NonBrand,NonBrand,NonBrand,NonBrand,NonBrand", "Brand,Brand,Brand,Brand,Brand,NonBrand",
"NonBrand,Brand,Brand,NonBrand,NonBrand", "Brand,NonBrand,NonBrand,Brand,Brand",
"NonBrand,NonBrand,NonBrand,NonBrand,Brand,Brand", "NonBrand,NonBrand,Brand,Brand,Brand,Brand",
"NonBrand,NonBrand,NonBrand,NonBrand,Brand,NonBrand", "NonBrand,NonBrand,Brand,NonBrand,Brand",
"Brand,NonBrand,NonBrand,Brand,NonBrand", "NonBrand,NonBrand,NonBrand,Brand,Brand,Brand",
"NonBrand,Brand,Brand,NonBrand,Brand", "Brand,NonBrand,NonBrand,NonBrand,NonBrand,Brand",
"Brand,Brand,NonBrand,NonBrand,NonBrand,NonBrand,NonBrand", "Brand,Brand,Brand,Brand,NonBrand,NonBrand,NonBrand"
), click_count = c(1799265, 874478, 198657, 128159, 45728, 30172,
20520, 17815, 16718, 9479, 6554, 3722, 3561, 3408, 3391, 3366,
3256, 2526, 1846, 1708, 1682, 1013, 951, 899, 881, 782, 780,
703, 642, 625, 615, 601, 453, 442, 414, 407, 362, 343, 313, 284,
281, 281, 271, 269, 268, 229, 223, 218, 215, 212, 204, 162, 161,
158, 155, 145, 132, 130, 115, 103, 102, 86, 77, 77, 72, 68, 68,
67, 58, 52, 32, 18, 18), conv_count = c(30938, 19652, 7401, 3803,
2014, 1072, 1084, 981, 652, 379, 230, 166, 205, 246, 254, 93,
239, 104, 112, 51, 76, 23, 66, 81, 55, 29, 62, 57, 50, 37, 17,
33, 38, 17, 8, 41, 33, 30, 24, 16, 26, 18, 16, 17, 7, 21, 10,
8, 27, 23, 11, 13, 6, 15, 14, 16, 8, 10, 6, 6, 11, 11, 8, 9,
8, 8, 9, 7, 7, 6, 6, 6, 7), CR = c(0.0171947989873643, 0.0224728352228415,
0.0372551684561833, 0.0296740767328085, 0.0440430370888733, 0.0355296301206417,
0.0528265107212476, 0.0550659556553466, 0.0389998803684651, 0.0399831205823399,
0.0350930729325603, 0.0445996775926921, 0.057568098848638, 0.0721830985915493,
0.0749041580654674, 0.0276292335115865, 0.0734029484029484, 0.0411718131433096,
0.0606717226435536, 0.0298594847775176, 0.0451843043995244, 0.0227048371174729,
0.0694006309148265, 0.0901001112347052, 0.0624290578887628, 0.0370843989769821,
0.0794871794871795, 0.0810810810810811, 0.0778816199376947, 0.0592,
0.0276422764227642, 0.0549084858569052, 0.0838852097130243, 0.0384615384615385,
0.0193236714975845, 0.100737100737101, 0.0911602209944751, 0.0874635568513119,
0.0766773162939297, 0.0563380281690141, 0.0925266903914591, 0.0640569395017794,
0.0590405904059041, 0.0631970260223048, 0.0261194029850746, 0.091703056768559,
0.0448430493273543, 0.036697247706422, 0.125581395348837, 0.108490566037736,
0.053921568627451, 0.0802469135802469, 0.0372670807453416, 0.0949367088607595,
0.0903225806451613, 0.110344827586207, 0.0606060606060606, 0.0769230769230769,
0.0521739130434783, 0.058252427184466, 0.107843137254902, 0.127906976744186,
0.103896103896104, 0.116883116883117, 0.111111111111111, 0.117647058823529,
0.132352941176471, 0.104477611940299, 0.120689655172414, 0.115384615384615,
0.1875, 0.333333333333333, 0.388888888888889)), .Names = c("Path",
"click_count", "conv_count", "CR"), row.names = c(NA, -73L), class = "data.frame")
another one here:
breakVector <- structure(list(breakVector = structure(c(1L, 1L), .Label = "NonBrand", class = "factor"),
CR = c(0.461541302855402, 0.538458697144598)), .Names = c("breakVector",
"CR"), row.names = c(NA, -2L), class = "data.frame")
and:
FinalTable <- structure(list(autribution_category = structure(c(2L, 1L), .Label = c("Brand",
"NonBrand"), class = "factor"), attributed_result = c(0, 0)), .Names = c("autribution_category",
"attributed_result"), row.names = 1:2, class = "data.frame")
when I run the following command:
if (FinalTable [2,1] == breakVector[1,1]) {
FinalTable$attributed_result[2] <- FinalTable$attributed_result[2] +
breakVector[1,2] * AggData$conv_count[3];
break}
I get the following error:
Error in Ops.factor(FinalTable[2, 1], breakVector[1, 1]) :
level sets of factors are different
This is pretty weird, since both values that im comparing are factors, I don't see any reason why R cant compare the two levels?
FinalTable[2,1] and breakVector[1,1] do not have the same levels:
> FinalTable[2,1]
[1] Brand
Levels: Brand NonBrand
> breakVector[1,1]
[1] NonBrand
Levels: NonBrand
This is easily fixed by using
breakVector[,1] <- factor(breakVector[,1], levels=c("Brand", "NonBrand"))
or, more generally
breakVector[,1] <- factor(breakVector[,1], levels=levels(FinalTable[,1]))
Perhaps, it will better compare both variables like a string:
if (as.character(FinalTable [2,1]) == as.character(breakVector[1,1])) {
FinalTable$attributed_result[2] <- FinalTable$attributed_result[2] +
breakVector[1,2] * AggData$conv_count[3];
break}
I have a dataframe of 3500 X 4000. I am trying to write a professional command in R to remove any columns in a matrix that show the same variance. I am able to do this a with a long, complicated command such as
datavar <- apply(data, 2, var)
datavar <- datavar[!duplicated(datavar)]
then assemble my data by matching the remaining column names, but this is SAD! I was hoping to do this in a single go. I was thinking of something like
data <- data[, which(apply(data, 2, function(col) !any(var(data) = any(var(data)) )))]
I know the last part of the above command is nonsense, but I also know there is someway it can be done in some... smart command!
Here's some data that applies to the question
data <- structure(list(V1 = c(3, 213, 1, 135, 5, 2323, 1231, 351, 1,
33, 2, 213, 153, 132, 1321, 53, 1, 231, 351, 3135, 13), V2 = c(1,
1, 1, 2, 3, 5, 13, 33, 53, 132, 135, 153, 213, 213, 231, 351,
351, 1231, 1321, 2323, 3135), V3 = c(65, 41, 1, 53132, 1, 6451,
3241, 561, 321, 534, 31, 135, 1, 1351, 31, 351, 31, 31, 3212,
3132, 1), V4 = c(2, 2, 5, 4654, 5641, 21, 21, 1, 1, 465, 31,
4, 651, 35153, 13, 132, 123, 1231, 321, 321, 5), V5 = c(23, 13,
213, 135, 15341, 564, 564, 8, 464, 8, 484, 6546, 132, 165, 123,
135, 132, 132, 123, 123, 2), V6 = c(2, 1, 84, 86468, 464, 18,
45, 55, 2, 5, 12, 4512, 5, 123, 132465, 12, 456, 15, 45, 123213,
12), V7 = c(1, 2, 2, 5, 5, 12, 12, 12, 15, 18, 45, 45, 55, 84,
123, 456, 464, 4512, 86468, 123213, 132465)), .Names = c("V1",
"V2", "V3", "V4", "V5", "V6", "V7"), row.names = c(NA, 21L), class = "data.frame")
Would I be able to keep one of the "similar variance" columns too?
Thanks,
I might go a more cautious route, like
data[, !duplicated(round(sapply(data,var),your_precision_here))]
This is pretty similar to what you've come up with:
vars <- lapply(data,var)
data[,which(sapply(1:length(vars), function(x) !vars[x] %in% vars[-x]))]
One thing to think about though is whether you want to match variances exactly (as in this example) or just variances that are close. The latter would be a significantly more challenging problem.
... or as alternative:
data[ , !c(duplicated(apply(data, 2, var)) | duplicated(apply(data, 2, var), fromLast=TRUE))]
...but also not shorter :)