nmelone/GoldenCheetah
1
0
Fork 0
mirror of https://github.com/GoldenCheetah/GoldenCheetah.git synced 2026-02-13 16:18:42 +00:00
Code Issues Packages Projects Releases Wiki Activity

R Use List not Pairlist (Part 2 of 2)

Browse Source 
.. completes the updates to RTool.cpp

.. as predicted by forming the pmc data.frame via an S3
   list instead of a pair list the merge() function works
   properly and column names are retained.
This commit is contained in:
Mark Liversedge
2016-05-26 21:19:52 +01:00
parent 236d34be82
commit b3607eedad
2 changed files with 69 additions and 109 deletions
Download Patch File Download Diff File Expand all files Collapse all files

176
src/R/RTool.cpp
View File

@@ -1779,13 +1779,12 @@ RTool::dfForRideFileCache(RideFileCache *cache)
// we return a list of series vectors
SEXP ans;
PROTECT(ans = Rf_allocList(seriescount));
PROTECT(ans = Rf_allocVector(VECSXP, seriescount));
// we collect the names as we go
SEXP names;
PROTECT(names = Rf_allocVector(STRSXP, seriescount)); // names attribute (column names)
int next=0;
SEXP nextS = ans;
//
// Now we need to add vectors to the ans list...
@@ -1809,8 +1808,7 @@ RTool::dfForRideFileCache(RideFileCache *cache)
for(int j=0; j<values.count(); j++) REAL(vector)[j] = values[j];
// add to the list
SETCAR(nextS, vector);
nextS = CDR(nextS);
SET_VECTOR_ELT(ans, next, vector);
// give it a name
SET_STRING_ELT(names, next, Rf_mkChar(RideFile::seriesName(series, true).toLatin1().constData()));
@@ -1892,10 +1890,8 @@ RTool::seasonPeaks(SEXP pAll, SEXP pFilter, SEXP pCompare, SEXP pSeries, SEXP pD
// cool we can return a list of intervals to compare
SEXP list;
PROTECT(list=Rf_allocList(count));
// start at the front
SEXP nextS = list;
PROTECT(list=Rf_allocVector(VECSXP, count));
int index=0;
// a named list with data.frame 'metrics' and color 'color'
SEXP namedlist;
@@ -1911,26 +1907,23 @@ RTool::seasonPeaks(SEXP pAll, SEXP pFilter, SEXP pCompare, SEXP pSeries, SEXP pD
if (p.isChecked()) {
// create a named list
PROTECT(namedlist=Rf_allocList(2));
SEXP offset = namedlist;
PROTECT(namedlist=Rf_allocVector(VECSXP, 2));
// add the ride
SEXP df = rtool->dfForDateRangePeaks(all, DateRange(p.start, p.end), pFilter, series, durations);
SETCAR(offset, df);
offset=CDR(offset);
SET_VECTOR_ELT(namedlist, 0, df);
// add the color
SEXP color;
PROTECT(color=Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(color, 0, Rf_mkChar(p.color.name().toLatin1().constData()));
SETCAR(offset, color);
SET_VECTOR_ELT(namedlist, 1, color);
// name them
Rf_namesgets(namedlist, names);
// add to back and move on
SETCAR(nextS, namedlist);
nextS=CDR(nextS);
SET_VECTOR_ELT(list, index++, namedlist);
UNPROTECT(2);
}
@@ -1943,7 +1936,7 @@ RTool::seasonPeaks(SEXP pAll, SEXP pFilter, SEXP pCompare, SEXP pSeries, SEXP pD
// otherwise return the current metrics in a compare list
SEXP list;
PROTECT(list=Rf_allocList(1));
PROTECT(list=Rf_allocVector(VECSXP, 1));
// names
SEXP names;
@@ -1953,26 +1946,24 @@ RTool::seasonPeaks(SEXP pAll, SEXP pFilter, SEXP pCompare, SEXP pSeries, SEXP pD
// named list of metrics and color
SEXP namedlist;
PROTECT(namedlist=Rf_allocList(2));
SEXP offset = namedlist;
PROTECT(namedlist=Rf_allocVector(VECSXP, 2));
// add the metrics
DateRange range = rtool->context->currentDateRange();
SEXP df = rtool->dfForDateRangePeaks(all, range, pFilter, series, durations);
SETCAR(offset, df);
offset=CDR(offset);
SET_VECTOR_ELT(namedlist, 0, df);
// add the color
SEXP color;
PROTECT(color=Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(color, 0, Rf_mkChar("#FF00FF"));
SETCAR(offset, color);
SET_VECTOR_ELT(namedlist, 1, color);
// name them
Rf_namesgets(namedlist, names);
// add to back and move on
SETCAR(list, namedlist);
SET_VECTOR_ELT(list, 0, namedlist);
UNPROTECT(4);
return list;
@@ -1996,8 +1987,8 @@ RTool::dfForDateRangePeaks(bool all, DateRange range, SEXP filter, QList<RideFil
// so how many vectors in the frame ? +1 is the datetime of the peak
int listsize=series.count() * durations.count() + 1;
SEXP df;
PROTECT(df=Rf_allocList(listsize));
SEXP nextS=df;
PROTECT(df=Rf_allocVector(VECSXP, listsize));
int dfindex=0;
// and each one needs a name
SEXP names;
@@ -2064,8 +2055,7 @@ RTool::dfForDateRangePeaks(bool all, DateRange range, SEXP filter, QList<RideFil
Rf_classgets(dates,clas);
Rf_setAttrib(dates, Rf_install("tzone"), Rf_mkString("UTC"));
SETCAR(nextS, dates);
nextS=CDR(nextS);
SET_VECTOR_ELT(df, dfindex++, dates);
foreach(RideFile::SeriesType pseries, series) {
@@ -2097,8 +2087,7 @@ RTool::dfForDateRangePeaks(bool all, DateRange range, SEXP filter, QList<RideFil
}
// add named vector to the list
SETCAR(nextS, vector);
nextS=CDR(nextS);
SET_VECTOR_ELT(df, dfindex++, vector);
UNPROTECT(1);
@@ -2148,10 +2137,8 @@ RTool::seasonMeanmax(SEXP pAll, SEXP pFilter, SEXP pCompare)
// cool we can return a list of meanaxes to compare
SEXP list;
PROTECT(list=Rf_allocList(count));
// start at the front
SEXP nextS = list;
PROTECT(list=Rf_allocVector(VECSXP, count));
int lindex=0;
// a named list with data.frame 'metrics' and color 'color'
SEXP namedlist;
@@ -2167,26 +2154,23 @@ RTool::seasonMeanmax(SEXP pAll, SEXP pFilter, SEXP pCompare)
if (p.isChecked()) {
// create a named list
PROTECT(namedlist=Rf_allocList(2));
SEXP offset = namedlist;
PROTECT(namedlist=Rf_allocVector(VECSXP, 2));
// add the ride
SEXP df = rtool->dfForDateRangeMeanmax(all, DateRange(p.start, p.end), pFilter);
SETCAR(offset, df);
offset=CDR(offset);
SET_VECTOR_ELT(namedlist, 0, df);
// add the color
SEXP color;
PROTECT(color=Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(color, 0, Rf_mkChar(p.color.name().toLatin1().constData()));
SETCAR(offset, color);
SET_VECTOR_ELT(namedlist, 1, color);
// name them
Rf_namesgets(namedlist, names);
// add to back and move on
SETCAR(nextS, namedlist);
nextS=CDR(nextS);
SET_VECTOR_ELT(list, lindex++, namedlist);
UNPROTECT(2);
}
@@ -2199,7 +2183,7 @@ RTool::seasonMeanmax(SEXP pAll, SEXP pFilter, SEXP pCompare)
// otherwise return the current season meanmax in a compare list
SEXP list;
PROTECT(list=Rf_allocList(1));
PROTECT(list=Rf_allocVector(VECSXP, 1));
// names
SEXP names;
@@ -2209,26 +2193,24 @@ RTool::seasonMeanmax(SEXP pAll, SEXP pFilter, SEXP pCompare)
// named list of metrics and color
SEXP namedlist;
PROTECT(namedlist=Rf_allocList(2));
SEXP offset = namedlist;
PROTECT(namedlist=Rf_allocVector(VECSXP, 2));
// add the meanmaxes
DateRange range = rtool->context->currentDateRange();
SEXP df = rtool->dfForDateRangeMeanmax(all, range, pFilter);
SETCAR(offset, df);
offset=CDR(offset);
SET_VECTOR_ELT(namedlist, 0, df);
// add the color
SEXP color;
PROTECT(color=Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(color, 0, Rf_mkChar("#FF00FF"));
SETCAR(offset, color);
SET_VECTOR_ELT(namedlist, 1, color);
// name them
Rf_namesgets(namedlist, names);
// add to back and move on
SETCAR(list, namedlist);
SET_VECTOR_ELT(list, 0, namedlist);
UNPROTECT(4);
return list;
@@ -2269,10 +2251,8 @@ RTool::activityMeanmax(SEXP pCompare)
// cool we can return a list of intervals to compare
SEXP list;
PROTECT(list=Rf_allocList(count));
// start at the front
SEXP nextS = list;
PROTECT(list=Rf_allocVector(VECSXP, count));
int lindex=0;
// a named list with data.frame 'activity' and color 'color'
SEXP namedlist;
@@ -2288,26 +2268,23 @@ RTool::activityMeanmax(SEXP pCompare)
if (p.isChecked()) {
// create a named list
PROTECT(namedlist=Rf_allocList(2));
SEXP offset = namedlist;
PROTECT(namedlist=Rf_allocVector(VECSXP, 2));
// add the ride
SEXP df = rtool->dfForActivityMeanmax(p.rideItem);
SETCAR(offset, df);
offset=CDR(offset);
SET_VECTOR_ELT(namedlist, 0, df);
// add the color
SEXP color;
PROTECT(color=Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(color, 0, Rf_mkChar(p.color.name().toLatin1().constData()));
SETCAR(offset, color);
SET_VECTOR_ELT(namedlist, 1, color);
// name them
Rf_namesgets(namedlist, names);
// add to back and move on
SETCAR(nextS, namedlist);
nextS=CDR(nextS);
SET_VECTOR_ELT(list, lindex++, namedlist);
UNPROTECT(2);
}
@@ -2321,7 +2298,7 @@ RTool::activityMeanmax(SEXP pCompare)
// just return a list of one ride
// cool we can return a list of intervals to compare
SEXP list;
PROTECT(list=Rf_allocList(1));
PROTECT(list=Rf_allocVector(VECSXP, 1));
// names
SEXP names;
@@ -2331,25 +2308,23 @@ RTool::activityMeanmax(SEXP pCompare)
// named list of activity and color
SEXP namedlist;
PROTECT(namedlist=Rf_allocList(2));
SEXP offset = namedlist;
PROTECT(namedlist=Rf_allocVector(VECSXP, 2));
// add the ride
SEXP df = rtool->dfForActivityMeanmax(rtool->context->currentRideItem());
SETCAR(offset, df);
offset=CDR(offset);
SET_VECTOR_ELT(namedlist, 0, df);
// add the color
SEXP color;
PROTECT(color=Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(color, 0, Rf_mkChar("#FF00FF"));
SETCAR(offset, color);
SET_VECTOR_ELT(namedlist, 1, color);
// name them
Rf_namesgets(namedlist, names);
// add to back and move on
SETCAR(list, namedlist);
SET_VECTOR_ELT(list, 0, namedlist);
UNPROTECT(4);
return list;
@@ -2392,10 +2367,8 @@ RTool::activityMetrics(SEXP pCompare)
// cool we can return a list of intervals to compare
SEXP list;
PROTECT(list=Rf_allocList(count));
// start at the front
SEXP nextS = list;
PROTECT(list=Rf_allocVector(VECSXP, count));
int lindex=0;
// a named list with data.frame 'activity' and color 'color'
SEXP namedlist;
@@ -2411,26 +2384,23 @@ RTool::activityMetrics(SEXP pCompare)
if (p.isChecked()) {
// create a named list
PROTECT(namedlist=Rf_allocList(2));
SEXP offset = namedlist;
PROTECT(namedlist=Rf_allocVector(VECSXP, 2));
// add the ride
SEXP df = rtool->dfForRideItem(p.rideItem);
SETCAR(offset, df);
offset=CDR(offset);
SET_VECTOR_ELT(namedlist, 0, df);
// add the color
SEXP color;
PROTECT(color=Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(color, 0, Rf_mkChar(p.color.name().toLatin1().constData()));
SETCAR(offset, color);
SET_VECTOR_ELT(namedlist, 1, color);
// name them
Rf_namesgets(namedlist, names);
// add to back and move on
SETCAR(nextS, namedlist);
nextS=CDR(nextS);
SET_VECTOR_ELT(list, lindex++, namedlist);
UNPROTECT(2);
}
@@ -2444,7 +2414,7 @@ RTool::activityMetrics(SEXP pCompare)
// just return a list of one ride
// cool we can return a list of intervals to compare
SEXP list;
PROTECT(list=Rf_allocList(1));
PROTECT(list=Rf_allocVector(VECSXP, 1));
// names
SEXP names;
@@ -2454,25 +2424,23 @@ RTool::activityMetrics(SEXP pCompare)
// named list of activity and color
SEXP namedlist;
PROTECT(namedlist=Rf_allocList(2));
SEXP offset = namedlist;
PROTECT(namedlist=Rf_allocVector(VECSXP, 2));
// add the ride
SEXP df = rtool->dfForRideItem(rtool->context->currentRideItem());
SETCAR(offset, df);
offset=CDR(offset);
SET_VECTOR_ELT(namedlist, 0, df);
// add the color
SEXP color;
PROTECT(color=Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(color, 0, Rf_mkChar("#FF00FF"));
SETCAR(offset, color);
SET_VECTOR_ELT(namedlist, 1, color);
// name them
Rf_namesgets(namedlist, names);
// add to back and move on
SETCAR(list, namedlist);
SET_VECTOR_ELT(list, 0, namedlist);
UNPROTECT(4);
return list;
@@ -2542,8 +2510,7 @@ RTool::pmc(SEXP pAll, SEXP pMetric)
SEXP ans, names;
// date, stress, lts, sts, sb, rr
PROTECT(ans=Rf_allocList(6));
SEXP nextS = ans;
PROTECT(ans=Rf_allocVector(VECSXP, 6));
// set ther names
PROTECT(names = Rf_allocVector(STRSXP, 6));
@@ -2566,7 +2533,7 @@ RTool::pmc(SEXP pAll, SEXP pMetric)
Rf_classgets(date,dclas);
// add to the data.frame
SETCAR(nextS, date); nextS=CDR(nextS);
SET_VECTOR_ELT(ans, 0, date);
// PMC DATA
@@ -2607,11 +2574,11 @@ RTool::pmc(SEXP pAll, SEXP pMetric)
}
// add to the list
SETCAR(nextS, stress); nextS = CDR(nextS);
SETCAR(nextS, lts); nextS = CDR(nextS);
SETCAR(nextS, sts); nextS = CDR(nextS);
SETCAR(nextS, sb); nextS = CDR(nextS);
SETCAR(nextS, rr); nextS = CDR(nextS);
SET_VECTOR_ELT(ans, 1, stress);
SET_VECTOR_ELT(ans, 2, lts);
SET_VECTOR_ELT(ans, 3, sts);
SET_VECTOR_ELT(ans, 4, sb);
SET_VECTOR_ELT(ans, 5, rr);
SEXP rownames;
PROTECT(rownames = Rf_allocVector(STRSXP, size));
@@ -2656,10 +2623,8 @@ RTool::activityWBal(SEXP pCompare)
// cool we can return a list of intervals to compare
SEXP list;
PROTECT(list=Rf_allocList(count));
// start at the front
SEXP nextS = list;
PROTECT(list=Rf_allocVector(VECSXP, count));
int lindex=0;
// a named list with data.frame 'activity' and color 'color'
SEXP namedlist;
@@ -2675,26 +2640,23 @@ RTool::activityWBal(SEXP pCompare)
if (p.isChecked()) {
// create a named list
PROTECT(namedlist=Rf_allocList(2));
SEXP offset = namedlist;
PROTECT(namedlist=Rf_allocVector(VECSXP, 2));
// add the ride
SEXP df = rtool->dfForActivityWBal(p.rideItem->ride());
SETCAR(offset, df);
offset=CDR(offset);
SET_VECTOR_ELT(namedlist, 0, df);
// add the color
SEXP color;
PROTECT(color=Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(color, 0, Rf_mkChar(p.color.name().toLatin1().constData()));
SETCAR(offset, color);
SET_VECTOR_ELT(namedlist, 1, color);
// name them
Rf_namesgets(namedlist, names);
// add to back and move on
SETCAR(nextS, namedlist);
nextS=CDR(nextS);
SET_VECTOR_ELT(list, lindex++, namedlist);
UNPROTECT(2);
}
@@ -2708,7 +2670,7 @@ RTool::activityWBal(SEXP pCompare)
// just return a list of one ride
// cool we can return a list of intervals to compare
SEXP list;
PROTECT(list=Rf_allocList(1));
PROTECT(list=Rf_allocVector(VECSXP, 1));
// names
SEXP names;
@@ -2718,27 +2680,25 @@ RTool::activityWBal(SEXP pCompare)
// named list of activity and color
SEXP namedlist;
PROTECT(namedlist=Rf_allocList(2));
SEXP offset = namedlist;
PROTECT(namedlist=Rf_allocVector(VECSXP, 2));
// add the ride
RideFile *f = const_cast<RideItem*>(rtool->context->currentRideItem())->ride();
f->recalculateDerivedSeries();
SEXP df = rtool->dfForActivityWBal(f);
SETCAR(offset, df);
offset=CDR(offset);
SET_VECTOR_ELT(namedlist, 0, df);
// add the color
SEXP color;
PROTECT(color=Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(color, 0, Rf_mkChar("#FF00FF"));
SETCAR(offset, color);
SET_VECTOR_ELT(namedlist, 1, color);
// name them
Rf_namesgets(namedlist, names);
// add to back and move on
SETCAR(list, namedlist);
SET_VECTOR_ELT(list, 0, namedlist);
UNPROTECT(4);
return list;

2
test/charts/TSB v IF.gchart
View File

@@ -10,7 +10,7 @@
"heightFactor":"2",
"style":"0",
"resizable":"0",
"script":"##\n## TSB v IF with TSS\n##\n## How fresh were we and how hard did we go\n## and how much stress did we elicit.\n## A more meaningful way of reviewing the\n## PMC data in terms of managing load\/intensity\n\nGC.page(width=800, height=600)\n\n## get data\ncompares <- GC.season.metrics(compare=TRUE)\n\n## all pmc data\npmc <- GC.season.pmc(all=TRUE, metric=\"TSS\")\n\n# bigger margins please\npar(mar=c(6,6,6,6))\n\nplot(x=c(-30), y=c(0), \n ylim=c(0.6,1.1), xlim=c(-60,+60),\n xlab=\"\", main=\"\", ylab=\"\")\n\n## grid lines\ngrid(col=\"#404040\", lty=\"solid\", lwd=1)\n\n## title\ntitle(main=\"\", \n xlab=\"TSB\",\n ylab=\"IF\")\n\n## abline\nabline(h=0.85, slope=0, lty=\"dashed\", col=\"white\")\nabline(v=0, slope=1, lty=\"dashed\", col=\"white\")\n\nfor (compare in compares) {\n\n # combine pmc and metric data\n z <- merge(compare$metrics, pmc, by=\"date\")\n\n # area of circle should be proportional\n radius <- sqrt( z$Duration\/ 3.1415927 )\n\n # plot using ride colors if not comparing\n # or only one date range selected\n if (length(compares) == 1) {\n\n # make transparent for overlapping\n colors <- adjustcolor(z$color, 0.6)\n\n symbols(z$\"4\", z$IF, \n circles=radius,\n inches=0.4,\n add=TRUE,\n bg=colors,fg=colors,\n xlab=\"\", ylab=\"\")\n } else {\n\n # make transparent for overlapping\n color <- adjustcolor(compare$color, 0.6)\n\n symbols(z$\"4\", z$IF, \n circles=radius,\n inches=0.4,\n add=TRUE,\n bg=color,\n fg=color,\n xlab=\"\", ylab=\"\")\n\n\n }\n\n # labels for each bubble\n ##text(z$\"4\", z$IF, z$Workout_Code, col=\"gray\", cex=0.5)\n}\n\n## name the quadrants\ntext(-30,0.6, \"Maintain\", col=\"darkgray\", cex=1)\ntext(30,1.09, \"Race\", col=\"darkgray\", cex=1)\ntext(-30,1.09, \"Overload\", col=\"darkgray\", cex=1)\ntext(30,0.6, \"Junk\", col=\"darkgray\", cex=1) ",
"script":"##\n## TSB v IF with TSS\n##\n## How fresh were we and how hard did we go\n## and how much stress did we elicit.\n## A more meaningful way of reviewing the\n## PMC data in terms of managing load\/intensity\n\nGC.page(width=800, height=600)\n\n## get data\ncompares <- GC.season.metrics(compare=TRUE)\n\n## all pmc data\npmc <- GC.season.pmc(all=TRUE, metric=\"cTSS\")\n\n# bigger margins please\npar(mar=c(6,6,6,6))\n\nplot(x=c(-30), y=c(0), \n ylim=c(0.6,1.1), xlim=c(-60,+60),\n xlab=\"\", main=\"\", ylab=\"\")\n\n## grid lines\ngrid(col=\"#404040\", lty=\"solid\", lwd=1)\n\n## title\ntitle(main=\"\", \n xlab=\"TSB\",\n ylab=\"IF\")\n\n## abline\nabline(h=0.85, slope=0, lty=\"dashed\", col=\"white\")\nabline(v=0, slope=1, lty=\"dashed\", col=\"white\")\n\nfor (compare in compares) {\n\n # combine pmc and metric data\n z <- merge(compare$metrics, pmc, by=\"date\")\n\n # area of circle should be proportional\n radius <- sqrt( z$cTSS\/ 3.1415927 )\n\n # plot using ride colors if not comparing\n # or only one date range selected\n if (length(compares) == 1) {\n\n # make transparent for overlapping\n colors <- adjustcolor(z$color, 0.6)\n\n symbols(z$sb, z$IF, \n circles=radius,\n inches=0.4,\n add=TRUE,\n bg=colors,fg=colors,\n xlab=\"\", ylab=\"\")\n } else {\n\n # make transparent for overlapping\n color <- adjustcolor(compare$color, 0.6)\n\n symbols(z$sb, z$IF, \n circles=radius,\n inches=0.4,\n add=TRUE,\n bg=color,\n fg=color,\n xlab=\"\", ylab=\"\")\n\n\n }\n\n # labels for each bubble\n ##text(z$\"4\", z$IF, z$Workout_Code, col=\"gray\", cex=0.5)\n}\n\n## name the quadrants\ntext(-30,0.6, \"Maintain\", col=\"darkgray\", cex=1)\ntext(30,1.09, \"Race\", col=\"darkgray\", cex=1)\ntext(-30,1.09, \"Overload\", col=\"darkgray\", cex=1)\ntext(30,0.6, \"Junk\", col=\"darkgray\", cex=1) ",
"state":" ",
"showConsole":"0",
"__LAST__":"1",